Teach :print to not panic when the DataCon for a closure is not exposed by the .hi...

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

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index 138992f..8491069 100644 (file)
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -63,15 +63,16 @@ pprintClosureCommand session bindThings force str = do
    -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
    go :: Session -> Id -> IO (Maybe TvSubst)
    go cms id = do 
-       term_ <- obtainTerm cms force id 
-       term      <- tidyTermTyVars cms term_
-       term'     <- if not bindThings then return term 
+       term_    <- withSession cms $ \hsc_env -> obtainTerm hsc_env force id 
+       term     <- tidyTermTyVars cms term_
+       term'    <- if not bindThings then return term 
                      else bindSuspensions cms term                         
-       showterm  <- printTerm cms term'
-       unqual    <- GHC.getPrintUnqual cms
+       showterm <- printTerm cms term'
+       unqual   <- GHC.getPrintUnqual cms
        let showSDocForUserOneLine unqual doc = 
                showDocWith LeftMode (doc (mkErrStyle unqual))
-       (putStrLn . showSDocForUserOneLine unqual) (ppr id <+> char '=' <+> showterm)
+       (putStrLn . showSDocForUserOneLine unqual) 
+                                   (ppr id <+> char '=' <+> showterm)
      -- Before leaving, we compare the type obtained to see if it's more specific
      --  Then, we extract a substitution, 
      --  mapping the old tyvars to the reconstructed types.
@@ -143,7 +144,8 @@ bindSuspensions cms@(Session ref) t = do
      where
 
 --    Processing suspensions. Give names and recopilate info
-        nameSuspensionsAndGetInfos :: IORef [String] -> TermFold (IO (Term, [(Name,Type,HValue)]))
+        nameSuspensionsAndGetInfos :: IORef [String] -> 
+                                       TermFold (IO (Term, [(Name,Type,HValue)]))
         nameSuspensionsAndGetInfos freeNames = TermFold 
                       {
                         fSuspension = doSuspension freeNames
@@ -180,20 +182,27 @@ printTerm cms@(Session ref) = cPprTerm cPpr
            GHC.setSessionDynFlags cms dflags{log_action=noop_log}
            mb_txt <- withExtendedLinkEnv [(bname, val)] 
                                          (GHC.compileExpr cms expr)
-           let myprec = 9 -- TODO Infix constructors
+           let myprec = 10 -- application precedence. TODO Infix constructors
            case mb_txt of 
-             Just txt -> return . Just . text . unsafeCoerce# 
-                           $ txt
-             Nothing  -> return Nothing
+             Just txt_ | txt <- unsafeCoerce# txt_, not (null txt) 
+                       -> return $ Just$ cparen (prec >= myprec && 
+                                                      needsParens txt) 
+                                                (text txt)
+             _  -> return Nothing
          `finally` do 
            writeIORef ref hsc_env
            GHC.setSessionDynFlags cms dflags
-     
+  needsParens ('"':txt) = False -- some simple heuristics to see whether parens
+                                -- are redundant in an arbitrary Show output
+  needsParens ('(':txt) = False 
+  needsParens txt = ' ' `elem` txt
+
+ 
   bindToFreshName hsc_env ty userName = do
     name <- newGrimName cms userName 
     let ictxt    = hsc_IC hsc_env
         tmp_ids  = ic_tmp_ids ictxt
-        id       = mkGlobalId VanillaGlobal name ty vanillaIdInfo
+        id       = mkGlobalId VanillaGlobal name (sigmaType ty) vanillaIdInfo
         new_ic   = ictxt { ic_tmp_ids = id : tmp_ids }
     return (hsc_env {hsc_IC = new_ic }, name)
 
@@ -203,7 +212,7 @@ newGrimName cms userName  = do
     us <- mkSplitUniqSupply 'b'
     let unique  = uniqFromSupply us
         occname = mkOccName varName userName
-        name    = mkInternalName unique occname noSrcLoc
+        name    = mkInternalName unique occname noSrcSpan
     return name
 
 skolemSubst subst = subst `setTvSubstEnv`