dcRepTyCon :: TyCon, -- Result tycon, T
dcRepType :: Type, -- Type of the constructor
- -- forall a x y. (a:=:(x,y), Ord x) => x -> y -> MkT a
+ -- forall a x y. (a:=:(x,y), x~y, Ord x) =>
+ -- x -> y -> T a
-- (this is *not* of the constructor wrapper Id:
-- see Note [Data con representation] below)
-- Notice that the existential type parameters come *second*.
-- Reason: in a case expression we may find:
- -- case (e :: T t) of { MkT b (d:Ord b) (x:t) (xs:[b]) -> ... }
+ -- case (e :: T t) of
+ -- MkT x y co1 co2 (d:Ord x) (v:r) (w:F s) -> ...
-- It's convenient to apply the rep-type of MkT to 't', to get
- -- forall b. Ord b => ...
+ -- forall x y. (t:=:(x,y), x~y, Ord x) => x -> y -> T t
-- and use that to check the pattern. Mind you, this is really only
- -- use in CoreLint.
+ -- used in CoreLint.
- -- Finally, the curried worker function that corresponds to the constructor
+ -- The curried worker function that corresponds to the constructor:
-- It doesn't have an unfolding; the code generator saturates these Ids
-- and allocates a real constructor when it finds one.
--
{ -- Check the pattern
-- Scrutinee type must be a tycon applicn; checked by caller
-- This code is remarkably compact considering what it does!
- -- NB: args must be in scope here so that the lintCoreArgs line works.
- -- NB: relies on existential type args coming *after* ordinary type args
-
+ -- NB: args must be in scope here so that the lintCoreArgs
+ -- line works.
+ -- NB: relies on existential type args coming *after*
+ -- ordinary type args
; con_result_ty <- lintCoreArgs con_payload_ty (varsToCoreExprs args)
; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
}
scrungle (Let binds body) = Let binds (scrungle body)
scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
-\end{code}
+\end{code}
%************************************************************************
%* *
then do { -- The common case; no class bindings etc
-- (see Note [Arrows and patterns])
(arg_pats', inner_tvs, res) <- tcConArgs data_con arg_tys'
- arg_pats pstate thing_inside
+ arg_pats pstate thing_inside
; let res_pat = ConPatOut { pat_con = L con_span data_con,
- pat_tvs = [], pat_dicts = [], pat_binds = emptyLHsBinds,
- pat_args = arg_pats', pat_ty = pat_ty' }
+ pat_tvs = [], pat_dicts = [],
+ pat_binds = emptyLHsBinds,
+ pat_args = arg_pats',
+ pat_ty = pat_ty' }
; return (wrap_res_pat res_pat, inner_tvs, res) }
else do -- The general case, with existential, and local equality
-- constraints
{ let eq_preds = [mkEqPred (mkTyVarTy tv, ty) | (tv, ty) <- eq_spec]
- theta' = substTheta tenv (full_theta ++ eq_preds)
+ theta' = substTheta tenv (eq_preds ++ full_theta)
+ -- order is *important* as we generate the list of
+ -- dictionary binders from theta'
ctxt = pat_ctxt pstate
; checkTc (case ctxt of { ProcPat -> False; other -> True })
(existentialProcPat data_con)
-- 8. Substitute the wanted *equations* in the wanted *dictionaries*
; let irreds = dict_irreds ++ implic_irreds
- ; (norm_irreds, normalise_binds2) <- substEqInDictInsts eq_irreds irreds
+ ; (norm_irreds, normalise_binds2) <- substEqInDictInsts True {-wanted-}
+ eq_irreds irreds
-- 9. eliminate the artificial skolem constants introduced in 1.
; eliminate_skolems
-- Fals <=> they are given
-> TcM ([Inst],TcDictBinds)
normalise_dicts given_eqs dicts is_wanted
- = do { traceTc $ text "normalise???Dicts <-" <+> ppr dicts <+>
+ = do { traceTc $ let name | is_wanted = "normaliseWantedDicts <-"
+ | otherwise = "normaliseGivenDicts <-"
+ in
+ text name <+> ppr dicts <+>
text "with" <+> ppr given_eqs
; (dicts0, binds0) <- normaliseInsts is_wanted dicts
- ; (dicts1, binds1) <- substEqInDictInsts given_eqs dicts0
+ ; (dicts1, binds1) <- substEqInDictInsts is_wanted given_eqs dicts0
; let binds01 = binds0 `unionBags` binds1
; if isEmptyBag binds1
then return (dicts1, binds01)
- else do { (dicts2, binds2) <- normaliseGivenDicts given_eqs dicts1
+ else do { (dicts2, binds2) <-
+ normalise_dicts given_eqs dicts1 is_wanted
; return (dicts2, binds01 `unionBags` binds2) } }
\end{code}
where F is a type family.
\begin{code}
-substEqInDictInsts :: [Inst] -- given equalities (used as rewrite rules)
+substEqInDictInsts :: Bool -- whether the *dictionaries* are wanted/given
+ -> [Inst] -- given equalities (used as rewrite rules)
-> [Inst] -- dictinaries to be normalised
-> TcM ([Inst], TcDictBinds)
-substEqInDictInsts eqInsts dictInsts
+substEqInDictInsts isWanted eqInsts dictInsts
= do { traceTc (text "substEqInDictInst <-" <+> ppr dictInsts)
; dictInsts' <-
foldlM rewriteWithOneEquality (dictInsts, emptyBag) eqInsts
tci_right = target})
| isOpenSynTyConApp pattern || isTyVarTy pattern
= do { (dictInsts', moreDictBinds) <-
- genericNormaliseInsts True {- wanted -} applyThisEq dictInsts
+ genericNormaliseInsts isWanted applyThisEq dictInsts
; return (dictInsts', dictBinds `unionBags` moreDictBinds)
}
where
rhs = L (instLocSpan loc) cast_expr
binds = instToDictBind target_dict rhs
-- return the new inst
- ; traceTc $ text "genericNormaliseInst ->" <+> ppr dict'
+ ; traceTc $ let name | isWanted
+ = "genericNormaliseInst (wanted) ->"
+ | otherwise
+ = "genericNormaliseInst (given) ->"
+ in
+ text name <+> ppr dict' <+>
+ text "with" <+> ppr binds
; return (dict', binds)
}
}
-- TOMDO: What do we have to do about ImplicInst, Method, and LitInst??
normaliseOneInst _isWanted _fun inst
= do { inst' <- zonkInst inst
+ ; traceTc $ text "*** TcTyFuns.normaliseOneInst: Skipping" <+>
+ ppr inst
; return (inst', emptyBag)
}
\end{code}
projects / ghc-hetmet.git / commitdiff