Interpreter.hs

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