2 {-# Language MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
3 {-# Language GeneralizedNewtypeDeriving #-}
7 import Prelude hiding (lookup)
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
20 import System.IO.Error
22 import Text.Read (readMaybe)
26 type Env = Map.Map Name Val
28 lookup :: Name -> Env -> Eval Val
29 lookup k t = case Map.lookup k t of
31 Nothing -> throwError ("Unknown variable " ++ k)
33 {-- Monadic style expression evaluator,
34 -- with error handling and Reader monad instance to carry dictionary
37 type Eval a = ReaderT Env (ExceptT String Identity) a
39 runEval :: Env -> Eval a -> Either String a
40 runEval env ex = runIdentity ( runExceptT ( runReaderT ex env) )
42 evali :: (Int -> Int -> Int) -> Expr -> Expr -> Eval Val
43 evali op e0 e1 = do e0' <- eval e0
46 (I i0, I i1) -> return $ I (i0 `op` i1)
47 _ -> throwError "type error in arithmetic expression"
49 evalb :: (Bool -> Bool -> Bool) -> Expr -> Expr -> Eval Val
50 evalb op e0 e1 = do e0' <- eval e0
53 (B i0, B i1) -> return $ B (i0 `op` i1)
54 _ -> throwError "type error in boolean expression"
56 evalib :: (Int -> Int -> Bool) -> Expr -> Expr -> Eval Val
57 evalib op e0 e1 = do e0' <- eval e0
60 (I i0, I i1) -> return $ B (i0 `op` i1)
61 _ -> throwError "type error in arithmetic expression"
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
70 eval (And e0 e1) = evalb (&&) e0 e1
71 eval (Or e0 e1) = evalb (||) e0 e1
73 eval (Not e) = evalb (const not) (Const (B True)) e
75 eval (Eq e0 e1) = evalib (==) e0 e1
76 eval (Gt e0 e1) = evalib (>) e0 e1
77 eval (Lt e0 e1) = evalib (<) e0 e1
79 eval (Var s) = do env <- ask
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
88 -- The monad for tracing the execution of a program.
89 -- Records a list of 'Steps' taken throughout execution
90 -- Handles exceptions too.
91 newtype Tracer a = Tracer { runTracer :: ExceptT String (WriterT [Step] (State Env)) a }
92 deriving (Functor, Applicative, Monad, MonadState Env, MonadWriter [Step], MonadError String)
94 hoistEither :: Either String b -> Tracer b
95 hoistEither = Tracer . ExceptT . return
97 -- | Evaluates an expression with the current environment inside the tracer.
98 evalI :: Expr -> Tracer Val
99 evalI e = get >>= hoistEither . flip runEval (eval e)
101 -- | Traces a program and returns a list of steps taken throughout its execution.
102 -- Thanks to lazy evaluation though, the steps can be "streamed" and so this can
103 -- be used to debug non-terminating and recursive programs!
104 trace :: Statement -> [Step]
106 let f = runTracer (exec x)
107 (_result, effects) = fst $ flip runState mempty $ runWriterT $ runExceptT f
111 exec :: Statement -> Tracer ()
112 exec s = logStatement s >> go s
114 -- | Records the statement's execution in the Tracer monad
115 logStatement :: Statement -> Tracer ()
119 Tracer $ lift $ tell $ pure $ Step s env o
120 where output :: Tracer [String]
122 | (Print e) <- s = pure . show <$> evalI e
123 | otherwise = return []
126 -- | Where the magic happens. Provides all the control flow
127 go :: Statement -> Tracer ()
128 go (Assign n e) = modify . Map.insert n =<< evalI e
129 go (Seq s1 s2) = exec s1 >> exec s2
130 go (If cond sThen sElse) = do
135 go w@(While cond x) = do
137 when (res == B True) $ exec x >> exec w
138 go (Try t c) = exec t `catchError` const (exec c)
139 go (Print _) = pure () -- the printing is done in 'logStatement'
144 hSetBuffering stdin LineBuffering -- Read stuff one line at a time
145 putStrLn "ttdb: time travelling debugger"
149 -- | Handles the start menu
154 "?" -> printMenuHelp >> menu
155 "r increment" -> debugProg increment
156 "r tryCatch" -> debugProg tryCatch
157 "r fibonacci" -> debugProg fibonacci
158 "r boolNot" -> debugProg boolNot
159 ('r':' ':file) -> read <$> readFile file >>= debugProg
160 x -> printUnknown x >> menu
162 type Breakpoint = Expr
164 debugProg :: Statement -> IO ()
165 debugProg prog = go (trace prog) [] [] `catch` (\e -> unless (isEOFError e) (throw e))
167 go :: [Step] -- ^ Steps to step through
168 -> [Step] -- ^ Steps that have been stepped through
171 go [] _ _ = finishDebug
172 go list@(e@(Step _ env output):xs) done bps = do
177 "n" -> mapM_ putStrLn output >> go xs (e:done) bps
181 (y:ys) -> go (y:list) ys bps
183 ('e':' ':exprStr) -> do
184 mExpr <- tryReadExpr exprStr
186 Just expr -> case runEval env (eval expr) of
187 Left err -> withColor 1 (print err)
188 Right val -> withColor 250 (print val)
192 ('b':' ':exprStr) -> do
193 mExpr <- tryReadExpr exprStr
195 Just expr -> withColor 32 $ do
196 putStrLn $ "Added breakpoint " ++ show expr
197 go list done (expr:bps)
198 Nothing -> go list done bps
200 "c" -> continue xs (e:done) bps False
201 "cb" -> continue xs (e:done) bps True
204 withColor 32 $ case bps of
205 [] -> putStrLn "No breakpoints"
206 _ -> putStrLn "Breakpoints:" >> mapM_ print bps
209 ('d':' ':exprStr) -> do
210 mExpr <- tryReadExpr exprStr
213 withColor 32 $ if expr `elem` bps
214 then putStrLn $ "Deleted breakpoint " ++ exprStr
215 else putStrLn $ "Couldn't find breakpoint " ++ exprStr
216 go list done (delete expr bps)
217 Nothing -> go list done bps
219 "?" -> printHelp >> go list done bps
221 _ -> printUnknown c >> go list done bps
223 -- | Continues until the first breakpoint is hit
224 continue :: [Step] -> [Step] -> [Breakpoint] -> Bool -> IO ()
225 continue [] _ _ False = finishDebug
226 continue _ [] _ True = finishDebug
227 continue [] (x:xs) bps True = continue [x] xs bps True
228 continue list@(e@(Step _ env output):xs) done bps backwards = do
229 mapM_ putStrLn output
230 case hitBreakpoint of
232 withColor 32 $ putStrLn $ "Hit breakpoint: " ++ show bp
234 Nothing -> if backwards
235 then continue (head done:list) (tail done) bps backwards
236 else continue xs (e:done) bps backwards
238 hitBreakpoint :: Maybe Breakpoint
239 hitBreakpoint = foldl f Nothing bps
240 f :: Maybe Breakpoint -> Breakpoint -> Maybe Breakpoint
241 f Nothing cond = case runEval env (eval cond) of
242 Right (B True) -> Just cond
246 finishDebug = putStrLn "Program terminated" >> menu
248 tryReadExpr :: String -> IO (Maybe Expr)
250 | Just expr <- readMaybe str = return (Just expr)
252 withColor 1 $ putStrLn "Couldn't read expression"
255 -- | Prints the future, present and past of a program
256 printProg :: [Step] -> [Step] -> IO ()
257 printProg [] _ = return ()
258 printProg (current:next) done = withColor 250 $ mapM_ putStrLn ls
259 where ls = above ++ [currentS] ++ below
260 currentS = " @" ++ trunc (show (getStatement current))
261 above = map (" " ++) $ reverse (sample done)
262 below = map (" " ++) $ sample next
263 sample = map (trunc . show . getStatement) . take 3
264 getStatement (Step s _ _) = s
266 printEnv :: Env -> IO ()
268 | null e = withColor 64 $ putStrLn "No variables"
269 | otherwise = withColor 64 $ putStr s
270 where s = unlines $ Map.foldlWithKey f [] e
271 f acc k v = acc ++ [k ++ ": " ++ show v]
274 putStrLn "Available commands:"
275 putStrLn " n Next statement"
276 putStrLn " p Previous statement"
277 putStrLn " e <expr> Evaluate expression"
278 putStrLn " c Continue to breakpoint"
279 putStrLn " cb Continue backwards to breakpoint"
280 putStrLn " b <expr> Set conditional breakpoint"
281 putStrLn " d <expr> Delete breakpoint"
282 putStrLn " l List breakpoints"
283 putStrLn " ? Show help"
286 putStrLn "Available commands:"
287 putStrLn " r <file> Run a program"
288 putStrLn " r <name> Run a program from Program.hs"
289 putStrLn " ? Show help"
291 printUnknown :: String -> IO ()
293 putStrLn $ "I don't know what '" ++ x ++ "' means. Enter ? for help"
295 -- | Prompt the user for some input
298 withColor 8 $ putStr "(ttdb) "
300 getLine `catch` \e ->
302 then putStrLn "" >> exitSuccess
305 -- | Add Ansi escape code to produce foreground color
306 withColor :: Int -> IO a -> IO a
307 withColor color f = do
308 putStr $ "\ESC[38;5;" ++ show color ++ "m"
313 -- | Truncates a string *lazily*
314 trunc :: String -> String
316 | tooLong s 0 = take 64 s ++ "..."
318 where tooLong "" n = n > 64
319 tooLong (_:_) 64 = True
320 tooLong (_:xs) n = tooLong xs (n + 1)