refactor: move pprintClosureCommand out of the GHCi monad

[ghc-hetmet.git] / compiler / ghci / InteractiveUI.hs

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index 3713c4c..4d7658e 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -14,13 +14,14 @@ module InteractiveUI (
 #include "HsVersions.h"
 
 import GhciMonad
 #include "HsVersions.h"
 
 import GhciMonad

+import GhciTags
+import Debugger

 
 -- The GHC interface
 import qualified GHC
 import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
                           Type, Module, ModuleName, TyThing(..), Phase,
 
 -- The GHC interface
 import qualified GHC
 import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
                           Type, Module, ModuleName, TyThing(..), Phase,

-                          BreakIndex )
-import Debugger
+                          BreakIndex, Name, SrcSpan )

 import DynFlags
 import Packages
 import PackageConfig
 import DynFlags
 import Packages
 import PackageConfig

@@ -29,11 +30,6 @@ import PprTyThing
 import Outputable       hiding (printForUser)
 import Module           -- for ModuleEnv
 
 import Outputable       hiding (printForUser)
 import Module           -- for ModuleEnv
 

--- for createtags
-import Name
-import OccName
-import SrcLoc
-

 -- Other random utilities
 import Digraph
 import BasicTypes hiding (isTopLevel)
 -- Other random utilities
 import Digraph
 import BasicTypes hiding (isTopLevel)

