--- /dev/null
+{-# OPTIONS_GHC -W #-}
+{-# Language MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
+{-# Language GeneralizedNewtypeDeriving #-}
+
+module Main where
+
+import Prelude hiding (lookup)
+
+import AST
+import qualified Data.Map as Map
+import Data.List hiding (lookup)
+import Control.Exception
+import Control.Monad.Identity
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Writer
+import System.Exit
+import System.IO
+import System.IO.Error
+import Programs
+import Text.Read (readMaybe)
+
+
+type Name = String
+type Env = Map.Map Name Val
+
+lookup :: Name -> Env -> Eval Val
+lookup k t = case Map.lookup k t of
+ Just x -> return x
+ Nothing -> throwError ("Unknown variable " ++ k)
+
+{-- Monadic style expression evaluator,
+ -- with error handling and Reader monad instance to carry dictionary
+ --}
+
+type Eval a = ReaderT Env (ExceptT String Identity) a
+
+runEval :: Env -> Eval a -> Either String a
+runEval env ex = runIdentity ( runExceptT ( runReaderT ex env) )
+
+evali :: (Int -> Int -> Int) -> Expr -> Expr -> Eval Val
+evali op e0 e1 = do e0' <- eval e0
+ e1' <- eval e1
+ case (e0', e1') of
+ (I i0, I i1) -> return $ I (i0 `op` i1)
+ _ -> throwError "type error in arithmetic expression"
+
+evalb :: (Bool -> Bool -> Bool) -> Expr -> Expr -> Eval Val
+evalb op e0 e1 = do e0' <- eval e0
+ e1' <- eval e1
+ case (e0', e1') of
+ (B i0, B i1) -> return $ B (i0 `op` i1)
+ _ -> throwError "type error in boolean expression"
+
+evalib :: (Int -> Int -> Bool) -> Expr -> Expr -> Eval Val
+evalib op e0 e1 = do e0' <- eval e0
+ e1' <- eval e1
+ case (e0', e1') of
+ (I i0, I i1) -> return $ B (i0 `op` i1)
+ _ -> throwError "type error in arithmetic expression"
+
+eval :: Expr -> Eval Val
+eval (Const v) = return v
+eval (Add e0 e1) = evali (+) e0 e1
+eval (Sub e0 e1) = evali (-) e0 e1
+eval (Mul e0 e1) = evali (*) e0 e1
+eval (Div e0 e1) = evali div e0 e1
+
+eval (And e0 e1) = evalb (&&) e0 e1
+eval (Or e0 e1) = evalb (||) e0 e1
+
+eval (Not e0 ) = evalb (const not) e0 (Const (B True))
+
+eval (Eq e0 e1) = evalib (==) e0 e1
+eval (Gt e0 e1) = evalib (>) e0 e1
+eval (Lt e0 e1) = evalib (<) e0 e1
+
+eval (Var s) = do env <- ask
+ lookup s env
+
+-- | A step that was taken during the execution of the program
+data Step = Step Statement -- ^ The statement that was executed
+ Env -- ^ The state of the environment before the statement was executed
+ [String] -- ^ Any output from executing the statement
+
+-- | Keep it pure!
+-- Traces the execution of a program, and
+newtype Interpreter a = Interpreter { runI :: ExceptT String (WriterT [Step] (State Env)) a }
+ deriving (Functor, Applicative, Monad, MonadState Env, MonadWriter [Step], MonadError String)
+
+logStatement :: Statement -> Interpreter ()
+logStatement s = do
+ env <- get
+ o <- output
+ Interpreter $ lift $ tell $ pure $ Step s env o
+ where output :: Interpreter [String]
+ output
+ | (Print e) <- s = pure . show <$> evalI e
+ | otherwise = return []
+
+hoistEither :: Either String b -> Interpreter b
+hoistEither = Interpreter . ExceptT . return
+
+-- | Evaluates an expression with the current environment inside Interpreter
+evalI :: Expr -> Interpreter Val
+evalI e = get >>= hoistEither . flip runEval (eval e)
+
+
+-- | Executes a statement
+exec :: Statement -> Interpreter ()
+exec s = logStatement s >> go s
+ where
+ go (Assign n e) = modify . Map.insert n =<< evalI e
+ go (Seq s1 s2) = exec s1 >> exec s2
+ go (If cond sThen sElse) = do
+ res <- evalI cond
+ if res == B True
+ then exec sThen
+ else exec sElse
+ go w@(While cond x) = do
+ res <- evalI cond
+ when (res == B True) $ exec x >> exec w
+ go (Try t c) = exec t `catchError` const (exec c)
+ go (Print _) = pure () -- the printing is done in 'logStatement'
+ go Pass = pure ()
+
+trace :: Statement -> [Step]
+trace f =
+ let interp = runI (exec f)
+ (_result, effects) = fst $ flip runState mempty $ runWriterT $ runExceptT interp
+ in effects
+
+type Breakpoint = Expr
+
+main :: IO ()
+main = do
+ hSetBuffering stdin LineBuffering -- read stuff one line at a time
+ putStrLn "ttdb: time travelling debugger"
+ printMenuHelp
+ menu
+
+menu :: IO ()
+menu = do
+ cmd <- prompt
+ case cmd of
+ "?" -> printMenuHelp >> menu
+ "r increment" -> debugProg increment
+ "r tryCatch" -> debugProg tryCatch
+ "r fibonacci" -> debugProg fibonacci
+ ('r':' ':file) -> read <$> readFile file >>= debugProg
+ x -> printUnknown x >> menu
+
+debugProg :: Statement -> IO ()
+debugProg prog = go (trace prog) [] [] `catch` (\e -> unless (isEOFError e) (throw e))
+ where
+ go :: [Step] -- ^ Effects to step through
+ -> [Step] -- ^ Effects that have been stepped through
+ -> [Breakpoint]
+ -> IO ()
+ go [] _ _ = finishDebug
+ go list@(e@(Step _ env output):xs) done bps = do
+ printEnv env
+ printProg list done
+ c <- prompt
+ case c of
+ "n" -> mapM_ putStrLn output >> go xs (e:done) bps
+
+ "p" -> case done of
+ [] -> return ()
+ (y:ys) -> go (y:list) ys bps
+
+ ('e':' ':exprStr) -> do
+ mExpr <- tryReadExpr exprStr
+ case mExpr of
+ Just expr -> case runEval env (eval expr) of
+ Left err -> withColor 1 (print err)
+ Right val -> withColor 250 (print val)
+ Nothing -> return ()
+ go list done bps
+
+ ('b':' ':exprStr) -> do
+ mExpr <- tryReadExpr exprStr
+ case mExpr of
+ Just expr -> withColor 32 $ do
+ putStrLn $ "Added breakpoint " ++ show expr
+ go list done (expr:bps)
+ Nothing -> go list done bps
+
+ "c" -> continue xs (e:done) bps
+
+ "l" -> do
+ withColor 32 $ case bps of
+ [] -> putStrLn "No breakpoints"
+ _ -> putStrLn "Breakpoints:" >> mapM_ print bps
+ go list done bps
+
+ ('d':' ':exprStr) -> do
+ mExpr <- tryReadExpr exprStr
+ case mExpr of
+ Just expr -> do
+ withColor 32 $ if expr `elem` bps
+ then putStrLn $ "Deleted breakpoint " ++ exprStr
+ else putStrLn $ "Couldn't find breakpoint " ++ exprStr
+ go list done (delete expr bps)
+ Nothing -> go list done bps
+
+ "?" -> printHelp >> go list done bps
+
+ _ -> printUnknown c >> go list done bps
+
+ -- | Continues until the first breakpoint is hit
+ continue :: [Step] -> [Step] -> [Breakpoint] -> IO ()
+ continue [] _ _ = finishDebug
+ continue (e@(Step _ env output):xs) done bps = do
+ mapM_ putStrLn output
+ case hitBreakpoint of
+ Just bp -> do
+ withColor 32 $ putStrLn $ "Hit breakpoint: " ++ show bp
+ go xs (e:done) bps
+ Nothing -> continue xs (e:done) bps
+ where
+ hitBreakpoint :: Maybe Breakpoint
+ hitBreakpoint = foldl f Nothing bps
+ f :: Maybe Breakpoint -> Breakpoint -> Maybe Breakpoint
+ f Nothing cond = case runEval env (eval cond) of
+ Right (B True) -> Just cond
+ _ -> Nothing
+ f acc _ = acc
+
+ finishDebug = putStrLn "Program terminated" >> menu
+
+tryReadExpr :: String -> IO (Maybe Expr)
+tryReadExpr str
+ | Just expr <- readMaybe str = return (Just expr)
+ | otherwise = do
+ withColor 1 $ putStrLn "Couldn't read expression"
+ return Nothing
+
+-- | Prints the future, present and past of a program
+printProg :: [Step] -> [Step] -> IO ()
+printProg [] _ = return ()
+printProg (current:next) done = withColor 250 $ mapM_ putStrLn ls
+ where ls = above ++ [currentS] ++ below
+ currentS = " @" ++ trunc (show (getStatement current))
+ above = map (" " ++) $ reverse (sample done)
+ below = map (" " ++) $ sample next
+ sample = map (trunc . show . getStatement) . take 3
+ getStatement (Step s _ _) = s
+
+printEnv :: Env -> IO ()
+printEnv e
+ | null e = withColor 64 $ putStrLn "No variables"
+ | otherwise = withColor 64 $ putStr s
+ where s = unlines $ Map.foldlWithKey f [] e
+ f acc k v = acc ++ [k ++ ": " ++ show v]
+
+printHelp = do
+ putStrLn "Available commands:"
+ putStrLn " n Next statement"
+ putStrLn " p Previous statement"
+ putStrLn " e <expr> Evaluate expression"
+ putStrLn " c Continue to breakpoint"
+ putStrLn " b <expr> Set conditional breakpoint"
+ putStrLn " d <expr> Delete breakpoint"
+ putStrLn " l List breakpoints"
+ putStrLn " ? Show help"
+
+printMenuHelp = do
+ putStrLn "Available commands:"
+ putStrLn " r <file> Run a program"
+ putStrLn " r <name> Run a program from Program.hs"
+ putStrLn " ? Show help"
+
+printUnknown :: String -> IO ()
+printUnknown x =
+ putStrLn $ "I don't know what '" ++ x ++ "' means. Enter ? for help"
+
+-- | Prompt the user for some input
+prompt :: IO String
+prompt = do
+ withColor 8 $ putStr "(ttdb) "
+ hFlush stdout
+ getLine `catch` \e ->
+ if isEOFError e
+ then putStrLn "" >> exitSuccess
+ else throw e
+
+-- | Add Ansi escape code to produce foreground color
+withColor :: Int -> IO a -> IO a
+withColor color f = do
+ putStr $ "\ESC[38;5;" ++ show color ++ "m"
+ res <- f
+ putStr "\ESC[0m"
+ return res
+
+-- | Truncates a string *lazily*
+trunc :: String -> String
+trunc s
+ | tooLong s 0 = take 64 s ++ "..."
+ | otherwise = s
+ where tooLong "" n = n > 64
+ tooLong (_:_) 64 = True
+ tooLong (_:xs) n = tooLong xs (n + 1)
projects / timetravel.git / blobdiff