Fix typo causing the PowerPC OS X build to fail

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

diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index bfb3936..efeb976 100644 (file)
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -39,6 +39,8 @@ module RtClosureInspect(
      isPointed,
      isFullyEvaluatedTerm,
 --     unsafeDeepSeq, 
+     
+     sigmaType
  ) where 
 
 #include "HsVersions.h"
@@ -61,7 +63,6 @@ import Name
 import VarEnv
 import OccName
 import VarSet
-import Unique
 import {-#SOURCE#-} TcRnDriver ( tcRnRecoverDataCon )
 
 import TysPrim         
@@ -125,6 +126,11 @@ isPrim   _    = False
 termType t@(Suspension {}) = mb_ty t
 termType t = Just$ ty t
 
+isFullyEvaluatedTerm :: Term -> Bool
+isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
+isFullyEvaluatedTerm Suspension {}      = False
+isFullyEvaluatedTerm Prim {}            = True
+
 instance Outputable (Term) where
  ppr = head . customPrintTerm customPrintTermBase
 
@@ -270,7 +276,7 @@ extractUnboxed tt ba = helper tt (byteArrayContents# ba)
            -- TODO: Improve the offset handling in decode (make it machine dependant)
 
 -----------------------------------
--- Boilerplate Fold code for Term
+-- * Traversals for Terms
 -----------------------------------
 
 data TermFold a = TermFold { fTerm :: Type -> DataCon -> HValue -> [a] -> a
@@ -358,7 +364,7 @@ customPrintTermBase showP =
                                     , largeIntegerDataConName] 
            isTupleDC Term{dc=dc}   = dc `elem` snd (unzip (elems boxedTupleArr))
            isDC a_dc Term{dc=dc}   = a_dc == dc
-           coerceShow f Term{val=val} = return . text . show . f . unsafeCoerce# $ val
+           coerceShow f = return . text . show . f . unsafeCoerce# . val
            --TODO pprinting of list terms is not lazy
            doList h t = do
                let elems = h : getListTerms t
@@ -379,12 +385,6 @@ customPrintTermBase showP =
                       getListTerms t@Suspension{}       = [t]
                       getListTerms t = pprPanic "getListTerms" (ppr t)
 
-isFullyEvaluatedTerm :: Term -> Bool
-isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
-isFullyEvaluatedTerm Suspension {}      = False
-isFullyEvaluatedTerm Prim {}            = True
-
-
 -----------------------------------
 -- Type Reconstruction
 -----------------------------------
@@ -409,6 +409,8 @@ addConstraint t1 t2  = congruenceNewtypes t1 t2 >> unifyType t1 t2
 -- in the right side reptypes for newtypes as found in the lhs
 -- Sadly it doesn't cover all the possibilities. It does not always manage
 -- to recover the highest level type. See test print016 for an example
+-- This is used for approximating a unification over types modulo newtypes that recovers
+-- the most concrete, with-newtypes type
 congruenceNewtypes ::  TcType -> TcType -> TcM TcType
 congruenceNewtypes lhs rhs
 --    | pprTrace "Congruence" (ppr lhs $$ ppr rhs) False = undefined
@@ -465,6 +467,7 @@ cvObtainTerm hsc_env force mb_ty a =
             }
          tidy ty = tidyType (emptyTidyOccEnv, tidyVarEnv ty) ty  
          tidyVarEnv ty = 
+
              mkVarEnv$ [ (v, setTyVarName v (tyVarName tv))
                          | (tv,v) <- zip alphaTyVars vars]
              where vars = varSetElems$ tyVarsOfType ty
@@ -474,7 +477,7 @@ cvObtainTerm1 hsc_env force mb_ty hval
   | Nothing <- mb_ty = runTR hsc_env . go argTypeKind $ hval
   | Just ty <- mb_ty = runTR hsc_env $ do
                  term <- go argTypeKind hval
-                 ty'  <- instScheme ty
+                 ty'  <- instScheme (sigmaType ty)
                  addConstraint ty' (fromMaybe (error "by definition") 
                                               (termType term)) 
                  return term
@@ -510,7 +513,7 @@ cvObtainTerm1 hsc_env force mb_ty hval
                 subTerms   = reOrderTerms subTermsP subTermsNP subTtypes
             resType       <- liftM mkTyVarTy (newVar k)
             baseType      <- instScheme (dataConRepType dc)
-            let myType     = mkFunTys (map (fromMaybe undefined . termType) 
+            let myType     = mkFunTys (map (fromMaybe (error "cvObtainTerm1") . termType) 
                                        subTerms) 
                                   resType
             addConstraint baseType myType
@@ -541,6 +544,11 @@ zonkTerm = foldTerm idTermFoldM {
              ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
                                           return (Suspension ct ty v b)}  
 
+
+-- Is this defined elsewhere?
+-- Find all free tyvars and insert the appropiate ForAll.
+sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
+
 {-
 Example of Type Reconstruction
 --------------------------------