X-Git-Url: http://git.lukelau.me/?p=timetravel.git;a=blobdiff_plain;f=Main.hs;fp=Main.hs;h=cbe999618300d2c9a6f762c7d9cda5b30aa1e314;hp=0000000000000000000000000000000000000000;hb=00b953eca8f8cdb1e39cf37c14c3705af3fc1afe;hpb=9a09a1be54afb5e15dfea8a8676bd6e1941b37ec

diff --git a/Main.hs b/Main.hs
new file mode 100644
index 0000000..cbe9996
--- /dev/null
+++ b/Main.hs
@@ -0,0 +1,304 @@
+{-# OPTIONS_GHC -W #-}
+{-# Language MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
+{-# Language GeneralizedNewtypeDeriving #-}
+
+module Main where
+
+import Prelude hiding (lookup)
+
+import AST
+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.Exit
+import System.IO
+import System.IO.Error
+import Programs
+import Text.Read (readMaybe)
+
+
+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
+  putStrLn "ttdb: time travelling debugger"
+  printMenuHelp
+  menu
+
+menu :: IO ()
+menu = do
+  cmd <- prompt
+  case cmd of
+    "?" -> printMenuHelp >> menu
+    "r increment" -> debugProg increment
+    "r tryCatch" -> debugProg tryCatch
+    "r fibonacci" -> debugProg fibonacci
+    ('r':' ':file) -> read <$> readFile file >>= debugProg
+    x -> printUnknown x >> menu
+
+debugProg :: Statement -> IO ()
+debugProg prog = go (trace prog) [] [] `catch` (\e -> unless (isEOFError e) (throw e))
+  where
+    go :: [Step] -- ^ Effects to step through
+       -> [Step] -- ^ Effects that have been stepped through
+       -> [Breakpoint]
+       -> IO ()
+    go [] _ _ = finishDebug
+    go list@(e@(Step _ env output):xs) done bps = do
+      printEnv env
+      printProg list done
+      c <- prompt
+      case c of
+        "n" -> mapM_ putStrLn output >> go xs (e:done) bps
+        
+        "p" -> case done of
+          [] -> return ()
+          (y:ys) -> go (y:list) ys bps
+
+        ('e':' ':exprStr) -> do
+          mExpr <- tryReadExpr exprStr
+          case mExpr of
+            Just expr -> case runEval env (eval expr) of
+              Left err -> withColor 1 (print err)
+              Right val -> withColor 250 (print val)
+            Nothing -> return ()
+          go list done bps
+
+        ('b':' ':exprStr) -> do
+          mExpr <- tryReadExpr exprStr
+          case mExpr of
+            Just expr -> withColor 32 $ do
+              putStrLn $ "Added breakpoint " ++ show expr
+              go list done (expr:bps)
+            Nothing -> go list done bps
+
+        "c" -> continue xs (e:done) bps
+
+        "l" -> do
+          withColor 32 $ case bps of
+            [] -> putStrLn "No breakpoints"
+            _ -> putStrLn "Breakpoints:" >> mapM_ print bps
+          go list done bps
+
+        ('d':' ':exprStr) -> do
+          mExpr <- tryReadExpr exprStr
+          case mExpr of
+            Just expr -> do
+              withColor 32 $ if expr `elem` bps
+                then putStrLn $ "Deleted breakpoint " ++ exprStr
+                else putStrLn $ "Couldn't find breakpoint " ++ exprStr
+              go list done (delete expr bps)
+            Nothing -> go list done bps
+
+        "?" -> printHelp >> go list done bps
+
+        _ -> printUnknown c >> go list done bps
+
+    -- | Continues until the first breakpoint is hit
+    continue :: [Step] -> [Step] -> [Breakpoint] -> IO ()
+    continue [] _ _ = finishDebug
+    continue (e@(Step _ env output):xs) done bps = do
+      mapM_ putStrLn output
+      case hitBreakpoint of
+        Just bp -> do
+          withColor 32 $ 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
+
+    finishDebug = putStrLn "Program terminated" >> menu
+
+tryReadExpr :: String -> IO (Maybe Expr)
+tryReadExpr str
+  | Just expr <- readMaybe str = return (Just expr)
+  | otherwise = do
+      withColor 1 $ putStrLn "Couldn't read expression" 
+      return Nothing
+
+-- | Prints the future, present and past of a program
+printProg :: [Step] -> [Step] -> IO ()
+printProg [] _ = return ()
+printProg (current:next) done = withColor 250 $ 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 64 $ putStrLn "No variables"
+  | otherwise = withColor 64 $ putStr s
+  where s = unlines $ Map.foldlWithKey f [] e
+        f acc k v = acc ++ [k ++ ": " ++ show v]
+
+printHelp = do
+  putStrLn "Available commands:"
+  putStrLn " n        Next statement"
+  putStrLn " p        Previous statement"
+  putStrLn " e <expr> Evaluate expression"
+  putStrLn " c        Continue to breakpoint"
+  putStrLn " b <expr> Set conditional breakpoint"
+  putStrLn " d <expr> Delete breakpoint"
+  putStrLn " l        List breakpoints"
+  putStrLn " ?        Show help"
+
+printMenuHelp = do
+  putStrLn "Available commands:"
+  putStrLn " r <file> Run a program"
+  putStrLn " r <name> Run a program from Program.hs"
+  putStrLn " ?        Show help"
+
+printUnknown :: String -> IO ()
+printUnknown x = 
+  putStrLn $ "I don't know what '" ++ x ++ "' means. Enter ? for help"
+
+-- | Prompt the user for some input
+prompt :: IO String
+prompt = do
+  withColor 8 $ putStr "(ttdb) "
+  hFlush stdout
+  getLine `catch` \e ->
+    if isEOFError e
+      then putStrLn "" >> exitSuccess
+      else throw e
+
+-- | 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)