X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcPat.lhs;h=e5bfc93ea7eeb93ac8159ac6d63434ea33a1319e;hb=f53c4074ff7554ceedaa6b7a5edb2bca7a2d3886;hp=3a27bdbe9680bec22b523b8fe1498ba147630f75;hpb=1c3601593186639f1086bc402582ff56fd3fe9f8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 3a27bdb..e5bfc93 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -4,7 +4,7 @@ \section[TcPat]{Typechecking patterns} \begin{code} -module TcPat ( tcPat, tcPatBndr_NoSigs, simpleHsLitTy, badFieldCon, polyPatSig ) where +module TcPat ( tcPat, tcMonoPatBndr, simpleHsLitTy, badFieldCon, polyPatSig ) where #include "HsVersions.h" @@ -14,12 +14,13 @@ import TcHsSyn ( TcPat, TcId ) import TcMonad import Inst ( InstOrigin(..), - emptyLIE, plusLIE, LIE, + emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId, newMethod, newOverloadedLit, newDicts, newClassDicts ) -import Name ( Name, getOccName, getSrcLoc ) +import Id ( mkVanillaId ) +import Name ( Name ) import FieldLabel ( fieldLabelName ) -import TcEnv ( tcLookupClass, tcLookupGlobalId, newLocalId, badCon ) +import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupSyntaxId ) import TcType ( TcType, TcTyVar, tcInstTyVars, newTyVarTy ) import TcMonoType ( tcHsSigType ) import TcUnify ( unifyTauTy, unifyListTy, unifyTupleTy ) @@ -28,16 +29,13 @@ import CmdLineOpts ( opt_IrrefutableTuples ) import DataCon ( dataConSig, dataConFieldLabels, dataConSourceArity ) -import Id ( isDataConWrapId_maybe ) -import Type ( isTauTy, mkTyConApp, mkClassPred, boxedTypeKind ) +import Type ( isTauTy, mkTyConApp, mkClassPred, liftedTypeKind ) import Subst ( substTy, substClasses ) import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, doublePrimTy, addrPrimTy ) import TysWiredIn ( charTy, stringTy, intTy, integerTy ) -import PrelNames ( eqClassOpKey, geClassOpKey, - cCallableClassKey, eqStringIdKey, - ) +import PrelNames ( minusName, eqStringName, eqName, geName, cCallableClassName ) import BasicTypes ( isBoxed ) import Bag import Outputable @@ -51,14 +49,10 @@ import Outputable %************************************************************************ \begin{code} --- This is the right function to pass to tcPat when there are no signatures -tcPatBndr_NoSigs binder_name pat_ty - = -- Need to make a new, monomorphic, Id - -- The binder_name is already being used for the polymorphic Id - newLocalId (getOccName binder_name) pat_ty loc `thenNF_Tc` \ bndr_id -> - returnTc bndr_id - where - loc = getSrcLoc binder_name +-- This is the right function to pass to tcPat when +-- we're looking at a lambda-bound pattern, +-- so there's no polymorphic guy to worry about +tcMonoPatBndr binder_name pat_ty = returnTc (mkVanillaId binder_name pat_ty) \end{code} @@ -237,7 +231,7 @@ tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty -- If foo isn't one of R's fields, we don't want to crash when -- typechecking the "a+b". [] -> addErrTc (badFieldCon name field_label) `thenNF_Tc_` - newTyVarTy boxedTypeKind `thenNF_Tc_` + newTyVarTy liftedTypeKind `thenNF_Tc_` returnTc (error "Bogus selector Id", pat_ty) -- The normal case, when the field comes from the right constructor @@ -267,12 +261,12 @@ tcPat tc_bndr (LitPatIn lit@(HsLitLit s _)) pat_ty -- cf tcExpr on LitLits = tcLookupClass cCallableClassName `thenNF_Tc` \ cCallableClass -> newDicts (LitLitOrigin (_UNPK_ s)) - [mkClassPred cCallableClass [pat_ty]] `thenNF_Tc` \ (dicts, _) -> - returnTc (LitPat (HsLitLit s pat_ty) pat_ty, dicts, emptyBag, emptyBag, emptyLIE) + [mkClassPred cCallableClass [pat_ty]] `thenNF_Tc` \ dicts -> + returnTc (LitPat (HsLitLit s pat_ty) pat_ty, mkLIE dicts, emptyBag, emptyBag, emptyLIE) tcPat tc_bndr pat@(LitPatIn lit@(HsString _)) pat_ty = unifyTauTy pat_ty stringTy `thenTc_` - tcLookupGlobalId eqStringIdName `thenNF_Tc` \ eq_id -> + tcLookupGlobalId eqStringName `thenNF_Tc` \ eq_id -> returnTc (NPat lit stringTy (HsVar eq_id `HsApp` HsLit lit), emptyLIE, emptyBag, emptyBag, emptyLIE) @@ -282,17 +276,17 @@ tcPat tc_bndr (LitPatIn simple_lit) pat_ty tcPat tc_bndr pat@(NPatIn over_lit) pat_ty = newOverloadedLit (PatOrigin pat) over_lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) -> - tcLookupGlobalId eqClassOpName `thenNF_Tc` \ eq_sel_id -> - newMethod origin eq_sel_id [pat_ty] `thenNF_Tc` \ (lie2, eq_id) -> + tcLookupGlobalId eqName `thenNF_Tc` \ eq_sel_id -> + newMethod origin eq_sel_id [pat_ty] `thenNF_Tc` \ eq -> - returnTc (NPat lit' pat_ty (HsApp (HsVar eq_id) over_lit_expr), - lie1 `plusLIE` lie2, + returnTc (NPat lit' pat_ty (HsApp (HsVar (instToId eq)) over_lit_expr), + lie1 `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 + HsIntegral i -> HsInteger i + HsFractional f -> HsRat f pat_ty \end{code} %************************************************************************ @@ -302,18 +296,19 @@ tcPat tc_bndr pat@(NPatIn over_lit) pat_ty %************************************************************************ \begin{code} -tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus) pat_ty +tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i)) pat_ty = tc_bndr name pat_ty `thenTc` \ bndr_id -> - tcLookupGlobalId minus `thenNF_Tc` \ minus_sel_id -> - tcLookupGlobalId geClassOpName `thenNF_Tc` \ ge_sel_id -> + -- The '-' part is re-mappable syntax + tcLookupSyntaxId minusName `thenNF_Tc` \ minus_sel_id -> + tcLookupGlobalId geName `thenNF_Tc` \ ge_sel_id -> newOverloadedLit origin lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) -> - newMethod origin ge_sel_id [pat_ty] `thenNF_Tc` \ (lie2, ge_id) -> - newMethod origin minus_sel_id [pat_ty] `thenNF_Tc` \ (lie3, minus_id) -> + 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 - (SectionR (HsVar ge_id) over_lit_expr) - (SectionR (HsVar minus_id) over_lit_expr), - lie1 `plusLIE` lie2 `plusLIE` lie3, + (SectionR (HsVar (instToId ge)) over_lit_expr) + (SectionR (HsVar (instToId minus)) over_lit_expr), + lie1 `plusLIE` mkLIE [ge,minus], emptyBag, unitBag (name, bndr_id), emptyLIE) where origin = PatOrigin pat @@ -366,7 +361,7 @@ simpleHsLitTy (HsString str) = stringTy \begin{code} tcConstructor pat con_name pat_ty = -- Check that it's a constructor - tcLookupDataCon `thenNF_Tc` \ data_con -> + tcLookupDataCon con_name `thenNF_Tc` \ data_con -> -- Instantiate it let @@ -384,13 +379,12 @@ tcConstructor pat con_name pat_ty ex_tvs' = take n_ex_tvs all_tvs' result_ty = mkTyConApp tycon (drop n_ex_tvs ty_args') in - newClassDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ (lie_avail, dicts) -> + newClassDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ dicts -> -- Check overall type matches unifyTauTy pat_ty result_ty `thenTc_` - returnTc (data_con, ex_tvs', dicts, lie_avail, arg_tys') - } + returnTc (data_con, ex_tvs', map instToId dicts, mkLIE dicts, arg_tys') \end{code} ------------------------------------------------------