diff --git a/remote-debugger.cabal b/remote-debugger.cabal --- a/remote-debugger.cabal +++ b/remote-debugger.cabal @@ -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, diff --git a/src/CmdArgsParser.hs b/src/CmdArgsParser.hs new file mode 100644 --- /dev/null +++ b/src/CmdArgsParser.hs @@ -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 +importArgument :: Parser Argument -- -i +setPortArgument :: Parser Argument -- -p +exposePkgArgument :: Parser Argument -- -pkg +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 diff --git a/src/CommandParser.hs b/src/CommandParser.hs new file mode 100644 --- /dev/null +++ b/src/CommandParser.hs @@ -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 diff --git a/src/DebuggerImpl.hs b/src/DebuggerImpl.hs new file mode 100644 --- /dev/null +++ b/src/DebuggerImpl.hs @@ -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 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 ' 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 []' 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 ' 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 ' 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 set a breakpoint for module at the line \n" ++ + " :breakindex set a breakpoint with index for module \n" ++ + " :breaklist show all available breakpoints (index and span) for module \n" ++ + " :breaklist show all breakpoints containing line for module and \n" ++ + " :continue resume after a breakpoint\n" ++ + " :delete delete the breakpoint with index from module \n" ++ + " :force print , forcing unevaluated parts\n" ++ + " :history after :trace, show the execution history\n" ++ + " :sprint 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 evaluate with tracing on (see :history)\n" ++ + " :type show the type of \n" ++ + " :eval evaluates (( > 0) => forced evaluation)\n" ++ + " :set sets given DynFlag\n" ++ + " :unset 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 diff --git a/src/DebuggerMonad.hs b/src/DebuggerMonad.hs new file mode 100644 --- /dev/null +++ b/src/DebuggerMonad.hs @@ -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) + diff --git a/src/DebuggerUtils.hs b/src/DebuggerUtils.hs new file mode 100644 --- /dev/null +++ b/src/DebuggerUtils.hs @@ -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) + ] diff --git a/src/ParserMonad.hs b/src/ParserMonad.hs new file mode 100644 --- /dev/null +++ b/src/ParserMonad.hs @@ -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")