Commit b6d08641 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Properly keep track of whether normalising given or wanted dicts

- The information of whether given or wanted class dictionaries where
  normalised by rewriting wasn't always correctly propagated in TcTyFuns,
  which lead to malformed dictionary bindings.
- Also fixes a bug in TcPat.tcConPat where GADT equalities where emitted in
  the wrong position in case bindings (which led to CoreLint failures).
parent a003ad80
......@@ -338,19 +338,21 @@ data DataCon
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.
--
......
......@@ -519,9 +519,10 @@ lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
{ -- 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)
}
......
......@@ -181,7 +181,7 @@ scrungleMatch var scrut body
scrungle (Let binds body) = Let binds (scrungle body)
scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
\end{code}
\end{code}
%************************************************************************
%* *
......
......@@ -637,17 +637,21 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
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)
......
......@@ -1820,7 +1820,8 @@ reduceContext env wanteds
-- 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
......
......@@ -388,14 +388,18 @@ normalise_dicts
-- 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}
......@@ -1080,10 +1084,11 @@ form
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
......@@ -1097,7 +1102,7 @@ substEqInDictInsts eqInsts dictInsts
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
......@@ -1176,7 +1181,13 @@ genericNormaliseInsts isWanted fun insts
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)
}
}
......@@ -1184,6 +1195,8 @@ genericNormaliseInsts isWanted fun insts
-- 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}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment