X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcPat.lhs;h=4d1a49d73d6b6c464aa6f466e8b432a2f1fd8d9e;hb=b473b6c241cf54b5edc1e21553250739476c0cf9;hp=a867a8cff85a06104931ee021ff1a7f9c6406145;hpb=710e207487929c4a5977b5ee3bc6e539091953db;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index a867a8c..4d1a49d 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,14 +14,13 @@ import TcHsSyn ( TcPat, TcId ) import TcMonad import Inst ( InstOrigin(..), - emptyLIE, plusLIE, LIE, - newMethod, newOverloadedLit, newDicts, newClassDicts + emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId, + newMethod, newOverloadedLit, newDicts ) -import Name ( Name, getOccName, getSrcLoc ) +import Id ( mkLocalId ) +import Name ( Name ) import FieldLabel ( fieldLabelName ) -import TcEnv ( tcLookupValue, tcLookupClassByKey, - tcLookupValueByKey, newLocalId, badCon - ) +import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupSyntaxId ) import TcType ( TcType, TcTyVar, tcInstTyVars, newTyVarTy ) import TcMonoType ( tcHsSigType ) import TcUnify ( unifyTauTy, unifyListTy, unifyTupleTy ) @@ -30,16 +29,13 @@ import CmdLineOpts ( opt_IrrefutableTuples ) import DataCon ( dataConSig, dataConFieldLabels, dataConSourceArity ) -import Id ( isDataConWrapId_maybe ) -import Type ( isTauTy, mkTyConApp, mkClassPred, boxedTypeKind ) -import Subst ( substTy, substClasses ) +import Type ( isTauTy, mkTyConApp, mkClassPred, liftedTypeKind ) +import Subst ( substTy, substTheta ) 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 @@ -53,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 (mkLocalId binder_name pat_ty) \end{code} @@ -71,7 +63,7 @@ tcPatBndr_NoSigs binder_name pat_ty %************************************************************************ \begin{code} -tcPat :: (Name -> TcType -> TcM s TcId) -- How to construct a suitable (monomorphic) +tcPat :: (Name -> TcType -> TcM TcId) -- How to construct a suitable (monomorphic) -- Id for variables found in the pattern -- The TcType is the expected type, see note below -> RenamedPat @@ -82,7 +74,7 @@ tcPat :: (Name -> TcType -> TcM s TcId) -- How to construct a suitable (monomorp -- INVARIANT: if it is, the foralls will always be visible, -- not hidden inside a mutable type variable - -> TcM s (TcPat, + -> TcM (TcPat, LIE, -- Required by n+k and literal pats Bag TcTyVar, -- TyVars bound by the pattern -- These are just the existentially-bound ones. @@ -239,13 +231,13 @@ 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 (pat_ty : extras) -> ASSERT( null extras ) - tcLookupValue field_label `thenNF_Tc` \ sel_id -> + tcLookupGlobalId field_label `thenNF_Tc` \ sel_id -> returnTc (sel_id, pat_ty) ) `thenTc` \ (sel_id, pat_ty) -> @@ -267,14 +259,14 @@ tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty \begin{code} tcPat tc_bndr (LitPatIn lit@(HsLitLit s _)) pat_ty -- cf tcExpr on LitLits - = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass -> + = 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_` - tcLookupValueByKey eqStringIdKey `thenNF_Tc` \ eq_id -> + tcLookupGlobalId eqStringName `thenNF_Tc` \ eq_id -> returnTc (NPat lit stringTy (HsVar eq_id `HsApp` HsLit lit), emptyLIE, emptyBag, emptyBag, emptyLIE) @@ -284,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) -> - tcLookupValueByKey eqClassOpKey `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} %************************************************************************ @@ -304,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 -> - tcLookupValue minus `thenNF_Tc` \ minus_sel_id -> - tcLookupValueByKey geClassOpKey `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 @@ -330,9 +323,9 @@ tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus) pat_ty Helper functions \begin{code} -tcPats :: (Name -> TcType -> TcM s TcId) -- How to deal with variables +tcPats :: (Name -> TcType -> TcM TcId) -- How to deal with variables -> [RenamedPat] -> [TcType] -- Excess 'expected types' discarded - -> TcM s ([TcPat], + -> TcM ([TcPat], LIE, -- Required by n+k and literal pats Bag TcTyVar, Bag (Name, TcId), -- Ids bound by the pattern @@ -368,10 +361,7 @@ simpleHsLitTy (HsString str) = stringTy \begin{code} tcConstructor pat con_name pat_ty = -- Check that it's a constructor - tcLookupValue con_name `thenNF_Tc` \ con_id -> - case isDataConWrapId_maybe con_id of { - Nothing -> failWithTc (badCon con_id); - Just data_con -> + tcLookupDataCon con_name `thenNF_Tc` \ data_con -> -- Instantiate it let @@ -382,20 +372,19 @@ tcConstructor pat con_name pat_ty in tcInstTyVars (ex_tvs ++ tvs) `thenNF_Tc` \ (all_tvs', ty_args', tenv) -> let - ex_theta' = substClasses tenv ex_theta + 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 - newClassDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ (lie_avail, dicts) -> + newDicts (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} ------------------------------------------------------