@@ -106,6 +102,7 @@ builtin_commands = [
        -- Hugs users are accustomed to :e, so make sure it doesn't overlap
   ("?",                keepGoing help,                 False, completeNone),
   ("add",      keepGoingPaths addModule,       False, completeFilename),
        -- Hugs users are accustomed to :e, so make sure it doesn't overlap
   ("?",                keepGoing help,                 False, completeNone),
   ("add",      keepGoingPaths addModule,       False, completeFilename),

+  ("abandon",   keepGoing abandonCmd,           False, completeNone),

   ("break",     keepGoing breakCmd,             False, completeIdentifier),
   ("browse",    keepGoing browseCmd,           False, completeModule),
   ("cd",       keepGoing changeDirectory,      False, completeFilename),
   ("break",     keepGoing breakCmd,             False, completeIdentifier),
   ("browse",    keepGoing browseCmd,           False, completeModule),
   ("cd",       keepGoing changeDirectory,      False, completeFilename),

@@ -117,7 +114,7 @@ builtin_commands = [
   ("e",        keepGoing editFile,             False, completeFilename),
   ("edit",     keepGoing editFile,             False, completeFilename),
   ("etags",    keepGoing createETagsFileCmd,   False, completeFilename),
   ("e",        keepGoing editFile,             False, completeFilename),
   ("edit",     keepGoing editFile,             False, completeFilename),
   ("etags",    keepGoing createETagsFileCmd,   False, completeFilename),

-  ("force",     keepGoing (pprintClosureCommand False True), False, completeIdentifier),
+  ("force",     keepGoing forceCmd,             False, completeIdentifier),

   ("help",     keepGoing help,                 False, completeNone),
   ("info",      keepGoing info,                        False, completeIdentifier),
   ("kind",     keepGoing kindOfType,           False, completeIdentifier),
   ("help",     keepGoing help,                 False, completeNone),
   ("info",      keepGoing info,                        False, completeIdentifier),
   ("kind",     keepGoing kindOfType,           False, completeIdentifier),

@@ -125,12 +122,12 @@ builtin_commands = [
   ("list",     keepGoing listCmd,              False, completeNone),
   ("module",   keepGoing setContext,           False, completeModule),
   ("main",     keepGoing runMain,              False, completeIdentifier),
   ("list",     keepGoing listCmd,              False, completeNone),
   ("module",   keepGoing setContext,           False, completeModule),
   ("main",     keepGoing runMain,              False, completeIdentifier),

-  ("print",     keepGoing (pprintClosureCommand True False), False, completeIdentifier),
+  ("print",     keepGoing printCmd,             False, completeIdentifier),

   ("quit",     quit,                           False, completeNone),
   ("reload",   keepGoing reloadModule,         False, completeNone),
   ("set",      keepGoing setCmd,               True,  completeSetOptions),
   ("show",     keepGoing showCmd,              False, completeNone),
   ("quit",     quit,                           False, completeNone),
   ("reload",   keepGoing reloadModule,         False, completeNone),
   ("set",      keepGoing setCmd,               True,  completeSetOptions),
   ("show",     keepGoing showCmd,              False, completeNone),

-  ("sprint",    keepGoing (pprintClosureCommand False False),False, completeIdentifier),
+  ("sprint",    keepGoing sprintCmd,            False, completeIdentifier),

   ("step",      stepCmd,                        False, completeIdentifier), 
   ("type",     keepGoing typeOfExpr,           False, completeIdentifier),
   ("undef",     keepGoing undefineMacro,       False, completeMacro),
   ("step",      stepCmd,                        False, completeIdentifier), 
   ("type",     keepGoing typeOfExpr,           False, completeIdentifier),
   ("undef",     keepGoing undefineMacro,       False, completeMacro),

@@ -150,6 +147,7 @@ helpText =
  "\n" ++
  "   <stmt>                      evaluate/run <stmt>\n" ++
  "   :add <filename> ...         add module(s) to the current target set\n" ++
  "\n" ++
  "   <stmt>                      evaluate/run <stmt>\n" ++
  "   :add <filename> ...         add module(s) to the current target set\n" ++

+ "   :abandon                    at a breakpoint, abandon current computation\n" ++

  "   :break [<mod>] <l> [<col>]  set a breakpoint at the specified location\n" ++
  "   :break <name>               set a breakpoint on the specified function\n" ++
  "   :browse [*]<module>         display the names defined by <module>\n" ++
  "   :break [<mod>] <l> [<col>]  set a breakpoint at the specified location\n" ++
  "   :break <name>               set a breakpoint on the specified function\n" ++
  "   :browse [*]<module>         display the names defined by <module>\n" ++

@@ -418,7 +416,7 @@ fileLoop hdl show_prompt = do
    session <- getSession
    (mod,imports) <- io (GHC.getContext session)
    st <- getGHCiState
    session <- getSession
    (mod,imports) <- io (GHC.getContext session)
    st <- getGHCiState

-   when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
+   when show_prompt (io (putStr (mkPrompt mod imports (resume st) (prompt st))))

    l <- io (IO.try (hGetLine hdl))
    case l of
        Left e | isEOFError e              -> return ()
    l <- io (IO.try (hGetLine hdl))
    case l of
        Left e | isEOFError e              -> return ()

@@ -443,7 +441,7 @@ stringLoop (s:ss) = do
        l  -> do quit <- runCommand l
                  if quit then return True else stringLoop ss
 
        l  -> do quit <- runCommand l
                  if quit then return True else stringLoop ss
 

-mkPrompt toplevs exports prompt
+mkPrompt toplevs exports resumes prompt

   = showSDoc $ f prompt
     where
         f ('%':'s':xs) = perc_s <> f xs
   = showSDoc $ f prompt
     where
         f ('%':'s':xs) = perc_s <> f xs

@@ -451,8 +449,17 @@ mkPrompt toplevs exports prompt
         f (x:xs) = char x <> f xs
         f [] = empty
     
         f (x:xs) = char x <> f xs
         f [] = empty
     

-        perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
-                 hsep (map (ppr . GHC.moduleName) exports)
+        perc_s
+          | (span,_,_):rest <- resumes 
+          = (if not (null rest) then text "... " else empty)
+            <> brackets (ppr span) <+> modules_prompt
+          | otherwise
+          = modules_prompt
+
+        modules_prompt = 
+             hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
+             hsep (map (ppr . GHC.moduleName) exports)
+

 
 
 #ifdef USE_READLINE
 
 
 #ifdef USE_READLINE

@@ -463,7 +470,7 @@ readlineLoop = do
    io yield
    saveSession -- for use by completion
    st <- getGHCiState
    io yield
    saveSession -- for use by completion
    st <- getGHCiState

-   l <- io (readline (mkPrompt mod imports (prompt st))
+   l <- io (readline (mkPrompt mod imports (resume st) (prompt st))

                `finally` setNonBlockingFD 0)
                -- readline sometimes puts stdin into blocking mode,
                -- so we need to put it back for the IO library
                `finally` setNonBlockingFD 0)
                -- readline sometimes puts stdin into blocking mode,
                -- so we need to put it back for the IO library

@@ -621,9 +628,6 @@ pprInfo exts (thing, fixity, insts)
        | fix == GHC.defaultFixity = empty
        | otherwise                = ppr fix <+> ppr (GHC.getName thing)
 
        | fix == GHC.defaultFixity = empty
        | otherwise                = ppr fix <+> ppr (GHC.getName thing)
 

------------------------------------------------------------------------------
--- Commands
-

 runMain :: String -> GHCi ()
 runMain args = do
   let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
 runMain :: String -> GHCi ()
 runMain args = do
   let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))

@@ -859,118 +863,6 @@ shellEscape :: String -> GHCi Bool
 shellEscape str = io (system str >> return False)
 
 -----------------------------------------------------------------------------
 shellEscape str = io (system str >> return False)
 
 -----------------------------------------------------------------------------

--- create tags file for currently loaded modules.
-
-createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
-
-createCTagsFileCmd ""   = ghciCreateTagsFile CTags "tags"
-createCTagsFileCmd file = ghciCreateTagsFile CTags file
-
-createETagsFileCmd ""    = ghciCreateTagsFile ETags "TAGS"
-createETagsFileCmd file  = ghciCreateTagsFile ETags file
-
-data TagsKind = ETags | CTags
-
-ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
-ghciCreateTagsFile kind file = do
-  session <- getSession
-  io $ createTagsFile session kind file
-
--- ToDo: 
---     - remove restriction that all modules must be interpreted
---       (problem: we don't know source locations for entities unless
---       we compiled the module.
---
---     - extract createTagsFile so it can be used from the command-line
---       (probably need to fix first problem before this is useful).
---
-createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
-createTagsFile session tagskind tagFile = do
-  graph <- GHC.getModuleGraph session
-  let ms = map GHC.ms_mod graph
-      tagModule m = do 
-        is_interpreted <- GHC.moduleIsInterpreted session m
-        -- should we just skip these?
-        when (not is_interpreted) $
-          throwDyn (CmdLineError ("module '" 
-                                ++ GHC.moduleNameString (GHC.moduleName m)
-                                ++ "' is not interpreted"))
-        mbModInfo <- GHC.getModuleInfo session m
-        let unqual 
-             | Just modinfo <- mbModInfo,
-               Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
-             | otherwise = GHC.alwaysQualify
-
-        case mbModInfo of 
-          Just modInfo -> return $! listTags unqual modInfo 
-          _            -> return []
-
-  mtags <- mapM tagModule ms
-  either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
-  case either_res of
-    Left e  -> hPutStrLn stderr $ ioeGetErrorString e
-    Right _ -> return ()
-
-listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
-listTags unqual modInfo =
-          [ tagInfo unqual name loc 
-           | name <- GHC.modInfoExports modInfo
-           , let loc = nameSrcLoc name
-           , isGoodSrcLoc loc
-           ]
-
-type TagInfo = (String -- tag name
-               ,String -- file name
-               ,Int    -- line number
-               ,Int    -- column number
-               )
-
--- get tag info, for later translation into Vim or Emacs style
-tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
-tagInfo unqual name loc
-    = ( showSDocForUser unqual $ pprOccName (nameOccName name)
-      , showSDocForUser unqual $ ftext (srcLocFile loc)
-      , srcLocLine loc
-      , srcLocCol loc
-      )
-
-collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
-collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
-  let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
-  IO.try (writeFile file tags)
-collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
-  let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
-      groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
-  tagGroups <- mapM tagFileGroup groups 
-  IO.try (writeFile file $ concat tagGroups)
-  where
-    tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
-    tagFileGroup group@((_,fileName,_,_):_) = do
-      file <- readFile fileName -- need to get additional info from sources..
-      let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
-          sortedGroup = sortLe byLine group
-          tags = unlines $ perFile sortedGroup 1 0 $ lines file
-      return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
-    perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
-      perFile (tagInfo:tags) (count+1) (pos+length line) lines
-    perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
-      showETag tagInfo line pos : perFile tags count pos lines
-    perFile tags count pos lines = []
-
--- simple ctags format, for Vim et al
-showTag :: TagInfo -> String
-showTag (tag,file,lineNo,colNo)
-    =  tag ++ "\t" ++ file ++ "\t" ++ show lineNo
-
--- etags format, for Emacs/XEmacs
-showETag :: TagInfo -> String -> Int -> String
-showETag (tag,file,lineNo,colNo) line charPos
-    =  take colNo line ++ tag
-    ++ "\x7f" ++ tag
-    ++ "\x01" ++ show lineNo
-    ++ "," ++ show charPos
-
------------------------------------------------------------------------------

 -- Browsing a module's contents
 
 browseCmd :: String -> GHCi ()
 -- Browsing a module's contents
 
 browseCmd :: String -> GHCi ()

@@ -1464,6 +1356,14 @@ setUpConsole = do
 -- -----------------------------------------------------------------------------
 -- commands for debugger
 
 -- -----------------------------------------------------------------------------
 -- commands for debugger
 

+sprintCmd = pprintCommand False False
+printCmd  = pprintCommand True False
+forceCmd  = pprintCommand False True
+
+pprintCommand bind force str = do
+  session <- getSession
+  io $ pprintClosureCommand session bind force str
+

 foreign import ccall "rts_setStepFlag" setStepFlag :: IO () 
 
 stepCmd :: String -> GHCi Bool
 foreign import ccall "rts_setStepFlag" setStepFlag :: IO () 
 
 stepCmd :: String -> GHCi Bool

@@ -1493,6 +1393,16 @@ doContinue actionBeforeCont = do
          finishEvalExpr names
          return False
 
          finishEvalExpr names
          return False
 

+abandonCmd :: String -> GHCi ()
+abandonCmd "" = do
+   mb_res <- popResume
+   case mb_res of
+      Nothing -> do 
+         io $ putStrLn "There is no computation running."
+      Just (span,_,_) ->
+         return ()
+         -- the prompt will change to indicate the new context
+

 deleteCmd :: String -> GHCi ()
 deleteCmd argLine = do
    deleteSwitch $ words argLine
 deleteCmd :: String -> GHCi ()
 deleteCmd argLine = do
    deleteSwitch $ words argLine

@@ -1535,16 +1445,17 @@ breakSwitch session args@(arg1:rest)
         case names of
           []    -> return ()
           (n:_) -> do
         case names of
           []    -> return ()
           (n:_) -> do

-            let loc  = nameSrcLoc n
-                modl = nameModule n
+            let loc  = GHC.nameSrcLoc n
+                modl = GHC.nameModule n

             is_interpreted <- io (GHC.moduleIsInterpreted session modl)
             if not is_interpreted
                then noCanDo $ text "module " <> ppr modl <>
                               text " is not interpreted"
                else do
             is_interpreted <- io (GHC.moduleIsInterpreted session modl)
             if not is_interpreted
                then noCanDo $ text "module " <> ppr modl <>
                               text " is not interpreted"
                else do

-            if isGoodSrcLoc loc
-               then findBreakAndSet (nameModule n) $ 
-                         findBreakByCoord (srcLocLine loc, srcLocCol loc)
+            if GHC.isGoodSrcLoc loc
+               then findBreakAndSet (GHC.nameModule n) $ 
+                         findBreakByCoord (GHC.srcLocLine loc, 
+                                           GHC.srcLocCol loc)

                else noCanDo $ text "can't find its location: " <>
                               ppr loc
            where
                else noCanDo $ text "can't find its location: " <>
                               ppr loc
            where

@@ -1616,10 +1527,10 @@ findBreakByLine line arr
         ticks = arr ! line
 
         starts_here = [ tick | tick@(nm,span) <- ticks,
         ticks = arr ! line
 
         starts_here = [ tick | tick@(nm,span) <- ticks,

-                               srcSpanStartLine span == line ]
+                               GHC.srcSpanStartLine span == line ]

 
         (complete,incomplete) = partition ends_here starts_here
 
         (complete,incomplete) = partition ends_here starts_here

-            where ends_here (nm,span) = srcSpanEndLine span == line
+            where ends_here (nm,span) = GHC.srcSpanEndLine span == line

 
 findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan)
 findBreakByCoord (line, col) arr
 
 findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan)
 findBreakByCoord (line, col) arr

