From 9a09a1be54afb5e15dfea8a8676bd6e1941b37ec Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Sat, 24 Nov 2018 22:52:28 +0000 Subject: [PATCH] Chunk up files --- AST.hs | 84 +++++++++++++++++++++ Interpreter.hs | 196 +++++++++++++++++++------------------------------ Programs.hs | 12 +++ 3 files changed, 173 insertions(+), 119 deletions(-) create mode 100644 AST.hs create mode 100644 Programs.hs diff --git a/AST.hs b/AST.hs new file mode 100644 index 0000000..cf1fc40 --- /dev/null +++ b/AST.hs @@ -0,0 +1,84 @@ +module AST where + +import Text.ParserCombinators.ReadP +import Text.Read (readPrec, lift) +import Data.Char +import Data.Functor + +{-------------------------------------------------------------------} +{- 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 = lift pExpr + where + pExpr = pVar +++ pLit +++ pBinOp + pBrackets = between (char '(') (char ')') + + pVar = Var <$> munch1 isLetter + pLit = pLit' B +++ pLit' I + pLit' x = Const . x <$> readS_to_P (readsPrec 10000) + + pBinOp = do + -- TODO: figure out how to just use pExpr without getting + -- stuck recursively + e1 <- pVar +++ pLit +++ pBrackets pBinOp + skipSpaces + op <- pOp + skipSpaces + e2 <- pVar +++ pLit +++ pBrackets pBinOp + return (op e1 e2) + + pOp = choice + [ string "==" $> Eq + , char '+' $> Add + , char '-' $> Sub + , char '*' $> Mul + , char '/' $> Div + , char '&' $> And + , char '|' $> Or + , char '>' $> Gt + , char '<' $> Lt + ] + +{-------------------------------------------------------------------} +{- 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) + diff --git a/Interpreter.hs b/Interpreter.hs index dd3c835..09a6f00 100644 --- a/Interpreter.hs +++ b/Interpreter.hs @@ -5,83 +5,25 @@ 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.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) - -{-------------------------------------------------------------------} -{- 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 @@ -97,6 +39,8 @@ lookup k t = case Map.lookup k t of --} 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 @@ -131,7 +75,6 @@ eval (And e0 e1) = evalb (&&) e0 e1 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 @@ -140,29 +83,21 @@ eval (Lt 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) +-- | 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) --- | A record of stuff being printed and run -data Effect = Effect Statement Env [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 = output >>= (Interpreter . lift . tell . pure . Effect 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 @@ -171,51 +106,48 @@ logStatement s e = output >>= (Interpreter . lift . tell . pure . Effect s e) 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 (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 (runInterpreter (exec testProg)) [] [] `catch` (\e -> unless (isEOFError e) (throw e)) + go (trace testProg) [] [] `catch` (\e -> unless (isEOFError e) (throw e)) where - go :: [Effect] -> [Effect] -> [Breakpoint] -> IO () + go :: [Step] -- ^ Effects to step through + -> [Step] -- ^ Effects that have been stepped through + -> [Breakpoint] + -> IO () go [] _ _ = return () - -- go bps (e@(EffectPrint str):xs) done = putStrLn str >> go bps xs (e:done) - go list@(e@(Effect s env output):xs) done bps = do + go list@(e@(Step _ env output):xs) done bps = do withDebug $ do printEnv env printProg list done @@ -223,20 +155,42 @@ main = do c <- getLine case c of "n" -> mapM_ putStrLn output >> go xs (e:done) bps + "p" -> case done of [] -> return () (y:ys) -> go (y:list) ys bps - ('b':' ':exprStr) -> let expr = read exprStr in go list done (expr: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 :: [Effect] -> [Effect] -> [Breakpoint] -> IO () + continue :: [Step] -> [Step] -> [Breakpoint] -> IO () continue [] _ _ = return () - continue (e@(Effect _ env output):xs) done bps = do + continue (e@(Step _ env output):xs) done bps = do mapM_ putStrLn output case hitBreakpoint of Just bp -> do @@ -252,18 +206,20 @@ main = do _ -> Nothing f acc _ = acc - printProg :: [Effect] -> [Effect] -> IO () - printProg [] _ = putStrLn "Completed" - printProg (current:next) done = mapM_ putStrLn ls + 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 (" " ++) $ sample done + above = map (" " ++) $ reverse (sample done) below = map (" " ++) $ sample next sample = map (trunc . show . getStatement) . take 3 - getStatement (Effect s _ _) = s + 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] @@ -274,11 +230,13 @@ main = do putStrLn " ? Show help" putStrLn " c Continue to breakpoint" putStrLn " b Set conditional breakpoint" + putStrLn " d 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 diff --git a/Programs.hs b/Programs.hs new file mode 100644 index 0000000..22cc493 --- /dev/null +++ b/Programs.hs @@ -0,0 +1,12 @@ +module Programs where + +import AST + +testProg :: Statement +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 :: Statement +testTry = Try (Print (Add (Const (I 3)) (Const (B True)))) + (Print (Const (I 0))) -- 2.30.2