2 {-# Language MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
3 {-# Language GeneralizedNewtypeDeriving #-}
12 import Prelude hiding (lookup)
16 import qualified Data.Map as Map
17 import Data.List hiding (lookup)
18 import Control.Exception
19 import Control.Monad.Identity
20 import Control.Monad.Except
21 import Control.Monad.Reader
22 import Control.Monad.State
23 import Control.Monad.Writer
25 import System.IO.Error
30 type Env = Map.Map Name Val
32 lookup :: Name -> Env -> Eval Val
33 lookup k t = case Map.lookup k t of
35 Nothing -> throwError ("Unknown variable " ++ k)
37 {-- Monadic style expression evaluator,
38 -- with error handling and Reader monad instance to carry dictionary
41 type Eval a = ReaderT Env (ExceptT String Identity) a
43 runEval :: Env -> Eval a -> Either String a
44 runEval env ex = runIdentity ( runExceptT ( runReaderT ex env) )
46 evali :: (Int -> Int -> Int) -> Expr -> Expr -> Eval Val
47 evali op e0 e1 = do e0' <- eval e0
50 (I i0, I i1) -> return $ I (i0 `op` i1)
51 _ -> throwError "type error in arithmetic expression"
53 evalb :: (Bool -> Bool -> Bool) -> Expr -> Expr -> Eval Val
54 evalb op e0 e1 = do e0' <- eval e0
57 (B i0, B i1) -> return $ B (i0 `op` i1)
58 _ -> throwError "type error in boolean expression"
60 evalib :: (Int -> Int -> Bool) -> Expr -> Expr -> Eval Val
61 evalib op e0 e1 = do e0' <- eval e0
64 (I i0, I i1) -> return $ B (i0 `op` i1)
65 _ -> throwError "type error in arithmetic expression"
67 eval :: Expr -> Eval Val
68 eval (Const v) = return v
69 eval (Add e0 e1) = evali (+) e0 e1
70 eval (Sub e0 e1) = evali (-) e0 e1
71 eval (Mul e0 e1) = evali (*) e0 e1
72 eval (Div e0 e1) = evali div e0 e1
74 eval (And e0 e1) = evalb (&&) e0 e1
75 eval (Or e0 e1) = evalb (||) e0 e1
77 eval (Not e0 ) = evalb (const not) e0 (Const (B True))
79 eval (Eq e0 e1) = evalib (==) e0 e1
80 eval (Gt e0 e1) = evalib (>) e0 e1
81 eval (Lt e0 e1) = evalib (<) e0 e1
83 eval (Var s) = do env <- ask
86 -- | A step that was taken during the execution of the program
87 data Step = Step Statement -- ^ The statement that was executed
88 Env -- ^ The state of the environment before the statement was executed
89 [String] -- ^ Any output from executing the statement
92 -- Traces the execution of a program, and
93 newtype Interpreter a = Interpreter { runI :: ExceptT String (WriterT [Step] (State Env)) a }
94 deriving (Functor, Applicative, Monad, MonadState Env, MonadWriter [Step], MonadError String)
96 logStatement :: Statement -> Interpreter ()
100 Interpreter $ lift $ tell $ pure $ Step s env o
101 where output :: Interpreter [String]
103 | (Print e) <- s = pure . show <$> evalI e
104 | otherwise = return []
106 hoistEither :: Either String b -> Interpreter b
107 hoistEither = Interpreter . ExceptT . return
109 -- | Evaluates an expression with the current environment inside Interpreter
110 evalI :: Expr -> Interpreter Val
111 evalI e = get >>= hoistEither . flip runEval (eval e)
114 -- | Executes a statement
115 exec :: Statement -> Interpreter ()
116 exec s = logStatement s >> go s
118 go (Assign n e) = modify . Map.insert n =<< evalI e
119 go (Seq s1 s2) = exec s1 >> exec s2
120 go (If cond sThen sElse) = do
125 go w@(While cond x) = do
127 when (res == B True) $ exec x >> exec w
128 go (Try t c) = exec t `catchError` const (exec c)
129 go (Print _) = pure () -- the printing is done in 'logStatement'
132 trace :: Statement -> [Step]
134 let interp = runI (exec f)
135 (_result, effects) = fst $ flip runState mempty $ runWriterT $ runExceptT interp
138 type Breakpoint = Expr
142 hSetBuffering stdin LineBuffering -- read stuff one line at a time
143 go (trace testProg) [] [] `catch` (\e -> unless (isEOFError e) (throw e))
145 go :: [Step] -- ^ Effects to step through
146 -> [Step] -- ^ Effects that have been stepped through
149 go [] _ _ = return ()
150 go list@(e@(Step _ env output):xs) done bps = do
157 "n" -> mapM_ putStrLn output >> go xs (e:done) bps
161 (y:ys) -> go (y:list) ys bps
163 ('b':' ':exprStr) -> do
164 let expr = read exprStr
166 putStrLn $ "Added breakpoint " ++ show expr
167 go list done (expr:bps)
169 "c" -> continue xs (e:done) bps
172 withColor 32 $ case bps of
173 [] -> putStrLn "No breakpoints"
177 ('d':' ':exprStr) -> do
178 let expr = read exprStr
179 withColor 32 $ if expr `elem` bps
180 then putStrLn $ "Deleted breakpoint " ++ exprStr
181 else putStrLn $ "Couldn't find breakpoint " ++ exprStr
182 go list done (delete expr bps)
184 "?" -> printHelp >> go list done bps
187 putStrLn $ "I don't know what '" ++ c ++ "' means. Enter ? for help"
190 -- | Continues until the first breakpoint is hit
191 continue :: [Step] -> [Step] -> [Breakpoint] -> IO ()
192 continue [] _ _ = return ()
193 continue (e@(Step _ env output):xs) done bps = do
194 mapM_ putStrLn output
195 case hitBreakpoint of
197 withDebug $ putStrLn $ "Hit breakpoint: " ++ show bp
199 Nothing -> continue xs (e:done) bps
201 hitBreakpoint :: Maybe Breakpoint
202 hitBreakpoint = foldl f Nothing bps
203 f :: Maybe Breakpoint -> Breakpoint -> Maybe Breakpoint
204 f Nothing cond = case runEval env (eval cond) of
205 Right (B True) -> Just cond
209 printProg :: [Step] -> [Step] -> IO ()
210 printProg [] _ = withColor 240 $ putStrLn "Completed"
211 printProg (current:next) done = withColor 240 $ mapM_ putStrLn ls
212 where ls = above ++ [currentS] ++ below
213 currentS = " @" ++ trunc (show (getStatement current))
214 above = map (" " ++) $ reverse (sample done)
215 below = map (" " ++) $ sample next
216 sample = map (trunc . show . getStatement) . take 3
217 getStatement (Step s _ _) = s
219 printEnv :: Env -> IO ()
221 | null e = withColor 40 $ putStrLn "No variables"
222 | otherwise = withColor 40 $ putStr s
223 where s = unlines $ Map.foldlWithKey f [] e
224 f acc k v = acc ++ [k ++ ": " ++ show v]
226 printHelp = withDebug $ do
227 putStrLn "Available commands:"
228 putStrLn " n Next statement"
229 putStrLn " p Previous statement"
230 putStrLn " ? Show help"
231 putStrLn " c Continue to breakpoint"
232 putStrLn " b <expr> Set conditional breakpoint"
233 putStrLn " d <expr> Delete breakpoint"
234 putStrLn " l List breakpoints"
236 -- | Add Ansi escape code to produce foreground color
237 withColor :: Int -> IO a -> IO a
238 withColor color f = do
239 putStr $ "\ESC[38;5;" ++ show color ++ "m"
244 -- | Truncates a string *lazily*
245 trunc :: String -> String
247 | tooLong s 0 = take 64 s ++ "..."
249 where tooLong "" n = n > 64
250 tooLong (_:_) 64 = True
251 tooLong (_:xs) n = tooLong xs (n + 1)