Give the inferred type when warning of a missing type-signature (Trac #1256)

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

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index f0f8973..4f721d1 100644 (file)
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -4,10 +4,15 @@
 --
 -- Pepe Iborra (supported by Google SoC) 2006
 --
+-- ToDo: lots of violation of layering here.  This module should
+-- decide whether it is above the GHC API (import GHC and nothing
+-- else) or below it.
+-- 
 -----------------------------------------------------------------------------
 
-module Debugger (pprintClosureCommand, instantiateTyVarsToUnknown) where
+module Debugger (pprintClosureCommand) where
 
+import qualified DebuggerTys
 import Linker
 import RtClosureInspect
 
@@ -24,7 +29,6 @@ import RdrName
 import UniqSupply
 import Type
 import TyCon
-import DataCon
 import TcGadt
 import GHC
 import GhciMonad
@@ -58,7 +62,7 @@ pprintClosureCommand bindThings force str = do
   mb_new_ids <- mapM (io . go cms) (catMaybes mb_ids)
   io$ updateIds cms (catMaybes mb_new_ids)
  where 
-   -- Find the Id, clean up 'Unknowns'
+   -- Find the Id, clean up 'Unknowns' in the idType
    cleanUp :: Session -> [Name] -> String -> IO (Maybe Id)
    cleanUp cms newNames str = do
      tythings <- GHC.parseName cms str >>= mapM (GHC.lookupName cms)
@@ -73,7 +77,7 @@ pprintClosureCommand bindThings force str = do
      maybe (return Nothing) `flip` mb_term $ \term -> do
        term'     <- if not bindThings then return term 
                      else bindSuspensions cms term                         
-       showterm  <- pprTerm cms term'
+       showterm  <- printTerm cms term'
        unqual    <- GHC.getPrintUnqual cms
        let showSDocForUserOneLine unqual doc = 
                showDocWith LeftMode (doc (mkErrStyle unqual))
@@ -156,10 +160,10 @@ bindSuspensions cms@(Session ref) t = do
 
 
 --  A custom Term printer to enable the use of Show instances
-pprTerm cms@(Session ref) = customPrintTerm customPrint
+printTerm cms@(Session ref) = cPprTerm cPpr
  where
-  customPrint = \p-> customPrintShowable : customPrintTermBase p 
-  customPrintShowable t@Term{ty=ty, dc=dc, val=val} = do
+  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
@@ -175,8 +179,10 @@ pprTerm cms@(Session ref) = customPrintTerm customPrint
            GHC.setSessionDynFlags cms dflags{log_action=noop_log}
            mb_txt <- withExtendedLinkEnv [(bname, val)] 
                                          (GHC.compileExpr cms expr)
+           let myprec = 9 -- TODO Infix constructors
            case mb_txt of 
-             Just txt -> return . Just . text . unsafeCoerce# $ txt
+             Just txt -> return . Just . text . unsafeCoerce# 
+                           $ txt
              Nothing  -> return Nothing
          `finally` do 
            writeIORef ref hsc_env
@@ -203,56 +209,6 @@ newGrimName cms userName  = do
         name    = mkInternalName unique occname noSrcLoc
     return name
 
-----------------------------------------------------------------------------
--- | Replace all the tyvars in a Term with the opaque type GHC.Base.Unknown
-----------------------------------------------------------------------------
-instantiateTyVarsToUnknown :: Session -> Type -> IO Type
-instantiateTyVarsToUnknown cms ty
--- We have a GADT, so just fix its tyvars
-    | Just (tycon, args) <- splitTyConApp_maybe ty
-    , tycon /= funTyCon
-    , isGADT tycon
-    = mapM fixTyVars args >>= return . mkTyConApp tycon
--- We have a regular TyCon, so map recursively to its args
-    | Just (tycon, args) <- splitTyConApp_maybe ty
-    , tycon /= funTyCon
-    = do unknownTyVar <- unknownTV
-         args' <- mapM (instantiateTyVarsToUnknown cms) args
-         return$ mkTyConApp tycon args'
--- we have a tyvar of kind *
-    | Just tyvar <- getTyVar_maybe ty
-    , ([],_) <- splitKindFunTys (tyVarKind tyvar) 
-    = unknownTV
--- we have a higher kind tyvar, so insert an unknown of the appropriate kind
-    | Just tyvar <- getTyVar_maybe ty
-    , (args,_) <- splitKindFunTys (tyVarKind tyvar)
-    = liftM mkTyConTy $ unknownTC !! length args
--- Base case
-    | otherwise    = return ty 
-
- where unknownTV = do 
-         Just (ATyCon unknown_tc) <- lookupName cms unknownTyConName
-         return$ mkTyConTy unknown_tc
-       unknownTC = [undefined, unknownTC1, unknownTC2, unknownTC3]
-       unknownTC1 = do 
-         Just (ATyCon unknown_tc) <- lookupName cms unknown1TyConName
-         return unknown_tc
-       unknownTC2 = do 
-         Just (ATyCon unknown_tc) <- lookupName cms unknown2TyConName
-         return unknown_tc
-       unknownTC3 = do 
-         Just (ATyCon unknown_tc) <- lookupName cms unknown3TyConName
-         return unknown_tc
---       isGADT ty | pprTrace' "isGADT" (ppr ty <> colon <> ppr(isGadtSyntaxTyCon ty)) False = undefined
-       isGADT tc | Just dcs <- tyConDataCons_maybe tc = any (not . null . dataConEqSpec) dcs
-                 | otherwise = False
-       fixTyVars ty 
-           | Just (tycon, args) <- splitTyConApp_maybe ty
-           = mapM fixTyVars args >>= return . mkTyConApp tycon
--- Fix the tyvar so that the interactive environment doesn't choke on it TODO 
-           | Just tv <- getTyVar_maybe ty = return ty --TODO
-           | otherwise = return ty
-
 -- | The inverse function. Strip the GHC.Base.Unknowns in the type of the id, they correspond to tyvars. The caller must provide an infinite list of fresh names
 stripUnknowns :: [Name] -> Id -> Id
 stripUnknowns names id = setIdType id . fst . go names . idType 
@@ -289,3 +245,8 @@ stripUnknowns names id = setIdType id . fst . go names . idType
            kind1 = mkArrowKind liftedTypeKind liftedTypeKind
            kind2 = mkArrowKind kind1 liftedTypeKind
            kind3 = mkArrowKind kind2 liftedTypeKind
+
+instantiateTyVarsToUnknown :: Session -> Type -> IO Type
+instantiateTyVarsToUnknown (Session ref) ty
+  = do hsc_env <- readIORef ref
+       DebuggerTys.instantiateTyVarsToUnknown hsc_env ty