import TcMonad
import Inst ( InstOrigin(..),
emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId, isEmptyLIE,
- newMethod, newOverloadedLit, newDicts
+ newMethod, newMethodFromName, newOverloadedLit, newDicts,
+ tcInstDataCon, tcSyntaxName
)
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,
- 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 PrelNames ( eqStringName, eqName, geName, cCallableClassName )
+import DataCon ( dataConFieldLabels, dataConSourceArity )
+import PrelNames ( eqStringName, eqName, geName, negateName, minusName, cCallableClassName )
import BasicTypes ( isBoxed )
import Bag
import Outputable
+import FastString
\end{code}
-- 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)
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)
= unifyTauTy pat_ty (simpleHsLitTy simple_lit) `thenTc_`
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 ->
-
- returnTc (NPat lit' pat_ty (HsApp (HsVar (instToId eq)) over_lit_expr),
- lie1 `plusLIE` unitLIE eq,
+tcPat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty
+ = newOverloadedLit origin over_lit pat_ty `thenNF_Tc` \ (pos_lit_expr, lie1) ->
+ newMethodFromName origin pat_ty eqName `thenNF_Tc` \ eq ->
+ (case mb_neg of
+ Nothing -> returnNF_Tc (pos_lit_expr, emptyLIE) -- Positive literal
+ Just neg -> -- Negative literal
+ -- The 'negate' is re-mappable syntax
+ tcSyntaxName origin pat_ty negateName neg `thenTc` \ (neg_expr, neg_lie, _) ->
+ returnNF_Tc (HsApp neg_expr pos_lit_expr, neg_lie)
+ ) `thenNF_Tc` \ (lit_expr, lie2) ->
+
+ returnTc (NPat lit' pat_ty (HsApp (HsVar (instToId eq)) lit_expr),
+ lie1 `plusLIE` lie2 `plusLIE` unitLIE eq,
emptyBag, emptyBag, emptyLIE)
where
origin = PatOrigin pat
- lit' = case over_lit of
- HsIntegral i _ -> HsInteger i
- HsFractional f _ -> HsRat f pat_ty
+
+ -- The literal in an NPatIn is always positive...
+ -- But in NPat, the literal is used to find identical patterns
+ -- so we must negate the literal when necessary!
+ lit' = case (over_lit, mb_neg) of
+ (HsIntegral i _, Nothing) -> HsInteger i
+ (HsIntegral i _, Just _) -> HsInteger (-i)
+ (HsFractional f _, Nothing) -> HsRat f pat_ty
+ (HsFractional f _, Just _) -> HsRat (-f) pat_ty
\end{code}
%************************************************************************
\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) ->
- -- 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 ->
+ newMethodFromName origin pat_ty geName `thenNF_Tc` \ ge ->
+
+ -- The '-' part is re-mappable syntax
+ tcSyntaxName origin pat_ty minusName minus_name `thenTc` \ (minus_expr, minus_lie, _) ->
returnTc (NPlusKPat bndr_id i pat_ty
(SectionR (HsVar (instToId ge)) over_lit_expr)
- (SectionR (HsVar (instToId minus)) over_lit_expr),
- lie1 `plusLIE` lie2 `plusLIE` mkLIE [ge,minus],
+ (SectionR minus_expr over_lit_expr),
+ lie1 `plusLIE` lie2 `plusLIE` minus_lie `plusLIE` unitLIE ge,
emptyBag, unitBag (name, bndr_id), emptyLIE)
where
origin = PatOrigin pat
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 (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
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
projects / ghc-hetmet.git / blobdiff