-{-# 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
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 -}
| 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
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]
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
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"
| 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)