Main.hs

   1 {-# OPTIONS_GHC -W #-}
   2 {-# Language MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
   3 {-# Language GeneralizedNewtypeDeriving #-}
   4
   5 module Main where
   6
   7 import Prelude hiding (lookup)
   8
   9 import AST
  10 import qualified Data.Map as Map
  11 import Data.List hiding (lookup)
  12 import Control.Exception
  13 import Control.Monad.Identity
  14 import Control.Monad.Except
  15 import Control.Monad.Reader
  16 import Control.Monad.State
  17 import Control.Monad.Writer
  18 import System.Exit
  19 import System.IO
  20 import System.IO.Error
  21 import Programs
  22 import Text.Read (readMaybe)
  23
  24
  25 type Name = String
  26 type Env = Map.Map Name Val
  27
  28 lookup :: Name -> Env -> Eval Val
  29 lookup k t = case Map.lookup k t of
  30                Just x -> return x
  31                Nothing -> throwError ("Unknown variable " ++ k)
  32
  33 {-- Monadic style expression evaluator,
  34  -- with error handling and Reader monad instance to carry dictionary
  35  --}
  36
  37 type Eval a = ReaderT Env (ExceptT String Identity) a
  38
  39 runEval :: Env -> Eval a -> Either String a
  40 runEval env ex = runIdentity ( runExceptT ( runReaderT ex env) )
  41
  42 evali :: (Int -> Int -> Int) -> Expr -> Expr -> Eval Val
  43 evali op e0 e1 = do e0' <- eval e0
  44                     e1' <- eval e1
  45                     case (e0', e1') of
  46                          (I i0, I i1) -> return $ I (i0 `op` i1)
  47                          _            -> throwError "type error in arithmetic expression"
  48
  49 evalb :: (Bool -> Bool -> Bool) -> Expr -> Expr -> Eval Val
  50 evalb op e0 e1 = do e0' <- eval e0
  51                     e1' <- eval e1
  52                     case (e0', e1') of
  53                          (B i0, B i1) -> return $ B (i0 `op` i1)
  54                          _            -> throwError "type error in boolean expression"
  55
  56 evalib :: (Int -> Int -> Bool) -> Expr -> Expr -> Eval Val
  57 evalib op e0 e1 = do e0' <- eval e0
  58                      e1' <- eval e1
  59                      case (e0', e1') of
  60                           (I i0, I i1) -> return $ B (i0 `op` i1)
  61                           _            -> throwError "type error in arithmetic expression"
  62
  63 eval :: Expr -> Eval Val
  64 eval (Const v) = return v
  65 eval (Add e0 e1) = evali (+) e0 e1
  66 eval (Sub e0 e1) = evali (-) e0 e1
  67 eval (Mul e0 e1) = evali (*) e0 e1
  68 eval (Div e0 e1) = evali div e0 e1
  69
  70 eval (And e0 e1) = evalb (&&) e0 e1
  71 eval (Or e0 e1) = evalb (||) e0 e1
  72
  73 eval (Not e0  ) = evalb (const not) e0 (Const (B True))
  74
  75 eval (Eq e0 e1) = evalib (==) e0 e1
  76 eval (Gt e0 e1) = evalib (>) e0 e1
  77 eval (Lt e0 e1) = evalib (<) e0 e1
  78
  79 eval (Var s) = do env <- ask
  80                   lookup s env
  81
  82 -- | A step that was taken during the execution of the program
  83 data Step = Step Statement  -- ^ The statement that was executed
  84                  Env        -- ^ The state of the environment before the statement was executed
  85                  [String]   -- ^ Any output from executing the statement
  86
  87 -- | Keep it pure!
  88 -- Traces the execution of a program, and
  89 newtype Interpreter a = Interpreter { runI :: ExceptT String (WriterT [Step] (State Env)) a }
  90   deriving (Functor, Applicative, Monad, MonadState Env, MonadWriter [Step], MonadError String)
  91
  92 logStatement :: Statement -> Interpreter ()
  93 logStatement s = do
  94   env <- get
  95   o <- output
  96   Interpreter $ lift $ tell $ pure $ Step s env o
  97   where output :: Interpreter [String]
  98         output
  99           | (Print e) <- s = pure . show <$> evalI e
 100           | otherwise = return []
 101
 102 hoistEither :: Either String b -> Interpreter b
 103 hoistEither = Interpreter . ExceptT . return
 104
 105 -- | Evaluates an expression with the current environment inside Interpreter
 106 evalI :: Expr -> Interpreter Val
 107 evalI e = get >>= hoistEither . flip runEval (eval e)
 108
 109
 110 -- | Executes a statement
 111 exec :: Statement -> Interpreter ()
 112 exec s = logStatement s >> go s
 113   where
 114     go (Assign n e) = modify . Map.insert n =<< evalI e
 115     go (Seq s1 s2) = exec s1 >> exec s2
 116     go (If cond sThen sElse) = do
 117       res <- evalI cond
 118       if res == B True
 119           then exec sThen
 120           else exec sElse
 121     go w@(While cond x) = do
 122       res <- evalI cond
 123       when (res == B True) $ exec x >> exec w
 124     go (Try t c) = exec t `catchError` const (exec c)
 125     go (Print _) = pure () -- the printing is done in 'logStatement'
 126     go Pass = pure ()
 127
 128 trace :: Statement -> [Step]
 129 trace f =
 130   let interp = runI (exec f)
 131       (_result, effects) = fst $ flip runState mempty $ runWriterT $ runExceptT interp
 132     in effects
 133
 134 type Breakpoint = Expr
 135
 136 main :: IO ()
 137 main = do
 138   hSetBuffering stdin LineBuffering -- read stuff one line at a time
 139   putStrLn "ttdb: time travelling debugger"
 140   printMenuHelp
 141   menu
 142
 143 menu :: IO ()
 144 menu = do
 145   cmd <- prompt
 146   case cmd of
 147     "?" -> printMenuHelp >> menu
 148     "r increment" -> debugProg increment
 149     "r tryCatch" -> debugProg tryCatch
 150     "r fibonacci" -> debugProg fibonacci
 151     ('r':' ':file) -> read <$> readFile file >>= debugProg
 152     x -> printUnknown x >> menu
 153
 154 debugProg :: Statement -> IO ()
 155 debugProg prog = go (trace prog) [] [] `catch` (\e -> unless (isEOFError e) (throw e))
 156   where
 157     go :: [Step] -- ^ Effects to step through
 158        -> [Step] -- ^ Effects that have been stepped through
 159        -> [Breakpoint]
 160        -> IO ()
 161     go [] _ _ = finishDebug
 162     go list@(e@(Step _ env output):xs) done bps = do
 163       printEnv env
 164       printProg list done
 165       c <- prompt
 166       case c of
 167         "n" -> mapM_ putStrLn output >> go xs (e:done) bps
 168
 169         "p" -> case done of
 170           [] -> return ()
 171           (y:ys) -> go (y:list) ys bps
 172
 173         ('e':' ':exprStr) -> do
 174           mExpr <- tryReadExpr exprStr
 175           case mExpr of
 176             Just expr -> case runEval env (eval expr) of
 177               Left err -> withColor 1 (print err)
 178               Right val -> withColor 250 (print val)
 179             Nothing -> return ()
 180           go list done bps
 181
 182         ('b':' ':exprStr) -> do
 183           mExpr <- tryReadExpr exprStr
 184           case mExpr of
 185             Just expr -> withColor 32 $ do
 186               putStrLn $ "Added breakpoint " ++ show expr
 187               go list done (expr:bps)
 188             Nothing -> go list done bps
 189
 190         "c" -> continue xs (e:done) bps
 191
 192         "l" -> do
 193           withColor 32 $ case bps of
 194             [] -> putStrLn "No breakpoints"
 195             _ -> putStrLn "Breakpoints:" >> mapM_ print bps
 196           go list done bps
 197
 198         ('d':' ':exprStr) -> do
 199           mExpr <- tryReadExpr exprStr
 200           case mExpr of
 201             Just expr -> do
 202               withColor 32 $ if expr `elem` bps
 203                 then putStrLn $ "Deleted breakpoint " ++ exprStr
 204                 else putStrLn $ "Couldn't find breakpoint " ++ exprStr
 205               go list done (delete expr bps)
 206             Nothing -> go list done bps
 207
 208         "?" -> printHelp >> go list done bps
 209
 210         _ -> printUnknown c >> go list done bps
 211
 212     -- | Continues until the first breakpoint is hit
 213     continue :: [Step] -> [Step] -> [Breakpoint] -> IO ()
 214     continue [] _ _ = finishDebug
 215     continue (e@(Step _ env output):xs) done bps = do
 216       mapM_ putStrLn output
 217       case hitBreakpoint of
 218         Just bp -> do
 219           withColor 32 $ putStrLn $ "Hit breakpoint: " ++ show bp
 220           go xs (e:done) bps
 221         Nothing -> continue xs (e:done) bps
 222       where
 223         hitBreakpoint :: Maybe Breakpoint
 224         hitBreakpoint = foldl f Nothing bps
 225         f :: Maybe Breakpoint -> Breakpoint -> Maybe Breakpoint
 226         f Nothing cond = case runEval env (eval cond) of
 227           Right (B True) -> Just cond
 228           _ -> Nothing
 229         f acc _ = acc
 230
 231     finishDebug = putStrLn "Program terminated" >> menu
 232
 233 tryReadExpr :: String -> IO (Maybe Expr)
 234 tryReadExpr str
 235   | Just expr <- readMaybe str = return (Just expr)
 236   | otherwise = do
 237       withColor 1 $ putStrLn "Couldn't read expression"
 238       return Nothing
 239
 240 -- | Prints the future, present and past of a program
 241 printProg :: [Step] -> [Step] -> IO ()
 242 printProg [] _ = return ()
 243 printProg (current:next) done = withColor 250 $ mapM_ putStrLn ls
 244   where ls = above ++ [currentS] ++ below
 245         currentS = "  @" ++ trunc (show (getStatement current))
 246         above = map ("   " ++) $ reverse (sample done)
 247         below = map ("   " ++) $ sample next
 248         sample = map (trunc . show . getStatement) . take 3
 249         getStatement (Step s _ _) = s
 250
 251 printEnv :: Env -> IO ()
 252 printEnv e
 253   | null e = withColor 64 $ putStrLn "No variables"
 254   | otherwise = withColor 64 $ putStr s
 255   where s = unlines $ Map.foldlWithKey f [] e
 256         f acc k v = acc ++ [k ++ ": " ++ show v]
 257
 258 printHelp = do
 259   putStrLn "Available commands:"
 260   putStrLn " n        Next statement"
 261   putStrLn " p        Previous statement"
 262   putStrLn " e <expr> Evaluate expression"
 263   putStrLn " c        Continue to breakpoint"
 264   putStrLn " b <expr> Set conditional breakpoint"
 265   putStrLn " d <expr> Delete breakpoint"
 266   putStrLn " l        List breakpoints"
 267   putStrLn " ?        Show help"
 268
 269 printMenuHelp = do
 270   putStrLn "Available commands:"
 271   putStrLn " r <file> Run a program"
 272   putStrLn " r <name> Run a program from Program.hs"
 273   putStrLn " ?        Show help"
 274
 275 printUnknown :: String -> IO ()
 276 printUnknown x =
 277   putStrLn $ "I don't know what '" ++ x ++ "' means. Enter ? for help"
 278
 279 -- | Prompt the user for some input
 280 prompt :: IO String
 281 prompt = do
 282   withColor 8 $ putStr "(ttdb) "
 283   hFlush stdout
 284   getLine `catch` \e ->
 285     if isEOFError e
 286       then putStrLn "" >> exitSuccess
 287       else throw e
 288
 289 -- | Add Ansi escape code to produce foreground color
 290 withColor :: Int -> IO a -> IO a
 291 withColor color f = do
 292   putStr $ "\ESC[38;5;" ++ show color ++ "m"
 293   res <- f
 294   putStr "\ESC[0m"
 295   return res
 296
 297 -- | Truncates a string *lazily*
 298 trunc :: String -> String
 299 trunc s
 300   | tooLong s 0 = take 64 s ++ "..."
 301   | otherwise = s
 302   where tooLong "" n = n > 64
 303         tooLong (_:_) 64 = True
 304         tooLong (_:xs) n = tooLong xs (n + 1)