Interpreter.hs

   1 {-# OPTIONS_GHC -Wall #-}
   2 {-# Language MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
   3 {-# Language GeneralizedNewtypeDeriving #-}
   4
   5 module Interpreter
   6   ( Statement(..)
   7   , Expr(..)
   8   , runInterpreter
   9   ) where
  10
  11 import Prelude hiding (lookup)
  12
  13 import Data.Functor
  14 import qualified Data.Map as Map
  15 import Data.Maybe
  16 import Data.Char
  17 import Control.Exception
  18 import Control.Monad.Identity
  19 import Control.Monad.Except
  20 import Control.Monad.Reader
  21 import Control.Monad.State
  22 import Control.Monad.Writer
  23 import Control.Applicative hiding (Const)
  24 import System.IO
  25 import System.IO.Error
  26 import qualified Text.ParserCombinators.ReadP as Read
  27 import Text.ParserCombinators.ReadP ((<++))
  28 import qualified Text.Read as Read (lift, readPrec)
  29 import Debug.Trace
  30
  31 {-------------------------------------------------------------------}
  32 {- The pure expression language                                    -}
  33 {-------------------------------------------------------------------}
  34
  35 data Val = I Int | B Bool
  36            deriving Eq
  37
  38 instance Show Val where
  39   show (I x) = show x
  40   show (B x) = show x
  41
  42 data Expr = Const Val
  43      | Add Expr Expr | Sub Expr Expr  | Mul Expr Expr | Div Expr Expr
  44      | And Expr Expr | Or Expr Expr | Not Expr
  45      | Eq Expr Expr | Gt Expr Expr | Lt Expr Expr
  46      | Var String
  47    deriving Eq
  48
  49 instance Show Expr where
  50   show (Const v) = show v
  51   show (Add e1 e2) = show e1 ++ " + " ++ show e2
  52   show (Sub e1 e2) = show e1 ++ " - " ++ show e2
  53   show (Mul e1 e2) = show e1 ++ " * " ++ show e2
  54   show (Div e1 e2) = show e1 ++ " / " ++ show e2
  55   show (And e1 e2) = show e1 ++ " & " ++ show e2
  56   show (Or e1 e2) = show e1 ++ " | " ++ show e2
  57   show (Not e) = "!" ++ show e
  58   show (Eq e1 e2) = show e1 ++ " == " ++ show e2
  59   show (Gt e1 e2) = show e1 ++ " > " ++ show e2
  60   show (Lt e1 e2) = show e1 ++ " < " ++ show e2
  61   show (Var s) = s
  62
  63 instance Read Expr where
  64   readPrec = Read.lift pExpr
  65     where pExpr :: Read.ReadP Expr
  66           pExpr = pVar <|> pLit <++ pBinOp
  67           pBrackets = Read.between (Read.char '(') (Read.char ')')
  68
  69           pVar = Var <$> Read.munch1 isLetter
  70           pLit = pLit' B <|> pLit' I
  71           pLit' x = Const . x <$> Read.readS_to_P (readsPrec 10000)
  72
  73           pBinOp = do
  74             e1 <- pLit <|> pVar
  75             Read.char ' '
  76             op <- pOp
  77             Read.char ' '
  78             e2 <- pLit <|> pVar
  79             return (op e1 e2)
  80
  81           pOp = Read.choice
  82             [ Read.string "==" $> Eq
  83             , Read.char '+' $> Add
  84             , Read.char '-' $> Sub
  85             ]
  86
  87
  88 type Name = String
  89 type Env = Map.Map Name Val
  90
  91 lookup :: Name -> Env -> Eval Val
  92 lookup k t = case Map.lookup k t of
  93                Just x -> return x
  94                Nothing -> throwError ("Unknown variable " ++ k)
  95
  96 {-- Monadic style expression evaluator,
  97  -- with error handling and Reader monad instance to carry dictionary
  98  --}
  99
 100 type Eval a = ReaderT Env (ExceptT String Identity) a
 101 runEval env ex = runIdentity ( runExceptT ( runReaderT ex env) )
 102
 103 evali :: (Int -> Int -> Int) -> Expr -> Expr -> Eval Val
 104 evali op e0 e1 = do e0' <- eval e0
 105                     e1' <- eval e1
 106                     case (e0', e1') of
 107                          (I i0, I i1) -> return $ I (i0 `op` i1)
 108                          _            -> throwError "type error in arithmetic expression"
 109
 110 evalb :: (Bool -> Bool -> Bool) -> Expr -> Expr -> Eval Val
 111 evalb op e0 e1 = do e0' <- eval e0
 112                     e1' <- eval e1
 113                     case (e0', e1') of
 114                          (B i0, B i1) -> return $ B (i0 `op` i1)
 115                          _            -> throwError "type error in boolean expression"
 116
 117 evalib :: (Int -> Int -> Bool) -> Expr -> Expr -> Eval Val
 118 evalib op e0 e1 = do e0' <- eval e0
 119                      e1' <- eval e1
 120                      case (e0', e1') of
 121                           (I i0, I i1) -> return $ B (i0 `op` i1)
 122                           _            -> throwError "type error in arithmetic expression"
 123
 124 eval :: Expr -> Eval Val
 125 eval (Const v) = return v
 126 eval (Add e0 e1) = evali (+) e0 e1
 127 eval (Sub e0 e1) = evali (-) e0 e1
 128 eval (Mul e0 e1) = evali (*) e0 e1
 129 eval (Div e0 e1) = evali div e0 e1
 130
 131 eval (And e0 e1) = evalb (&&) e0 e1
 132 eval (Or e0 e1) = evalb (||) e0 e1
 133
 134 eval (Not e0  ) = evalb (const not) e0 (Const (B True))
 135   where not2 a _ = not a -- hack, hack
 136
 137 eval (Eq e0 e1) = evalib (==) e0 e1
 138 eval (Gt e0 e1) = evalib (>) e0 e1
 139 eval (Lt e0 e1) = evalib (<) e0 e1
 140
 141 eval (Var s) = do env <- ask
 142                   lookup s env
 143
 144
 145 {-------------------------------------------------------------------}
 146 {- The statement language                                          -}
 147
 148
 149 data Statement = Assign String Expr
 150                | If Expr Statement Statement
 151                | While Expr Statement
 152                | Print Expr
 153                | Seq Statement Statement
 154                | Try Statement Statement
 155                | Pass
 156       deriving (Eq, Show)
 157
 158 -- | A record of stuff being printed or run
 159 data Effect = EffectStatement Statement Env
 160             | EffectPrint String
 161
 162 -- Keep it pure!
 163 newtype Interpreter a = Interpreter { runI :: ExceptT String (WriterT [Effect] (State Env)) a }
 164   deriving (Functor, Applicative, Monad, MonadState Env, MonadWriter [Effect], MonadError String)
 165
 166 logStatement :: Statement -> Env -> Interpreter ()
 167 logStatement s e = Interpreter $ lift $ tell $ pure $ EffectStatement s e
 168
 169 hoistEither :: Either String b -> Interpreter b
 170 hoistEither = Interpreter . ExceptT . return
 171
 172 evalI :: Expr -> Interpreter Val
 173 evalI e = get >>= hoistEither . flip runEval (eval e)
 174
 175 testProg = Seq (Assign "x" (Const (I 0))) loop
 176   where loop = Seq (Print (Var "x"))
 177                    (Seq (Assign "x" (Add (Var "x") (Const (I 1))))
 178                         loop)
 179 testTry = Try (Print (Add (Const (I 3)) (Const (B True))))
 180               (Print (Const (I 0)))
 181
 182 exec :: Statement -> Interpreter ()
 183 exec s = get >>= logStatement s >> go s
 184   where
 185     go (Assign n e) = do
 186       env <- get
 187       new <- hoistEither $ runEval env (eval e)
 188       modify $ Map.insert n new
 189     go (Seq s1 s2) = exec s1 >> exec s2
 190     go (If cond sThen sElse) = do
 191       res <- evalI cond
 192       if res == B True
 193           then exec sThen
 194           else exec sElse
 195     go w@(While cond s) = do
 196       res <- evalI cond
 197       when (res == B True) $ exec s >> exec w
 198     go (Print e) = evalI e >>= (tell . pure . EffectPrint . show)
 199     go (Try s catch) = exec s `catchError` const (exec catch)
 200     go Pass = pure ()
 201
 202 runInterpreter :: Interpreter a -> [Effect]
 203 runInterpreter f =
 204   let (result, effects) = fst $ flip runState mempty $ runWriterT $ runExceptT $ runI f
 205     in effects
 206
 207 type Breakpoint = Expr
 208
 209 main = do
 210   hSetBuffering stdin LineBuffering -- read stuff one line at a time
 211   go mempty (runInterpreter (exec testProg)) `catch` (\e -> unless (isEOFError e) (throw e))
 212   where
 213     go :: [Breakpoint] -> [Effect] -> IO ()
 214     go _ [] = return ()
 215     go bps (EffectPrint str:xs) = putStrLn str >> go bps xs
 216     go bps list@(EffectStatement s env:xs) = do
 217       withDebug $ do
 218         printEnv env
 219         putStrLn $ "@" ++ trunc (show s)
 220       putStr "> "
 221       c <- getLine
 222       case c of
 223         "n" -> go bps xs
 224         ('b':' ':exprStr) -> let expr = read exprStr in go (expr:bps) list
 225         "c" ->
 226           let seek [] = return ()
 227               seek (EffectStatement s env:xs) =
 228                 case hitBreakpoint of
 229                   Just bp -> do
 230                     withDebug $ putStrLn $ "hit breakpoint: " ++ show bp
 231                     go bps xs
 232                   Nothing -> seek xs
 233                 where
 234                   hitBreakpoint :: Maybe Breakpoint
 235                   hitBreakpoint = foldl f Nothing bps
 236                   f :: Maybe Breakpoint -> Breakpoint -> Maybe Breakpoint
 237                   f Nothing cond = case runEval env (eval cond) of
 238                     Right (B True) -> Just cond
 239                     _ -> Nothing
 240                   f acc _ = acc
 241               seek (x:xs) = seek xs
 242             in seek xs
 243         "?" -> printHelp >> go bps list
 244         _ -> putStrLn "What?" >> go bps list
 245
 246     printEnv :: Env -> IO ()
 247     printEnv e = putStr s
 248       where s = unlines $ Map.foldlWithKey f [] e
 249             f acc k v = acc ++ [k ++ ": " ++ show v]
 250
 251     printHelp = do
 252       putStrLn "Available commands:"
 253       putStrLn " n        Next statement"
 254       putStrLn " ?        Show help"
 255       putStrLn " c        Continue to breakpoint"
 256       putStrLn " b <expr> Set conditional breakpoint"
 257
 258 -- | Ansi escapes any output to be kind of gray
 259 withDebug :: IO a -> IO a
 260 withDebug f = do
 261   putStr "\ESC[38;5;240m"
 262   res <- f
 263   putStr "\ESC[0m"
 264   return res
 265
 266 -- | Truncates a string *lazily*
 267 trunc :: String -> String
 268 trunc s
 269   | tooLong s 0 = take 64 s ++ "..."
 270   | otherwise = s
 271   where tooLong "" n = n > 64
 272         tooLong (_:_) 64 = True
 273         tooLong (x:xs) n = tooLong xs (n + 1)