import TcMonad
import Inst ( InstOrigin(..),
emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId, isEmptyLIE,
- newMethod, newOverloadedLit, newDicts
+ newMethod, newMethodFromName, newOverloadedLit, newDicts, tcInstDataCon
)
import Id ( mkLocalId, mkSysLocal )
import Name ( Name )
import FieldLabel ( fieldLabelName )
import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupId )
-import TcMType ( tcInstTyVars, newTyVarTy, getTcTyVar, putTcTyVar )
-import TcType ( TcType, TcTyVar, TcSigmaType, TyVarDetails(VanillaTv),
- mkTyConApp, mkClassPred, liftedTypeKind, tcGetTyVar_maybe,
- isHoleTyVar, openTypeKind )
-import TcUnify ( tcSub, unifyTauTy, unifyListTy, unifyPArrTy,
- unifyTupleTy, mkCoercion, idCoercion, isIdCoercion,
+import TcMType ( newTyVarTy, zapToType )
+import TcType ( TcType, TcTyVar, TcSigmaType,
+ mkClassPred, liftedTypeKind )
+import TcUnify ( tcSubOff, TcHoleType,
+ unifyTauTy, unifyListTy, unifyPArrTy, unifyTupleTy,
+ mkCoercion, idCoercion, isIdCoercion,
(<$>), PatCoFn )
import TcMonoType ( tcHsSigType, UserTypeCtxt(..) )
import TysWiredIn ( stringTy )
import CmdLineOpts ( opt_IrrefutableTuples )
-import DataCon ( dataConSig, dataConFieldLabels,
- dataConSourceArity
- )
-import Subst ( substTy, substTheta )
+import DataCon ( dataConFieldLabels, dataConSourceArity )
import PrelNames ( eqStringName, eqName, geName, cCallableClassName )
import BasicTypes ( isBoxed )
import Bag
-- so there's no polymorphic guy to worry about
tcMonoPatBndr binder_name pat_ty
- | Just tv <- tcGetTyVar_maybe pat_ty,
- isHoleTyVar tv
+ = zapToType pat_ty `thenNF_Tc` \ pat_ty' ->
-- If there are *no constraints* on the pattern type, we
-- revert to good old H-M typechecking, making
-- the type of the binder into an *ordinary*
-- What we are trying to avoid here is giving a binder
-- a type that is a 'hole'. The only place holes should
-- appear is as an argument to tcPat and tcExpr/tcMonoExpr.
- = getTcTyVar tv `thenNF_Tc` \ maybe_ty ->
- case maybe_ty of
- Just ty -> tcMonoPatBndr binder_name ty
- Nothing -> newTyVarTy openTypeKind `thenNF_Tc` \ ty ->
- putTcTyVar tv ty `thenNF_Tc_`
- returnTc (idCoercion, emptyLIE, mkLocalId binder_name ty)
- | otherwise
- = returnTc (idCoercion, emptyLIE, mkLocalId binder_name pat_ty)
+
+ returnTc (idCoercion, emptyLIE, mkLocalId binder_name pat_ty')
\end{code}
tcPat :: BinderChecker
-> RenamedPat
- -> TcSigmaType -- Expected type derived from the context
+ -> TcHoleType -- Expected type derived from the context
-- In the case of a function with a rank-2 signature,
-- this type might be a forall type.
tvs, (name, bndr_id) `consBag` ids, lie_avail)
tcPat tc_bndr WildPatIn pat_ty
- = returnTc (WildPat pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE)
+ = zapToType pat_ty `thenNF_Tc` \ pat_ty' ->
+ -- We might have an incoming 'hole' type variable; no annotation
+ -- so zap it to a type. Rather like tcMonoPatBndr.
+ returnTc (WildPat pat_ty', emptyLIE, emptyBag, emptyBag, emptyLIE)
tcPat tc_bndr (ParPatIn parend_pat) pat_ty
= tcPat tc_bndr parend_pat pat_ty
= tcAddErrCtxt (patCtxt pat) $
-- Check the constructor itself
- tcConstructor pat name `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys, con_res_ty) ->
+ tcConstructor pat name `thenTc` \ (data_con, lie_req1, ex_tvs, ex_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) ->
+ tcSubPat con_res_ty pat_ty `thenTc` \ (co_fn, lie_req2) ->
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_req2, tvs, ids, lie_avail2) ->
+ tc_fields field_tys rpats `thenTc` \ (rpats', lie_req3, tvs, ids, lie_avail2) ->
- returnTc (RecPat data_con pat_ty ex_tvs dicts rpats',
- lie_req1 `plusLIE` lie_req2,
+ returnTc (RecPat data_con pat_ty ex_tvs ex_dicts rpats',
+ lie_req1 `plusLIE` lie_req2 `plusLIE` lie_req3,
listToBag ex_tvs `unionBags` tvs,
ids,
lie_avail1 `plusLIE` lie_avail2)
returnTc (LitPat simple_lit pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE)
tcPat tc_bndr pat@(NPatIn over_lit) pat_ty
- = newOverloadedLit (PatOrigin pat) over_lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
- tcLookupGlobalId eqName `thenNF_Tc` \ eq_sel_id ->
- newMethod origin eq_sel_id [pat_ty] `thenNF_Tc` \ eq ->
+ = newOverloadedLit origin over_lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
+ newMethodFromName origin pat_ty eqName `thenNF_Tc` \ eq ->
returnTc (NPat lit' pat_ty (HsApp (HsVar (instToId eq)) over_lit_expr),
lie1 `plusLIE` unitLIE eq,
\begin{code}
tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus_name) pat_ty
= tc_bndr name pat_ty `thenTc` \ (co_fn, lie1, bndr_id) ->
+ newOverloadedLit origin lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie2) ->
+ newMethodFromName origin pat_ty geName `thenNF_Tc` \ ge ->
+
-- The '-' part is re-mappable syntax
tcLookupId minus_name `thenNF_Tc` \ minus_sel_id ->
- tcLookupGlobalId geName `thenNF_Tc` \ ge_sel_id ->
- newOverloadedLit origin lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie2) ->
- newMethod origin ge_sel_id [pat_ty] `thenNF_Tc` \ ge ->
newMethod origin minus_sel_id [pat_ty] `thenNF_Tc` \ minus ->
returnTc (NPlusKPat bndr_id i pat_ty
tcLookupDataCon con_name `thenNF_Tc` \ data_con ->
-- Instantiate it
- let
- (tvs, _, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
- -- Ignore the theta; overloaded constructors only
- -- behave differently when called, not when used for
- -- matching.
- in
- 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
-
- n_ex_tvs = length ex_tvs
- ex_tvs' = take n_ex_tvs all_tvs'
- result_ty = mkTyConApp tycon (drop n_ex_tvs ty_args')
- in
- newDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ dicts ->
+ tcInstDataCon (PatOrigin pat) data_con `thenNF_Tc` \ (_, ex_dicts, arg_tys, result_ty, lie_req, ex_lie, ex_tvs) ->
- returnTc (data_con, ex_tvs', map instToId dicts, mkLIE dicts, arg_tys', result_ty)
+ returnTc (data_con, lie_req, ex_tvs, ex_dicts, ex_lie, arg_tys, result_ty)
\end{code}
------------------------------------------------------
= tcAddErrCtxt (patCtxt pat) $
-- Check the constructor itself
- tcConstructor pat con_name `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys, con_res_ty) ->
+ tcConstructor pat con_name `thenTc` \ (data_con, lie_req1, ex_tvs, ex_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) ->
+ tcSubPat con_res_ty pat_ty `thenTc` \ (co_fn, lie_req2) ->
-- 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_req2, tvs, ids, lie_avail2) ->
+ tcPats tc_bndr arg_pats arg_tys `thenTc` \ (arg_pats', lie_req3, tvs, ids, lie_avail2) ->
- returnTc (co_fn <$> ConPat data_con pat_ty ex_tvs dicts arg_pats',
- lie_req1 `plusLIE` lie_req2,
+ returnTc (co_fn <$> ConPat data_con pat_ty ex_tvs ex_dicts arg_pats',
+ lie_req1 `plusLIE` lie_req2 `plusLIE` lie_req3,
listToBag ex_tvs `unionBags` tvs,
ids,
lie_avail1 `plusLIE` lie_avail2)
(forall a. a->a in the example)
\begin{code}
-tcSubPat :: TcSigmaType -> TcSigmaType -> TcM (PatCoFn, LIE)
+tcSubPat :: TcSigmaType -> TcHoleType -> TcM (PatCoFn, LIE)
tcSubPat sig_ty exp_ty
- = tcSub sig_ty exp_ty `thenTc` \ (co_fn, lie) ->
+ = tcSubOff 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
projects / ghc-hetmet.git / blobdiff