Finally, I managed to squash an infamous bug in :print

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

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index cc0d5ba..d31d4d6 100644 (file)
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -23,8 +23,9 @@ 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 )
@@ -128,6 +129,10 @@ 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)
                       }
         doSuspension freeNames ct mb_ty hval _name = do
           name <- atomicModifyIORef freeNames (\x->(tail x, head x))
@@ -139,11 +144,13 @@ bindSuspensions cms@(Session ref) t = do
 --  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 +172,11 @@ 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 _ _ = panic "cPprShowable - unreachable"
+
   needsParens ('"':_) = False   -- some simple heuristics to see whether parens
                                 -- are redundant in an arbitrary Show output
   needsParens ('(':_) = False
@@ -180,27 +191,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