From 00b953eca8f8cdb1e39cf37c14c3705af3fc1afe Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Sun, 25 Nov 2018 00:50:31 +0000 Subject: [PATCH] Project-ify --- .gitignore | 8 +++ AST.hs | 8 +-- LICENSE | 5 ++ Interpreter.hs => Main.hs | 109 ++++++++++++++++++++++++++++---------- Programs.hs | 22 ++++++-- README.md | 1 + Setup.hs | 2 + stack.yaml | 3 ++ tryCatch.prog | 1 + ttdb.cabal | 20 +++++++ 10 files changed, 143 insertions(+), 36 deletions(-) create mode 100644 .gitignore create mode 100644 LICENSE rename Interpreter.hs => Main.hs (62%) create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 stack.yaml create mode 100644 tryCatch.prog create mode 100644 ttdb.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..eb34585 --- /dev/null +++ b/.gitignore @@ -0,0 +1,8 @@ +.stack-work/ +dist +dist-newstyle +cabal.project.* +*.swp +*.swo +.ghc.environment.* +.DS_Store diff --git a/AST.hs b/AST.hs index cf1fc40..4aac768 100644 --- a/AST.hs +++ b/AST.hs @@ -40,7 +40,7 @@ instance Show Expr where instance Read Expr where readPrec = lift pExpr where - pExpr = pVar +++ pLit +++ pBinOp + pExpr = (pLit <++ pVar) +++ pBinOp pBrackets = between (char '(') (char ')') pVar = Var <$> munch1 isLetter @@ -50,11 +50,11 @@ instance Read Expr where pBinOp = do -- TODO: figure out how to just use pExpr without getting -- stuck recursively - e1 <- pVar +++ pLit +++ pBrackets pBinOp + e1 <- (pLit <++ pVar) +++ pBrackets pBinOp skipSpaces op <- pOp skipSpaces - e2 <- pVar +++ pLit +++ pBrackets pBinOp + e2 <- (pLit <++ pVar) +++ pBrackets pBinOp return (op e1 e2) pOp = choice @@ -80,5 +80,5 @@ data Statement = Assign String Expr | Seq Statement Statement | Try Statement Statement | Pass - deriving (Eq, Show) + deriving (Eq, Show, Read) diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..1f95d26 --- /dev/null +++ b/LICENSE @@ -0,0 +1,5 @@ +Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Interpreter.hs b/Main.hs similarity index 62% rename from Interpreter.hs rename to Main.hs index 09a6f00..cbe9996 100644 --- a/Interpreter.hs +++ b/Main.hs @@ -2,17 +2,11 @@ {-# Language MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} {-# Language GeneralizedNewtypeDeriving #-} -module Main - ( Statement(..) - , Expr(..) - , trace - , main - ) where +module Main where import Prelude hiding (lookup) import AST -import Programs import qualified Data.Map as Map import Data.List hiding (lookup) import Control.Exception @@ -21,9 +15,11 @@ 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 @@ -140,19 +136,33 @@ type Breakpoint = Expr main :: IO () main = do hSetBuffering stdin LineBuffering -- read stuff one line at a time - go (trace testProg) [] [] `catch` (\e -> unless (isEOFError e) (throw e)) + 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 [] _ _ = return () + go [] _ _ = finishDebug go list@(e@(Step _ env output):xs) done bps = do - withDebug $ do printEnv env printProg list done - putStr "> " - c <- getLine + c <- prompt case c of "n" -> mapM_ putStrLn output >> go xs (e:done) bps @@ -160,41 +170,53 @@ main = do [] -> 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 - let expr = read exprStr - withColor 32 $ + 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" - _ -> mapM_ print bps + _ -> putStrLn "Breakpoints:" >> mapM_ print bps go list done bps ('d':' ':exprStr) -> do - let expr = read exprStr + 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 - _ -> do - putStrLn $ "I don't know what '" ++ c ++ "' means. Enter ? for help" - go list done bps + _ -> printUnknown c >> go list done bps -- | Continues until the first breakpoint is hit continue :: [Step] -> [Step] -> [Breakpoint] -> IO () - continue [] _ _ = return () + continue [] _ _ = finishDebug continue (e@(Step _ env output):xs) done bps = do mapM_ putStrLn output case hitBreakpoint of Just bp -> do - withDebug $ putStrLn $ "Hit breakpoint: " ++ show bp + withColor 32 $ putStrLn $ "Hit breakpoint: " ++ show bp go xs (e:done) bps Nothing -> continue xs (e:done) bps where @@ -206,9 +228,19 @@ main = do _ -> 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 [] _ = withColor 240 $ putStrLn "Completed" - printProg (current:next) done = withColor 240 $ mapM_ putStrLn ls +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) @@ -218,20 +250,41 @@ main = do printEnv :: Env -> IO () printEnv e - | null e = withColor 40 $ putStrLn "No variables" - | otherwise = withColor 40 $ putStr s + | 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 = withDebug $ do +printHelp = do putStrLn "Available commands:" putStrLn " n Next statement" putStrLn " p Previous statement" - putStrLn " ? Show help" + putStrLn " e Evaluate expression" putStrLn " c Continue to breakpoint" putStrLn " b Set conditional breakpoint" putStrLn " d Delete breakpoint" putStrLn " l List breakpoints" + putStrLn " ? Show help" + +printMenuHelp = do + putStrLn "Available commands:" + putStrLn " r Run a program" + putStrLn " r 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 diff --git a/Programs.hs b/Programs.hs index 22cc493..14f066b 100644 --- a/Programs.hs +++ b/Programs.hs @@ -2,11 +2,25 @@ module Programs where import AST -testProg :: Statement -testProg = Seq (Assign "x" (Const (I 0))) loop +-- | Infinitely increments and prints x (can't be written to a file sadly) +increment :: Statement +increment = Seq (Assign "x" (Const (I 0))) loop where loop = Seq (Print (Var "x")) (Seq (Assign "x" (Add (Var "x") (Const (I 1)))) loop) -testTry :: Statement -testTry = Try (Print (Add (Const (I 3)) (Const (B True)))) + +-- | Catches a type error and prints 0 +tryCatch :: Statement +tryCatch = Try (Print (Add (Const (I 3)) (Const (B True)))) (Print (Const (I 0))) + +-- | Calculates nth fibonacci (5 by default) and stores result in 'x' +fibonacci :: Statement +fibonacci = Seq (Assign "n" (Const (I 5))) + (Seq (Assign "x" (Const (I 1))) + (Seq (Assign "y" (Const (I 0))) + (While (Gt (Var "n") (Const (I 0))) + (Seq (Assign "tmp" (Var "x")) + (Seq (Assign "x" (Add (Var "x") (Var "y"))) + (Seq (Assign "y" (Var "x")) + (Assign "n" (Sub (Var "n") (Const (I 1)))))))))) diff --git a/README.md b/README.md new file mode 100644 index 0000000..1d53a51 --- /dev/null +++ b/README.md @@ -0,0 +1 @@ +# Time Travelling Debugger diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..91f30ff --- /dev/null +++ b/stack.yaml @@ -0,0 +1,3 @@ +resolver: nightly-2018-11-24 +packages: +- . diff --git a/tryCatch.prog b/tryCatch.prog new file mode 100644 index 0000000..41b4d5c --- /dev/null +++ b/tryCatch.prog @@ -0,0 +1 @@ +Try (Print 3 + True) (Print 0) \ No newline at end of file diff --git a/ttdb.cabal b/ttdb.cabal new file mode 100644 index 0000000..de59cfa --- /dev/null +++ b/ttdb.cabal @@ -0,0 +1,20 @@ +name: ttdb +version: 0.1.0.0 +synopsis: Time travelling debugger +license: MIT +license-file: LICENSE +author: Luke Lau +maintainer: luke_lau@icloud.com +category: Development +build-type: Simple +extra-source-files: stack.yaml, README.md +cabal-version: >=1.10 + +executable ttdb + main-is: Main.hs + other-modules: Programs + , AST + build-depends: base >=4.12 && <4.13 + , containers >=0.6 && <0.7 + , mtl >=2.2 && <2.3 + default-language: Haskell2010 -- 2.30.2