[project @ 1997-05-26 04:54:13 by sof]

[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreUtils.lhs

diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index f4cbb53..471e2b5 100644 (file)
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -21,7 +21,6 @@ module CoreUtils (
     ) where
 
 IMP_Ubiq()
-IMPORT_DELOOPER(IdLoop)        -- for pananoia-checking purposes
 
 import CoreSyn
 
@@ -31,31 +30,34 @@ import Id           ( idType, mkSysLocal, isBottomingId,
                          dataConRepType,
                          addOneToIdEnv, growIdEnvList, lookupIdEnv,
                          isNullIdEnv, SYN_IE(IdEnv),
-                         GenId{-instances-}
+                         GenId{-instances-}, SYN_IE(Id)
                        )
 import Literal         ( literalType, isNoRepLit, Literal(..) )
 import Maybes          ( catMaybes, maybeToBool )
 import PprCore
-import PprStyle                ( PprStyle(..) )
-import PprType         ( GenType{-instances-} )
-import Pretty          ( ppAboves, ppStr )
-import PrelVals                ( augmentId, buildId )
+import Outputable      ( PprStyle(..), Outputable(..) )
+import PprType         ( GenType{-instances-}, GenTyVar )
+import Pretty          ( vcat, text )
 import PrimOp          ( primOpType, PrimOp(..) )
 import SrcLoc          ( noSrcLoc )
 import TyVar           ( cloneTyVar,
-                         isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv)
+                         isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv),
+                         SYN_IE(TyVar), GenTyVar
                        )
 import Type            ( mkFunTy, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
                          getFunTyExpandingDicts_maybe, applyTy, isPrimType,
-                         splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
+                         splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy,
+                         SYN_IE(Type)
                        )
 import TysWiredIn      ( trueDataCon, falseDataCon )
+import Unique          ( Unique )
 import UniqSupply      ( initUs, returnUs, thenUs,
                          mapUs, mapAndUnzipUs, getUnique,
                          SYN_IE(UniqSM), UniqSupply
                        )
 import Usage           ( SYN_IE(UVar) )
-import Util            ( zipEqual, panic, pprPanic, assertPanic )
+import Util            ( zipEqual, panic, pprTrace, pprPanic, assertPanic )
+import Pretty
 
 type TypeEnv = TyVarEnv Type
 applyUsage = panic "CoreUtils.applyUsage:ToDo"
@@ -82,7 +84,14 @@ coreExprType (Coerce _ ty _) = ty -- that's the whole point!
 -- a Con is a fully-saturated application of a data constructor
 -- a Prim is <ditto> of a PrimOp
 
-coreExprType (Con con args) = applyTypeToArgs (dataConRepType    con) args
+coreExprType (Con con args) = 
+--                           pprTrace "appTyArgs" (hsep [ppr PprDebug con, semi, 
+--                                                        ppr PprDebug con_ty, semi,
+--                                                        ppr PprDebug args]) $
+                             applyTypeToArgs con_ty args
+                           where
+                               con_ty = dataConRepType con
+
 coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
 
 coreExprType (Lam (ValBinder binder) expr)
@@ -95,7 +104,11 @@ coreExprType (Lam (UsageBinder uvar) expr)
   = mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr)
 
 coreExprType (App expr (TyArg ty))
-  = applyTy (coreExprType expr) ty
+  = 
+--  pprTrace "appTy1" (hsep [ppr PprDebug fun_ty, space, ppr PprDebug ty]) $
+    applyTy fun_ty ty
+  where
+    fun_ty = coreExprType expr
 
 coreExprType (App expr (UsageArg use))
   = applyUsage (coreExprType expr) use
@@ -109,7 +122,7 @@ coreExprType (App expr val_arg)
          Just (_, result_ty) -> result_ty
 #ifdef DEBUG
          Nothing -> pprPanic "coreExprType:\n"
-               (ppAboves [ppr PprDebug fun_ty,
+               (vcat [ppr PprDebug fun_ty,
                           ppr PprShowAll (App expr val_arg)])
 #endif
 \end{code}
@@ -359,7 +372,7 @@ maybeErrorApp
                                        -- *pretend* that the result ty won't be
                                        -- primitive -- somebody later must
                                        -- ensure this.
-       -> Maybe (GenCoreExpr a Id TyVar UVar)
+       -> Maybe (GenCoreExpr b Id TyVar UVar)
 
 maybeErrorApp expr result_ty_maybe
   = case (collectArgs expr) of