Interpreter.hs

   1 {-# OPTIONS_GHC -W #-}
   2 {-# Language MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
   3 {-# Language GeneralizedNewtypeDeriving #-}
   4
   5 module Main
   6   ( Statement(..)
   7   , Expr(..)
   8   , trace
   9   , main
  10   ) where
  11
  12 import Prelude hiding (lookup)
  13
  14 import AST
  15 import Programs
  16 import qualified Data.Map as Map
  17 import Data.List hiding (lookup)
  18 import Control.Exception
  19 import Control.Monad.Identity
  20 import Control.Monad.Except
  21 import Control.Monad.Reader
  22 import Control.Monad.State
  23 import Control.Monad.Writer
  24 import System.IO
  25 import System.IO.Error
  26
  27
  28
  29 type Name = String
  30 type Env = Map.Map Name Val
  31
  32 lookup :: Name -> Env -> Eval Val
  33 lookup k t = case Map.lookup k t of
  34                Just x -> return x
  35                Nothing -> throwError ("Unknown variable " ++ k)
  36
  37 {-- Monadic style expression evaluator,
  38  -- with error handling and Reader monad instance to carry dictionary
  39  --}
  40
  41 type Eval a = ReaderT Env (ExceptT String Identity) a
  42
  43 runEval :: Env -> Eval a -> Either String a
  44 runEval env ex = runIdentity ( runExceptT ( runReaderT ex env) )
  45
  46 evali :: (Int -> Int -> Int) -> Expr -> Expr -> Eval Val
  47 evali op e0 e1 = do e0' <- eval e0
  48                     e1' <- eval e1
  49                     case (e0', e1') of
  50                          (I i0, I i1) -> return $ I (i0 `op` i1)
  51                          _            -> throwError "type error in arithmetic expression"
  52
  53 evalb :: (Bool -> Bool -> Bool) -> Expr -> Expr -> Eval Val
  54 evalb op e0 e1 = do e0' <- eval e0
  55                     e1' <- eval e1
  56                     case (e0', e1') of
  57                          (B i0, B i1) -> return $ B (i0 `op` i1)
  58                          _            -> throwError "type error in boolean expression"
  59
  60 evalib :: (Int -> Int -> Bool) -> Expr -> Expr -> Eval Val
  61 evalib op e0 e1 = do e0' <- eval e0
  62                      e1' <- eval e1
  63                      case (e0', e1') of
  64                           (I i0, I i1) -> return $ B (i0 `op` i1)
  65                           _            -> throwError "type error in arithmetic expression"
  66
  67 eval :: Expr -> Eval Val
  68 eval (Const v) = return v
  69 eval (Add e0 e1) = evali (+) e0 e1
  70 eval (Sub e0 e1) = evali (-) e0 e1
  71 eval (Mul e0 e1) = evali (*) e0 e1
  72 eval (Div e0 e1) = evali div e0 e1
  73
  74 eval (And e0 e1) = evalb (&&) e0 e1
  75 eval (Or e0 e1) = evalb (||) e0 e1
  76
  77 eval (Not e0  ) = evalb (const not) e0 (Const (B True))
  78
  79 eval (Eq e0 e1) = evalib (==) e0 e1
  80 eval (Gt e0 e1) = evalib (>) e0 e1
  81 eval (Lt e0 e1) = evalib (<) e0 e1
  82
  83 eval (Var s) = do env <- ask
  84                   lookup s env
  85
  86 -- | A step that was taken during the execution of the program
  87 data Step = Step Statement  -- ^ The statement that was executed
  88                  Env        -- ^ The state of the environment before the statement was executed
  89                  [String]   -- ^ Any output from executing the statement
  90
  91 -- | Keep it pure!
  92 -- Traces the execution of a program, and
  93 newtype Interpreter a = Interpreter { runI :: ExceptT String (WriterT [Step] (State Env)) a }
  94   deriving (Functor, Applicative, Monad, MonadState Env, MonadWriter [Step], MonadError String)
  95
  96 logStatement :: Statement -> Interpreter ()
  97 logStatement s = do
  98   env <- get
  99   o <- output
 100   Interpreter $ lift $ tell $ pure $ Step s env o
 101   where output :: Interpreter [String]
 102         output
 103           | (Print e) <- s = pure . show <$> evalI e
 104           | otherwise = return []
 105
 106 hoistEither :: Either String b -> Interpreter b
 107 hoistEither = Interpreter . ExceptT . return
 108
 109 -- | Evaluates an expression with the current environment inside Interpreter
 110 evalI :: Expr -> Interpreter Val
 111 evalI e = get >>= hoistEither . flip runEval (eval e)
 112
 113
 114 -- | Executes a statement
 115 exec :: Statement -> Interpreter ()
 116 exec s = logStatement s >> go s
 117   where
 118     go (Assign n e) = modify . Map.insert n =<< evalI e
 119     go (Seq s1 s2) = exec s1 >> exec s2
 120     go (If cond sThen sElse) = do
 121       res <- evalI cond
 122       if res == B True
 123           then exec sThen
 124           else exec sElse
 125     go w@(While cond x) = do
 126       res <- evalI cond
 127       when (res == B True) $ exec x >> exec w
 128     go (Try t c) = exec t `catchError` const (exec c)
 129     go (Print _) = pure () -- the printing is done in 'logStatement'
 130     go Pass = pure ()
 131
 132 trace :: Statement -> [Step]
 133 trace f =
 134   let interp = runI (exec f)
 135       (_result, effects) = fst $ flip runState mempty $ runWriterT $ runExceptT interp
 136     in effects
 137
 138 type Breakpoint = Expr
 139
 140 main :: IO ()
 141 main = do
 142   hSetBuffering stdin LineBuffering -- read stuff one line at a time
 143   go (trace testProg) [] [] `catch` (\e -> unless (isEOFError e) (throw e))
 144   where
 145     go :: [Step] -- ^ Effects to step through
 146        -> [Step] -- ^ Effects that have been stepped through
 147        -> [Breakpoint]
 148        -> IO ()
 149     go [] _ _ = return ()
 150     go list@(e@(Step _ env output):xs) done bps = do
 151       withDebug $ do
 152         printEnv env
 153         printProg list done
 154       putStr "> "
 155       c <- getLine
 156       case c of
 157         "n" -> mapM_ putStrLn output >> go xs (e:done) bps
 158
 159         "p" -> case done of
 160           [] -> return ()
 161           (y:ys) -> go (y:list) ys bps
 162
 163         ('b':' ':exprStr) -> do
 164           let expr = read exprStr
 165           withColor 32 $
 166             putStrLn $ "Added breakpoint " ++ show expr
 167           go list done (expr:bps)
 168
 169         "c" -> continue xs (e:done) bps
 170
 171         "l" -> do
 172           withColor 32 $ case bps of
 173             [] -> putStrLn "No breakpoints"
 174             _ -> mapM_ print bps
 175           go list done bps
 176
 177         ('d':' ':exprStr) -> do
 178           let expr = read exprStr
 179           withColor 32 $ if expr `elem` bps
 180             then putStrLn $ "Deleted breakpoint " ++ exprStr
 181             else putStrLn $ "Couldn't find breakpoint " ++ exprStr
 182           go list done (delete expr bps)
 183
 184         "?" -> printHelp >> go list done bps
 185
 186         _ -> do
 187           putStrLn $ "I don't know what '" ++ c ++ "' means. Enter ? for help"
 188           go list done bps
 189
 190     -- | Continues until the first breakpoint is hit
 191     continue :: [Step] -> [Step] -> [Breakpoint] -> IO ()
 192     continue [] _ _ = return ()
 193     continue (e@(Step _ env output):xs) done bps = do
 194       mapM_ putStrLn output
 195       case hitBreakpoint of
 196         Just bp -> do
 197           withDebug $ putStrLn $ "Hit breakpoint: " ++ show bp
 198           go xs (e:done) bps
 199         Nothing -> continue xs (e:done) bps
 200       where
 201         hitBreakpoint :: Maybe Breakpoint
 202         hitBreakpoint = foldl f Nothing bps
 203         f :: Maybe Breakpoint -> Breakpoint -> Maybe Breakpoint
 204         f Nothing cond = case runEval env (eval cond) of
 205           Right (B True) -> Just cond
 206           _ -> Nothing
 207         f acc _ = acc
 208
 209     printProg :: [Step] -> [Step] -> IO ()
 210     printProg [] _ = withColor 240 $ putStrLn "Completed"
 211     printProg (current:next) done = withColor 240 $ mapM_ putStrLn ls
 212       where ls = above ++ [currentS] ++ below
 213             currentS = "  @" ++ trunc (show (getStatement current))
 214             above = map ("   " ++) $ reverse (sample done)
 215             below = map ("   " ++) $ sample next
 216             sample = map (trunc . show . getStatement) . take 3
 217             getStatement (Step s _ _) = s
 218
 219     printEnv :: Env -> IO ()
 220     printEnv e
 221       | null e = withColor 40 $ putStrLn "No variables"
 222       | otherwise = withColor 40 $ putStr s
 223       where s = unlines $ Map.foldlWithKey f [] e
 224             f acc k v = acc ++ [k ++ ": " ++ show v]
 225
 226     printHelp = withDebug $ do
 227       putStrLn "Available commands:"
 228       putStrLn " n        Next statement"
 229       putStrLn " p        Previous statement"
 230       putStrLn " ?        Show help"
 231       putStrLn " c        Continue to breakpoint"
 232       putStrLn " b <expr> Set conditional breakpoint"
 233       putStrLn " d <expr> Delete breakpoint"
 234       putStrLn " l        List breakpoints"
 235
 236 -- | Add Ansi escape code to produce foreground color
 237 withColor :: Int -> IO a -> IO a
 238 withColor color f = do
 239   putStr $ "\ESC[38;5;" ++ show color ++ "m"
 240   res <- f
 241   putStr "\ESC[0m"
 242   return res
 243
 244 -- | Truncates a string *lazily*
 245 trunc :: String -> String
 246 trunc s
 247   | tooLong s 0 = take 64 s ++ "..."
 248   | otherwise = s
 249   where tooLong "" n = n > 64
 250         tooLong (_:_) 64 = True
 251         tooLong (_:xs) n = tooLong xs (n + 1)