-{-# OPTIONS_GHC -Wall #-}
+{-# OPTIONS_GHC -W #-}
{-# Language MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
{-# Language GeneralizedNewtypeDeriving #-}
-module Interpreter
+module Main
( Statement(..)
, Expr(..)
- , runInterpreter
+ , trace
+ , main
) where
import Prelude hiding (lookup)
-import Data.Functor
+import AST
+import Programs
import qualified Data.Map as Map
-import Data.Maybe
-import Data.Char
+import Data.List hiding (lookup)
import Control.Exception
import Control.Monad.Identity
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
-import Control.Applicative hiding (Const)
import System.IO
import System.IO.Error
-import qualified Text.ParserCombinators.ReadP as Read
-import Text.ParserCombinators.ReadP ((<++))
-import qualified Text.Read as Read (lift, readPrec)
-import Debug.Trace
-
-{-------------------------------------------------------------------}
-{- The pure expression language -}
-{-------------------------------------------------------------------}
-
-data Val = I Int | B Bool
- deriving Eq
-
-instance Show Val where
- show (I x) = show x
- show (B x) = show x
-
-data Expr = Const Val
- | Add Expr Expr | Sub Expr Expr | Mul Expr Expr | Div Expr Expr
- | And Expr Expr | Or Expr Expr | Not Expr
- | Eq Expr Expr | Gt Expr Expr | Lt Expr Expr
- | Var String
- deriving Eq
-
-instance Show Expr where
- show (Const v) = show v
- show (Add e1 e2) = show e1 ++ " + " ++ show e2
- show (Sub e1 e2) = show e1 ++ " - " ++ show e2
- show (Mul e1 e2) = show e1 ++ " * " ++ show e2
- show (Div e1 e2) = show e1 ++ " / " ++ show e2
- show (And e1 e2) = show e1 ++ " & " ++ show e2
- show (Or e1 e2) = show e1 ++ " | " ++ show e2
- show (Not e) = "!" ++ show e
- show (Eq e1 e2) = show e1 ++ " == " ++ show e2
- show (Gt e1 e2) = show e1 ++ " > " ++ show e2
- show (Lt e1 e2) = show e1 ++ " < " ++ show e2
- show (Var s) = s
-
-instance Read Expr where
- readPrec = Read.lift pExpr
- where pExpr :: Read.ReadP Expr
- pExpr = pVar <|> pLit <++ pBinOp
- pBrackets = Read.between (Read.char '(') (Read.char ')')
-
- pVar = Var <$> Read.munch1 isLetter
- pLit = pLit' B <|> pLit' I
- pLit' x = Const . x <$> Read.readS_to_P (readsPrec 10000)
-
- pBinOp = do
- e1 <- pLit <|> pVar
- Read.char ' '
- op <- pOp
- Read.char ' '
- e2 <- pLit <|> pVar
- return (op e1 e2)
-
- pOp = Read.choice
- [ Read.string "==" $> Eq
- , Read.char '+' $> Add
- , Read.char '-' $> Sub
- ]
+
type Name = String
--}
type Eval a = ReaderT Env (ExceptT String Identity) a
+
+runEval :: Env -> Eval a -> Either String a
runEval env ex = runIdentity ( runExceptT ( runReaderT ex env) )
evali :: (Int -> Int -> Int) -> Expr -> Expr -> Eval Val
eval (Or e0 e1) = evalb (||) e0 e1
eval (Not e0 ) = evalb (const not) e0 (Const (B True))
- where not2 a _ = not a -- hack, hack
eval (Eq e0 e1) = evalib (==) e0 e1
eval (Gt e0 e1) = evalib (>) e0 e1
eval (Var s) = do env <- ask
lookup s env
+-- | A step that was taken during the execution of the program
+data Step = Step Statement -- ^ The statement that was executed
+ Env -- ^ The state of the environment before the statement was executed
+ [String] -- ^ Any output from executing the statement
-{-------------------------------------------------------------------}
-{- The statement language -}
-
-
-data Statement = Assign String Expr
- | If Expr Statement Statement
- | While Expr Statement
- | Print Expr
- | Seq Statement Statement
- | Try Statement Statement
- | Pass
- deriving (Eq, Show)
-
--- | A record of stuff being printed or run
-data Effect = EffectStatement Statement Env
- | EffectPrint String
+-- | Keep it pure!
+-- Traces the execution of a program, and
+newtype Interpreter a = Interpreter { runI :: ExceptT String (WriterT [Step] (State Env)) a }
+ deriving (Functor, Applicative, Monad, MonadState Env, MonadWriter [Step], MonadError String)
--- Keep it pure!
-newtype Interpreter a = Interpreter { runI :: ExceptT String (WriterT [Effect] (State Env)) a }
- deriving (Functor, Applicative, Monad, MonadState Env, MonadWriter [Effect], MonadError String)
-
-logStatement :: Statement -> Env -> Interpreter ()
-logStatement s e = Interpreter $ lift $ tell $ pure $ EffectStatement s e
+logStatement :: Statement -> Interpreter ()
+logStatement s = do
+ env <- get
+ o <- output
+ Interpreter $ lift $ tell $ pure $ Step s env o
+ where output :: Interpreter [String]
+ output
+ | (Print e) <- s = pure . show <$> evalI e
+ | otherwise = return []
hoistEither :: Either String b -> Interpreter b
hoistEither = Interpreter . ExceptT . return
+-- | Evaluates an expression with the current environment inside Interpreter
evalI :: Expr -> Interpreter Val
evalI e = get >>= hoistEither . flip runEval (eval e)
-testProg = Seq (Assign "x" (Const (I 0))) loop
- where loop = Seq (Print (Var "x"))
- (Seq (Assign "x" (Add (Var "x") (Const (I 1))))
- loop)
-testTry = Try (Print (Add (Const (I 3)) (Const (B True))))
- (Print (Const (I 0)))
+-- | Executes a statement
exec :: Statement -> Interpreter ()
-exec s = get >>= logStatement s >> go s
+exec s = logStatement s >> go s
where
- go (Assign n e) = do
- env <- get
- new <- hoistEither $ runEval env (eval e)
- modify $ Map.insert n new
+ go (Assign n e) = modify . Map.insert n =<< evalI e
go (Seq s1 s2) = exec s1 >> exec s2
go (If cond sThen sElse) = do
res <- evalI cond
if res == B True
then exec sThen
else exec sElse
- go w@(While cond s) = do
+ go w@(While cond x) = do
res <- evalI cond
- when (res == B True) $ exec s >> exec w
- go (Print e) = evalI e >>= (tell . pure . EffectPrint . show)
- go (Try s catch) = exec s `catchError` const (exec catch)
+ when (res == B True) $ exec x >> exec w
+ go (Try t c) = exec t `catchError` const (exec c)
+ go (Print _) = pure () -- the printing is done in 'logStatement'
go Pass = pure ()
-runInterpreter :: Interpreter a -> [Effect]
-runInterpreter f =
- let (result, effects) = fst $ flip runState mempty $ runWriterT $ runExceptT $ runI f
+trace :: Statement -> [Step]
+trace f =
+ let interp = runI (exec f)
+ (_result, effects) = fst $ flip runState mempty $ runWriterT $ runExceptT interp
in effects
type Breakpoint = Expr
+main :: IO ()
main = do
hSetBuffering stdin LineBuffering -- read stuff one line at a time
- go mempty (runInterpreter (exec testProg)) `catch` (\e -> unless (isEOFError e) (throw e))
+ go (trace testProg) [] [] `catch` (\e -> unless (isEOFError e) (throw e))
where
- go :: [Breakpoint] -> [Effect] -> IO ()
- go _ [] = return ()
- go bps (EffectPrint str:xs) = putStrLn str >> go bps xs
- go bps list@(EffectStatement s env:xs) = do
+ go :: [Step] -- ^ Effects to step through
+ -> [Step] -- ^ Effects that have been stepped through
+ -> [Breakpoint]
+ -> IO ()
+ go [] _ _ = return ()
+ go list@(e@(Step _ env output):xs) done bps = do
withDebug $ do
printEnv env
- putStrLn $ "@" ++ trunc (show s)
+ printProg list done
putStr "> "
c <- getLine
case c of
- "n" -> go bps xs
- ('b':' ':exprStr) -> let expr = read exprStr in go (expr:bps) list
- "c" ->
- let seek [] = return ()
- seek (EffectStatement s env:xs) =
+ "n" -> mapM_ putStrLn output >> go xs (e:done) bps
+
+ "p" -> case done of
+ [] -> return ()
+ (y:ys) -> go (y:list) ys bps
+
+ ('b':' ':exprStr) -> do
+ let expr = read exprStr
+ withColor 32 $
+ putStrLn $ "Added breakpoint " ++ show expr
+ go list done (expr:bps)
+
+ "c" -> continue xs (e:done) bps
+
+ "l" -> do
+ withColor 32 $ case bps of
+ [] -> putStrLn "No breakpoints"
+ _ -> mapM_ print bps
+ go list done bps
+
+ ('d':' ':exprStr) -> do
+ let expr = read exprStr
+ withColor 32 $ if expr `elem` bps
+ then putStrLn $ "Deleted breakpoint " ++ exprStr
+ else putStrLn $ "Couldn't find breakpoint " ++ exprStr
+ go list done (delete expr bps)
+
+ "?" -> printHelp >> go list done bps
+
+ _ -> do
+ putStrLn $ "I don't know what '" ++ c ++ "' means. Enter ? for help"
+ go list done bps
+
+ -- | Continues until the first breakpoint is hit
+ continue :: [Step] -> [Step] -> [Breakpoint] -> IO ()
+ continue [] _ _ = return ()
+ continue (e@(Step _ env output):xs) done bps = do
+ mapM_ putStrLn output
case hitBreakpoint of
Just bp -> do
- withDebug $ putStrLn $ "hit breakpoint: " ++ show bp
- go bps xs
- Nothing -> seek xs
+ withDebug $ putStrLn $ "Hit breakpoint: " ++ show bp
+ go xs (e:done) bps
+ Nothing -> continue xs (e:done) bps
where
hitBreakpoint :: Maybe Breakpoint
hitBreakpoint = foldl f Nothing bps
Right (B True) -> Just cond
_ -> Nothing
f acc _ = acc
- seek (x:xs) = seek xs
- in seek xs
- "?" -> printHelp >> go bps list
- _ -> putStrLn "What?" >> go bps list
+
+ printProg :: [Step] -> [Step] -> IO ()
+ printProg [] _ = withColor 240 $ putStrLn "Completed"
+ printProg (current:next) done = withColor 240 $ mapM_ putStrLn ls
+ where ls = above ++ [currentS] ++ below
+ currentS = " @" ++ trunc (show (getStatement current))
+ above = map (" " ++) $ reverse (sample done)
+ below = map (" " ++) $ sample next
+ sample = map (trunc . show . getStatement) . take 3
+ getStatement (Step s _ _) = s
printEnv :: Env -> IO ()
- printEnv e = putStr s
+ printEnv e
+ | null e = withColor 40 $ putStrLn "No variables"
+ | otherwise = withColor 40 $ putStr s
where s = unlines $ Map.foldlWithKey f [] e
f acc k v = acc ++ [k ++ ": " ++ show v]
- printHelp = do
+ printHelp = withDebug $ do
putStrLn "Available commands:"
putStrLn " n Next statement"
+ putStrLn " p Previous statement"
putStrLn " ? Show help"
putStrLn " c Continue to breakpoint"
putStrLn " b <expr> Set conditional breakpoint"
+ putStrLn " d <expr> Delete breakpoint"
+ putStrLn " l List breakpoints"
--- | Ansi escapes any output to be kind of gray
-withDebug :: IO a -> IO a
-withDebug f = do
- putStr "\ESC[38;5;240m"
+-- | Add Ansi escape code to produce foreground color
+withColor :: Int -> IO a -> IO a
+withColor color f = do
+ putStr $ "\ESC[38;5;" ++ show color ++ "m"
res <- f
putStr "\ESC[0m"
return res
| otherwise = s
where tooLong "" n = n > 64
tooLong (_:_) 64 = True
- tooLong (x:xs) n = tooLong xs (n + 1)
+ tooLong (_:xs) n = tooLong xs (n + 1)
projects / timetravel.git / blobdiff