X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FDebugger.hs;h=e13b8a809a8648d50c7c7dd91c33e01ae99fe4da;hb=58de6cb725982dd1f57803cc838f233d5fd9c42c;hp=cc0d5baa482086ff349233846601ae45853348a8;hpb=18f671cc4b459195c24f0ea3b16fc600d5e7a4bf;p=ghc-hetmet.git

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index cc0d5ba..e13b8a8 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -10,7 +10,7 @@
 -- 
 -----------------------------------------------------------------------------
 
-module Debugger (pprintClosureCommand, showTerm) where
+module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where
 
 import Linker
 import RtClosureInspect
@@ -23,12 +23,13 @@ import Var hiding ( varName )
 import VarSet
 import Name 
 import UniqSupply
-import Type
+import TcType
 import GHC
+import DynFlags
 import InteractiveEval
 import Outputable
-import Pretty                    ( Mode(..), showDocWith )
 import SrcLoc
+import PprTyThing
 
 import Control.Exception
 import Control.Monad
@@ -60,10 +61,8 @@ pprintClosureCommand session bindThings force str = do
                                 (map skolemiseSubst substs)}
   -- Finally, print the Terms
   unqual  <- GHC.getPrintUnqual session
-  let showSDocForUserOneLine unqual doc =
-               showDocWith LeftMode (doc (mkErrStyle unqual))
   docterms <- mapM (showTerm session) terms
-  (putStrLn . showSDocForUserOneLine unqual . vcat)
+  (printForUser stdout unqual . vcat)
         (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
                  ids
                  docterms)
@@ -74,13 +73,15 @@ pprintClosureCommand session bindThings force str = do
    go cms id = do
        term_    <- GHC.obtainTerm cms force id
        term     <- tidyTermTyVars cms term_
-       term'    <- if not bindThings then return term
-                     else bindSuspensions cms term                       
+       term'    <- if bindThings && 
+                      False == isUnliftedTypeKind (termType term)
+                     then bindSuspensions cms term
+                     else return term
      -- 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.
-       let Just reconstructed_type = termType term
-           Just subst = computeRTTIsubst (idType id) (reconstructed_type)
+       let reconstructed_type = termType term
+           subst = unifyRTTI (idType id) (reconstructed_type)
        return (term',subst)
 
    tidyTermTyVars :: Session -> Term -> IO Term
@@ -128,22 +129,30 @@ bindSuspensions cms@(Session ref) t = do
                                     let (terms,names) = unzip tt'
                                     return (Term ty dc v terms, concat names)
                       , fPrim    = \ty n ->return (Prim ty n,[])
+                      , fNewtypeWrap  = 
+                                \ty dc t -> do 
+                                    (term, names) <- t
+                                    return (NewtypeWrap ty dc term, names)
+                      , fRefWrap = \ty t -> do
+                                    (term, names) <- t 
+                                    return (RefWrap ty term, names)
                       }
-        doSuspension freeNames ct mb_ty hval _name = do
+        doSuspension freeNames ct ty hval _name = do
           name <- atomicModifyIORef freeNames (\x->(tail x, head x))
           n <- newGrimName name
-          let ty' = fromMaybe (error "unexpected") mb_ty
-          return (Suspension ct mb_ty hval (Just n), [(n,ty',hval)])
+          return (Suspension ct ty hval (Just n), [(n,ty,hval)])
 
 
 --  A custom Term printer to enable the use of Show instances
 showTerm :: Session -> Term -> IO SDoc
 showTerm cms@(Session ref) term = do
-    cPprExtended <- cPprTermExtended cms
-    cPprTerm (liftM2 (++) cPprShowable cPprExtended) term
+    dflags       <- GHC.getSessionDynFlags cms
+    if dopt Opt_PrintEvldWithShow dflags
+       then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term
+       else cPprTerm cPprTermBase term
  where
-  cPprShowable _y = [\prec ty _ val tt ->
-    if not (all isFullyEvaluatedTerm tt)
+  cPprShowable prec t@Term{ty=ty, val=val} =
+    if not (isFullyEvaluatedTerm t)
      then return Nothing
      else do
         hsc_env <- readIORef ref
@@ -165,7 +174,12 @@ showTerm cms@(Session ref) term = do
              _  -> return Nothing
          `finally` do
            writeIORef ref hsc_env
-           GHC.setSessionDynFlags cms dflags]
+           GHC.setSessionDynFlags cms dflags
+  cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} = 
+      cPprShowable prec t{ty=new_ty}
+  cPprShowable prec RefWrap{wrapped_term=t} = cPprShowable prec t
+  cPprShowable _ _ = return Nothing
+
   needsParens ('"':_) = False   -- some simple heuristics to see whether parens
                                 -- are redundant in an arbitrary Show output
   needsParens ('(':_) = False
@@ -180,27 +194,6 @@ showTerm cms@(Session ref) term = do
         new_ic   = ictxt { ic_tmp_ids = id : tmp_ids }
     return (hsc_env {hsc_IC = new_ic }, name)
 
-{- | A custom Term printer to handle some types that 
-     we may not want to show, such as Data.Typeable.TypeRep -}
-cPprTermExtended :: Monad m => Session -> IO (CustomTermPrinter m)
-cPprTermExtended session = liftM22 (++) (return cPprTermBase) extended
-  where 
-   extended = do
-     [typerep_name]        <- parseName session "Data.Typeable.TypeRep"
-     Just (ATyCon typerep) <- lookupName session typerep_name 
-
-     return (\_y -> 
-        [ ifType (isTyCon typerep) (\_val _prec -> return (text "<typerep>")) ])
-
-   ifType pred f prec ty _ val _tt
-      | pred ty   = Just `liftM` f prec val
-      | otherwise = return Nothing
-   isTyCon a_tc ty = fromMaybe False $ do 
-             (tc,_) <- splitTyConApp_maybe ty
-             return (a_tc == tc)
-   liftM22 f x y = do x' <- x; y' <- y
-                      return$ do x'' <- x';y'' <- y';return (f x'' y'')
-
 --    Create new uniques and give them sequentially numbered names
 newGrimName :: String -> IO Name
 newGrimName userName  = do
@@ -209,3 +202,18 @@ newGrimName userName  = do
         occname = mkOccName varName userName
         name    = mkInternalName unique occname noSrcSpan
     return name
+
+pprTypeAndContents :: Session -> [Id] -> IO SDoc
+pprTypeAndContents session ids = do
+  dflags  <- GHC.getSessionDynFlags session
+  let pefas     = dopt Opt_PrintExplicitForalls dflags
+      pcontents = dopt Opt_PrintBindContents dflags
+  if pcontents 
+    then do
+      let depthBound = 100
+      terms      <- mapM (GHC.obtainTermB session depthBound False) ids
+      docs_terms <- mapM (showTerm session) terms
+      return $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
+                             (map (pprTyThing pefas . AnId) ids)
+                             docs_terms
+    else return $  vcat $ map (pprTyThing pefas . AnId) ids