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 e0 ) = evalb (const not) e0 (Const (B True))
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 -- 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)
92 logStatement :: Statement -> Interpreter ()
96 Interpreter $ lift $ tell $ pure $ Step s env o
97 where output :: Interpreter [String]
99 | (Print e) <- s = pure . show <$> evalI e
100 | otherwise = return []
102 hoistEither :: Either String b -> Interpreter b
103 hoistEither = Interpreter . ExceptT . return
105 -- | Evaluates an expression with the current environment inside Interpreter
106 evalI :: Expr -> Interpreter Val
107 evalI e = get >>= hoistEither . flip runEval (eval e)
110 -- | Executes a statement
111 exec :: Statement -> Interpreter ()
112 exec s = logStatement s >> go s
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
121 go w@(While cond x) = do
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'
128 trace :: Statement -> [Step]
130 let interp = runI (exec f)
131 (_result, effects) = fst $ flip runState mempty $ runWriterT $ runExceptT interp
134 type Breakpoint = Expr
138 hSetBuffering stdin LineBuffering -- read stuff one line at a time
139 putStrLn "ttdb: time travelling debugger"
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
154 debugProg :: Statement -> IO ()
155 debugProg prog = go (trace prog) [] [] `catch` (\e -> unless (isEOFError e) (throw e))
157 go :: [Step] -- ^ Effects to step through
158 -> [Step] -- ^ Effects that have been stepped through
161 go [] _ _ = finishDebug
162 go list@(e@(Step _ env output):xs) done bps = do
167 "n" -> mapM_ putStrLn output >> go xs (e:done) bps
171 (y:ys) -> go (y:list) ys bps
173 ('e':' ':exprStr) -> do
174 mExpr <- tryReadExpr exprStr
176 Just expr -> case runEval env (eval expr) of
177 Left err -> withColor 1 (print err)
178 Right val -> withColor 250 (print val)
182 ('b':' ':exprStr) -> do
183 mExpr <- tryReadExpr exprStr
185 Just expr -> withColor 32 $ do
186 putStrLn $ "Added breakpoint " ++ show expr
187 go list done (expr:bps)
188 Nothing -> go list done bps
190 "c" -> continue xs (e:done) bps
193 withColor 32 $ case bps of
194 [] -> putStrLn "No breakpoints"
195 _ -> putStrLn "Breakpoints:" >> mapM_ print bps
198 ('d':' ':exprStr) -> do
199 mExpr <- tryReadExpr exprStr
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
208 "?" -> printHelp >> go list done bps
210 _ -> printUnknown c >> go list done bps
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
219 withColor 32 $ putStrLn $ "Hit breakpoint: " ++ show bp
221 Nothing -> continue xs (e:done) bps
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
231 finishDebug = putStrLn "Program terminated" >> menu
233 tryReadExpr :: String -> IO (Maybe Expr)
235 | Just expr <- readMaybe str = return (Just expr)
237 withColor 1 $ putStrLn "Couldn't read expression"
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
251 printEnv :: Env -> IO ()
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]
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"
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"
275 printUnknown :: String -> IO ()
277 putStrLn $ "I don't know what '" ++ x ++ "' means. Enter ? for help"
279 -- | Prompt the user for some input
282 withColor 8 $ putStr "(ttdb) "
284 getLine `catch` \e ->
286 then putStrLn "" >> exitSuccess
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"
297 -- | Truncates a string *lazily*
298 trunc :: String -> String
300 | tooLong s 0 = take 64 s ++ "..."
302 where tooLong "" n = n > 64
303 tooLong (_:_) 64 = True
304 tooLong (_:xs) n = tooLong xs (n + 1)