From: Luke Lau <luke_lau@icloud.com>
Date: Sat, 24 Nov 2018 19:28:06 +0000 (+0000)
Subject: Add timetravel
X-Git-Url: https://git.lukelau.me/?p=timetravel.git;a=commitdiff_plain;h=7c8e673e4ad1b59527ae5fb6f15365e4f40905c6

Add timetravel
---

diff --git a/Interpreter.hs b/Interpreter.hs
index c86a084..dd3c835 100644
--- a/Interpreter.hs
+++ b/Interpreter.hs
@@ -1,18 +1,18 @@
-{-# OPTIONS_GHC -Wall #-}
+{-# OPTIONS_GHC -W #-}
 {-# Language MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
 {-# Language GeneralizedNewtypeDeriving #-}
 
-module Interpreter
+module Main
   ( Statement(..)
   , Expr(..)
   , runInterpreter
+  , main
   ) where
 
 import Prelude hiding (lookup)
 
 import Data.Functor
 import qualified Data.Map as Map
-import Data.Maybe
 import Data.Char
 import Control.Exception
 import Control.Monad.Identity
@@ -26,7 +26,6 @@ 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                                    -}
@@ -155,16 +154,19 @@ data Statement = Assign String Expr
                | Pass
       deriving (Eq, Show)
 
--- | A record of stuff being printed or run
-data Effect = EffectStatement Statement Env
-            | EffectPrint String
+-- | A record of stuff being printed and run
+data Effect = Effect Statement Env [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 s e = output >>= (Interpreter . lift . tell . pure . Effect s e)
+  where output :: Interpreter [String]
+        output
+          | (Print e) <- s = pure . show <$> evalI e
+          | otherwise = return []
 
 hoistEither :: Either String b -> Interpreter b
 hoistEither = Interpreter . ExceptT . return
@@ -195,8 +197,8 @@ exec s = get >>= logStatement s >> go s
     go w@(While cond s) = 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)
+    go (Print _) = pure () -- the printing is done in 'logStatement'
     go Pass = pure ()
 
 runInterpreter :: Interpreter a -> [Effect]
@@ -208,28 +210,39 @@ type Breakpoint = Expr
 
 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 (runInterpreter (exec 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 :: [Effect] -> [Effect] -> [Breakpoint] -> IO ()
+    go [] _ _ = return ()
+    -- go bps (e@(EffectPrint str):xs) done = putStrLn str >> go bps xs (e:done)
+    go list@(e@(Effect s 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) -> let expr = read exprStr in go list done (expr:bps)
+        "c" -> continue xs (e:done) 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 :: [Effect] -> [Effect] -> [Breakpoint] -> IO ()
+    continue [] _ _ = return ()
+    continue (e@(Effect _ 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,19 +251,26 @@ 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 :: [Effect] -> [Effect] -> IO ()
+    printProg [] _ = putStrLn "Completed"
+    printProg (current:next) done = mapM_ putStrLn ls
+      where ls = above ++ [currentS] ++ below
+            currentS = "  @" ++ trunc (show (getStatement current))
+            above = map ("   " ++) $ sample done
+            below = map ("   " ++) $ sample next
+            sample = map (trunc . show . getStatement) . take 3
+            getStatement (Effect s _ _) = s
 
     printEnv :: Env -> IO ()
     printEnv e = 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"
@@ -270,4 +290,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)