Main.hs

   1 {-# OPTIONS_GHC -W #-}
   2 {-# Language MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
   3 {-# Language GeneralizedNewtypeDeriving #-}
   4
   5 module Main where
   6
   7 import Prelude hiding (lookup)
   8
   9 import AST
  10 import qualified Data.Map as Map
  11 import Data.List hiding (lookup)
  12 import Control.Exception
  13 import Control.Monad.Identity
  14 import Control.Monad.Except
  15 import Control.Monad.Reader
  16 import Control.Monad.State
  17 import Control.Monad.Writer
  18 import System.Exit
  19 import System.IO
  20 import System.IO.Error
  21 import Programs
  22 import Text.Read (readMaybe)
  23
  24
  25 type Name = String
  26 type Env = Map.Map Name Val
  27
  28 lookup :: Name -> Env -> Eval Val
  29 lookup k t = case Map.lookup k t of
  30                Just x -> return x
  31                Nothing -> throwError ("Unknown variable " ++ k)
  32
  33 {-- Monadic style expression evaluator,
  34  -- with error handling and Reader monad instance to carry dictionary
  35  --}
  36
  37 type Eval a = ReaderT Env (ExceptT String Identity) a
  38
  39 runEval :: Env -> Eval a -> Either String a
  40 runEval env ex = runIdentity ( runExceptT ( runReaderT ex env) )
  41
  42 evali :: (Int -> Int -> Int) -> Expr -> Expr -> Eval Val
  43 evali op e0 e1 = do e0' <- eval e0
  44                     e1' <- eval e1
  45                     case (e0', e1') of
  46                          (I i0, I i1) -> return $ I (i0 `op` i1)
  47                          _            -> throwError "type error in arithmetic expression"
  48
  49 evalb :: (Bool -> Bool -> Bool) -> Expr -> Expr -> Eval Val
  50 evalb op e0 e1 = do e0' <- eval e0
  51                     e1' <- eval e1
  52                     case (e0', e1') of
  53                          (B i0, B i1) -> return $ B (i0 `op` i1)
  54                          _            -> throwError "type error in boolean expression"
  55
  56 evalib :: (Int -> Int -> Bool) -> Expr -> Expr -> Eval Val
  57 evalib op e0 e1 = do e0' <- eval e0
  58                      e1' <- eval e1
  59                      case (e0', e1') of
  60                           (I i0, I i1) -> return $ B (i0 `op` i1)
  61                           _            -> throwError "type error in arithmetic expression"
  62
  63 eval :: Expr -> Eval Val
  64 eval (Const v) = return v
  65 eval (Add e0 e1) = evali (+) e0 e1
  66 eval (Sub e0 e1) = evali (-) e0 e1
  67 eval (Mul e0 e1) = evali (*) e0 e1
  68 eval (Div e0 e1) = evali div e0 e1
  69
  70 eval (And e0 e1) = evalb (&&) e0 e1
  71 eval (Or e0 e1) = evalb (||) e0 e1
  72
  73 eval (Not e) = evalb (const not) (Const (B True)) e
  74
  75 eval (Eq e0 e1) = evalib (==) e0 e1
  76 eval (Gt e0 e1) = evalib (>) e0 e1
  77 eval (Lt e0 e1) = evalib (<) e0 e1
  78
  79 eval (Var s) = do env <- ask
  80                   lookup s env
  81
  82 -- | A step that was taken during the execution of the program
  83 data Step = Step Statement  -- ^ The statement that was executed
  84                  Env        -- ^ The state of the environment before the statement was executed
  85                  [String]   -- ^ Any output from executing the statement
  86
  87 -- | Keep it pure!
  88 -- The monad for tracing the execution of a program.
  89 -- Records a list of 'Steps' taken throughout execution
  90 -- Handles exceptions too.
  91 newtype Tracer a = Tracer { runTracer :: ExceptT String (WriterT [Step] (State Env)) a }
  92   deriving (Functor, Applicative, Monad, MonadState Env, MonadWriter [Step], MonadError String)
  93
  94 hoistEither :: Either String b -> Tracer b
  95 hoistEither = Tracer . ExceptT . return
  96
  97 -- | Evaluates an expression with the current environment inside the tracer.
  98 evalI :: Expr -> Tracer Val
  99 evalI e = get >>= hoistEither . flip runEval (eval e)
 100
 101 -- | Traces a program and returns a list of steps taken throughout its execution.
 102 -- Thanks to lazy evaluation though, the steps can be "streamed" and so this can
 103 -- be used to debug non-terminating and recursive programs!
 104 trace :: Statement -> [Step]
 105 trace x =
 106   let f = runTracer (exec x)
 107       (_result, effects) = fst $ flip runState mempty $ runWriterT $ runExceptT f
 108     in effects
 109   where
 110
 111     exec :: Statement -> Tracer ()
 112     exec s = logStatement s >> go s
 113
 114     -- | Records the statement's execution in the Tracer monad
 115     logStatement :: Statement -> Tracer ()
 116     logStatement s = do
 117       env <- get
 118       o <- output
 119       Tracer $ lift $ tell $ pure $ Step s env o
 120       where output :: Tracer [String]
 121             output
 122               | (Print e) <- s = pure . show <$> evalI e
 123               | otherwise = return []
 124
 125
 126     -- | Where the magic happens. Provides all the control flow
 127     go :: Statement -> Tracer ()
 128     go (Assign n e) = modify . Map.insert n =<< evalI e
 129     go (Seq s1 s2) = exec s1 >> exec s2
 130     go (If cond sThen sElse) = do
 131       res <- evalI cond
 132       if res == B True
 133           then exec sThen
 134           else exec sElse
 135     go w@(While cond x) = do
 136       res <- evalI cond
 137       when (res == B True) $ exec x >> exec w
 138     go (Try t c) = exec t `catchError` const (exec c)
 139     go (Print _) = pure () -- the printing is done in 'logStatement'
 140     go Pass = pure ()
 141
 142 main :: IO ()
 143 main = do
 144   hSetBuffering stdin LineBuffering -- Read stuff one line at a time
 145   putStrLn "ttdb: time travelling debugger"
 146   printMenuHelp
 147   menu
 148
 149 -- | Handles the start menu
 150 menu :: IO ()
 151 menu = do
 152   cmd <- prompt
 153   case cmd of
 154     "?" -> printMenuHelp >> menu
 155     "r increment" -> debugProg increment
 156     "r tryCatch" -> debugProg tryCatch
 157     "r fibonacci" -> debugProg fibonacci
 158     "r boolNot" -> debugProg boolNot
 159     ('r':' ':file) -> read <$> readFile file >>= debugProg
 160     x -> printUnknown x >> menu
 161
 162 type Breakpoint = Expr
 163
 164 debugProg :: Statement -> IO ()
 165 debugProg prog = go (trace prog) [] [] `catch` (\e -> unless (isEOFError e) (throw e))
 166   where
 167     go :: [Step] -- ^ Steps to step through
 168        -> [Step] -- ^ Steps that have been stepped through
 169        -> [Breakpoint]
 170        -> IO ()
 171     go [] _ _ = finishDebug
 172     go list@(e@(Step _ env output):xs) done bps = do
 173       printEnv env
 174       printProg list done
 175       c <- prompt
 176       case c of
 177         "n" -> mapM_ putStrLn output >> go xs (e:done) bps
 178
 179         "p" -> case done of
 180           [] -> finishDebug
 181           (y:ys) -> go (y:list) ys bps
 182
 183         ('e':' ':exprStr) -> do
 184           mExpr <- tryReadExpr exprStr
 185           case mExpr of
 186             Just expr -> case runEval env (eval expr) of
 187               Left err -> withColor 1 (print err)
 188               Right val -> withColor 250 (print val)
 189             Nothing -> return ()
 190           go list done bps
 191
 192         ('b':' ':exprStr) -> do
 193           mExpr <- tryReadExpr exprStr
 194           case mExpr of
 195             Just expr -> withColor 32 $ do
 196               putStrLn $ "Added breakpoint " ++ show expr
 197               go list done (expr:bps)
 198             Nothing -> go list done bps
 199
 200         "c" -> continue xs (e:done) bps False
 201         "cb" -> continue xs (e:done) bps True
 202
 203         "l" -> do
 204           withColor 32 $ case bps of
 205             [] -> putStrLn "No breakpoints"
 206             _ -> putStrLn "Breakpoints:" >> mapM_ print bps
 207           go list done bps
 208
 209         ('d':' ':exprStr) -> do
 210           mExpr <- tryReadExpr exprStr
 211           case mExpr of
 212             Just expr -> do
 213               withColor 32 $ if expr `elem` bps
 214                 then putStrLn $ "Deleted breakpoint " ++ exprStr
 215                 else putStrLn $ "Couldn't find breakpoint " ++ exprStr
 216               go list done (delete expr bps)
 217             Nothing -> go list done bps
 218
 219         "?" -> printHelp >> go list done bps
 220
 221         _ -> printUnknown c >> go list done bps
 222
 223     -- | Continues until the first breakpoint is hit
 224     continue :: [Step] -> [Step] -> [Breakpoint] -> Bool -> IO ()
 225     continue [] _ _ False = finishDebug
 226     continue _ [] _ True = finishDebug
 227     continue [] (x:xs) bps True = continue [x] xs bps True
 228     continue list@(e@(Step _ env output):xs) done bps backwards = do
 229       mapM_ putStrLn output
 230       case hitBreakpoint of
 231         Just bp -> do
 232           withColor 32 $ putStrLn $ "Hit breakpoint: " ++ show bp
 233           go list done bps
 234         Nothing -> if backwards
 235           then continue (head done:list) (tail done) bps backwards
 236           else continue xs (e:done) bps backwards
 237       where
 238         hitBreakpoint :: Maybe Breakpoint
 239         hitBreakpoint = foldl f Nothing bps
 240         f :: Maybe Breakpoint -> Breakpoint -> Maybe Breakpoint
 241         f Nothing cond = case runEval env (eval cond) of
 242           Right (B True) -> Just cond
 243           _ -> Nothing
 244         f acc _ = acc
 245
 246     finishDebug = putStrLn "Program terminated" >> menu
 247
 248 tryReadExpr :: String -> IO (Maybe Expr)
 249 tryReadExpr str
 250   | Just expr <- readMaybe str = return (Just expr)
 251   | otherwise = do
 252       withColor 1 $ putStrLn "Couldn't read expression"
 253       return Nothing
 254
 255 -- | Prints the future, present and past of a program
 256 printProg :: [Step] -> [Step] -> IO ()
 257 printProg [] _ = return ()
 258 printProg (current:next) done = withColor 250 $ mapM_ putStrLn ls
 259   where ls = above ++ [currentS] ++ below
 260         currentS = "  @" ++ trunc (show (getStatement current))
 261         above = map ("   " ++) $ reverse (sample done)
 262         below = map ("   " ++) $ sample next
 263         sample = map (trunc . show . getStatement) . take 3
 264         getStatement (Step s _ _) = s
 265
 266 printEnv :: Env -> IO ()
 267 printEnv e
 268   | null e = withColor 64 $ putStrLn "No variables"
 269   | otherwise = withColor 64 $ putStr s
 270   where s = unlines $ Map.foldlWithKey f [] e
 271         f acc k v = acc ++ [k ++ ": " ++ show v]
 272
 273 printHelp = do
 274   putStrLn "Available commands:"
 275   putStrLn " n        Next statement"
 276   putStrLn " p        Previous statement"
 277   putStrLn " e <expr> Evaluate expression"
 278   putStrLn " c        Continue to breakpoint"
 279   putStrLn " cb       Continue backwards to breakpoint"
 280   putStrLn " b <expr> Set conditional breakpoint"
 281   putStrLn " d <expr> Delete breakpoint"
 282   putStrLn " l        List breakpoints"
 283   putStrLn " ?        Show help"
 284
 285 printMenuHelp = do
 286   putStrLn "Available commands:"
 287   putStrLn " r <file> Run a program"
 288   putStrLn " r <name> Run a program from Program.hs"
 289   putStrLn " ?        Show help"
 290
 291 printUnknown :: String -> IO ()
 292 printUnknown x =
 293   putStrLn $ "I don't know what '" ++ x ++ "' means. Enter ? for help"
 294
 295 -- | Prompt the user for some input
 296 prompt :: IO String
 297 prompt = do
 298   withColor 8 $ putStr "(ttdb) "
 299   hFlush stdout
 300   getLine `catch` \e ->
 301     if isEOFError e
 302       then putStrLn "" >> exitSuccess
 303       else throw e
 304
 305 -- | Add Ansi escape code to produce foreground color
 306 withColor :: Int -> IO a -> IO a
 307 withColor color f = do
 308   putStr $ "\ESC[38;5;" ++ show color ++ "m"
 309   res <- f
 310   putStr "\ESC[0m"
 311   return res
 312
 313 -- | Truncates a string *lazily*
 314 trunc :: String -> String
 315 trunc s
 316   | tooLong s 0 = take 64 s ++ "..."
 317   | otherwise = s
 318   where tooLong "" n = n > 64
 319         tooLong (_:_) 64 = True
 320         tooLong (_:xs) n = tooLong xs (n + 1)