X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=Interpreter.hs;h=09a6f00ac776249347074b15cc96f05086967019;hb=9a09a1be54afb5e15dfea8a8676bd6e1941b37ec;hp=c86a084eef828960cef13418dbf87e9429dc8ff7;hpb=51ebe8b2e5b7e9d37cdeae2e994911a359655330;p=timetravel.git

diff --git a/Interpreter.hs b/Interpreter.hs
index c86a084..09a6f00 100644
--- a/Interpreter.hs
+++ b/Interpreter.hs
@@ -1,88 +1,29 @@
-{-# 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
@@ -98,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
@@ -132,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
@@ -141,95 +83,120 @@ 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)
-
--- | 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
@@ -238,27 +205,38 @@ main = do
           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
@@ -270,4 +248,4 @@ trunc s
   | 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)