import FieldLabel ( fieldLabelName )
import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupId )
import TcMType ( tcInstTyVars, newTyVarTy, getTcTyVar, putTcTyVar )
-import TcType ( TcType, TcTyVar, TcSigmaType,
+import TcType ( TcType, TcTyVar, TcSigmaType, TyVarDetails(VanillaTv),
mkTyConApp, mkClassPred, liftedTypeKind, tcGetTyVar_maybe,
isHoleTyVar, openTypeKind )
-import TcUnify ( tcSub, unifyTauTy, unifyListTy, unifyTupleTy,
- mkCoercion, idCoercion, isIdCoercion, (<$>), PatCoFn )
+import TcUnify ( tcSub, unifyTauTy, unifyListTy, unifyPArrTy,
+ unifyTupleTy, mkCoercion, idCoercion, isIdCoercion,
+ (<$>), PatCoFn )
import TcMonoType ( tcHsSigType, UserTypeCtxt(..) )
import TysWiredIn ( stringTy )
tcPat tc_bndr pat_in@(AsPatIn name pat) pat_ty
= tc_bndr name pat_ty `thenTc` \ (co_fn, lie_req1, bndr_id) ->
tcPat tc_bndr pat pat_ty `thenTc` \ (pat', lie_req2, tvs, ids, lie_avail) ->
- returnTc (co_fn <$> (AsPat bndr_id pat'), lie_req1 `plusLIE` lie_req1,
+ returnTc (co_fn <$> (AsPat bndr_id pat'), lie_req1 `plusLIE` lie_req2,
tvs, (name, bndr_id) `consBag` ids, lie_avail)
tcPat tc_bndr WildPatIn pat_ty
tcPat tc_bndr (ParPatIn parend_pat) pat_ty
= tcPat tc_bndr parend_pat pat_ty
-tcPat tc_bndr (SigPatIn pat sig) pat_ty
- = tcHsSigType PatSigCtxt sig `thenTc` \ sig_ty ->
+tcPat tc_bndr pat_in@(SigPatIn pat sig) pat_ty
+ = tcAddErrCtxt (patCtxt pat_in) $
+ tcHsSigType PatSigCtxt sig `thenTc` \ sig_ty ->
tcSubPat sig_ty pat_ty `thenTc` \ (co_fn, lie_sig) ->
tcPat tc_bndr pat sig_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
returnTc (co_fn <$> pat', lie_req `plusLIE` lie_sig, tvs, ids, lie_avail)
%************************************************************************
%* *
-\subsection{Explicit lists and tuples}
+\subsection{Explicit lists, parallel arrays, and tuples}
%* *
%************************************************************************
tcPats tc_bndr pats (repeat elem_ty) `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
returnTc (ListPat elem_ty pats', lie_req, tvs, ids, lie_avail)
+tcPat tc_bndr pat_in@(PArrPatIn pats) pat_ty
+ = tcAddErrCtxt (patCtxt pat_in) $
+ unifyPArrTy pat_ty `thenTc` \ elem_ty ->
+ tcPats tc_bndr pats (repeat elem_ty) `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
+ returnTc (PArrPat elem_ty pats', lie_req, tvs, ids, lie_avail)
+
tcPat tc_bndr pat_in@(TuplePatIn pats boxity) pat_ty
= tcAddErrCtxt (patCtxt pat_in) $
= tcAddErrCtxt (patCtxt pat) $
-- Check the constructor itself
- tcConstructor pat name pat_ty `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys) ->
+ tcConstructor pat name `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys, con_res_ty) ->
+
+ -- Check overall type matches (c.f. tcConPat)
+ tcSubPat con_res_ty pat_ty `thenTc` \ (co_fn, lie_req1) ->
let
-- Don't use zipEqual! If the constructor isn't really a record, then
-- dataConFieldLabels will be empty (and each field in the pattern
in
-- Check the fields
- tc_fields field_tys rpats `thenTc` \ (rpats', lie_req, tvs, ids, lie_avail2) ->
+ tc_fields field_tys rpats `thenTc` \ (rpats', lie_req2, tvs, ids, lie_avail2) ->
returnTc (RecPat data_con pat_ty ex_tvs dicts rpats',
- lie_req,
+ lie_req1 `plusLIE` lie_req2,
listToBag ex_tvs `unionBags` tvs,
ids,
lie_avail1 `plusLIE` lie_avail2)
------------------------------------------------------
\begin{code}
-tcConstructor pat con_name pat_ty
+tcConstructor pat con_name
= -- Check that it's a constructor
tcLookupDataCon con_name `thenNF_Tc` \ data_con ->
-- behave differently when called, not when used for
-- matching.
in
- tcInstTyVars (ex_tvs ++ tvs) `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
+ tcInstTyVars VanillaTv (ex_tvs ++ tvs) `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
let
ex_theta' = substTheta tenv ex_theta
arg_tys' = map (substTy tenv) arg_tys
in
newDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ dicts ->
- -- Check overall type matches
- unifyTauTy pat_ty result_ty `thenTc_`
-
- returnTc (data_con, ex_tvs', map instToId dicts, mkLIE dicts, arg_tys')
+ returnTc (data_con, ex_tvs', map instToId dicts, mkLIE dicts, arg_tys', result_ty)
\end{code}
------------------------------------------------------
= tcAddErrCtxt (patCtxt pat) $
-- Check the constructor itself
- tcConstructor pat con_name pat_ty `thenTc` \ (data_con, ex_tvs', dicts, lie_avail1, arg_tys') ->
+ tcConstructor pat con_name `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys, con_res_ty) ->
+
+ -- Check overall type matches.
+ -- The pat_ty might be a for-all type, in which
+ -- case we must instantiate to match
+ tcSubPat con_res_ty pat_ty `thenTc` \ (co_fn, lie_req1) ->
-- Check correct arity
let
(arityErr "Constructor" data_con con_arity no_of_args) `thenTc_`
-- Check arguments
- tcPats tc_bndr arg_pats arg_tys' `thenTc` \ (arg_pats', lie_req, tvs, ids, lie_avail2) ->
+ tcPats tc_bndr arg_pats arg_tys `thenTc` \ (arg_pats', lie_req2, tvs, ids, lie_avail2) ->
- returnTc (ConPat data_con pat_ty ex_tvs' dicts arg_pats',
- lie_req,
- listToBag ex_tvs' `unionBags` tvs,
+ returnTc (co_fn <$> ConPat data_con pat_ty ex_tvs dicts arg_pats',
+ lie_req1 `plusLIE` lie_req2,
+ listToBag ex_tvs `unionBags` tvs,
ids,
lie_avail1 `plusLIE` lie_avail2)
\end{code}
tcSubPat :: TcSigmaType -> TcSigmaType -> TcM (PatCoFn, LIE)
tcSubPat sig_ty exp_ty
- = tcSub exp_ty sig_ty `thenTc` \ (co_fn, lie) ->
+ = tcSub sig_ty exp_ty `thenTc` \ (co_fn, lie) ->
-- co_fn is a coercion on *expressions*, and we
-- need to make a coercion on *patterns*
if isIdCoercion co_fn then
else
tcGetUnique `thenNF_Tc` \ uniq ->
let
- arg_id = mkSysLocal SLIT("sub") uniq exp_ty
+ arg_id = mkSysLocal FSLIT("sub") uniq exp_ty
the_fn = DictLam [arg_id] (co_fn <$> HsVar arg_id)
pat_co_fn p = SigPat p exp_ty the_fn
in
%************************************************************************
\begin{code}
-patCtxt pat = hang (ptext SLIT("In the pattern:"))
+patCtxt pat = hang (ptext SLIT("When checking the pattern:"))
4 (ppr pat)
badFieldCon :: Name -> Name -> SDoc
projects / ghc-hetmet.git / blobdiff