X-Git-Url: http://git.lukelau.me/?p=timetravel.git;a=blobdiff_plain;f=Main.hs;h=951f38865fc5268e36ffa58d81d6db9c227b77ce;hp=cbe999618300d2c9a6f762c7d9cda5b30aa1e314;hb=HEAD;hpb=00b953eca8f8cdb1e39cf37c14c3705af3fc1afe diff --git a/Main.hs b/Main.hs index cbe9996..951f388 100644 --- a/Main.hs +++ b/Main.hs @@ -70,7 +70,7 @@ 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 (Not e) = evalb (const not) (Const (B True)) e eval (Eq e0 e1) = evalib (==) e0 e1 eval (Gt e0 e1) = evalib (>) e0 e1 @@ -85,32 +85,46 @@ data Step = Step Statement -- ^ The statement that 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 } +-- The monad for tracing the execution of a program. +-- Records a list of 'Steps' taken throughout execution +-- Handles exceptions too. +newtype Tracer a = Tracer { runTracer :: ExceptT String (WriterT [Step] (State Env)) a } deriving (Functor, Applicative, Monad, MonadState Env, MonadWriter [Step], MonadError String) -logStatement :: Statement -> Interpreter () +hoistEither :: Either String b -> Tracer b +hoistEither = Tracer . ExceptT . return + +-- | Evaluates an expression with the current environment inside the tracer. +evalI :: Expr -> Tracer Val +evalI e = get >>= hoistEither . flip runEval (eval e) + +-- | Traces a program and returns a list of steps taken throughout its execution. +-- Thanks to lazy evaluation though, the steps can be "streamed" and so this can +-- be used to debug non-terminating and recursive programs! +trace :: Statement -> [Step] +trace x = + let f = runTracer (exec x) + (_result, effects) = fst $ flip runState mempty $ runWriterT $ runExceptT f + in effects + where + + exec :: Statement -> Tracer () + exec s = logStatement s >> go s + + -- | Records the statement's execution in the Tracer monad + logStatement :: Statement -> Tracer () logStatement s = do env <- get o <- output - Interpreter $ lift $ tell $ pure $ Step s env o - where output :: Interpreter [String] + Tracer $ lift $ tell $ pure $ Step s env o + where output :: Tracer [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 + -- | Where the magic happens. Provides all the control flow + go :: Statement -> Tracer () go (Assign n e) = modify . Map.insert n =<< evalI e go (Seq s1 s2) = exec s1 >> exec s2 go (If cond sThen sElse) = do @@ -125,21 +139,14 @@ exec s = logStatement s >> go s 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 + hSetBuffering stdin LineBuffering -- Read stuff one line at a time putStrLn "ttdb: time travelling debugger" printMenuHelp menu +-- | Handles the start menu menu :: IO () menu = do cmd <- prompt @@ -148,14 +155,17 @@ menu = do "r increment" -> debugProg increment "r tryCatch" -> debugProg tryCatch "r fibonacci" -> debugProg fibonacci + "r boolNot" -> debugProg boolNot ('r':' ':file) -> read <$> readFile file >>= debugProg x -> printUnknown x >> menu +type Breakpoint = Expr + 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 + go :: [Step] -- ^ Steps to step through + -> [Step] -- ^ Steps that have been stepped through -> [Breakpoint] -> IO () go [] _ _ = finishDebug @@ -167,7 +177,7 @@ debugProg prog = go (trace prog) [] [] `catch` (\e -> unless (isEOFError e) (thr "n" -> mapM_ putStrLn output >> go xs (e:done) bps "p" -> case done of - [] -> return () + [] -> finishDebug (y:ys) -> go (y:list) ys bps ('e':' ':exprStr) -> do @@ -187,7 +197,8 @@ debugProg prog = go (trace prog) [] [] `catch` (\e -> unless (isEOFError e) (thr go list done (expr:bps) Nothing -> go list done bps - "c" -> continue xs (e:done) bps + "c" -> continue xs (e:done) bps False + "cb" -> continue xs (e:done) bps True "l" -> do withColor 32 $ case bps of @@ -210,15 +221,19 @@ debugProg prog = go (trace prog) [] [] `catch` (\e -> unless (isEOFError e) (thr _ -> 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 + continue :: [Step] -> [Step] -> [Breakpoint] -> Bool -> IO () + continue [] _ _ False = finishDebug + continue _ [] _ True = finishDebug + continue [] (x:xs) bps True = continue [x] xs bps True + continue list@(e@(Step _ env output):xs) done bps backwards = 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 + go list done bps + Nothing -> if backwards + then continue (head done:list) (tail done) bps backwards + else continue xs (e:done) bps backwards where hitBreakpoint :: Maybe Breakpoint hitBreakpoint = foldl f Nothing bps @@ -261,6 +276,7 @@ printHelp = do putStrLn " p Previous statement" putStrLn " e Evaluate expression" putStrLn " c Continue to breakpoint" + putStrLn " cb Continue backwards to breakpoint" putStrLn " b Set conditional breakpoint" putStrLn " d Delete breakpoint" putStrLn " l List breakpoints"