@@ -1633,14 +1544,14 @@ findBreakByCoord (line, col) arr
         contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col) ]
 
 leftmost_smallest  (_,a) (_,b) = a `compare` b
         contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col) ]
 
 leftmost_smallest  (_,a) (_,b) = a `compare` b

-leftmost_largest   (_,a) (_,b) = (srcSpanStart a `compare` srcSpanStart b)
+leftmost_largest   (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)

                                 `thenCmp`
                                 `thenCmp`

-                                 (srcSpanEnd b `compare` srcSpanEnd a)
+                                 (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)

 rightmost (_,a) (_,b) = b `compare` a
 
 spans :: SrcSpan -> (Int,Int) -> Bool
 rightmost (_,a) (_,b) = b `compare` a
 
 spans :: SrcSpan -> (Int,Int) -> Bool

-spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span
-   where loc = mkSrcLoc (srcSpanFile span) l c
+spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
+   where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c

 
 start_bold = BS.pack "\ESC[1m"
 end_bold   = BS.pack "\ESC[0m"
 
 start_bold = BS.pack "\ESC[1m"
 end_bold   = BS.pack "\ESC[0m"

@@ -1659,9 +1570,9 @@ listAround span do_highlight = do
       contents <- BS.readFile (unpackFS file)
       let 
           lines = BS.split '\n' contents
       contents <- BS.readFile (unpackFS file)
       let 
           lines = BS.split '\n' contents

