remote-debugger 0.1.0 → 0.1.1
raw patch · 7 files changed
+1309/−1 lines, 7 files
Files
- remote-debugger.cabal +9/−1
- src/CmdArgsParser.hs +56/−0
- src/CommandParser.hs +247/−0
- src/DebuggerImpl.hs +684/−0
- src/DebuggerMonad.hs +114/−0
- src/DebuggerUtils.hs +89/−0
- src/ParserMonad.hs +110/−0
remote-debugger.cabal view
@@ -1,5 +1,5 @@ name: remote-debugger-version: 0.1.0+version: 0.1.1 description: Wraper to GHC debugger API allowing debugging throught socket. Used in haskell-idea-plugin. license: BSD3 license-file: LICENSE@@ -13,6 +13,14 @@ executable remote-debugger main-is: Main.hs+ other-modules:+ CmdArgsParser,+ CommandParser,+ DebuggerImpl,+ DebuggerMonad,+ DebuggerUtils,+ ParserMonad+ hs-source-dirs: src build-depends: base >= 3 && <5, ghc,
+ src/CmdArgsParser.hs view
@@ -0,0 +1,56 @@+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+module CmdArgsParser where++import Data.Char+import ParserMonad++data Argument+ = SetPort Int+ | Main String+ | Import String+ | ExposePkg String+ | Unknown String+ deriving Show++cmdArgument :: Parser Argument+mainArgument :: Parser Argument -- -m<file>+importArgument :: Parser Argument -- -i<path>+setPortArgument :: Parser Argument -- -p<port>+exposePkgArgument :: Parser Argument -- -pkg<package>+unknownArgument :: Parser Argument++cmdArgument = unlist [+ mainArgument,+ importArgument,+ setPortArgument,+ exposePkgArgument,+ unknownArgument+ ]++mainArgument = do+ string "-m"+ file <- restSatisfiedChars (not . isSpace)+ end+ return $ Main file++importArgument = do+ string "-i"+ dir <- restSatisfiedChars (not . isSpace)+ end+ return $ Import dir++setPortArgument = do+ string "-p"+ p <- int+ end+ return $ SetPort p++exposePkgArgument = do+ string "-pkg"+ package <- restSatisfiedChars (not . isSpace)+ end+ return $ ExposePkg package++unknownArgument = do+ arg <- restOfInput+ return $ Unknown arg
+ src/CommandParser.hs view
@@ -0,0 +1,247 @@+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+module CommandParser where++import Data.Char+import ParserMonad++------------------------------------------------------------------------+data DebugCommand + = SetBreakpoint String Int -- module, line+ | SetBreakByIndex String Int -- module, index+ | RemoveBreakpoint String Int -- module, index+ | Resume+ | History+ | Back+ | Forward+ | StepInto+ | StepOver+ | Trace String -- command+ | BreakList String -- module+ | LineBreakList String Int -- module line+ | Exit+ | Help+ | Print String -- name of binding+ | SPrint String -- name of binding+ | Force String -- expr+ | ExprType String -- expr+ | Evaluate Bool String -- force, expr+ | Set String -- flag+ | Unset String -- flag+ | BreakinfoCmd+ | Unknown+ deriving Show++debugCommand :: Parser DebugCommand+setBreakpoint :: Parser DebugCommand+setBreakByIndex :: Parser DebugCommand+removeBreakpoint :: Parser DebugCommand+resume :: Parser DebugCommand+history :: Parser DebugCommand+back :: Parser DebugCommand+forward :: Parser DebugCommand+stepInto :: Parser DebugCommand+stepOver :: Parser DebugCommand+trace :: Parser DebugCommand+breaklist :: Parser DebugCommand+lineBreaklist :: Parser DebugCommand+exit :: Parser DebugCommand+help :: Parser DebugCommand+printName :: Parser DebugCommand+sprintName :: Parser DebugCommand+force :: Parser DebugCommand+exprType :: Parser DebugCommand+evaluate :: Parser DebugCommand+set :: Parser DebugCommand+unset :: Parser DebugCommand+breakinfo :: Parser DebugCommand+unknown :: Parser DebugCommand++debugCommand = unlist [+ setBreakpoint,+ setBreakByIndex,+ removeBreakpoint,+ resume,+ history,+ back,+ forward,+ stepInto,+ stepOver,+ trace,+ breaklist,+ lineBreaklist,+ exit,+ help,+ printName,+ sprintName,+ force,+ exprType,+ evaluate,+ set,+ unset,+ breakinfo,+ unknown+ ]++setBreakpoint = do+ string ":break"+ waitAndSkipSpaces+ mod' <- restSatisfiedChars (not . isSpace)+ waitAndSkipSpaces+ line <- int+ skipSpaces+ end+ return $ SetBreakpoint mod' line++setBreakByIndex = do+ string ":breakindex"+ waitAndSkipSpaces+ moduleName <- restSatisfiedChars (not . isSpace)+ waitAndSkipSpaces+ ind <- int+ skipSpaces+ end+ return $ SetBreakByIndex moduleName ind++removeBreakpoint = do+ string ":delete"+ waitAndSkipSpaces+ moduleName <- restSatisfiedChars (not . isSpace)+ waitAndSkipSpaces+ ind <- int+ skipSpaces+ end+ return $ RemoveBreakpoint moduleName ind++resume = do+ string ":continue"+ skipSpaces+ end+ return Resume++history = do+ string ":history"+ skipSpaces+ end+ return History++back = do+ string ":back"+ skipSpaces+ end+ return Back++forward = do+ string ":forward"+ skipSpaces+ end+ return Forward++stepInto = do+ string ":step"+ skipSpaces+ end+ return StepInto++stepOver = do+ string ":steplocal"+ skipSpaces+ end+ return StepOver++trace = do+ string ":trace"+ waitAndSkipSpaces+ cmd <- restOfInput+ return $ Trace cmd++breaklist = do+ string ":breaklist"+ waitAndSkipSpaces+ mod' <- restSatisfiedChars (not . isSpace)+ skipSpaces+ end+ return $ BreakList mod'++lineBreaklist = do+ string ":breaklist"+ waitAndSkipSpaces+ mod' <- restSatisfiedChars (not . isSpace)+ waitAndSkipSpaces+ line <- int+ skipSpaces+ end+ return $ LineBreakList mod' line++exit = do+ string ":q"+ skipSpaces+ end+ return Exit++help = do+ string ":?"+ skipSpaces+ end+ return Help++printName = do+ string ":print"+ waitAndSkipSpaces+ name <- restSatisfiedChars (not . isSpace)+ skipSpaces+ end+ return $ Print name++sprintName = do+ string ":sprint"+ waitAndSkipSpaces+ name <- restSatisfiedChars (not . isSpace)+ skipSpaces+ end+ return $ SPrint name++force = do+ string ":force"+ waitAndSkipSpaces+ expr <- restOfInput+ return $ Force expr++exprType = do+ string ":type"+ waitAndSkipSpaces+ cmd <- restOfInput+ return $ ExprType cmd++evaluate = do+ string ":eval"+ waitAndSkipSpaces+ force_int <- int+ waitAndSkipSpaces+ cmd <- restOfInput+ return $ Evaluate (force_int > 0) cmd++set = do+ string ":set"+ waitAndSkipSpaces+ flag <- restSatisfiedChars (not . isSpace)+ skipSpaces+ end+ return $ Set flag++unset = do+ string ":unset"+ waitAndSkipSpaces+ flag <- restSatisfiedChars (not . isSpace)+ skipSpaces+ end+ return $ Unset flag++breakinfo = do+ string ":breakinfo"+ skipSpaces+ end+ return BreakinfoCmd++unknown = do+ restOfInput+ return $ Unknown
+ src/DebuggerImpl.hs view
@@ -0,0 +1,684 @@+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+{-# LANGUAGE CPP, FlexibleInstances, UnboxedTuples, MagicHash #-}++module DebuggerImpl where++import GHC hiding (resume, back, forward)+import qualified GHC (resume, back, forward)+import qualified InteractiveEval+import GHC.Paths ( libdir )+import DynFlags+import GhcMonad (liftIO)++import ParserMonad (parse)+import CommandParser (debugCommand, DebugCommand(..))+import CmdArgsParser (cmdArgument, Argument(..))+import DebuggerMonad++import Network.Socket+import Network.BSD++import System.IO+import System.Environment (getArgs)+import Control.Monad (mplus, liftM)+import Data.List (partition, sortBy)+import BreakArray+import Data.Array+import Data.Function (on)+import SrcLoc (realSrcSpanEnd)++import Data.Maybe+import DebuggerUtils++import Debugger ()++import PprTyThing++import GHC.Exts()++---- || Debugger runner || --------------------------------------------------------------------------++tryRun :: DebuggerMonad (Result, Bool) -> DebuggerMonad (Result, Bool)+tryRun func = func `catch`+ (\ex -> return ([+ ("info", ConsStr "exception"),+ ("message", ConsStr $ show ex)+ ], False))+++-- |Runs Ghc program with default settings+defaultRunGhc :: DebuggerMonad a -> IO ()+defaultRunGhc program = defaultErrorHandler defaultFatalMessager defaultFlushOut $ runGhc (Just libdir) $+ startDebugger (do+ handleArguments+ st <- getDebugState+ modulePath <- do+ case (mainFile st) of+ Just path -> return path+ Nothing -> error "Main module not specified"+ setupContext modulePath "Main"+ initDebugOutput+ initInterpBuffering+ turnOffBuffering -- turns off buffering of stdout and stderr of program+ program+ return ()+ ) initState++-- |Setup needed flags before running debug program+setupContext :: String -> String -> DebuggerMonad ()+setupContext pathToModule nameOfModule = do+ dflags <- getSessionDynFlags+ setSessionDynFlags $ dflags { hscTarget = HscInterpreted+ , ghcLink = LinkInMemory+ , ghcMode = CompManager+ }+ setTargets =<< sequence [guessTarget pathToModule Nothing]+ GHC.load LoadAllTargets+ setContext [IIModule $ mkModuleName nameOfModule]+ return ()++handleArguments :: DebuggerMonad ()+handleArguments = do+ args <- liftIO getArgs+ mapM_ handle' args where+ handle' x = do+ let arg = fst $ head $ parse cmdArgument x+ case arg of+ Main m -> modifyDebugState $ \st -> st{mainFile = Just m}+ Import path -> do+ dflags <- getSessionDynFlags+ setSessionDynFlags dflags{importPaths = path : importPaths dflags}+ return ()+ SetPort p -> modifyDebugState $ \st -> st{port = Just p}+ ExposePkg pkg -> do+ dflags <- getSessionDynFlags+ setSessionDynFlags dflags{packageFlags = ExposePackage pkg : packageFlags dflags}+ return ()+ CmdArgsParser.Unknown s -> printJSON [+ ("info", ConsStr "warning"),+ ("message", ConsStr $ "unknown argument: " ++ s)+ ]++initDebugOutput :: DebuggerMonad ()+initDebugOutput = do+ st <- getDebugState+ let m_port = port st+ case m_port of+ Nothing -> printJSON [+ ("info", ConsStr "warning"),+ ("message", ConsStr "Port for debug stream was not set (using stdout); use command line argument -p<port> to set it")+ ]+ Just port' -> do+ let host = "localhost"+ sock <- liftIO $ socket AF_INET Stream 0+ addrs <- liftIO $ liftM hostAddresses $ getHostByName host+ do {+ liftIO $ connect sock $ SockAddrInet (toEnum port') (head addrs);+ handle <- liftIO $ socketToHandle sock ReadWriteMode;+ modifyDebugState $ \st' -> st'{debugOutput = handle};+ printJSON [+ ("info", ConsStr "connected to port"),+ ("port", ConsInt port')+ ];+ } `catch` (\ex -> printJSON [+ ("info", ConsStr "exception"),+ ("message", ConsStr $ show ex ++ "; using stdout for debug output")+ ])++-- |In loop waits for commands and executes them+startCommandLine :: DebuggerMonad ()+startCommandLine = whileNot $ do+ command <- getCommand stdin `catch` (const $ return Exit)+ result <- tryRun (runCommand command)+ printJSON $ fst result+ return $ snd result++whileNot :: DebuggerMonad Bool -> DebuggerMonad ()+whileNot p = do+ x <- p+ if not x then whileNot p else return ()++-- |Translates line from input stream into DebugCommand+getCommand :: Handle -> DebuggerMonad DebugCommand+getCommand handle_ = do+ line <- liftIO $ hGetLine handle_+ return $ fst $ head $ parse debugCommand line++type Result = [(String, T)]++-- |Runs DebugCommand and returns True iff debug is finished+-- Inside commands there should not be any output to debug stream+runCommand :: DebugCommand -> DebuggerMonad (Result, Bool)+runCommand (SetBreakpoint modName line) = notEnd $ setBreakpointLikeGHCiDo modName line+runCommand (SetBreakByIndex modName ind) = notEnd $ doBreakindex modName ind+runCommand (RemoveBreakpoint modName ind) = notEnd $ deleteBreakpoint modName ind+runCommand (Trace command) = doTrace command+runCommand Resume = doResume+runCommand StepInto = doStepInto+runCommand StepOver = doStepLocal+runCommand History = notEnd $ showHistory defaultHistSize+runCommand Back = notEnd $ back+runCommand Forward = notEnd $ forward+runCommand Exit = return ([], True)+runCommand (BreakList modName) = notEnd $ showBreaks modName+runCommand (LineBreakList modName line) = notEnd $ showBreaksForLine modName line+runCommand Help = printString fullHelpText >> return ([], False)+runCommand (SPrint name) = notEnd $ doSPrint name+runCommand (Force expr) = notEnd $ doForce expr+runCommand (ExprType expr) = notEnd $ getExprType expr+runCommand (Evaluate force expr) = notEnd $ evaluate force expr+runCommand (Set flag) = notEnd $ set flag+runCommand (Unset flag) = notEnd $ unset flag+runCommand BreakinfoCmd = notEnd $ doBreakinfo+runCommand _ = return ([+ ("info", ConsStr "exception"),+ ("message", ConsStr "unknown command")+ ], False)++notEnd :: DebuggerMonad Result -> DebuggerMonad (Result, Bool)+notEnd obj = obj >>= (\x -> return (x, False))++-- | setBreakpoint version with selector just taking first of avaliable breakpoints+setBreakpointFirstOfAvailable :: String -> Int -> DebuggerMonad Result+setBreakpointFirstOfAvailable modName line = setBreakpoint modName line (Just . head)++-- | setBreakpoint version with selector choosing+-- | - the leftmost complete subexpression on the specified line, or+-- | - the leftmost subexpression starting on the specified line, or+-- | - the rightmost subexpression enclosing the specified line+-- | This strategy is the same to one GHCi currently uses+setBreakpointLikeGHCiDo :: String -> Int -> DebuggerMonad Result+setBreakpointLikeGHCiDo modName line = setBreakpoint modName line selectOneOf+ where selectOneOf :: [(BreakIndex, SrcSpan)] -> Maybe (BreakIndex, SrcSpan)+ selectOneOf breaks_ = listToMaybe (sortBy (leftmost_largest `on` snd) onelineBreaks) `mplus`+ listToMaybe (sortBy (leftmost_smallest `on` snd) multilineBreaks) `mplus`+ listToMaybe (sortBy (rightmost `on` snd) breaks_)+ where (onelineBreaks, multilineBreaks) = partition endEqLine breaksWithStartEqLine+ endEqLine (_, RealSrcSpan r) = GHC.srcSpanEndLine r == line+ endEqLine _ = False+ breaksWithStartEqLine = [ br | br@(_, srcSpan) <- breaks_,+ case srcSpan of (RealSrcSpan r) -> GHC.srcSpanStartLine r == line; _ -> False ]++-- | finds all avaliable breakpoint for given line, then using selector takes one of them and activates it+-- | if no breaks are avaliable proper message is shown+setBreakpoint :: String -> Int -> ([(BreakIndex, SrcSpan)] -> Maybe (BreakIndex, SrcSpan)) -> DebuggerMonad Result+setBreakpoint modName line selector = do+ breaksForLine <- findBreaksForLine modName line+ case breaksForLine of + [] -> return [+ ("info", ConsStr "breakpoint was not set"),+ ("add_info", ConsStr "not allowed here")+ ]+ bbs@(b : bs) -> do+ let mbBreakToSet = if (null bs) then Just b else selector bbs+ case mbBreakToSet of+ Just (breakIndex, srcSpan) -> do+ res <- changeBreakFlagInModBreaks modName breakIndex True+-- let msg = if res then "# Breakpoint (index = "++ show breakIndex ++") was set here:\n" ++ show srcSpan+-- else "# Breakpoint was not set: setBreakOn returned False"+ if res+ then return [+ ("info", ConsStr "breakpoint was set"),+ ("index", ConsInt $ breakIndex),+ ("src_span", srcSpanAsJSON srcSpan)+ ]+ else return [+ ("info", ConsStr "breakpoint was not set"),+ ("add_info", ConsStr "selector returned Nothing")+ ]+ Nothing -> return [+ ("info", ConsStr "breakpoint was not set"),+ ("add_info", ConsStr "selector returned Nothing")+ ]++-- | sets breakpoint by index+doBreakindex :: String -> Int -> DebuggerMonad Result+doBreakindex modName breakIndex = do+ modBreaks <- getModBreaks modName+ let locs = modBreaks_locs modBreaks+ let (start, end) = bounds locs+ case start <= breakIndex && breakIndex <= end of+ True -> do+ res <- changeBreakFlagInModBreaks modName breakIndex True+ if res+ then return [+ ("info", ConsStr "breakpoint was set"),+ ("index", ConsInt $ breakIndex),+ ("src_span", srcSpanAsJSON $ locs ! breakIndex)+ ]+ else return [+ ("info", ConsStr "breakpoint was not set"),+ ("add_info", ConsStr "setBreakFlag returned False")+ ]+ False -> do+ return [ ("info", ConsStr "breakpoint was not set"), ("add_info", ConsStr "wrong index") ]++-- | returns list of (BreakIndex, SrcSpan) for moduleName, where each element satisfies: srcSpanStartLine == line+-- | todo: this function is very suboptimal, it is temporary decition+findBreaksForLine :: String -> Int -> DebuggerMonad [(BreakIndex, SrcSpan)]+findBreaksForLine modName line = filterBreaksLocations modName predLineEq+ where predLineEq = \(_, srcSpan) -> case srcSpan of UnhelpfulSpan _ -> False+ RealSrcSpan r -> line == (srcSpanStartLine r)++-- | returns list of (BreakIndex, SrcSpan) for moduleName, where each element satisfies: srcSpanStartLine <= line <= srcSpanEndLine+-- | todo: this function is very suboptimal, it is temporary decition+findBreaksContainingLine :: String -> Int -> DebuggerMonad [(BreakIndex, SrcSpan)]+findBreaksContainingLine modName line = filterBreaksLocations modName predLineEq+ where predLineEq = \(_, srcSpan) -> case srcSpan of UnhelpfulSpan _ -> False+ RealSrcSpan r -> (srcSpanStartLine r) <= line && line <= (srcSpanEndLine r)++-- | returns list of (BreakIndex, SrcSpan) for moduleName, where each element satisfies predicate+filterBreaksLocations :: String -> ((BreakIndex, SrcSpan) -> Bool) -> DebuggerMonad [(BreakIndex, SrcSpan)]+filterBreaksLocations modName predicate = do+ modBreaks <- getModBreaks modName+ let breaksLocations = assocs $ modBreaks_locs modBreaks+ return $ filter predicate breaksLocations++-- | get ModBreaks for given modulename+getModBreaks :: String -> DebuggerMonad ModBreaks+getModBreaks modName = do+ module_ <- GHC.lookupModule (mkModuleName modName) Nothing+ Just modInfo <- getModuleInfo module_+ return $ modInfoModBreaks modInfo++-- | modBreaks_flags of ModBreaks contains info about set and unset breakpoints for specified module+-- | This function just set or unset given flag+changeBreakFlagInModBreaks :: String -> Int -> Bool -> DebuggerMonad Bool+changeBreakFlagInModBreaks modName flagIndex flagValue = do+ modBreaks <- getModBreaks modName+ let breaksFlags = modBreaks_flags modBreaks+ liftIO $ setBreakFlag breaksFlags flagIndex flagValue++setBreakFlag :: BreakArray -> Int -> Bool -> IO Bool+setBreakFlag bArr ind flag | flag = setBreakOn bArr ind+ | otherwise = setBreakOff bArr ind++-- | ':delete <module name> <break index>' command+deleteBreakpoint :: String -> Int -> DebuggerMonad Result+deleteBreakpoint modName breakIndex = do+ res <- changeBreakFlagInModBreaks modName breakIndex False+ if res+ then return [+ ("info", ConsStr "breakpoint was removed"),+ ("index", ConsInt breakIndex)+ ]+ else return [+ ("info", ConsStr "breakpoint was not removed"),+ ("add_info", ConsStr "incorrect index")+ ]++-- | ':trace' command+doTrace :: String -> DebuggerMonad (Result, Bool)+doTrace [] = doContinue (const True) GHC.RunAndLogSteps+doTrace expr = do+ runResult <- GHC.runStmt expr GHC.RunAndLogSteps `catch`+ (\ex -> (liftIO $ hPutStrLn stderr $ show ex) >> (return $ GHC.RunOk []))+ afterRunStmt (const True) runResult++doContinue :: (SrcSpan -> Bool) -> SingleStep -> DebuggerMonad (Result, Bool)+doContinue canLogSpan step = do+ runResult <- GHC.resume canLogSpan step+ afterRunStmt canLogSpan runResult++afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> DebuggerMonad (Result, Bool)+afterRunStmt canLogSpan (GHC.RunException e) = do+ liftIO $ hPutStrLn stderr (show e)+ afterRunStmt canLogSpan (GHC.RunOk [])+afterRunStmt canLogSpan runResult = do+ -- flushInterpBuffers -- it's not needed to flush because buffering is disabled+ resumes <- GHC.getResumeContext+ case runResult of+ GHC.RunOk names -> do+ names_str <- mapM showOutputable names+ let res = [+ ("info", ConsStr "finished"),+ ("names", ConsArr $ map ConsStr names_str)+ ]+ return (res, False)+ GHC.RunBreak _ names mbBreakInfo+ | isNothing mbBreakInfo || canLogSpan (GHC.resumeSpan $ head resumes) -> do+ let srcSpan = GHC.resumeSpan $ head resumes+ apStack = InteractiveEval.resumeApStack $ head resumes+ --liftIO $ c_print_ap_stack (Ptr (unsafeCoerce# apStack))+ functionName <- getFunctionName mbBreakInfo+ vars <- getNamesInfo names+ let res = [+ ("info", ConsStr "paused"),+ ("src_span", srcSpanAsJSON srcSpan),+ ("function", ConsStr functionName),+ ("vars", vars)+ ]+ return (res, False)+ | otherwise -> do+ nextRunResult <- GHC.resume canLogSpan GHC.SingleStep+ afterRunStmt canLogSpan nextRunResult+ _ -> return ([+ ("info", ConsStr "warning"),+ ("message", ConsStr "Unknown RunResult")+ ], False)+ where+ getFunctionName :: Maybe BreakInfo -> DebuggerMonad String+ getFunctionName Nothing = return ""+ getFunctionName (Just breakInfo) = do+ Just modInfo <- getModuleInfo $ breakInfo_module breakInfo+ let modBreaks = modInfoModBreaks modInfo+ let allDecls = modBreaks_decls $ modBreaks+ return $ last (allDecls ! (breakInfo_number breakInfo))++-- | ':continue' command+doResume :: DebuggerMonad (Result, Bool)+doResume = doContinue (const True) GHC.RunToCompletion++-- |':step [<expr>]' command - general step command+doStepGeneral :: String -> DebuggerMonad (Result, Bool)+doStepGeneral [] = doContinue (const True) GHC.SingleStep+doStepGeneral _ = return ([+ ("info", ConsStr "exception"),+ ("message", ConsStr "not implemented yet")+ ], False)++-- |':step' command+doStepInto :: DebuggerMonad (Result, Bool)+doStepInto = doStepGeneral []++-- | ':steplocal' command+doStepLocal :: DebuggerMonad (Result, Bool)+doStepLocal = do+ mbSrcSpan <- getCurrentBreakSpan+ case mbSrcSpan of+ Nothing -> doStepInto+ Just srcSpan -> do+ Just module_ <- getCurrentBreakModule+ mbCurrentToplevelDecl <- enclosingSpan module_ srcSpan+ case mbCurrentToplevelDecl of+ Nothing -> return ([+ ("info", ConsStr "warning"),+ ("message", ConsStr "steplocal was not performed: enclosingSpan returned Nothing")+ ], False)+ Just currentToplevelDecl -> doContinue (`isSubspanOf` currentToplevelDecl) GHC.SingleStep++-- | Returns the largest SrcSpan containing the given one or Nothing+enclosingSpan :: Module -> SrcSpan -> DebuggerMonad (Maybe SrcSpan)+enclosingSpan _ (UnhelpfulSpan _) = return Nothing+enclosingSpan module_ (RealSrcSpan rSrcSpan) = do+ let line = srcSpanStartLine rSrcSpan+ breaks_ <- findBreaksContainingLine (moduleNameString $ moduleName module_) line+ case breaks_ of+ [] -> return Nothing+ bs -> return . Just . head . sortBy leftmost_largest $ enclosingSpans bs+ where+ enclosingSpans bs = [ s | (_, s) <- bs, case s of UnhelpfulSpan _ -> False+ RealSrcSpan r -> realSrcSpanEnd r >= realSrcSpanEnd rSrcSpan ]+++getCurrentBreakSpan :: DebuggerMonad (Maybe SrcSpan)+getCurrentBreakSpan = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (Just (GHC.resumeSpan r))+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ pan <- GHC.getHistorySpan hist+ return (Just pan)+++getNamesInfo :: [Name] -> DebuggerMonad T+getNamesInfo names = do+ let namesSorted = sortBy compareNames names+ alltythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted+ let tythings = [AnId i | AnId i <- alltythings]+ names' <- mapM getThingName tythings+ types <- mapM getThingType tythings+ values <- mapM getThingValue tythings++ return $ ConsArr $ map (\(n, t, v) -> ConsObj [+ ("name", ConsStr n),+ ("type", ConsStr t),+ ("value", ConsStr v)+ ]) (zip3 names' types values)+ where+ getThingName :: TyThing -> DebuggerMonad (String)+ getThingName = showOutputable . getName++ getThingType :: TyThing -> DebuggerMonad (String)+ getThingType (AnId id') = do+ showSDoc $ pprTypeForUser False (GHC.idType id')+ getThingType _ = fail "Shouldn't be here"++ getThingValue :: TyThing -> DebuggerMonad (String)+ getThingValue (AnId id') = do+ term <- GHC.obtainTermFromId 100 False id'+ showOutputable term+ getThingValue _ = fail "Shouldn't be here"+++getCurrentBreakModule :: DebuggerMonad (Maybe Module)+getCurrentBreakModule = do+ mbBreakInfo <- getCurrentBreakInfo+ return $ GHC.breakInfo_module `liftM` mbBreakInfo+++getCurrentBreakInfo :: DebuggerMonad (Maybe BreakInfo)+getCurrentBreakInfo = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return $ GHC.resumeBreakInfo r+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ return $ Just $ GHC.historyBreakInfo hist++-- | ':breakinfo' debugCommand+doBreakinfo :: DebuggerMonad Result+doBreakinfo = do+ mbBreakInfo <- getCurrentBreakInfo+ case mbBreakInfo of+ Nothing -> printString "# No break info available"+ Just breakInfo -> printOutputable breakInfo+ return []++-- | ':history' command+showHistory :: Int -> DebuggerMonad Result+showHistory num = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return [("info", ConsStr "not stopped at breakpoint")]+ (r:_) -> do+ let hist = resumeHistory r+ (took, rest) = splitAt num hist+ spans' <- mapM (GHC.getHistorySpan) took+ let idx = map (0-) [(1::Int) ..]+ -- todo: get full path of the file+ lines' = map (\(i, s, h) -> ConsObj [+ ("index", ConsInt i),+ ("function", (ConsStr . head . GHC.historyEnclosingDecls) h),+ ("src_span", srcSpanAsJSON s)+ ]) (zip3 idx spans' hist)+ return [+ ("info", ConsStr "got history"),+ ("history", ConsArr lines'),+ ("end_reached", ConsBool (null rest))+ ]++-- | ':breaklist <mod>' command+showBreaks :: String -> DebuggerMonad Result+showBreaks modName = do+ modBreaks <- getModBreaks modName+ let locs = assocs $ modBreaks_locs $ modBreaks+ return [+ ("info", ConsStr "break list"),+ ("breaks", ConsArr $ map (\(i, e) -> ConsObj [+ ("index", ConsInt i),+ ("src_span", srcSpanAsJSON e)+ ]) locs)+ ]++-- | ':breaklist <mod> <line>' command+showBreaksForLine :: String -> Int -> DebuggerMonad Result+showBreaksForLine modName line = do+ breaksInfo <- findBreaksForLine modName line+ return [+ ("info", ConsStr $ "break list for line"),+ ("line", ConsStr $ show line),+ ("breaks",+ ConsArr $ map (\(i, e) -> ConsObj [("index", ConsInt i), ("src_span", srcSpanAsJSON e)]) breaksInfo)+ ]++-- | ':sprint' and ':force' commands+doSPrint, doForce :: String -> DebuggerMonad Result+doSPrint = evaluate False+doForce = evaluate True++getExprType :: String -> DebuggerMonad Result+getExprType expr = do+ ty <- GHC.exprType expr+ doc <- showSDoc $ pprTypeForUser False ty+ return [+ ("info", ConsStr "expression type"),+ ("type", ConsStr doc)+ ]++-- | ":eval"+evaluate :: Bool -> String -> DebuggerMonad Result+evaluate force str = do+ -- it seems that __evalResult is not stored after evaluating, so it is safe to do such binding+ RunOk [name] <- GHC.runStmt ("let __evalResult = " ++ str) GHC.RunToCompletion+ Just (AnId id') <- GHC.lookupName name+ type' <- showSDoc $ pprTypeForUser False (GHC.idType id')+ term <- GHC.obtainTermFromId 100 force id'+ value <- showOutputable term+ return [+ ("info", ConsStr "evaluated"),+ ("type", ConsStr type'),+ ("value", ConsStr value)+ ]++-- | ":back"+back :: DebuggerMonad Result+back = do+ (names, _, pan) <- GHC.back+ names_str <- mapM showOutputable names+ evs <- mapM (evaluate False) names_str+ return [+ ("info", ConsStr "stepped back"),+ ("src_span", srcSpanAsJSON pan),+ ("vars", ConsArr $ map (\(name, [_, (_, ConsStr ty), (_, ConsStr val)]) -> ConsObj [+ ("name", ConsStr name),+ ("type", ConsStr ty),+ ("value", ConsStr val)+ ]) (zip names_str evs))+ ]++-- | ":forward"+forward :: DebuggerMonad Result+forward = do+ (names, ix, pan) <- GHC.forward+ names_str <- mapM showOutputable names+ evs <- mapM (evaluate False) names_str+ return [+ ("info", ConsStr "stepped forward"),+ ("src_span", srcSpanAsJSON pan),+ ("vars", ConsArr $ map (\(name, [_, (_, ConsStr ty), (_, ConsStr val)]) -> ConsObj [+ ("name", ConsStr name),+ ("type", ConsStr ty),+ ("value", ConsStr val)+ ]) (zip names_str evs)),+ ("hist_top", ConsBool (ix == 0))+ ]++set :: String -> DebuggerMonad Result+set flag = do+ case flag of+ "-fbreak-on-error" -> do+ dflags <- GHC.getSessionDynFlags+ let dflags' = DynFlags.dopt_set dflags DynFlags.Opt_BreakOnError+ dflags'' = DynFlags.dopt_unset dflags' DynFlags.Opt_BreakOnException+ GHC.setSessionDynFlags dflags''+ return [("info", ConsStr "break set")]+ "-fbreak-on-exception" -> do+ dflags <- GHC.getSessionDynFlags+ let dflags' = DynFlags.dopt_set dflags DynFlags.Opt_BreakOnException+ dflags'' = DynFlags.dopt_unset dflags' DynFlags.Opt_BreakOnError+ GHC.setSessionDynFlags dflags''+ return [("info", ConsStr "break set")]+ _ -> return [("info", ConsStr "exception"), ("message", ConsStr "Unknown \"set\" flag")]++unset :: String -> DebuggerMonad Result+unset flag = do+ case flag of+ "-fbreak-on-error" -> unsetBreak+ "-fbreak-on-exception" -> unsetBreak+ _ -> return [("info", ConsStr "exception"), ("message", ConsStr "Unknown \"unset\" flag")]+ where+ unsetBreak = do+ dflags <- GHC.getSessionDynFlags+ let dflags' = DynFlags.dopt_unset dflags DynFlags.Opt_BreakOnException+ dflags'' = DynFlags.dopt_unset dflags' DynFlags.Opt_BreakOnError+ GHC.setSessionDynFlags dflags''+ return [("info", ConsStr "break unset")]+++fullHelpText :: String+fullHelpText =+ " Commands available from the prompt:\n" +++ " -- Commands for debugging:\n" +++ "\n" +++ " :break <mod> <l> set a breakpoint for module <mod> at the line <l>\n" +++ " :breakindex <mod> <i> set a breakpoint with index <i> for module <mod>\n" +++ " :breaklist <mod> show all available breakpoints (index and span) for module <mod>\n" +++ " :breaklist <mod> <l> show all breakpoints containing line <l> for module <mod> and \n" +++ " :continue resume after a breakpoint\n" +++ " :delete <mod> <ind> delete the breakpoint with index <ind> from module <mod>\n" +++ " :force <expr> print <expr>, forcing unevaluated parts\n" +++ " :history after :trace, show the execution history\n" +++ " :sprint <name> prints a value without forcing its computation\n" +++ " :step single-step after stopping at a breakpoint\n" +++ " :steplocal single-step within the current top-level binding\n" +++ " :trace <expr> evaluate <expr> with tracing on (see :history)\n" +++ " :type <expr> show the type of <expr>\n" +++ " :eval <int> <expr> evaluates <expr> ((<int> > 0) => forced evaluation)\n" +++ " :set <flag> sets given DynFlag\n" +++ " :unset <flag> unsets given DynFlag\n" +++ " available flags: -fbreak-on-error, -fbreak-on-exception\n" +++ " :breakinfo pretty printing for current BreakInfo\n" +++ " :q exit debugger\n"++---- || Hardcoded parameters (temporary for testing) || -----------------++-- |Default history size+defaultHistSize :: Int+defaultHistSize = 20+++---- || Utils || -------------------------------------------------------++-- | Shows info from ModBreaks for given moduleName. It is useful for debuging of our debuger = )+printAllBreaksInfo :: String -> DebuggerMonad ()+printAllBreaksInfo modName = do+ modBreaks <- getModBreaks modName+ -- modBreaks_flags - 0 if unset 1 if set+ printString "# modBreaks_flags:"+ liftIO $ showBreakArray $ modBreaks_flags $ modBreaks+ -- modBreaks_locs - breakpoint index and SrcSpan+ printString "# modBreaks_locs:"+ mapM (\(i, e) -> printString (show i ++ " : " ++ show e)) $ assocs $ modBreaks_locs $ modBreaks+ -- modBreaks_decls - An array giving the names of the declarations enclosing each breakpoint+ printString "# modBreaks_decls:"+ mapM (\(i, ds) -> printString (show i ++ " : " ++ show ds)) $ assocs $ modBreaks_decls $ modBreaks+ return ()++-- | parse and execute commands in list (to auto tests)+-- | exapmle: main = defaultRunGhc $ execCommands [":trace main", ":q"] - load default module, make trace and exit+execCommands :: [String] -> DebuggerMonad ()+execCommands [] = return ()+execCommands (c : cs) = do+ result <- tryRun (runCommand $ fst $ head $ parse debugCommand c)+ printJSON $ fst result+ execCommands cs
+ src/DebuggerMonad.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE CPP, FlexibleInstances, UnboxedTuples, MagicHash #-}+{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}++module DebuggerMonad where++import GHC hiding (resume)+import Data.IORef+import Control.Monad+import Exception (ExceptionMonad(..))+import GhcMonad ()+import DynFlags+import MonadUtils+import GhcMonad ()++import ObjLink (lookupSymbol)+import GHC.Ptr ()+import Linker+import GHC.Exts++import System.IO++data DebugState = DebugState {+ mainFile :: Maybe String,+ breaks :: [(Int, Module, Int)], -- number, module, line+ port :: Maybe Int,+ debugOutput :: Handle,+ mb_stdout_ptr :: Maybe (Ptr ()),+ mb_stderr_ptr :: Maybe (Ptr ())+}++initState :: DebugState+initState = DebugState {+ mainFile = Nothing,+ breaks = [],+ port = Nothing,+ debugOutput = stdout,+ mb_stdout_ptr = Nothing,+ mb_stderr_ptr = Nothing+}++newtype DebuggerMonad a = DebuggerMonad {toGhc :: IORef DebugState -> Ghc a}++getDebugState :: DebuggerMonad DebugState+getDebugState = DebuggerMonad $ \r -> liftIO $ readIORef r+setDebugState :: DebugState -> DebuggerMonad ()+setDebugState s = DebuggerMonad $ \r -> liftIO $ writeIORef r s+modifyDebugState :: (DebugState -> DebugState) -> DebuggerMonad ()+modifyDebugState f = DebuggerMonad $ \r -> liftIO $ readIORef r >>= writeIORef r . f++liftGhc :: Ghc a -> DebuggerMonad a+liftGhc m = DebuggerMonad $ \_ -> m++startDebugger :: DebuggerMonad a -> DebugState -> Ghc a+startDebugger g state = do ref <- liftIO $ newIORef state; toGhc g ref+++instance MonadIO DebuggerMonad where+ liftIO = liftGhc . liftIO++instance Monad DebuggerMonad where+ (DebuggerMonad m) >>= k = DebuggerMonad $ \s -> m s >>= \a -> toGhc (k a) s+ return a = DebuggerMonad $ \_ -> return a++instance Functor DebuggerMonad where+ fmap = liftM++instance HasDynFlags DebuggerMonad where+ getDynFlags = getSessionDynFlags++instance GhcMonad DebuggerMonad where+ setSession s' = liftGhc $ setSession s'+ getSession = liftGhc $ getSession++instance ExceptionMonad DebuggerMonad where+ gcatch m h = DebuggerMonad $ \r -> toGhc m r `gcatch` (\e -> toGhc (h e) r)+ gmask f =+ DebuggerMonad $ \s -> gmask $ \io_restore ->+ let+ g_restore (DebuggerMonad m) = DebuggerMonad $ \s' -> io_restore (m s')+ in+ toGhc (f g_restore) s++initInterpBuffering :: DebuggerMonad ()+initInterpBuffering = do+ dflags <- GHC.getSessionDynFlags+ liftIO $ initDynLinker dflags+ mb_stdout <- liftIO $ ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdout_closure"+ mb_stderr <- liftIO $ ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stderr_closure"+ modifyDebugState $ \st -> st{mb_stdout_ptr = mb_stdout, mb_stderr_ptr = mb_stderr}++flushInterpBuffers :: DebuggerMonad ()+flushInterpBuffers = do+ st <- getDebugState+ let (Just stdout_ptr) = mb_stdout_ptr st+ let (Just stderr_ptr) = mb_stderr_ptr st+ h1 <- liftIO $ getHandle (stdout_ptr)+ h2 <- liftIO $ getHandle (stderr_ptr)+ liftIO $ hFlush h1+ liftIO $ hFlush h2++turnOffBuffering :: DebuggerMonad ()+turnOffBuffering = do+ st <- getDebugState+ let (Just stdout_ptr) = mb_stdout_ptr st+ let (Just stderr_ptr) = mb_stderr_ptr st+ h1 <- liftIO $ getHandle (stdout_ptr)+ h2 <- liftIO $ getHandle (stderr_ptr)+ liftIO $ hSetBuffering h1 NoBuffering+ liftIO $ hSetBuffering h2 NoBuffering++getHandle :: Ptr () -> IO Handle+getHandle (Ptr addr) = do+ case addrToAny# addr of (# hval #) -> return (unsafeCoerce# hval)+
+ src/DebuggerUtils.hs view
@@ -0,0 +1,89 @@+module DebuggerUtils where++import Outputable (Outputable)+import qualified Outputable+import DebuggerMonad+import GHC hiding (resume)+import DynFlags+import GhcMonad (liftIO)+import qualified FastString+import Text.JSON+import qualified Data.Ratio+import Name+import Control.Exception (SomeException)+++-- | Remove casting to SomeException+catch :: DebuggerMonad a -> (SomeException -> DebuggerMonad a) -> DebuggerMonad a+catch = gcatch++compareNames :: Name -> Name -> Ordering+n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2+ where compareWith n = (getOccString n, getSrcSpan n)++-- | Prints SDoc to the debug stream+printSDoc :: Outputable.SDoc -> DebuggerMonad ()+printSDoc message = do+ st <- getDebugState+ dflags <- getDynFlags+ unqual <- getPrintUnqual+ liftIO $ Outputable.printForUser dflags (debugOutput st) unqual message+ return ()++showSDoc :: Outputable.SDoc -> DebuggerMonad String+showSDoc message = do+ dflags <- getDynFlags+ unqual <- getPrintUnqual+ return $ Outputable.showSDocForUser dflags unqual message++showOutputable :: (Outputable d) => d -> DebuggerMonad String+showOutputable str = do+ showSDoc $ Outputable.ppr str++-- | Prints Outputable to the debug stream+printOutputable :: (Outputable d) => d -> DebuggerMonad ()+printOutputable = printSDoc . Outputable.ppr++printListOfOutputable :: (Outputable d) => [d] -> DebuggerMonad ()+printListOfOutputable = mapM_ printOutputable++-- | Prints String to the debug stream+printString :: String -> DebuggerMonad ()+printString = printSDoc . Outputable.text++printJSON :: [(String, T)] -> DebuggerMonad ()+printJSON = printString . getJSONLine+++data T+ = ConsNull+ | ConsBool Bool+ | ConsInt Int+ | ConsStr String+ | ConsArr [T]+ | ConsObj [(String, T)]++instance JSON T where+ readJSON _ = Error "Not implemented" -- function is not needed++ showJSON (ConsNull) = JSNull+ showJSON (ConsBool x) = JSBool x+ showJSON (ConsInt x) = JSRational False ((toInteger x) Data.Ratio.% 1)+ showJSON (ConsStr x) = JSString $ toJSString x+ showJSON (ConsArr x) = JSArray $ map showJSON x+ showJSON (ConsObj x) = JSObject $ toJSObject $ map (\(key, value) -> (key, showJSON value)) x+++getJSONLine :: [(String, T)] -> String+getJSONLine = encode . toJSObject++-- | Used methods are marked as 'unsafe'+srcSpanAsJSON :: SrcSpan -> T+srcSpanAsJSON (UnhelpfulSpan str) = ConsObj [("span", ConsStr $ FastString.unpackFS str)]+srcSpanAsJSON (RealSrcSpan span') = ConsObj [+ ("file", ConsStr $ FastString.unpackFS $ srcSpanFile span'),+ ("startline", ConsInt $ srcSpanStartLine span'),+ ("endline", ConsInt $ srcSpanEndLine span'),+ ("startcol", ConsInt $ srcSpanStartCol span'),+ ("endcol", ConsInt $ srcSpanEndCol span' - 1)+ ]
+ src/ParserMonad.hs view
@@ -0,0 +1,110 @@+module ParserMonad where++import Data.Char++-- | Parser type+newtype Parser a = P (String -> [ (a, String) ])++-- | parse function+parse :: Parser a -> String -> [ (a, String) ]+parse (P p) s = p s++-- | conveyer of parsers+(<|>) :: Parser a -> Parser a -> Parser a+p1 <|> p2 = P $ \cs -> case parse p1 cs of+ [] -> parse p2 cs+ ps -> ps++instance Monad Parser where+ p1 >>= fp2 = P $ \cs -> do+ (a, cs') <- parse p1 cs+ parse (fp2 a) cs'+ return x = P $ \cs -> [ (x, cs) ]+ fail _ = P $ \_ -> []++instance Functor Parser where+ fmap f p = p >>= \x -> return (f x)++-- | Parses one char+anyChar :: Parser Char+anyChar = P $ \cs -> case cs of+ (x:xs) -> [ (x, xs) ]+ [] -> []++-- | Parses char by predicate+satisfy :: (Char -> Bool) -> Parser Char+satisfy p = do+ c <- anyChar+ if p c then return c else fail "Did not satisfy boolean predicate"++-- | Parses exact Char+char :: Char -> Parser Char+char = satisfy . (==)++-- | Parses exact String+string :: String -> Parser String+string = mapM char++-- | Parses zero or more instances of p.+many :: Parser a -> Parser [a]+many p = rest p <|> (return [])++-- | Parses one or more instances of p.+rest :: Parser a -> Parser [a]+rest p = do+ x <- p+ xs <- many p+ return (x:xs)++-- | Parses one special character+alpha, digit, upper, lower, space :: Parser Char+alpha = satisfy isAlpha+digit = satisfy isDigit+upper = satisfy isUpper+lower = satisfy isLower+space = satisfy isSpace++-- | Parses integer+int :: Parser Int+int = do+ s <- string "-" <|> return []+ d <- rest digit+ return (read (s ++ d) :: Int)++-- | Parses sequence of 'ok' chars+manySatisfiedChars :: (Char -> Bool) -> Parser String+manySatisfiedChars = many . satisfy+restSatisfiedChars :: (Char -> Bool) -> Parser String+restSatisfiedChars = rest . satisfy++-- | Parses word of non-space characters++-- | Skips spacing characters+skipSpaces :: Parser ()+skipSpaces = do+ manySatisfiedChars isSpace+ return ()++-- | Skips spacing characters (more than zero)+waitAndSkipSpaces :: Parser ()+waitAndSkipSpaces = do+ restSatisfiedChars isSpace+ return ()++-- | Returns remaining input+restOfInput :: Parser String+restOfInput = manySatisfiedChars $ const True+++-- | Fails if end was not reached+end :: Parser ()+end = do+ b <- do {+ c <- anyChar ;+ return False ;+ } <|> return True+ if b then return () else fail "End wasn't reached"++-- | Connects all parsers+unlist :: [Parser a] -> Parser a+unlist = foldr (<|>) (fail "Could not parse")