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 e0  ) = evalb (const not) e0 (Const (B True))
  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':' ':file) -> read <$> readFile file >>= debugProg
 159     x -> printUnknown x >> menu
 160
 161 type Breakpoint = Expr
 162
 163 debugProg :: Statement -> IO ()
 164 debugProg prog = go (trace prog) [] [] `catch` (\e -> unless (isEOFError e) (throw e))
 165   where
 166     go :: [Step] -- ^ Steps to step through
 167        -> [Step] -- ^ Steps that have been stepped through
 168        -> [Breakpoint]
 169        -> IO ()
 170     go [] _ _ = finishDebug
 171     go list@(e@(Step _ env output):xs) done bps = do
 172       printEnv env
 173       printProg list done
 174       c <- prompt
 175       case c of
 176         "n" -> mapM_ putStrLn output >> go xs (e:done) bps
 177
 178         "p" -> case done of
 179           [] -> finishDebug
 180           (y:ys) -> go (y:list) ys bps
 181
 182         ('e':' ':exprStr) -> do
 183           mExpr <- tryReadExpr exprStr
 184           case mExpr of
 185             Just expr -> case runEval env (eval expr) of
 186               Left err -> withColor 1 (print err)
 187               Right val -> withColor 250 (print val)
 188             Nothing -> return ()
 189           go list done bps
 190
 191         ('b':' ':exprStr) -> do
 192           mExpr <- tryReadExpr exprStr
 193           case mExpr of
 194             Just expr -> withColor 32 $ do
 195               putStrLn $ "Added breakpoint " ++ show expr
 196               go list done (expr:bps)
 197             Nothing -> go list done bps
 198
 199         "c" -> continue xs (e:done) bps False
 200         "cb" -> continue xs (e:done) bps True
 201
 202         "l" -> do
 203           withColor 32 $ case bps of
 204             [] -> putStrLn "No breakpoints"
 205             _ -> putStrLn "Breakpoints:" >> mapM_ print bps
 206           go list done bps
 207
 208         ('d':' ':exprStr) -> do
 209           mExpr <- tryReadExpr exprStr
 210           case mExpr of
 211             Just expr -> do
 212               withColor 32 $ if expr `elem` bps
 213                 then putStrLn $ "Deleted breakpoint " ++ exprStr
 214                 else putStrLn $ "Couldn't find breakpoint " ++ exprStr
 215               go list done (delete expr bps)
 216             Nothing -> go list done bps
 217
 218         "?" -> printHelp >> go list done bps
 219
 220         _ -> printUnknown c >> go list done bps
 221
 222     -- | Continues until the first breakpoint is hit
 223     continue :: [Step] -> [Step] -> [Breakpoint] -> Bool -> IO ()
 224     continue [] _ _ False = finishDebug
 225     continue _ [] _ True = finishDebug
 226     continue [] (x:xs) bps True = continue [x] xs bps True
 227     continue list@(e@(Step _ env output):xs) done bps backwards = do
 228       mapM_ putStrLn output
 229       case hitBreakpoint of
 230         Just bp -> do
 231           withColor 32 $ putStrLn $ "Hit breakpoint: " ++ show bp
 232           go list done bps
 233         Nothing -> if backwards
 234           then continue (head done:list) (tail done) bps backwards
 235           else continue xs (e:done) bps backwards
 236       where
 237         hitBreakpoint :: Maybe Breakpoint
 238         hitBreakpoint = foldl f Nothing bps
 239         f :: Maybe Breakpoint -> Breakpoint -> Maybe Breakpoint
 240         f Nothing cond = case runEval env (eval cond) of
 241           Right (B True) -> Just cond
 242           _ -> Nothing
 243         f acc _ = acc
 244
 245     finishDebug = putStrLn "Program terminated" >> menu
 246
 247 tryReadExpr :: String -> IO (Maybe Expr)
 248 tryReadExpr str
 249   | Just expr <- readMaybe str = return (Just expr)
 250   | otherwise = do
 251       withColor 1 $ putStrLn "Couldn't read expression"
 252       return Nothing
 253
 254 -- | Prints the future, present and past of a program
 255 printProg :: [Step] -> [Step] -> IO ()
 256 printProg [] _ = return ()
 257 printProg (current:next) done = withColor 250 $ mapM_ putStrLn ls
 258   where ls = above ++ [currentS] ++ below
 259         currentS = "  @" ++ trunc (show (getStatement current))
 260         above = map ("   " ++) $ reverse (sample done)
 261         below = map ("   " ++) $ sample next
 262         sample = map (trunc . show . getStatement) . take 3
 263         getStatement (Step s _ _) = s
 264
 265 printEnv :: Env -> IO ()
 266 printEnv e
 267   | null e = withColor 64 $ putStrLn "No variables"
 268   | otherwise = withColor 64 $ putStr s
 269   where s = unlines $ Map.foldlWithKey f [] e
 270         f acc k v = acc ++ [k ++ ": " ++ show v]
 271
 272 printHelp = do
 273   putStrLn "Available commands:"
 274   putStrLn " n        Next statement"
 275   putStrLn " p        Previous statement"
 276   putStrLn " e <expr> Evaluate expression"
 277   putStrLn " c        Continue to breakpoint"
 278   putStrLn " cb       Continue backwards to breakpoint"
 279   putStrLn " b <expr> Set conditional breakpoint"
 280   putStrLn " d <expr> Delete breakpoint"
 281   putStrLn " l        List breakpoints"
 282   putStrLn " ?        Show help"
 283
 284 printMenuHelp = do
 285   putStrLn "Available commands:"
 286   putStrLn " r <file> Run a program"
 287   putStrLn " r <name> Run a program from Program.hs"
 288   putStrLn " ?        Show help"
 289
 290 printUnknown :: String -> IO ()
 291 printUnknown x =
 292   putStrLn $ "I don't know what '" ++ x ++ "' means. Enter ? for help"
 293
 294 -- | Prompt the user for some input
 295 prompt :: IO String
 296 prompt = do
 297   withColor 8 $ putStr "(ttdb) "
 298   hFlush stdout
 299   getLine `catch` \e ->
 300     if isEOFError e
 301       then putStrLn "" >> exitSuccess
 302       else throw e
 303
 304 -- | Add Ansi escape code to produce foreground color
 305 withColor :: Int -> IO a -> IO a
 306 withColor color f = do
 307   putStr $ "\ESC[38;5;" ++ show color ++ "m"
 308   res <- f
 309   putStr "\ESC[0m"
 310   return res
 311
 312 -- | Truncates a string *lazily*
 313 trunc :: String -> String
 314 trunc s
 315   | tooLong s 0 = take 64 s ++ "..."
 316   | otherwise = s
 317   where tooLong "" n = n > 64
 318         tooLong (_:_) 64 = True
 319         tooLong (_:xs) n = tooLong xs (n + 1)