{-# 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
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
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
[] -> 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
_ -> 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)
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
projects / timetravel.git / commitdiff