X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FDebugger.hs;h=9fbee36b947803d6e930aa73e16c836b626e3d90;hb=40739684494d88dde2efad64f15be2acbcc884a2;hp=d632d1655971d2b5e160eaa5ab3b35f20d886327;hpb=ad94d40948668032189ad22a0ad741ac1f645f50;p=ghc-hetmet.git

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index d632d16..9fbee36 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -10,13 +10,6 @@
 -- 
 -----------------------------------------------------------------------------
 
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
--- for details
-
 module Debugger (pprintClosureCommand, showTerm) where
 
 import Linker
@@ -32,6 +25,7 @@ import Name
 import UniqSupply
 import TcType
 import GHC
+import DynFlags
 import InteractiveEval
 import Outputable
 import Pretty                    ( Mode(..), showDocWith )
@@ -46,7 +40,6 @@ import Data.IORef
 import System.IO
 import GHC.Exts
 
-#include "HsVersions.h"
 -------------------------------------
 -- | The :print & friends commands
 -------------------------------------
@@ -88,7 +81,7 @@ pprintClosureCommand session bindThings force str = do
      --  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)
+           subst = computeRTTIsubst (idType id) (reconstructed_type)
        return (term',subst)
 
    tidyTermTyVars :: Session -> Term -> IO Term
@@ -111,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
@@ -136,19 +129,27 @@ 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} = 
+  cPprShowable prec t@Term{ty=ty, val=val} =
     if not (isFullyEvaluatedTerm t)
      then return Nothing
      else do
@@ -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