import Maybes
import Outputable
import FastString
+import Monad
\end{code}
; return (LazyPat pat', [], res) }
+tc_pat _ p@(QuasiQuotePat _) _ _
+ = pprPanic "Should never see QuasiQuotePat in type checker" (ppr p)
+
tc_pat pstate (WildPat _) pat_ty thing_inside
= do { pat_ty' <- unBoxWildCardType pat_ty -- Make sure it's filled in with monotypes
; res <- thing_inside pstate
-- (view -> f) where view :: _ -> forall b. b
-- we will only be able to use view at one instantation in the
-- rest of the view
- ; (expr_coerc, pat_ty) <- tcInfer (\ pat_ty -> tcSubExp (expr'_expected pat_ty) expr'_inferred)
+ ; (expr_coerc, pat_ty) <- tcInfer $ \ pat_ty ->
+ tcSubExp ViewPatOrigin (expr'_expected pat_ty) expr'_inferred
+
-- pattern must have pat_ty
; (pat', tvs, res) <- tc_lpat pat pat_ty pstate thing_inside
-- this should get zonked later on, but we unBox it here
-- Lists, tuples, arrays
tc_pat pstate (ListPat pats _) pat_ty thing_inside
= do { (elt_ty, coi) <- boxySplitListTy pat_ty
+ ; let scoi = mkSymCoI coi
; (pats', pats_tvs, res) <- tcMultiple (\p -> tc_lpat p elt_ty)
pats pstate thing_inside
- ; return (mkCoPatCoI coi (ListPat pats' elt_ty) pat_ty, pats_tvs, res) }
+ ; return (mkCoPatCoI scoi (ListPat pats' elt_ty) pat_ty, pats_tvs, res)
+ }
tc_pat pstate (PArrPat pats _) pat_ty thing_inside
= do { (elt_ty, coi) <- boxySplitPArrTy pat_ty
+ ; let scoi = mkSymCoI coi
; (pats', pats_tvs, res) <- tcMultiple (\p -> tc_lpat p elt_ty)
pats pstate thing_inside
; ifM (null pats) (zapToMonotype pat_ty) -- c.f. ExplicitPArr in TcExpr
- ; return (mkCoPatCoI coi (PArrPat pats' elt_ty) pat_ty, pats_tvs, res) }
+ ; return (mkCoPatCoI scoi (PArrPat pats' elt_ty) pat_ty, pats_tvs, res)
+ }
tc_pat pstate (TuplePat pats boxity _) pat_ty thing_inside
= do { let tc = tupleTyCon boxity (length pats)
; (arg_tys, coi) <- boxySplitTyConApp tc pat_ty
+ ; let scoi = mkSymCoI coi
; (pats', pats_tvs, res) <- tcMultiple tc_lpat_pr (pats `zip` arg_tys)
pstate thing_inside
| otherwise = unmangled_result
; ASSERT( length arg_tys == length pats ) -- Syntactically enforced
- return (mkCoPatCoI coi possibly_mangled_result pat_ty, pats_tvs, res)
+ return (mkCoPatCoI scoi possibly_mangled_result pat_ty, pats_tvs, res)
}
------------------------
-> HsConPatDetails Name -> (PatState -> TcM a)
-> TcM (Pat TcId, [TcTyVar], a)
tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
- = do { let (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _) = dataConFullSig data_con
+ = do { let (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _)
+ = dataConFullSig data_con
skol_info = PatSkol data_con
origin = SigOrigin skol_info
full_theta = eq_theta ++ dict_theta
-- Instantiate the constructor type variables [a->ty]
- -- This may involve doing a family-instance coercion, and building a wrapper
+ -- This may involve doing a family-instance coercion, and building a
+ -- wrapper
; (ctxt_res_tys, coi) <- boxySplitTyConAppWithFamily tycon pat_ty
- ; let pat_ty' = mkTyConApp tycon ctxt_res_tys
- -- pat_ty /= pat_ty iff coi /= IdCo
- wrap_res_pat res_pat
- = mkCoPatCoI coi (unwrapFamInstScrutinee tycon ctxt_res_tys res_pat) pat_ty
+ ; let sym_coi = mkSymCoI coi -- boxy split coercion oriented wrongly
+ pat_ty' = mkTyConApp tycon ctxt_res_tys
+ -- pat_ty' /= pat_ty iff coi /= IdCo
+
+ wrap_res_pat res_pat = mkCoPatCoI sym_coi uwScrut pat_ty
+ where
+ uwScrut = unwrapFamInstScrutinee tycon ctxt_res_tys res_pat
+
+ ; traceTc $ case sym_coi of
+ IdCo -> text "sym_coi:IdCo"
+ ACo co -> text "sym_coi: ACoI" <+> ppr co
-- Add the stupid theta
; addDataConStupidTheta data_con ctxt_res_tys
- ; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs -- Get location from monad,
- -- not from ex_tvs
+ ; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs
+ -- Get location from monad, not from ex_tvs
+
; let tenv = zipTopTvSubst (univ_tvs ++ ex_tvs)
(ctxt_res_tys ++ mkTyVarTys ex_tvs')
arg_tys' = substTys tenv arg_tys
; if null ex_tvs && null eq_spec && null full_theta
- then do { -- The common case; no class bindings etc (see Note [Arrows and patterns])
+ 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_spec' = substEqSpec tenv eq_spec
- theta' = substTheta tenv full_theta
+ 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 (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)
- ; co_vars <- newCoVars eq_spec' -- Make coercion variables
- ; traceTc (text "tcConPat: refineAlt")
- ; pstate' <- refineAlt data_con pstate ex_tvs' co_vars pat_ty
- ; traceTc (text "tcConPat: refineAlt done!")
-
+
+ -- Need to test for rigidity if *any* constraints in theta as class
+ -- constraints may have superclass equality constraints. However,
+ -- we don't want to check for rigidity if we got here only because
+ -- ex_tvs was non-null.
+-- ; unless (null theta') $
+ -- FIXME: AT THE MOMENT WE CHEAT! We only perform the rigidity test
+ -- if we explicit or implicit (by a GADT def) have equality
+ -- constraints.
+ ; unless (all (not . isEqPred) theta') $
+ checkTc (isRigidTy pat_ty) (nonRigidMatch data_con)
+
; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $
- tcConArgs data_con arg_tys' arg_pats pstate' thing_inside
+ tcConArgs data_con arg_tys' arg_pats pstate thing_inside
; loc <- getInstLoc origin
; dicts <- newDictBndrs loc theta'
- ; dict_binds <- tcSimplifyCheckPat loc co_vars (pat_reft pstate')
+ ; dict_binds <- tcSimplifyCheckPat loc [] emptyRefinement
ex_tvs' dicts lie_req
; let res_pat = ConPatOut { pat_con = L con_span data_con,
- pat_tvs = ex_tvs' ++ co_vars,
+ pat_tvs = ex_tvs',
pat_dicts = map instToVar dicts,
pat_binds = dict_binds,
pat_args = arg_pats', pat_ty = pat_ty' }
= return pstate -- Common case: no equational constraints
refineAlt con pstate ex_tvs co_vars pat_ty
- = do { opt_gadt <- doptM Opt_GADTs -- No type-refinement unless GADTs are on
- ; if (not opt_gadt) then return pstate
- else do
-
- { checkTc (isRigidTy pat_ty) (nonRigidMatch con)
+ = -- See Note [Flags and equational constraints]
+ do { checkTc (isRigidTy pat_ty) (nonRigidMatch con)
-- We are matching against a GADT constructor with non-trivial
-- constraints, but pattern type is wobbly. For now we fail.
-- We can make sense of this, however:
vcat [ ppr con <+> ppr ex_tvs,
ppr [(v, tyVarKind v) | v <- co_vars],
ppr reft]
- } } }
+ } }
\end{code}
+Note [Flags and equational constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If there are equational constraints, we take account of them
+regardless of flag settings; -XGADTs etc applies only to the
+*definition* of a data type.
+
+An alternative would be also to reject a program that *used*
+constructors with equational constraints. But want we should avoid at
+all costs is simply to *ignore* the constraints, since that gives
+incomprehensible errors (Trac #2004).
+
%************************************************************************
%* *
nonRigidMatch con
= hang (ptext SLIT("GADT pattern match in non-rigid context for") <+> quotes (ppr con))
- 2 (ptext SLIT("Tell GHC HQ if you'd like this to unify the context"))
+ 2 (ptext SLIT("Solution: add a type signature"))
nonRigidResult res_ty
= hang (ptext SLIT("GADT pattern match with non-rigid result type") <+> quotes (ppr res_ty))
- 2 (ptext SLIT("Tell GHC HQ if you'd like this to unify the context"))
+ 2 (ptext SLIT("Solution: add a type signature"))
inaccessibleAlt msg
= hang (ptext SLIT("Inaccessible case alternative:")) 2 msg
projects / ghc-hetmet.git / blobdiff