X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FDebugger.hs;h=d31d4d67d157d8428bdd2c713fad02d5b0fce26e;hb=cf2ee54939510b1a64ad99ca7d00aeb8a862c06b;hp=602a1a578123ea54c1812537eb06451f9e8524d6;hpb=61e253e98937a2b83454f4d5ab3c94ef8c2dc81e;p=ghc-hetmet.git

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index 602a1a5..d31d4d6 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -21,18 +21,14 @@ import IdInfo
 import Name
 import Var hiding ( varName )
 import VarSet
-import VarEnv
 import Name 
 import UniqSupply
-import Type
 import TcType
-import TcGadt
 import GHC
-import GhciMonad
+import DynFlags
 import InteractiveEval
 import Outputable
 import Pretty                    ( Mode(..), showDocWith )
-import FastString
 import SrcLoc
 
 import Control.Exception
@@ -44,7 +40,6 @@ import Data.IORef
 import System.IO
 import GHC.Exts
 
-#include "HsVersions.h"
 -------------------------------------
 -- | The :print & friends commands
 -------------------------------------
@@ -109,7 +104,7 @@ bindSuspensions cms@(Session ref) t = do
       let ictxt        = hsc_IC hsc_env
           prefix       = "_t"
           alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
-          availNames   = map ((prefix++) . show) [1..] \\ alreadyUsedNames
+          availNames   = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
       availNames_var  <- newIORef availNames
       (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
       let (names, tys, hvals) = unzip3 stuff
@@ -134,22 +129,28 @@ 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 Nothing = do
+        doSuspension freeNames ct mb_ty hval _name = do
           name <- atomicModifyIORef freeNames (\x->(tail x, head x))
-          n <- newGrimName cms name
+          n <- newGrimName name
           let ty' = fromMaybe (error "unexpected") mb_ty
           return (Suspension ct mb_ty hval (Just n), [(n,ty',hval)])
 
 
 --  A custom Term printer to enable the use of Show instances
-showTerm cms@(Session ref) = cPprTerm cPpr
+showTerm :: Session -> Term -> IO SDoc
+showTerm cms@(Session ref) term = do
+    dflags       <- GHC.getSessionDynFlags cms
+    if dopt Opt_PrintEvldWithShow dflags
+       then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term
+       else cPprTerm cPprTermBase term
  where
-  cPpr = \p-> cPprShowable : cPprTermBase p
-  cPprShowable prec t@Term{ty=ty, dc=dc, val=val} = do
-    let hasType = isEmptyVarSet (tyVarsOfType ty)  -- redundant
-        isEvaled = isFullyEvaluatedTerm t
-    if not isEvaled -- || not hasType
+  cPprShowable prec t@Term{ty=ty, val=val} =
+    if not (isFullyEvaluatedTerm t)
      then return Nothing
      else do
         hsc_env <- readIORef ref
@@ -172,14 +173,18 @@ showTerm cms@(Session ref) = cPprTerm cPpr
          `finally` do
            writeIORef ref hsc_env
            GHC.setSessionDynFlags cms dflags
-  needsParens ('"':txt) = False -- some simple heuristics to see whether parens
+  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 ('(':txt) = False
+  needsParens ('(':_) = False
   needsParens txt = ' ' `elem` txt
 
 
   bindToFreshName hsc_env ty userName = do
-    name <- newGrimName cms userName
+    name <- newGrimName userName
     let ictxt    = hsc_IC hsc_env
         tmp_ids  = ic_tmp_ids ictxt
         id       = mkGlobalId VanillaGlobal name (sigmaType ty) vanillaIdInfo
@@ -187,8 +192,8 @@ showTerm cms@(Session ref) = cPprTerm cPpr
     return (hsc_env {hsc_IC = new_ic }, name)
 
 --    Create new uniques and give them sequentially numbered names
---    newGrimName :: Session -> String -> IO Name
-newGrimName cms userName  = do
+newGrimName :: String -> IO Name
+newGrimName userName  = do
     us <- mkSplitUniqSupply 'b'
     let unique  = uniqFromSupply us
         occname = mkOccName varName userName