--- /dev/null
+{-# OPTIONS_GHC -Wall #-}
+{-# Language MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
+{-# Language GeneralizedNewtypeDeriving #-}
+
+module Interpreter
+ ( Statement(..)
+ , Expr(..)
+ , runInterpreter
+ ) 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 Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Writer
+import Control.Applicative hiding (Const)
+import System.IO
+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 -}
+{-------------------------------------------------------------------}
+
+data Val = I Int | B Bool
+ deriving Eq
+
+instance Show Val where
+ show (I x) = show x
+ show (B x) = show x
+
+data Expr = Const Val
+ | Add Expr Expr | Sub Expr Expr | Mul Expr Expr | Div Expr Expr
+ | And Expr Expr | Or Expr Expr | Not Expr
+ | Eq Expr Expr | Gt Expr Expr | Lt Expr Expr
+ | Var String
+ deriving Eq
+
+instance Show Expr where
+ show (Const v) = show v
+ show (Add e1 e2) = show e1 ++ " + " ++ show e2
+ show (Sub e1 e2) = show e1 ++ " - " ++ show e2
+ show (Mul e1 e2) = show e1 ++ " * " ++ show e2
+ show (Div e1 e2) = show e1 ++ " / " ++ show e2
+ show (And e1 e2) = show e1 ++ " & " ++ show e2
+ show (Or e1 e2) = show e1 ++ " | " ++ show e2
+ show (Not e) = "!" ++ show e
+ show (Eq e1 e2) = show e1 ++ " == " ++ show e2
+ show (Gt e1 e2) = show e1 ++ " > " ++ show e2
+ show (Lt e1 e2) = show e1 ++ " < " ++ show e2
+ show (Var s) = s
+
+instance Read Expr where
+ readPrec = Read.lift pExpr
+ where pExpr :: Read.ReadP Expr
+ pExpr = pVar <|> pLit <++ pBinOp
+ pBrackets = Read.between (Read.char '(') (Read.char ')')
+
+ pVar = Var <$> Read.munch1 isLetter
+ pLit = pLit' B <|> pLit' I
+ pLit' x = Const . x <$> Read.readS_to_P (readsPrec 10000)
+
+ pBinOp = do
+ e1 <- pLit <|> pVar
+ Read.char ' '
+ op <- pOp
+ Read.char ' '
+ e2 <- pLit <|> pVar
+ return (op e1 e2)
+
+ pOp = Read.choice
+ [ Read.string "==" $> Eq
+ , Read.char '+' $> Add
+ , Read.char '-' $> Sub
+ ]
+
+
+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 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))
+ where not2 a _ = not a -- hack, hack
+
+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
+
+
+{-------------------------------------------------------------------}
+{- The statement language -}
+
+
+data Statement = Assign String Expr
+ | If Expr Statement Statement
+ | While Expr Statement
+ | Print Expr
+ | Seq Statement Statement
+ | Try Statement Statement
+ | Pass
+ deriving (Eq, Show)
+
+-- | A record of stuff being printed or run
+data Effect = EffectStatement Statement Env
+ | EffectPrint 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
+
+hoistEither :: Either String b -> Interpreter b
+hoistEither = Interpreter . ExceptT . return
+
+evalI :: Expr -> Interpreter Val
+evalI e = get >>= hoistEither . flip runEval (eval e)
+
+testProg = Seq (Assign "x" (Const (I 0))) loop
+ where loop = Seq (Print (Var "x"))
+ (Seq (Assign "x" (Add (Var "x") (Const (I 1))))
+ loop)
+testTry = Try (Print (Add (Const (I 3)) (Const (B True))))
+ (Print (Const (I 0)))
+
+exec :: Statement -> Interpreter ()
+exec s = get >>= logStatement s >> go s
+ where
+ go (Assign n e) = do
+ env <- get
+ new <- hoistEither $ runEval env (eval e)
+ modify $ Map.insert n new
+ 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 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 Pass = pure ()
+
+runInterpreter :: Interpreter a -> [Effect]
+runInterpreter f =
+ let (result, effects) = fst $ flip runState mempty $ runWriterT $ runExceptT $ runI f
+ in effects
+
+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))
+ 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
+ withDebug $ do
+ printEnv env
+ putStrLn $ "@" ++ trunc (show s)
+ 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) =
+ case hitBreakpoint of
+ Just bp -> do
+ withDebug $ putStrLn $ "hit breakpoint: " ++ show bp
+ go bps xs
+ Nothing -> seek xs
+ 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
+ seek (x:xs) = seek xs
+ in seek xs
+ "?" -> printHelp >> go bps list
+ _ -> putStrLn "What?" >> go bps list
+
+ printEnv :: Env -> IO ()
+ printEnv e = putStr s
+ where s = unlines $ Map.foldlWithKey f [] e
+ f acc k v = acc ++ [k ++ ": " ++ show v]
+
+ printHelp = do
+ putStrLn "Available commands:"
+ putStrLn " n Next statement"
+ putStrLn " ? Show help"
+ putStrLn " c Continue to breakpoint"
+ putStrLn " b <expr> Set conditional breakpoint"
+
+-- | Ansi escapes any output to be kind of gray
+withDebug :: IO a -> IO a
+withDebug f = do
+ putStr "\ESC[38;5;240m"
+ 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 (x:xs) n = tooLong xs (n + 1)
projects / timetravel.git / commitdiff