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, zapToType )
-import TcType ( TcType, TcTyVar, TcSigmaType, TyVarDetails(VanillaTv),
- mkTyConApp, mkClassPred, liftedTypeKind, tcGetTyVar_maybe,
- isHoleTyVar, openTypeKind )
+import TcMType ( newTyVarTy, zapToType )
+import TcType ( TcType, TcTyVar, TcSigmaType,
+ mkClassPred, liftedTypeKind )
import TcUnify ( tcSubOff, TcHoleType,
unifyTauTy, unifyListTy, unifyPArrTy, unifyTupleTy,
mkCoercion, idCoercion, isIdCoercion,
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
import Outputable
+import FastString
\end{code}
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)
tcPat tc_bndr (LitPatIn lit@(HsLitLit s _)) pat_ty
-- cf tcExpr on LitLits
= tcLookupClass cCallableClassName `thenNF_Tc` \ cCallableClass ->
- newDicts (LitLitOrigin (_UNPK_ s))
+ newDicts (LitLitOrigin (unpackFS s))
[mkClassPred cCallableClass [pat_ty]] `thenNF_Tc` \ dicts ->
returnTc (LitPat (HsLitLit s pat_ty) pat_ty, mkLIE dicts, emptyBag, emptyBag, emptyLIE)
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)
projects / ghc-hetmet.git / blobdiff