X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMType.lhs;h=2c01d2300a4505c34164414c5f746b6d8f862d7c;hp=fb5d8fb5791968fc5c2d57a489c410de8fc54527;hb=febf1ced754a3996ac1a5877dcded87828560d1c;hpb=b6264a6b8a8e22e24464da39ca0a3a0176d91f4e diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index fb5d8fb..2c01d23 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -26,7 +26,6 @@ module TcMType ( -------------------------------- -- Creating new evidence variables newEvVar, newCoVar, newEvVars, - writeWantedCoVar, readWantedCoVar, newIP, newDict, newSilentGiven, isSilentEvVar, newWantedEvVar, newWantedEvVars, @@ -43,16 +42,15 @@ module TcMType ( -- Checking type validity Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType, SourceTyCtxt(..), checkValidTheta, - checkValidInstance, - checkValidTypeInst, checkTyFamFreeness, + checkValidInstHead, checkValidInstance, + checkInstTermination, checkValidTypeInst, checkTyFamFreeness, arityErr, growPredTyVars, growThetaTyVars, validDerivPred, -------------------------------- -- Zonking zonkType, mkZonkTcTyVar, zonkTcPredType, - zonkTcTypeCarefully, - skolemiseUnboundMetaTyVar, + zonkTcTypeCarefully, skolemiseUnboundMetaTyVar, zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkSigTyVar, zonkQuantifiedTyVar, zonkQuantifiedTyVars, zonkTcType, zonkTcTypes, zonkTcThetaType, @@ -72,7 +70,6 @@ module TcMType ( import TypeRep import TcType import Type -import Coercion import Class import TyCon import Var @@ -145,7 +142,7 @@ newEvVar (IParam ip ty) = newIP ip ty newCoVar :: TcType -> TcType -> TcM CoVar newCoVar ty1 ty2 - = do { name <- newName (mkTyVarOccFS (fsLit "co")) + = do { name <- newName (mkVarOccFS (fsLit "co")) ; return (mkCoVar name (mkPredTy (EqPred ty1 ty2))) } newIP :: IPName Name -> TcType -> TcM IpId @@ -300,10 +297,6 @@ readMetaTyVar :: TyVar -> TcM MetaDetails readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar ) readMutVar (metaTvRef tyvar) -readWantedCoVar :: CoVar -> TcM MetaDetails -readWantedCoVar covar = ASSERT2( isMetaTyVar covar, ppr covar ) - readMutVar (metaTvRef covar) - isFilledMetaTyVar :: TyVar -> TcM Bool -- True of a filled-in (Indirect) meta type variable isFilledMetaTyVar tv @@ -342,9 +335,6 @@ writeMetaTyVar tyvar ty = WARN( True, text "Writing to non-meta tyvar" <+> ppr tyvar ) return () -writeWantedCoVar :: CoVar -> Coercion -> TcM () -writeWantedCoVar cv co = writeMetaTyVar cv co - -------------------- writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM () -- Here the tyvar is for error checking only; @@ -750,13 +740,12 @@ zonkType zonk_tc_tyvar ty -- The two interesting cases! go (TyVarTy tyvar) | isTcTyVar tyvar = zonk_tc_tyvar tyvar - | otherwise = liftM TyVarTy $ - zonkTyVar zonk_tc_tyvar tyvar + | otherwise = return (TyVarTy tyvar) -- Ordinary (non Tc) tyvars occur inside quantified types go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar ) do ty' <- go ty - tyvar' <- zonkTyVar zonk_tc_tyvar tyvar + tyvar' <- return tyvar return (ForAllTy tyvar' ty') go_pred (ClassP c tys) = do tys' <- mapM go tys @@ -779,16 +768,6 @@ mkZonkTcTyVar unbound_var_fn tyvar ; case cts of Flexi -> unbound_var_fn tyvar Indirect ty -> zonkType (mkZonkTcTyVar unbound_var_fn) ty } - --- Zonk the kind of a non-TC tyvar in case it is a coercion variable --- (their kind contains types). -zonkTyVar :: (TcTyVar -> TcM Type) -- What to do for a TcTyVar - -> TyVar -> TcM TyVar -zonkTyVar zonk_tc_tyvar tv - | isCoVar tv - = do { kind <- zonkType zonk_tc_tyvar (tyVarKind tv) - ; return $ setTyVarKind tv kind } - | otherwise = return tv \end{code} @@ -1159,7 +1138,7 @@ check_valid_theta ctxt theta = do warnTc (notNull dups) (dupPredWarn dups) mapM_ (check_pred_ty dflags ctxt) theta where - (_,dups) = removeDups tcCmpPred theta + (_,dups) = removeDups cmpPred theta ------------------------- check_pred_ty :: DynFlags -> SourceTyCtxt -> PredType -> TcM () @@ -1281,7 +1260,7 @@ checkAmbiguity forall_tyvars theta tau_tyvars ambigErr :: PredType -> SDoc ambigErr pred - = sep [ptext (sLit "Ambiguous constraint") <+> quotes (pprPred pred), + = sep [ptext (sLit "Ambiguous constraint") <+> quotes (pprPredTy pred), nest 2 (ptext (sLit "At least one of the forall'd type variables mentioned by the constraint") $$ ptext (sLit "must be reachable from the type after the '=>'"))] \end{code} @@ -1348,14 +1327,14 @@ eqSuperClassErr pred 2 (ppr pred) badPredTyErr, eqPredTyErr, predTyVarErr :: PredType -> SDoc -badPredTyErr pred = ptext (sLit "Illegal constraint") <+> pprPred pred -eqPredTyErr pred = ptext (sLit "Illegal equational constraint") <+> pprPred pred +badPredTyErr pred = ptext (sLit "Illegal constraint") <+> pprPredTy pred +eqPredTyErr pred = ptext (sLit "Illegal equational constraint") <+> pprPredTy pred $$ parens (ptext (sLit "Use -XTypeFamilies to permit this")) predTyVarErr pred = sep [ptext (sLit "Non type-variable argument"), - nest 2 (ptext (sLit "in the constraint:") <+> pprPred pred)] + nest 2 (ptext (sLit "in the constraint:") <+> pprPredTy pred)] dupPredWarn :: [[PredType]] -> SDoc -dupPredWarn dups = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups) +dupPredWarn dups = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas pprPredTy (map head dups) arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc arityErr kind name n m @@ -1503,7 +1482,7 @@ checkInstTermination tys theta predUndecErr :: PredType -> SDoc -> SDoc predUndecErr pred msg = sep [msg, - nest 2 (ptext (sLit "in the constraint:") <+> pprPred pred)] + nest 2 (ptext (sLit "in the constraint:") <+> pprPredTy pred)] nomoreMsg, smallerMsg, undecidableMsg :: SDoc nomoreMsg = ptext (sLit "Variable occurs more often in a constraint than in the instance head")