1 {-# OPTIONS_GHC -Wall #-}
2 {-# Language MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
3 {-# Language GeneralizedNewtypeDeriving #-}
11 import Prelude hiding (lookup)
14 import qualified Data.Map as Map
17 import Control.Exception
18 import Control.Monad.Identity
19 import Control.Monad.Except
20 import Control.Monad.Reader
21 import Control.Monad.State
22 import Control.Monad.Writer
23 import Control.Applicative hiding (Const)
25 import System.IO.Error
26 import qualified Text.ParserCombinators.ReadP as Read
27 import Text.ParserCombinators.ReadP ((<++))
28 import qualified Text.Read as Read (lift, readPrec)
31 {-------------------------------------------------------------------}
32 {- The pure expression language -}
33 {-------------------------------------------------------------------}
35 data Val = I Int | B Bool
38 instance Show Val where
43 | Add Expr Expr | Sub Expr Expr | Mul Expr Expr | Div Expr Expr
44 | And Expr Expr | Or Expr Expr | Not Expr
45 | Eq Expr Expr | Gt Expr Expr | Lt Expr Expr
49 instance Show Expr where
50 show (Const v) = show v
51 show (Add e1 e2) = show e1 ++ " + " ++ show e2
52 show (Sub e1 e2) = show e1 ++ " - " ++ show e2
53 show (Mul e1 e2) = show e1 ++ " * " ++ show e2
54 show (Div e1 e2) = show e1 ++ " / " ++ show e2
55 show (And e1 e2) = show e1 ++ " & " ++ show e2
56 show (Or e1 e2) = show e1 ++ " | " ++ show e2
57 show (Not e) = "!" ++ show e
58 show (Eq e1 e2) = show e1 ++ " == " ++ show e2
59 show (Gt e1 e2) = show e1 ++ " > " ++ show e2
60 show (Lt e1 e2) = show e1 ++ " < " ++ show e2
63 instance Read Expr where
64 readPrec = Read.lift pExpr
65 where pExpr :: Read.ReadP Expr
66 pExpr = pVar <|> pLit <++ pBinOp
67 pBrackets = Read.between (Read.char '(') (Read.char ')')
69 pVar = Var <$> Read.munch1 isLetter
70 pLit = pLit' B <|> pLit' I
71 pLit' x = Const . x <$> Read.readS_to_P (readsPrec 10000)
82 [ Read.string "==" $> Eq
83 , Read.char '+' $> Add
84 , Read.char '-' $> Sub
89 type Env = Map.Map Name Val
91 lookup :: Name -> Env -> Eval Val
92 lookup k t = case Map.lookup k t of
94 Nothing -> throwError ("Unknown variable " ++ k)
96 {-- Monadic style expression evaluator,
97 -- with error handling and Reader monad instance to carry dictionary
100 type Eval a = ReaderT Env (ExceptT String Identity) a
101 runEval env ex = runIdentity ( runExceptT ( runReaderT ex env) )
103 evali :: (Int -> Int -> Int) -> Expr -> Expr -> Eval Val
104 evali op e0 e1 = do e0' <- eval e0
107 (I i0, I i1) -> return $ I (i0 `op` i1)
108 _ -> throwError "type error in arithmetic expression"
110 evalb :: (Bool -> Bool -> Bool) -> Expr -> Expr -> Eval Val
111 evalb op e0 e1 = do e0' <- eval e0
114 (B i0, B i1) -> return $ B (i0 `op` i1)
115 _ -> throwError "type error in boolean expression"
117 evalib :: (Int -> Int -> Bool) -> Expr -> Expr -> Eval Val
118 evalib op e0 e1 = do e0' <- eval e0
121 (I i0, I i1) -> return $ B (i0 `op` i1)
122 _ -> throwError "type error in arithmetic expression"
124 eval :: Expr -> Eval Val
125 eval (Const v) = return v
126 eval (Add e0 e1) = evali (+) e0 e1
127 eval (Sub e0 e1) = evali (-) e0 e1
128 eval (Mul e0 e1) = evali (*) e0 e1
129 eval (Div e0 e1) = evali div e0 e1
131 eval (And e0 e1) = evalb (&&) e0 e1
132 eval (Or e0 e1) = evalb (||) e0 e1
134 eval (Not e0 ) = evalb (const not) e0 (Const (B True))
135 where not2 a _ = not a -- hack, hack
137 eval (Eq e0 e1) = evalib (==) e0 e1
138 eval (Gt e0 e1) = evalib (>) e0 e1
139 eval (Lt e0 e1) = evalib (<) e0 e1
141 eval (Var s) = do env <- ask
145 {-------------------------------------------------------------------}
146 {- The statement language -}
149 data Statement = Assign String Expr
150 | If Expr Statement Statement
151 | While Expr Statement
153 | Seq Statement Statement
154 | Try Statement Statement
158 -- | A record of stuff being printed or run
159 data Effect = EffectStatement Statement Env
163 newtype Interpreter a = Interpreter { runI :: ExceptT String (WriterT [Effect] (State Env)) a }
164 deriving (Functor, Applicative, Monad, MonadState Env, MonadWriter [Effect], MonadError String)
166 logStatement :: Statement -> Env -> Interpreter ()
167 logStatement s e = Interpreter $ lift $ tell $ pure $ EffectStatement s e
169 hoistEither :: Either String b -> Interpreter b
170 hoistEither = Interpreter . ExceptT . return
172 evalI :: Expr -> Interpreter Val
173 evalI e = get >>= hoistEither . flip runEval (eval e)
175 testProg = Seq (Assign "x" (Const (I 0))) loop
176 where loop = Seq (Print (Var "x"))
177 (Seq (Assign "x" (Add (Var "x") (Const (I 1))))
179 testTry = Try (Print (Add (Const (I 3)) (Const (B True))))
180 (Print (Const (I 0)))
182 exec :: Statement -> Interpreter ()
183 exec s = get >>= logStatement s >> go s
187 new <- hoistEither $ runEval env (eval e)
188 modify $ Map.insert n new
189 go (Seq s1 s2) = exec s1 >> exec s2
190 go (If cond sThen sElse) = do
195 go w@(While cond s) = do
197 when (res == B True) $ exec s >> exec w
198 go (Print e) = evalI e >>= (tell . pure . EffectPrint . show)
199 go (Try s catch) = exec s `catchError` const (exec catch)
202 runInterpreter :: Interpreter a -> [Effect]
204 let (result, effects) = fst $ flip runState mempty $ runWriterT $ runExceptT $ runI f
207 type Breakpoint = Expr
210 hSetBuffering stdin LineBuffering -- read stuff one line at a time
211 go mempty (runInterpreter (exec testProg)) `catch` (\e -> unless (isEOFError e) (throw e))
213 go :: [Breakpoint] -> [Effect] -> IO ()
215 go bps (EffectPrint str:xs) = putStrLn str >> go bps xs
216 go bps list@(EffectStatement s env:xs) = do
219 putStrLn $ "@" ++ trunc (show s)
224 ('b':' ':exprStr) -> let expr = read exprStr in go (expr:bps) list
226 let seek [] = return ()
227 seek (EffectStatement s env:xs) =
228 case hitBreakpoint of
230 withDebug $ putStrLn $ "hit breakpoint: " ++ show bp
234 hitBreakpoint :: Maybe Breakpoint
235 hitBreakpoint = foldl f Nothing bps
236 f :: Maybe Breakpoint -> Breakpoint -> Maybe Breakpoint
237 f Nothing cond = case runEval env (eval cond) of
238 Right (B True) -> Just cond
241 seek (x:xs) = seek xs
243 "?" -> printHelp >> go bps list
244 _ -> putStrLn "What?" >> go bps list
246 printEnv :: Env -> IO ()
247 printEnv e = putStr s
248 where s = unlines $ Map.foldlWithKey f [] e
249 f acc k v = acc ++ [k ++ ": " ++ show v]
252 putStrLn "Available commands:"
253 putStrLn " n Next statement"
254 putStrLn " ? Show help"
255 putStrLn " c Continue to breakpoint"
256 putStrLn " b <expr> Set conditional breakpoint"
258 -- | Ansi escapes any output to be kind of gray
259 withDebug :: IO a -> IO a
261 putStr "\ESC[38;5;240m"
266 -- | Truncates a string *lazily*
267 trunc :: String -> String
269 | tooLong s 0 = take 64 s ++ "..."
271 where tooLong "" n = n > 64
272 tooLong (_:_) 64 = True
273 tooLong (x:xs) n = tooLong xs (n + 1)