-          these_lines = take (line2 - line1 + 1 + 2*padding) $ 
-                        drop (line1 - 1 - padding) $ lines
-          fst_line = max 1 (line1 - padding)
+          these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $ 
+                        drop (line1 - 1 - pad_before) $ lines
+          fst_line = max 1 (line1 - pad_before)

           line_nos = [ fst_line .. ]
 
           highlighted | do_highlight = zipWith highlight line_nos these_lines
           line_nos = [ fst_line .. ]
 
           highlighted | do_highlight = zipWith highlight line_nos these_lines

@@ -1672,12 +1583,15 @@ listAround span do_highlight = do
       --
       BS.putStrLn (BS.join (BS.pack "\n") prefixed)
   where
       --
       BS.putStrLn (BS.join (BS.pack "\n") prefixed)
   where

-        file  = srcSpanFile span
-        line1 = srcSpanStartLine span
-        col1  = srcSpanStartCol span
-        line2 = srcSpanEndLine span
-        col2  = srcSpanEndCol span
-        padding = 1
+        file  = GHC.srcSpanFile span
+        line1 = GHC.srcSpanStartLine span
+        col1  = GHC.srcSpanStartCol span
+        line2 = GHC.srcSpanEndLine span
+        col2  = GHC.srcSpanEndCol span
+
+        pad_before | line1 == 1 = 0
+                   | otherwise  = 1
+        pad_after = 1

 
         highlight no line
           | no == line1 && no == line2
 
         highlight no line
           | no == line1 && no == line2

@@ -1719,8 +1633,9 @@ mkTickArray ticks
         [ (line, (nm,span)) | (nm,span) <- ticks,
                               line <- srcSpanLines span ]
     where
         [ (line, (nm,span)) | (nm,span) <- ticks,
                               line <- srcSpanLines span ]
     where

-        max_line = maximum (map srcSpanEndLine (map snd ticks))
-        srcSpanLines span = [ srcSpanStartLine span .. srcSpanEndLine span ]
+        max_line = maximum (map GHC.srcSpanEndLine (map snd ticks))
+        srcSpanLines span = [ GHC.srcSpanStartLine span .. 
+                              GHC.srcSpanEndLine span ]

 
 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
 getModBreak mod = do
 
 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
 getModBreak mod = do