tcNormaliseFamInstPred = tcGenericNormaliseFamInstPred tcUnfoldSynFamInst
\end{code}
-Normalise a type relative to the rewrite rule implied by one EqInst or an
-already unpacked EqInst (ie, an equality rewrite rule).
+An elementary rewrite is a properly oriented equality with associated coercion
+that has one of the following two forms:
+
+(1) co :: F t1..tn ~ t
+(2) co :: a ~ t , where t /= F t1..tn
+
+The following functions takes an equality instance and turns it into an
+elementary rewrite if possible.
\begin{code}
--- Rewrite by EqInst
-tcEqInstNormaliseFamInst :: Inst -> TcType -> TcM (CoercionI, Type)
-tcEqInstNormaliseFamInst inst =
- ASSERT( isEqInst inst )
- tcEqRuleNormaliseFamInst (pat, rhs, co)
+data Rewrite = Rewrite TcType -- lhs of rewrite rule
+ TcType -- rhs of rewrite rule
+ TcType -- coercion witnessing the rewrite rule
+
+eqInstToRewrite :: Inst -> Maybe (Rewrite, Bool)
+ -- True iff rewrite swapped equality
+eqInstToRewrite inst
+ = ASSERT( isEqInst inst )
+ go (eqInstLeftTy inst) (eqInstRightTy inst) (eqInstType inst)
where
- pat = eqInstLeftTy inst
- rhs = eqInstRightTy inst
- co = eqInstType inst
+ -- look through synonyms
+ go ty1 ty2 co | Just ty1' <- tcView ty1 = go ty1' ty2 co
+ go ty1 ty2 co | Just ty2' <- tcView ty2 = go ty1 ty2' co
+
+ -- left-to-right rule with type family head
+ go ty1@(TyConApp con _) ty2 co
+ | isOpenSynTyCon con
+ = Just (Rewrite ty1 ty2 co, False) -- not swapped
+
+ -- left-to-right rule with type variable head
+ go ty1@(TyVarTy tv) ty2 co
+ | isSkolemTyVar tv
+ = Just (Rewrite ty1 ty2 co, False) -- not swapped
+
+ -- right-to-left rule with type family head, only after
+ -- having checked whether we can work left-to-right
+ go ty1 ty2@(TyConApp con _) co
+ | isOpenSynTyCon con
+ = Just (Rewrite ty2 ty1 (mkSymCoercion co), True) -- swapped
+
+ -- right-to-left rule with type variable head, only after
+ -- having checked whether we can work left-to-right
+ go ty1 ty2@(TyVarTy tv) co
+ | isSkolemTyVar tv
+ = Just (Rewrite ty2 ty1 (mkSymCoercion co), True) -- swapped
+
+ -- this equality is not a rewrite rule => ignore
+ go _ _ _ = Nothing
+\end{code}
+
+Normalise a type relative to an elementary rewrite implied by an EqInst or an
+explicitly given elementary rewrite.
+
+\begin{code}
+-- Rewrite by EqInst
+-- Precondition: the EqInst passes the occurs check
+tcEqInstNormaliseFamInst :: Inst -> TcType -> TcM (CoercionI, TcType)
+tcEqInstNormaliseFamInst inst ty
+ = case eqInstToRewrite inst of
+ Just (rewrite, _) -> tcEqRuleNormaliseFamInst rewrite ty
+ Nothing -> return (IdCo, ty)
-- Rewrite by equality rewrite rule
-tcEqRuleNormaliseFamInst :: (TcType, -- rewrite rule lhs
- TcType, -- rewrite rule rhs
- TcType) -- coercion witnessing the rewrite rule
- -> TcType -- type to rewrite
- -> TcM (CoercionI, Type)
-tcEqRuleNormaliseFamInst (pat, rhs, co) ty
+tcEqRuleNormaliseFamInst :: Rewrite -- elementary rewrite
+ -> TcType -- type to rewrite
+ -> TcM (CoercionI, -- witnessing coercion
+ TcType) -- rewritten type
+tcEqRuleNormaliseFamInst (Rewrite pat rhs co) ty
= tcGenericNormaliseFamInst matchEqRule ty
where
matchEqRule sty | pat `tcEqType` sty = return $ Just (rhs, co)
where
oneSkolemOccurs inst
= ASSERT( isEqInst inst )
- isRewriteRule (eqInstLeftTy inst) (eqInstRightTy inst)
+ case eqInstToRewrite inst of
+ Just (rewrite, swapped) -> breakRecursion rewrite swapped
+ Nothing -> return ([inst], return ())
where
+ -- inst is an elementary rewrite rule, check whether we need to break
+ -- it up
+ breakRecursion (Rewrite pat body _) swapped
- -- look through synonyms
- isRewriteRule ty1 ty2 | Just ty1' <- tcView ty1 = isRewriteRule ty1' ty2
- isRewriteRule ty1 ty2 | Just ty2' <- tcView ty2 = isRewriteRule ty1 ty2'
-
- -- left-to-right rule with type family head
- isRewriteRule ty1@(TyConApp con _) ty2
- | isOpenSynTyCon con
- = breakRecursion ty1 ty2 False -- not swapped
-
- -- left-to-right rule with type variable head
- isRewriteRule ty1@(TyVarTy _) ty2
- = breakRecursion ty1 ty2 False -- not swapped
-
- -- right-to-left rule with type family head
- isRewriteRule ty1 ty2@(TyConApp con _)
- | isOpenSynTyCon con
- = breakRecursion ty2 ty1 True -- swapped
-
- -- right-to-left rule with type variable head
- isRewriteRule ty1 ty2@(TyVarTy _)
- = breakRecursion ty2 ty1 True -- swapped
-
- -- this equality is not a rewrite rule => ignore
- isRewriteRule _ _ = return ([inst], return ())
-
-
- breakRecursion pat body swapped
+ -- skolemOccurs does not apply, leave as is
| null tysToLiftOut
= return ([inst], return ())
+
+ -- recursive occurence of pat in body under a type family application
| otherwise
- = do { skTvs <- mapM (newMetaTyVar TauTv . typeKind) tysToLiftOut
+ = do { traceTc $ text "oneSkolemOccurs[TLO]:" <+> ppr tysToLiftOut
+ ; skTvs <- mapM (newMetaTyVar TauTv . typeKind) tysToLiftOut
; let skTvs_tysTLO = zip skTvs tysToLiftOut
insertSkolems = return . replace skTvs_tysTLO
; (_, body') <- tcGenericNormaliseFamInst insertSkolems body
else mkEqInst (EqPred pat body') co
-- ensure to reconstruct the inst in the
-- original orientation
+ ; traceTc $ text "oneSkolemOccurs[inst']:" <+> ppr inst'
; (insts, undoSk) <- mapAndUnzipM (mkSkolemInst inst')
skTvs_tysTLO
; return (inst':insts, sequence_ undoSk)
= do { (co, tyLiftedOut) <- tcEqInstNormaliseFamInst inst' tyTLO
; inst <- mkEqInst (EqPred tyLiftedOut (mkTyVarTy skTv))
(mkGivenCo $ mkSymCoercion (fromACo co))
+ -- co /= IdCo due to construction of inst'
; return (inst, writeMetaTyVar skTv tyTLO)
}
\end{code}
--
substInst :: Inst -> [Inst] -> TcM ([Inst], Bool)
substInst inst insts
- = ASSERT( isEqInst inst )
- go (eqInstLeftTy inst) (eqInstRightTy inst) (eqInstType inst)
+ = case eqInstToRewrite inst of
+ Just (rewrite, _) -> substEquality rewrite insts
+ Nothing -> return (insts, False)
where
- -- look through synonyms
- go ty1 ty2 co | Just ty1' <- tcView ty1 = go ty1' ty2 co
- go ty1 ty2 co | Just ty2' <- tcView ty2 = go ty1 ty2' co
-
- -- rewrite type family applications
- go ty1@(TyConApp con _) ty2 co
- | isOpenSynTyCon con
- = substEquality (ty1, ty2, co) insts
-
- -- rewrite skolems
- go ty1@(TyVarTy tv) ty2 co
- | isSkolemTyVar tv
- = substEquality (ty1, ty2, co) insts
-
- -- rewrite type family applications from right-to-left, only after
- -- having checked whether we can work left-to-right
- go ty1 ty2@(TyConApp con _) co
- | isOpenSynTyCon con
- = substEquality (ty2, ty1, mkSymCoercion co) insts
-
- -- rewrite skolems from right-to-left, only after having checked
- -- whether we can work left-to-right
- go ty1 ty2@(TyVarTy tv) co
- | isSkolemTyVar tv
- = substEquality (ty2, ty1, mkSymCoercion co) insts
-
- go _ _ _ = return (insts, False)
-
- substEquality :: (TcType, -- rewrite rule lhs
- TcType, -- rewrite rule rhs
- TcType) -- coercion witnessing the rewrite rule
- -> [Inst] -- insts to rewrite
+ substEquality :: Rewrite -- elementary rewrite
+ -> [Inst] -- insts to rewrite
-> TcM ([Inst], Bool)
- substEquality eqRule@(pat, rhs, _) insts
+ substEquality eqRule@(Rewrite pat rhs _) insts
| pat `tcPartOfType` rhs -- occurs check!
= occurCheckErr pat rhs
| otherwise
-- updatable meta variable meets non-variable type
-- => occurs check, monotype check, and kinds match check, then update
uMeta swapped tv (DoneTv (MetaTv _ ref)) ty cotv
- = do { ty' <- checkTauTvUpdate tv ty -- occurs + monotype check
- ; checkUpdateMeta swapped tv ref ty' -- update meta var
- ; writeMetaTyVar cotv ty' -- update the co var
- ; return ([], True)
+ = do { mb_ty' <- checkTauTvUpdate tv ty -- occurs + monotype check
+ ; case mb_ty' of
+ Nothing -> return ([inst], False) -- tv occurs in faminst
+ Just ty' ->
+ do { checkUpdateMeta swapped tv ref ty' -- update meta var
+ ; writeMetaTyVar cotv ty' -- update co var
+ ; return ([], True)
+ }
}
uMeta _ _ _ _ _ = panic "uMeta"
projects / ghc-hetmet.git / blobdiff