X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcPat.lhs;h=291d85498531d9decae8c4faa56a115842c2d817;hb=a63bd8f558fedec86451f36d86833c9afb934ae8;hp=cb08317063b62cc8ab24ebf610dc45cb7c152cd6;hpb=aaed11810cfb0f8890376142740e731cdf84c001;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index cb08317..291d854 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -17,16 +17,16 @@ import TcHsSyn ( TcPat, TcId, simpleHsLitTy ) 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, 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, @@ -35,14 +35,12 @@ 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} @@ -139,7 +137,10 @@ tcPat tc_bndr pat_in@(AsPatIn name pat) pat_ty 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 @@ -224,10 +225,10 @@ tcPat tc_bndr pat@(RecPatIn name rpats) 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 @@ -237,10 +238,10 @@ tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty 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) @@ -292,7 +293,7 @@ tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty 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) @@ -306,19 +307,31 @@ tcPat tc_bndr (LitPatIn simple_lit) pat_ty = 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} %************************************************************************ @@ -330,17 +343,16 @@ tcPat tc_bndr pat@(NPatIn over_lit) pat_ty \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 @@ -381,24 +393,9 @@ tcConstructor pat con_name 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} ------------------------------------------------------ @@ -407,12 +404,12 @@ tcConPat tc_bndr pat con_name arg_pats pat_ty = 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 @@ -423,10 +420,10 @@ tcConPat tc_bndr pat con_name arg_pats pat_ty (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)