X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcType.lhs;h=db151f1ce4a98fa879aaecfe6a383171d02d1f8a;hb=d386e0d20c6953b7cba4d53538a1782c4aa9980d;hp=aa0b0c988062ec9ba862f0cf61f17269ba8d97ef;hpb=ab22f4e6456820c1b5169d75f5975a94e61f54ce;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index aa0b0c9..db151f1 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -59,7 +59,7 @@ module TcType (
 
   ---------------------------------
   -- Misc type manipulators
-  deNoteType, classesOfTheta,
+  deNoteType,
   tyClsNamesOfType, tyClsNamesOfDFunHead, 
   getDFunTyKey,
 
@@ -69,8 +69,8 @@ module TcType (
   isClassPred, isTyVarClassPred, isEqPred, 
   mkDictTy, tcSplitPredTy_maybe, 
   isPredTy, isDictTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique, 
-  mkClassPred, isInheritablePred, isIPPred, mkPredName, 
-  dataConsStupidTheta, isRefineableTy,
+  mkClassPred, isInheritablePred, isIPPred, 
+  dataConsStupidTheta, isRefineableTy, isRefineablePred,
 
   ---------------------------------
   -- Foreign import and export
@@ -142,6 +142,7 @@ import TyCon
 
 -- others:
 import DynFlags
+import CoreSyn
 import Name
 import NameSet
 import VarEnv
@@ -149,7 +150,6 @@ import OccName
 import PrelNames
 import TysWiredIn
 import BasicTypes
-import SrcLoc
 import Util
 import Maybes
 import ListSetOps
@@ -299,6 +299,8 @@ data MetaDetails
 		     --   For a BoxTv, this type must be non-boxy
                      --   For a TauTv, this type must be a tau-type
 
+-- Generally speaking, SkolemInfo should not contain location info
+-- that is contained in the Name of the tyvar with this SkolemInfo
 data SkolemInfo
   = SigSkol UserTypeCtxt	-- A skolem that is created by instantiating
 				-- a programmer-supplied type signature
@@ -306,25 +308,26 @@ data SkolemInfo
 
 	-- The rest are for non-scoped skolems
   | ClsSkol Class	-- Bound at a class decl
-  | InstSkol Id		-- Bound at an instance decl
-  | FamInstSkol TyCon	-- Bound at a family instance decl
+  | InstSkol 		-- Bound at an instance decl
+  | FamInstSkol 	-- Bound at a family instance decl
   | PatSkol DataCon	-- An existential type variable bound by a pattern for
-	    SrcSpan	-- a data constructor with an existential type. E.g.
+	    		-- a data constructor with an existential type. E.g.
 			--	data T = forall a. Eq a => MkT a
 			-- 	f (MkT x) = ...
 			-- The pattern MkT x will allocate an existential type
 			-- variable for 'a'.  
-  | ArrowSkol SrcSpan	-- An arrow form (see TcArrows)
+  | ArrowSkol 		-- An arrow form (see TcArrows)
 
+  | RuleSkol RuleName	-- The LHS of a RULE
   | GenSkol [TcTyVar]	-- Bound when doing a subsumption check for 
 	    TcType	-- 	(forall tvs. ty)
-	    SrcSpan
 
   | UnkSkol		-- Unhelpful info (until I improve it)
 
 -------------------------------------
 -- UserTypeCtxt describes the places where a 
 -- programmer-written type signature can occur
+-- Like SkolemInfo, no location info
 data UserTypeCtxt 
   = FunSigCtxt Name	-- Function type signature
 			-- Also used for types in SPECIALISE pragmas
@@ -340,7 +343,6 @@ data UserTypeCtxt
   | ResSigCtxt		-- Result type sig
 			-- 	f x :: t = ....
   | ForSigCtxt Name	-- Foreign inport or export signature
-  | RuleSigCtxt Name 	-- Signature on a forall'd variable in a RULE
   | DefaultDeclCtxt	-- Types in a default declaration
   | SpecInstCtxt	-- SPECIALISE instance pragma
 
@@ -405,7 +407,6 @@ pprUserTypeCtxt LamPatSigCtxt   = ptext SLIT("a pattern type signature")
 pprUserTypeCtxt BindPatSigCtxt  = ptext SLIT("a pattern type signature")
 pprUserTypeCtxt ResSigCtxt      = ptext SLIT("a result type signature")
 pprUserTypeCtxt (ForSigCtxt n)  = ptext SLIT("the foreign declaration for") <+> quotes (ppr n)
-pprUserTypeCtxt (RuleSigCtxt n) = ptext SLIT("the type signature for") <+> quotes (ppr n)
 pprUserTypeCtxt DefaultDeclCtxt = ptext SLIT("a type in a `default' declaration")
 pprUserTypeCtxt SpecInstCtxt    = ptext SLIT("a SPECIALISE instance pragma")
 
@@ -426,7 +427,7 @@ tidySkolemTyVar env tv
 				  (env1, info') = tidy_skol_info env info
 			info -> (env, info)
 
-    tidy_skol_info env (GenSkol tvs ty loc) = (env2, GenSkol tvs1 ty1 loc)
+    tidy_skol_info env (GenSkol tvs ty) = (env2, GenSkol tvs1 ty1)
 			    where
 			      (env1, tvs1) = tidyOpenTyVars env tvs
 			      (env2, ty1)  = tidyOpenType env1 ty
@@ -444,27 +445,22 @@ pprSkolTvBinding tv
     ppr_details (MetaTv (SigTv info) _) = ppr_skol info
     ppr_details (SkolemTv info)		= ppr_skol info
 
-    ppr_skol UnkSkol 	     = empty	-- Unhelpful; omit
-    ppr_skol (SigSkol ctxt)  = sep [quotes (ppr tv) <+> ptext SLIT("is bound by") <+> pprUserTypeCtxt ctxt,
-				    nest 2 (ptext SLIT("at") <+> ppr (getSrcLoc tv))]
-    ppr_skol info            = quotes (ppr tv) <+> pprSkolInfo info
+    ppr_skol UnkSkol = empty	-- Unhelpful; omit
+    ppr_skol info    = quotes (ppr tv) <+> ptext SLIT("is bound by") 
+			<+> sep [pprSkolInfo info, nest 2 (ptext SLIT("at") <+> ppr (getSrcLoc tv))]
  
 pprSkolInfo :: SkolemInfo -> SDoc
-pprSkolInfo (SigSkol ctxt)   = ptext SLIT("is bound by") <+> pprUserTypeCtxt ctxt
-pprSkolInfo (ClsSkol cls)    = ptext SLIT("is bound by the class declaration for") <+> quotes (ppr cls)
-pprSkolInfo (InstSkol df)    = 
-  ptext SLIT("is bound by the instance declaration at") <+> ppr (getSrcLoc df)
-pprSkolInfo (FamInstSkol tc) = 
-  ptext SLIT("is bound by the family instance declaration at") <+> 
-  ppr (getSrcLoc tc)
-pprSkolInfo (ArrowSkol loc)  = 
-  ptext SLIT("is bound by the arrow form at") <+> ppr loc
-pprSkolInfo (PatSkol dc loc) = sep [ptext SLIT("is bound by the pattern for") <+> quotes (ppr dc),
-           		            nest 2 (ptext SLIT("at") <+> ppr loc)]
-pprSkolInfo (GenSkol tvs ty loc) = sep [sep [ptext SLIT("is bound by the polymorphic type"), 
-				   	     nest 2 (quotes (ppr (mkForAllTys tvs ty)))],
-				        nest 2 (ptext SLIT("at") <+> ppr loc)]
--- UnkSkol, SigSkol
+pprSkolInfo (SigSkol ctxt)   = pprUserTypeCtxt ctxt
+pprSkolInfo (ClsSkol cls)    = ptext SLIT("the class declaration for") <+> quotes (ppr cls)
+pprSkolInfo InstSkol         = ptext SLIT("the instance declaration")
+pprSkolInfo FamInstSkol      = ptext SLIT("the family instance declaration")
+pprSkolInfo (RuleSkol name)  = ptext SLIT("the RULE") <+> doubleQuotes (ftext name)
+pprSkolInfo ArrowSkol        = ptext SLIT("the arrow form")
+pprSkolInfo (PatSkol dc)     = sep [ptext SLIT("the constructor") <+> quotes (ppr dc)]
+pprSkolInfo (GenSkol tvs ty) = sep [ptext SLIT("the polymorphic type"), 
+				    nest 2 (quotes (ppr (mkForAllTys tvs ty)))]
+
+-- UnkSkol
 -- For type variables the others are dealt with by pprSkolTvBinding.  
 -- For Insts, these cases should not happen
 pprSkolInfo UnkSkol = panic "UnkSkol"
@@ -496,8 +492,8 @@ isSkolemTyVar tv
 isExistentialTyVar tv 	-- Existential type variable, bound by a pattern
   = ASSERT( isTcTyVar tv )
     case tcTyVarDetails tv of
-	SkolemTv (PatSkol _ _) -> True
-	other 		       -> False
+	SkolemTv (PatSkol {}) -> True
+	other 		      -> False
 
 isMetaTyVar tv 
   = ASSERT2( isTcTyVar tv, ppr tv )
@@ -544,7 +540,7 @@ mkSigmaTy :: [TyVar] -> [PredType] -> Type -> Type
 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau)
 
 mkPhiTy :: [PredType] -> Type -> Type
-mkPhiTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta
+mkPhiTy theta ty = foldr (\p r -> mkFunTy (mkPredTy p) r) ty theta
 \end{code}
 
 @isTauTy@ tests for nested for-alls.  It should not be called on a boxy type.
@@ -573,15 +569,20 @@ isBoxyTy ty = any isBoxyTyVar (varSetElems (tcTyVarsOfType ty))
 
 isRigidTy :: TcType -> Bool
 -- A type is rigid if it has no meta type variables in it
-isRigidTy ty = all isSkolemTyVar (varSetElems (tcTyVarsOfType ty))
+isRigidTy ty = all isImmutableTyVar (varSetElems (tcTyVarsOfType ty))
 
 isRefineableTy :: TcType -> Bool
 -- A type should have type refinements applied to it if it has
 -- free type variables, and they are all rigid
-isRefineableTy ty = not (null tc_tvs) && all isSkolemTyVar tc_tvs
+isRefineableTy ty = not (null tc_tvs) && all isImmutableTyVar tc_tvs
 		    where
 		      tc_tvs = varSetElems (tcTyVarsOfType ty)
 
+isRefineablePred :: TcPredType -> Bool
+isRefineablePred pred = not (null tc_tvs) && all isImmutableTyVar tc_tvs
+		      where
+		        tc_tvs = varSetElems (tcTyVarsOfPred pred)
+
 ---------------
 getDFunTyKey :: Type -> OccName	-- Get some string from a type, to be used to 
 				-- construct a dictionary function name
@@ -800,10 +801,6 @@ tcSplitPredTy_maybe other	  = Nothing
 predTyUnique :: PredType -> Unique
 predTyUnique (IParam n _)      = getUnique (ipNameName n)
 predTyUnique (ClassP clas tys) = getUnique clas
-
-mkPredName :: Unique -> SrcLoc -> PredType -> Name
-mkPredName uniq loc (ClassP cls tys) = mkInternalName uniq (mkDictOcc (getOccName cls)) loc
-mkPredName uniq loc (IParam ip ty)   = mkInternalName uniq (getOccName (ipNameName ip)) loc
 \end{code}
 
 
@@ -853,7 +850,8 @@ isInheritablePred :: PredType -> Bool
 -- but it doesn't need to be quantified over the Num a dictionary
 -- which can be free in g's rhs, and shared by both calls to g
 isInheritablePred (ClassP _ _) = True
-isInheritablePred other	     = False
+isInheritablePred (EqPred _ _) = True
+isInheritablePred other	       = False
 \end{code}
 
 --------------------- Equality predicates ---------------------------------
@@ -1046,10 +1044,6 @@ tyClsNamesOfDFunHead :: Type -> NameSet
 tyClsNamesOfDFunHead dfun_ty 
   = case tcSplitSigmaTy dfun_ty of
 	(tvs,_,head_ty) -> tyClsNamesOfType head_ty
-
-classesOfTheta :: ThetaType -> [Class]
--- Looks just for ClassP things; maybe it should check
-classesOfTheta preds = [ c | ClassP c _ <- preds ]
 \end{code}