X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=Interpreter.hs;fp=Interpreter.hs;h=0000000000000000000000000000000000000000;hb=00b953eca8f8cdb1e39cf37c14c3705af3fc1afe;hp=09a6f00ac776249347074b15cc96f05086967019;hpb=9a09a1be54afb5e15dfea8a8676bd6e1941b37ec;p=timetravel.git diff --git a/Interpreter.hs b/Interpreter.hs deleted file mode 100644 index 09a6f00..0000000 --- a/Interpreter.hs +++ /dev/null @@ -1,251 +0,0 @@ -{-# OPTIONS_GHC -W #-} -{-# Language MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} -{-# Language GeneralizedNewtypeDeriving #-} - -module Main - ( Statement(..) - , Expr(..) - , trace - , main - ) where - -import Prelude hiding (lookup) - -import AST -import Programs -import qualified Data.Map as Map -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 System.IO -import System.IO.Error - - - -type Name = String -type Env = Map.Map Name Val - -lookup :: Name -> Env -> Eval Val -lookup k t = case Map.lookup k t of - Just x -> return x - Nothing -> throwError ("Unknown variable " ++ k) - -{-- Monadic style expression evaluator, - -- with error handling and Reader monad instance to carry dictionary - --} - -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 -evali op e0 e1 = do e0' <- eval e0 - e1' <- eval e1 - case (e0', e1') of - (I i0, I i1) -> return $ I (i0 `op` i1) - _ -> throwError "type error in arithmetic expression" - -evalb :: (Bool -> Bool -> Bool) -> Expr -> Expr -> Eval Val -evalb op e0 e1 = do e0' <- eval e0 - e1' <- eval e1 - case (e0', e1') of - (B i0, B i1) -> return $ B (i0 `op` i1) - _ -> throwError "type error in boolean expression" - -evalib :: (Int -> Int -> Bool) -> Expr -> Expr -> Eval Val -evalib op e0 e1 = do e0' <- eval e0 - e1' <- eval e1 - case (e0', e1') of - (I i0, I i1) -> return $ B (i0 `op` i1) - _ -> throwError "type error in arithmetic expression" - -eval :: Expr -> Eval Val -eval (Const v) = return v -eval (Add e0 e1) = evali (+) e0 e1 -eval (Sub e0 e1) = evali (-) e0 e1 -eval (Mul e0 e1) = evali (*) e0 e1 -eval (Div e0 e1) = evali div e0 e1 - -eval (And e0 e1) = evalb (&&) e0 e1 -eval (Or e0 e1) = evalb (||) e0 e1 - -eval (Not e0 ) = evalb (const not) e0 (Const (B True)) - -eval (Eq e0 e1) = evalib (==) e0 e1 -eval (Gt e0 e1) = evalib (>) e0 e1 -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 - --- | 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) - -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) - - --- | Executes a statement -exec :: Statement -> Interpreter () -exec s = logStatement s >> go s - where - 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 x) = do - res <- evalI cond - 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 () - -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 (trace testProg) [] [] `catch` (\e -> unless (isEOFError e) (throw e)) - where - 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 - printProg list done - putStr "> " - 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) -> 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 xs (e:done) bps - Nothing -> continue xs (e:done) bps - where - hitBreakpoint :: Maybe Breakpoint - hitBreakpoint = foldl f Nothing bps - f :: Maybe Breakpoint -> Breakpoint -> Maybe Breakpoint - f Nothing cond = case runEval env (eval cond) of - Right (B True) -> Just cond - _ -> Nothing - f acc _ = acc - - 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 - | 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 = withDebug $ do - putStrLn "Available commands:" - putStrLn " n Next statement" - putStrLn " p Previous statement" - putStrLn " ? Show help" - putStrLn " c Continue to breakpoint" - putStrLn " b Set conditional breakpoint" - putStrLn " d Delete breakpoint" - putStrLn " l List breakpoints" - --- | 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 - --- | Truncates a string *lazily* -trunc :: String -> String -trunc s - | tooLong s 0 = take 64 s ++ "..." - | otherwise = s - where tooLong "" n = n > 64 - tooLong (_:_) 64 = True - tooLong (_:xs) n = tooLong xs (n + 1)