normaliseGivenEqs, normaliseGivenDicts,
normaliseWantedEqs, normaliseWantedDicts,
- solveWantedEqs,
-- errors
misMatchMsg, failWithMisMatch
import Outputable
import SrcLoc ( Located(..) )
import Maybes
+import FastString
-- standard
import Data.List
= do { (coi,nty1) <- tcGenericNormaliseFamInst fun ty1
; return (mkForAllTyCoI tyvar coi, mkForAllTy tyvar nty1)
}
-tcGenericNormaliseFamInst fun (NoteTy note ty1)
- = do { (coi,nty1) <- tcGenericNormaliseFamInst fun ty1
- ; return (coi, NoteTy note nty1)
- }
tcGenericNormaliseFamInst fun ty@(TyVarTy tv)
| isTcTyVar tv
= do { traceTc (text "tcGenericNormaliseFamInst" <+> ppr ty)
\end{code}
\begin{code}
-normaliseWantedEqs :: [Inst] -> TcM [Inst]
-normaliseWantedEqs insts
- = do { traceTc (text "normaliseWantedEqs <-" <+> ppr insts)
- ; result <- liftM fst $ rewriteToFixedPoint Nothing
- [ ("(ZONK)", dontRerun $ zonkInsts)
- , ("(TRIVIAL)", dontRerun $ trivialRule)
- , ("(DECOMP)", decompRule)
- , ("(TOP)", topRule)
- , ("(UNIFY)", unifyMetaRule) -- incl. occurs check
- , ("(SUBST)", substRule) -- incl. occurs check
- ] insts
- ; traceTc (text "normaliseWantedEqs ->" <+> ppr result)
- ; return result
- }
-\end{code}
-
-
-%************************************************************************
-%* *
-\section{Solving of wanted constraints with respect to a given set}
-%* *
-%************************************************************************
-
-The set of given equalities must have been normalised already.
-
-\begin{code}
-solveWantedEqs :: [Inst] -- givens
- -> [Inst] -- wanteds
- -> TcM [Inst] -- irreducible wanteds
-solveWantedEqs givens wanteds
- = do { traceTc $ text "solveWantedEqs <-" <+> ppr wanteds <+> text "with" <+>
- ppr givens
+normaliseWantedEqs :: [Inst] -- givens
+ -> [Inst] -- wanteds
+ -> TcM [Inst] -- irreducible wanteds
+normaliseWantedEqs givens wanteds
+ = do { traceTc $ text "normaliseWantedEqs <-" <+> ppr wanteds
+ <+> text "with" <+> ppr givens
; result <- liftM fst $ rewriteToFixedPoint Nothing
[ ("(ZONK)", dontRerun $ zonkInsts)
, ("(TRIVIAL)", dontRerun $ trivialRule)
, ("(TOP)", topRule)
, ("(GIVEN)", substGivens givens) -- incl. occurs check
, ("(UNIFY)", unifyMetaRule) -- incl. occurs check
+ , ("(SUBST)", substRule) -- incl. occurs check
] wanteds
- ; traceTc (text "solveWantedEqs ->" <+> ppr result)
+ ; traceTc (text "normaliseWantedEqs ->" <+> ppr result)
; return result
}
where
-- else
-- dict' = dict `cast` co
expr = HsVar $ instToId source_dict
- cast_expr = HsWrap (WpCo st_co) expr
+ cast_expr = HsWrap (WpCast st_co) expr
rhs = L (instLocSpan loc) cast_expr
binds = instToDictBind target_dict rhs
-- return the new inst
misMatchMsg env0 (ty_act, ty_exp)
= let (env1, pp_exp, extra_exp) = ppr_ty env0 ty_exp
(env2, pp_act, extra_act) = ppr_ty env1 ty_act
- msg = sep [sep [ptext SLIT("Couldn't match expected type") <+> pp_exp,
+ msg = sep [sep [ptext (sLit "Couldn't match expected type") <+> pp_exp,
nest 7 $
- ptext SLIT("against inferred type") <+> pp_act],
+ ptext (sLit "against inferred type") <+> pp_act],
nest 2 (extra_exp $$ extra_act)]
in
(env2, msg)