X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcPat.lhs;h=9f7dbc0ebb0fd3cfddb838b89ab0434f82465890;hb=a170160cc21678c30ca90696d4ae0fc1155f25bf;hp=e5bfc93ea7eeb93ac8159ac6d63434ea33a1319e;hpb=5e6242927839c8ddc73a55eb7828c0b7e4cc3ab2;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index e5bfc93..9f7dbc0 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -4,38 +4,41 @@ \section[TcPat]{Typechecking patterns} \begin{code} -module TcPat ( tcPat, tcMonoPatBndr, simpleHsLitTy, badFieldCon, polyPatSig ) where +module TcPat ( tcPat, tcMonoPatBndr, tcSubPat, + badFieldCon, polyPatSig + ) where #include "HsVersions.h" import HsSyn ( InPat(..), OutPat(..), HsLit(..), HsOverLit(..), HsExpr(..) ) import RnHsSyn ( RenamedPat ) -import TcHsSyn ( TcPat, TcId ) +import TcHsSyn ( TcPat, TcId, simpleHsLitTy ) import TcMonad import Inst ( InstOrigin(..), - emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId, - newMethod, newOverloadedLit, newDicts, newClassDicts + emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId, isEmptyLIE, + newMethod, newOverloadedLit, newDicts ) -import Id ( mkVanillaId ) +import Id ( mkLocalId, mkSysLocal ) import Name ( Name ) import FieldLabel ( fieldLabelName ) -import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupSyntaxId ) -import TcType ( TcType, TcTyVar, tcInstTyVars, newTyVarTy ) -import TcMonoType ( tcHsSigType ) -import TcUnify ( unifyTauTy, unifyListTy, unifyTupleTy ) - +import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupId ) +import TcMType ( tcInstTyVars, newTyVarTy, getTcTyVar, putTcTyVar ) +import TcType ( TcType, TcTyVar, TcSigmaType, TyVarDetails(VanillaTv), + mkTyConApp, mkClassPred, liftedTypeKind, tcGetTyVar_maybe, + isHoleTyVar, openTypeKind ) +import TcUnify ( tcSub, 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 Type ( isTauTy, mkTyConApp, mkClassPred, liftedTypeKind ) -import Subst ( substTy, substClasses ) -import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, - doublePrimTy, addrPrimTy - ) -import TysWiredIn ( charTy, stringTy, intTy, integerTy ) -import PrelNames ( minusName, eqStringName, eqName, geName, cCallableClassName ) +import Subst ( substTy, substTheta ) +import PrelNames ( eqStringName, eqName, geName, cCallableClassName ) import BasicTypes ( isBoxed ) import Bag import Outputable @@ -49,10 +52,41 @@ import Outputable %************************************************************************ \begin{code} --- 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) +type BinderChecker = Name -> TcSigmaType -> TcM (PatCoFn, LIE, TcId) + -- How to construct a suitable (monomorphic) + -- Id for variables found in the pattern + -- The TcSigmaType is the expected type + -- from the pattern context + +-- The Id may have a sigma type (e.g. f (x::forall a. a->a)) +-- so we want to *create* it during pattern type checking. +-- We don't want to make Ids first with a type-variable type +-- and then unify... becuase we can't unify a sigma type with a type variable. + +tcMonoPatBndr :: BinderChecker + -- 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 + | Just tv <- tcGetTyVar_maybe pat_ty, + isHoleTyVar tv + -- 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* + -- type variable. We find out if there are no constraints + -- by seeing if we are given an "open hole" as our info. + -- 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) \end{code} @@ -63,16 +97,12 @@ tcMonoPatBndr binder_name pat_ty = returnTc (mkVanillaId binder_name pat_ty) %************************************************************************ \begin{code} -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 +tcPat :: BinderChecker -> RenamedPat - -> TcType -- Expected type derived from the context + -> TcSigmaType -- Expected type derived from the context -- In the case of a function with a rank-2 signature, -- this type might be a forall type. - -- INVARIANT: if it is, the foralls will always be visible, - -- not hidden inside a mutable type variable -> TcM (TcPat, LIE, -- Required by n+k and literal pats @@ -100,18 +130,18 @@ tcPat tc_bndr pat@(TypePatIn ty) pat_ty = failWithTc (badTypePat pat) tcPat tc_bndr (VarPatIn name) pat_ty - = tc_bndr name pat_ty `thenTc` \ bndr_id -> - returnTc (VarPat bndr_id, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE) + = tc_bndr name pat_ty `thenTc` \ (co_fn, lie_req, bndr_id) -> + returnTc (co_fn <$> VarPat bndr_id, lie_req, + emptyBag, unitBag (name, bndr_id), emptyLIE) tcPat tc_bndr (LazyPatIn pat) pat_ty = tcPat tc_bndr pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) -> returnTc (LazyPat pat', lie_req, tvs, ids, lie_avail) tcPat tc_bndr pat_in@(AsPatIn name pat) pat_ty - = tc_bndr name pat_ty `thenTc` \ bndr_id -> - tcPat tc_bndr pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) -> - tcAddErrCtxt (patCtxt pat_in) $ - returnTc (AsPat bndr_id pat', lie_req, + = tc_bndr name pat_ty `thenTc` \ (co_fn, lie_req1, bndr_id) -> + tcPat tc_bndr pat pat_ty `thenTc` \ (pat', lie_req2, tvs, ids, lie_avail) -> + returnTc (co_fn <$> (AsPat bndr_id pat'), lie_req1 `plusLIE` lie_req2, tvs, (name, bndr_id) `consBag` ids, lie_avail) tcPat tc_bndr WildPatIn pat_ty @@ -120,20 +150,18 @@ tcPat tc_bndr WildPatIn pat_ty tcPat tc_bndr (ParPatIn parend_pat) pat_ty = tcPat tc_bndr parend_pat pat_ty -tcPat tc_bndr (SigPatIn pat sig) pat_ty - = tcHsSigType sig `thenTc` \ sig_ty -> - - -- Check that the signature isn't a polymorphic one, which - -- we don't permit (at present, anyway) - checkTc (isTauTy sig_ty) (polyPatSig sig_ty) `thenTc_` - - unifyTauTy pat_ty sig_ty `thenTc_` - tcPat tc_bndr pat sig_ty +tcPat tc_bndr pat_in@(SigPatIn pat sig) pat_ty + = tcAddErrCtxt (patCtxt pat_in) $ + tcHsSigType PatSigCtxt sig `thenTc` \ sig_ty -> + tcSubPat sig_ty pat_ty `thenTc` \ (co_fn, lie_sig) -> + tcPat tc_bndr pat sig_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) -> + returnTc (co_fn <$> pat', lie_req `plusLIE` lie_sig, tvs, ids, lie_avail) \end{code} + %************************************************************************ %* * -\subsection{Explicit lists and tuples} +\subsection{Explicit lists, parallel arrays, and tuples} %* * %************************************************************************ @@ -144,6 +172,12 @@ tcPat tc_bndr pat_in@(ListPatIn pats) pat_ty tcPats tc_bndr pats (repeat elem_ty) `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) -> returnTc (ListPat elem_ty pats', lie_req, tvs, ids, lie_avail) +tcPat tc_bndr pat_in@(PArrPatIn pats) pat_ty + = tcAddErrCtxt (patCtxt pat_in) $ + unifyPArrTy pat_ty `thenTc` \ elem_ty -> + tcPats tc_bndr pats (repeat elem_ty) `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) -> + returnTc (PArrPat elem_ty pats', lie_req, tvs, ids, lie_avail) + tcPat tc_bndr pat_in@(TuplePatIn pats boxity) pat_ty = tcAddErrCtxt (patCtxt pat_in) $ @@ -168,6 +202,7 @@ tcPat tc_bndr pat_in@(TuplePatIn pats boxity) pat_ty arity = length pats \end{code} + %************************************************************************ %* * \subsection{Other constructors} @@ -195,7 +230,10 @@ tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty = tcAddErrCtxt (patCtxt pat) $ -- Check the constructor itself - tcConstructor pat name pat_ty `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys) -> + tcConstructor pat name `thenTc` \ (data_con, ex_tvs, 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) -> let -- Don't use zipEqual! If the constructor isn't really a record, then -- dataConFieldLabels will be empty (and each field in the pattern @@ -205,10 +243,10 @@ tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty in -- Check the fields - tc_fields field_tys rpats `thenTc` \ (rpats', lie_req, tvs, ids, lie_avail2) -> + tc_fields field_tys rpats `thenTc` \ (rpats', lie_req2, tvs, ids, lie_avail2) -> returnTc (RecPat data_con pat_ty ex_tvs dicts rpats', - lie_req, + lie_req1 `plusLIE` lie_req2, listToBag ex_tvs `unionBags` tvs, ids, lie_avail1 `plusLIE` lie_avail2) @@ -285,8 +323,8 @@ tcPat tc_bndr pat@(NPatIn over_lit) pat_ty 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} %************************************************************************ @@ -296,19 +334,19 @@ tcPat tc_bndr pat@(NPatIn over_lit) pat_ty %************************************************************************ \begin{code} -tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i)) pat_ty - = tc_bndr name pat_ty `thenTc` \ bndr_id -> +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 - tcLookupSyntaxId minusName `thenNF_Tc` \ minus_sel_id -> + 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, lie1) -> + 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 (SectionR (HsVar (instToId ge)) over_lit_expr) (SectionR (HsVar (instToId minus)) over_lit_expr), - lie1 `plusLIE` mkLIE [ge,minus], + lie1 `plusLIE` lie2 `plusLIE` mkLIE [ge,minus], emptyBag, unitBag (name, bndr_id), emptyLIE) where origin = PatOrigin pat @@ -323,7 +361,7 @@ tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i)) pat_ty Helper functions \begin{code} -tcPats :: (Name -> TcType -> TcM TcId) -- How to deal with variables +tcPats :: BinderChecker -- How to deal with variables -> [RenamedPat] -> [TcType] -- Excess 'expected types' discarded -> TcM ([TcPat], LIE, -- Required by n+k and literal pats @@ -344,22 +382,7 @@ tcPats tc_bndr (ty:tys) (pat:pats) ------------------------------------------------------ \begin{code} -simpleHsLitTy :: HsLit -> TcType -simpleHsLitTy (HsCharPrim c) = charPrimTy -simpleHsLitTy (HsStringPrim s) = addrPrimTy -simpleHsLitTy (HsInt i) = intTy -simpleHsLitTy (HsInteger i) = integerTy -simpleHsLitTy (HsIntPrim i) = intPrimTy -simpleHsLitTy (HsFloatPrim f) = floatPrimTy -simpleHsLitTy (HsDoublePrim d) = doublePrimTy -simpleHsLitTy (HsChar c) = charTy -simpleHsLitTy (HsString str) = stringTy -\end{code} - - ------------------------------------------------------- -\begin{code} -tcConstructor pat con_name pat_ty +tcConstructor pat con_name = -- Check that it's a constructor tcLookupDataCon con_name `thenNF_Tc` \ data_con -> @@ -370,21 +393,18 @@ tcConstructor pat con_name pat_ty -- behave differently when called, not when used for -- matching. in - tcInstTyVars (ex_tvs ++ tvs) `thenNF_Tc` \ (all_tvs', ty_args', tenv) -> + tcInstTyVars VanillaTv (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` \ dicts -> + newDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ dicts -> - -- Check overall type matches - unifyTauTy pat_ty result_ty `thenTc_` - - returnTc (data_con, ex_tvs', map instToId dicts, mkLIE dicts, arg_tys') + returnTc (data_con, ex_tvs', map instToId dicts, mkLIE dicts, arg_tys', result_ty) \end{code} ------------------------------------------------------ @@ -393,7 +413,12 @@ tcConPat tc_bndr pat con_name arg_pats pat_ty = tcAddErrCtxt (patCtxt pat) $ -- Check the constructor itself - tcConstructor pat con_name pat_ty `thenTc` \ (data_con, ex_tvs', dicts, lie_avail1, arg_tys') -> + tcConstructor pat con_name `thenTc` \ (data_con, ex_tvs, 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) -> -- Check correct arity let @@ -404,11 +429,11 @@ 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_req, tvs, ids, lie_avail2) -> + tcPats tc_bndr arg_pats arg_tys `thenTc` \ (arg_pats', lie_req2, tvs, ids, lie_avail2) -> - returnTc (ConPat data_con pat_ty ex_tvs' dicts arg_pats', - lie_req, - listToBag ex_tvs' `unionBags` tvs, + returnTc (co_fn <$> ConPat data_con pat_ty ex_tvs dicts arg_pats', + lie_req1 `plusLIE` lie_req2, + listToBag ex_tvs `unionBags` tvs, ids, lie_avail1 `plusLIE` lie_avail2) \end{code} @@ -416,12 +441,54 @@ tcConPat tc_bndr pat con_name arg_pats pat_ty %************************************************************************ %* * +\subsection{Subsumption} +%* * +%************************************************************************ + +Example: + f :: (forall a. a->a) -> Int -> Int + f (g::Int->Int) y = g y +This is ok: the type signature allows fewer callers than +the (more general) signature f :: (Int->Int) -> Int -> Int +I.e. (forall a. a->a) <= Int -> Int +We end up translating this to: + f = \g' :: (forall a. a->a). let g = g' Int in g' y + +tcSubPat does the work + sig_ty is the signature on the pattern itself + (Int->Int in the example) + expected_ty is the type passed inwards from the context + (forall a. a->a in the example) + +\begin{code} +tcSubPat :: TcSigmaType -> TcSigmaType -> TcM (PatCoFn, LIE) + +tcSubPat sig_ty exp_ty + = tcSub 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 + ASSERT( isEmptyLIE lie ) + returnNF_Tc (idCoercion, emptyLIE) + else + tcGetUnique `thenNF_Tc` \ uniq -> + let + 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 + returnNF_Tc (mkCoercion pat_co_fn, lie) +\end{code} + + +%************************************************************************ +%* * \subsection{Errors and contexts} %* * %************************************************************************ \begin{code} -patCtxt pat = hang (ptext SLIT("In the pattern:")) +patCtxt pat = hang (ptext SLIT("When checking the pattern:")) 4 (ppr pat) badFieldCon :: Name -> Name -> SDoc