+++ /dev/null
-{-# OPTIONS_GHC -W #-}
-{-# Language MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
-{-# Language GeneralizedNewtypeDeriving #-}
-
-module Main
- ( Statement(..)
- , Expr(..)
- , trace
- , 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.Identity
-import Control.Monad.Except
-import Control.Monad.Reader
-import Control.Monad.State
-import Control.Monad.Writer
-import System.IO
-import System.IO.Error
-
-
-
-type Name = String
-type Env = Map.Map Name Val
-
-lookup :: Name -> Env -> Eval Val
-lookup k t = case Map.lookup k t of
- Just x -> return x
- Nothing -> throwError ("Unknown variable " ++ k)
-
-{-- Monadic style expression evaluator,
- -- with error handling and Reader monad instance to carry dictionary
- --}
-
-type Eval a = ReaderT Env (ExceptT String Identity) a
-
-runEval :: Env -> Eval a -> Either String a
-runEval env ex = runIdentity ( runExceptT ( runReaderT ex env) )
-
-evali :: (Int -> Int -> Int) -> Expr -> Expr -> Eval Val
-evali op e0 e1 = do e0' <- eval e0
- e1' <- eval e1
- case (e0', e1') of
- (I i0, I i1) -> return $ I (i0 `op` i1)
- _ -> throwError "type error in arithmetic expression"
-
-evalb :: (Bool -> Bool -> Bool) -> Expr -> Expr -> Eval Val
-evalb op e0 e1 = do e0' <- eval e0
- e1' <- eval e1
- case (e0', e1') of
- (B i0, B i1) -> return $ B (i0 `op` i1)
- _ -> throwError "type error in boolean expression"
-
-evalib :: (Int -> Int -> Bool) -> Expr -> Expr -> Eval Val
-evalib op e0 e1 = do e0' <- eval e0
- e1' <- eval e1
- case (e0', e1') of
- (I i0, I i1) -> return $ B (i0 `op` i1)
- _ -> throwError "type error in arithmetic expression"
-
-eval :: Expr -> Eval Val
-eval (Const v) = return v
-eval (Add e0 e1) = evali (+) e0 e1
-eval (Sub e0 e1) = evali (-) e0 e1
-eval (Mul e0 e1) = evali (*) e0 e1
-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 (Eq e0 e1) = evalib (==) e0 e1
-eval (Gt e0 e1) = evalib (>) e0 e1
-eval (Lt e0 e1) = evalib (<) e0 e1
-
-eval (Var s) = do env <- ask
- lookup s env
-
--- | A step that was taken during the execution of the program
-data Step = Step Statement -- ^ The statement that was executed
- Env -- ^ The state of the environment before the statement 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 }
- deriving (Functor, Applicative, Monad, MonadState Env, MonadWriter [Step], MonadError String)
-
-logStatement :: Statement -> Interpreter ()
-logStatement s = do
- env <- get
- o <- output
- Interpreter $ lift $ tell $ pure $ Step s env o
- where output :: Interpreter [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
- go (Assign n e) = modify . Map.insert n =<< evalI e
- go (Seq s1 s2) = exec s1 >> exec s2
- go (If cond sThen sElse) = do
- res <- evalI cond
- if res == B True
- then exec sThen
- else exec sElse
- go w@(While cond x) = do
- res <- evalI cond
- when (res == B True) $ exec x >> exec w
- go (Try t c) = exec t `catchError` const (exec c)
- 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
- go (trace testProg) [] [] `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 list@(e@(Step _ env output):xs) done bps = do
- withDebug $ do
- printEnv env
- printProg list done
- putStr "> "
- c <- getLine
- case c of
- "n" -> mapM_ putStrLn output >> go xs (e:done) bps
-
- "p" -> case done of
- [] -> return ()
- (y:ys) -> go (y:list) ys bps
-
- ('b':' ':exprStr) -> do
- let expr = read exprStr
- withColor 32 $
- putStrLn $ "Added breakpoint " ++ show expr
- go list done (expr:bps)
-
- "c" -> continue xs (e:done) bps
-
- "l" -> do
- withColor 32 $ case bps of
- [] -> putStrLn "No breakpoints"
- _ -> mapM_ print bps
- go list done bps
-
- ('d':' ':exprStr) -> do
- let expr = read exprStr
- withColor 32 $ if expr `elem` bps
- then putStrLn $ "Deleted breakpoint " ++ exprStr
- else putStrLn $ "Couldn't find breakpoint " ++ exprStr
- go list done (delete expr 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 :: [Step] -> [Step] -> [Breakpoint] -> IO ()
- continue [] _ _ = return ()
- continue (e@(Step _ env output):xs) done bps = do
- mapM_ putStrLn output
- case hitBreakpoint of
- Just bp -> do
- 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
- f :: Maybe Breakpoint -> Breakpoint -> Maybe Breakpoint
- f Nothing cond = case runEval env (eval cond) of
- Right (B True) -> Just cond
- _ -> Nothing
- f acc _ = acc
-
- printProg :: [Step] -> [Step] -> IO ()
- printProg [] _ = withColor 240 $ putStrLn "Completed"
- printProg (current:next) done = withColor 240 $ mapM_ putStrLn ls
- where ls = above ++ [currentS] ++ below
- currentS = " @" ++ trunc (show (getStatement current))
- above = map (" " ++) $ reverse (sample done)
- below = map (" " ++) $ sample next
- sample = map (trunc . show . getStatement) . take 3
- getStatement (Step s _ _) = s
-
- printEnv :: Env -> IO ()
- printEnv e
- | null e = withColor 40 $ putStrLn "No variables"
- | otherwise = withColor 40 $ putStr s
- where s = unlines $ Map.foldlWithKey f [] e
- f acc k v = acc ++ [k ++ ": " ++ show v]
-
- 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"
- putStrLn " d <expr> Delete breakpoint"
- putStrLn " l List breakpoints"
-
--- | Add Ansi escape code to produce foreground color
-withColor :: Int -> IO a -> IO a
-withColor color f = do
- putStr $ "\ESC[38;5;" ++ show color ++ "m"
- res <- f
- putStr "\ESC[0m"
- return res
-
--- | Truncates a string *lazily*
-trunc :: String -> String
-trunc s
- | tooLong s 0 = take 64 s ++ "..."
- | otherwise = s
- where tooLong "" n = n > 64
- tooLong (_:_) 64 = True
- tooLong (_:xs) n = tooLong xs (n + 1)
projects / timetravel.git / blobdiff