From: Luke Lau <luke_lau@icloud.com>
Date: Sat, 24 Nov 2018 01:11:42 +0000 (+0000)
Subject: Initial commit
X-Git-Url: https://git.lukelau.me/?p=timetravel.git;a=commitdiff_plain;h=51ebe8b2e5b7e9d37cdeae2e994911a359655330

Initial commit
---

51ebe8b2e5b7e9d37cdeae2e994911a359655330
diff --git a/Interpreter.hs b/Interpreter.hs
new file mode 100644
index 0000000..c86a084
--- /dev/null
+++ b/Interpreter.hs
@@ -0,0 +1,273 @@
+{-# 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)