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

diff --git a/Interpreter.hs b/Main.hs
similarity index 62%
rename from Interpreter.hs
rename to Main.hs
index 09a6f00..cbe9996 100644
--- a/Interpreter.hs
+++ b/Main.hs
@@ -2,17 +2,11 @@
 {-# Language MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
 {-# Language GeneralizedNewtypeDeriving #-}
 
-module Main
-  ( Statement(..)
-  , Expr(..)
-  , trace
-  , main
-  ) where
+module Main where
 
 import Prelude hiding (lookup)
 
 import AST
-import Programs
 import qualified Data.Map as Map
 import Data.List hiding (lookup)
 import Control.Exception
@@ -21,9 +15,11 @@ 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
@@ -140,19 +136,33 @@ 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))
+  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 [] _ _ = return ()
+    go [] _ _ = finishDebug
     go list@(e@(Step _ env output):xs) done bps = do
-      withDebug $ do
       printEnv env
       printProg list done
-      putStr "> "
-      c <- getLine
+      c <- prompt
       case c of
         "n" -> mapM_ putStrLn output >> go xs (e:done) bps
         
@@ -160,41 +170,53 @@ main = do
           [] -> 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
-          let expr = read exprStr
-          withColor 32 $
+          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"
-            _ -> mapM_ print bps
+            _ -> putStrLn "Breakpoints:" >> mapM_ print bps
           go list done bps
 
         ('d':' ':exprStr) -> do
-          let expr = read exprStr
+          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
 
-        _ -> do
-          putStrLn $ "I don't know what '" ++ c ++ "' means. Enter ? for help"
-          go list done bps
+        _ -> printUnknown c >> go list done bps
 
     -- | Continues until the first breakpoint is hit
     continue :: [Step] -> [Step] -> [Breakpoint] -> IO ()
-    continue [] _ _ = return ()
+    continue [] _ _ = finishDebug
     continue (e@(Step _ env output):xs) done bps = do
       mapM_ putStrLn output
       case hitBreakpoint of
         Just bp -> do
-          withDebug $ putStrLn $ "Hit breakpoint: " ++ show bp
+          withColor 32 $ putStrLn $ "Hit breakpoint: " ++ show bp
           go xs (e:done) bps
         Nothing -> continue xs (e:done) bps
       where
@@ -206,9 +228,19 @@ main = do
           _ -> 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 [] _ = withColor 240 $ putStrLn "Completed"
-    printProg (current:next) done = withColor 240 $ mapM_ putStrLn ls
+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)
@@ -218,20 +250,41 @@ main = do
 
 printEnv :: Env -> IO ()
 printEnv e
-      | null e = withColor 40 $ putStrLn "No variables"
-      | otherwise = withColor 40 $ putStr s
+  | 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 = withDebug $ do
+printHelp = do
   putStrLn "Available commands:"
   putStrLn " n        Next statement"
   putStrLn " p        Previous statement"
-      putStrLn " ?        Show help"
+  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