X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcPat.lhs;h=f816b7c181321ea77c9f10105c5af2a01a504bf2;hb=b085ee40c7f265a5977ea6ec1c415e573be5ff8c;hp=0bf3c314c482c8995d6b8779ac8e49820b35335c;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 0bf3c31..f816b7c 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -1,389 +1,484 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcPat]{Typechecking patterns} \begin{code} +module TcPat ( tcPat, tcMonoPatBndr, tcSubPat, + badFieldCon, polyPatSig + ) where + #include "HsVersions.h" -module TcPat ( - tcPat -#ifdef DPH - , tcPats -#endif - ) where - -import TcMonad -- typechecking monad machinery -import TcMonadFns ( newOpenTyVarTy, newPolyTyVarTy, - newPolyTyVarTys, copyTyVars, newMethod, - newOverloadedLit - ) -import AbsSyn -- the stuff being typechecked - -import AbsPrel ( charPrimTy, intPrimTy, floatPrimTy, - doublePrimTy, charTy, stringTy, mkListTy, - mkTupleTy, addrTy, addrPrimTy, --OLD: eqStringId - PrimOp - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) -#ifdef DPH - ,mkProcessorTy, toDomainId -#endif {- Data Parallel Haskell -} - ) -import AbsUniType ( instantiateTauTy, applyTyCon, InstTyEnv(..) - IF_ATTACK_PRAGMAS(COMMA instantiateTy) - ) -import CmdLineOpts ( GlobalSwitch(..) ) -import Id ( mkInstId, getIdUniType, getDataConSig, - getInstantiatedDataConSig, Id, DataCon(..) - ) -import Inst -import E ( lookupE_Binder, lookupE_Value, - lookupE_ClassOpByKey, E, - LVE(..), TCE(..), UniqFM, CE(..) - -- TCE and CE for pragmas only - ) -import Errors ( dataConArityErr, Error(..), UnifyErrContext(..) +import HsSyn ( InPat(..), OutPat(..), HsLit(..), HsOverLit(..), HsExpr(..) ) +import RnHsSyn ( RenamedPat ) +import TcHsSyn ( TcPat, TcId, simpleHsLitTy ) + +import TcMonad +import Inst ( InstOrigin(..), + emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId, isEmptyLIE, + newMethod, newMethodFromName, newOverloadedLit, newDicts, tcInstDataCon ) -import LIE ( nullLIE, plusLIE, mkLIE, LIE ) -import Unify -import Unique -- some ClassKey stuff -import Util - -#ifdef DPH -import TcParQuals -#endif {- Data Parallel Haskell -} +import Id ( mkLocalId, mkSysLocal ) +import Name ( Name ) +import FieldLabel ( fieldLabelName ) +import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupId ) +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 ( dataConFieldLabels, dataConSourceArity ) +import PrelNames ( eqStringName, eqName, geName, cCallableClassName ) +import BasicTypes ( isBoxed ) +import Bag +import Outputable +import FastString \end{code} -The E passed in already contains bindings for all the variables in -the pattern, usually to fresh type variables (but maybe not, if there -were type signatures present). + +%************************************************************************ +%* * +\subsection{Variable patterns} +%* * +%************************************************************************ \begin{code} -tcPat :: E -> RenamedPat -> TcM (TypecheckedPat, LIE, UniType) +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 + = 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* + -- 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. + + returnTc (idCoercion, emptyLIE, mkLocalId binder_name pat_ty') \end{code} + %************************************************************************ %* * -\subsection{Variables, wildcards, lazy pats, as-pats} +\subsection{Typechecking patterns} %* * %************************************************************************ \begin{code} -tcPat e (VarPatIn name) - = let - id = lookupE_Binder e name - in - returnTc (VarPat id, nullLIE, getIdUniType id) +tcPat :: BinderChecker + -> RenamedPat + + -> 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. + + -> TcM (TcPat, + LIE, -- Required by n+k and literal pats + Bag TcTyVar, -- TyVars bound by the pattern + -- These are just the existentially-bound ones. + -- Any tyvars bound by *type signatures* in the + -- patterns are brought into scope before we begin. + Bag (Name, TcId), -- Ids bound by the pattern, along with the Name under + -- which it occurs in the pattern + -- The two aren't the same because we conjure up a new + -- local name for each variable. + LIE) -- Dicts or methods [see below] bound by the pattern + -- from existential constructor patterns +\end{code} -tcPat e (LazyPatIn pat) - = tcPat e pat `thenTc` \ (pat', lie, ty) -> - returnTc (LazyPat pat', lie, ty) -tcPat e pat_in@(AsPatIn name pat) - = let - id = lookupE_Binder e name - in - tcPat e pat `thenTc` \ (pat', lie, ty) -> - unifyTauTy (getIdUniType id) ty (PatCtxt pat_in) `thenTc_` - returnTc (AsPat id pat', lie, ty) +%************************************************************************ +%* * +\subsection{Variables, wildcards, lazy pats, as-pats} +%* * +%************************************************************************ -tcPat e (WildPatIn) - = newOpenTyVarTy `thenNF_Tc` \ tyvar_ty -> - returnTc (WildPat tyvar_ty, nullLIE, tyvar_ty) +\begin{code} +tcPat tc_bndr pat@(TypePatIn ty) pat_ty + = failWithTc (badTypePat pat) + +tcPat tc_bndr (VarPatIn name) pat_ty + = 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` \ (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 + = 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 + +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} %* * %************************************************************************ \begin{code} -tcPat e pat_in@(ListPatIn pats) - = tcPats e pats `thenTc` \ (pats', lie, tys) -> - newPolyTyVarTy `thenNF_Tc` \ tyvar_ty -> - - unifyTauTyList (tyvar_ty:tys) (PatCtxt pat_in) `thenTc_` - - returnTc (ListPat tyvar_ty pats', lie, mkListTy tyvar_ty) +tcPat tc_bndr pat_in@(ListPatIn pats) pat_ty + = tcAddErrCtxt (patCtxt pat_in) $ + unifyListTy pat_ty `thenTc` \ elem_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 e pat_in@(TuplePatIn pats) - = let - arity = length pats - in - tcPats e pats `thenTc` \ (pats', lie, tys) -> +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) - -- We have to unify with fresh polymorphic type variables, to - -- make sure we record that the tuples can only contain boxed - -- types. - newPolyTyVarTys arity `thenNF_Tc` \ tyvar_tys -> +tcPat tc_bndr pat_in@(TuplePatIn pats boxity) pat_ty + = tcAddErrCtxt (patCtxt pat_in) $ - unifyTauTyLists tyvar_tys tys (PatCtxt pat_in) `thenTc_` + unifyTupleTy boxity arity pat_ty `thenTc` \ arg_tys -> + tcPats tc_bndr pats arg_tys `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) -> -- possibly do the "make all tuple-pats irrefutable" test: - getSwitchCheckerTc `thenNF_Tc` \ sw_chkr -> let - unmangled_result = TuplePat pats' + unmangled_result = TuplePat pats' boxity -- Under flag control turn a pattern (x,y,z) into ~(x,y,z) -- so that we can experiment with lazy tuple-matching. -- This is a pretty odd place to make the switch, but -- it was easy to do. - possibly_mangled_result - = if sw_chkr IrrefutableTuples - then LazyPat unmangled_result - else unmangled_result - -- ToDo: IrrefutableEverything + possibly_mangled_result + | opt_IrrefutableTuples && isBoxed boxity = LazyPat unmangled_result + | otherwise = unmangled_result in - returnTc (possibly_mangled_result, lie, mkTupleTy arity tys) + returnTc (possibly_mangled_result, lie_req, tvs, ids, lie_avail) + where + arity = length pats \end{code} + %************************************************************************ %* * \subsection{Other constructors} %* * -%************************************************************************ -Constructor patterns are a little fun: -\begin{itemize} -\item -typecheck the arguments -\item -look up the constructor -\item -specialise its type (ignore the translation this produces) -\item -check that the context produced by this specialisation is empty -\item -get the arguments out of the function type produced from specialising -\item -unify them with the types of the patterns -\item -back substitute with the type of the result of the constructor -\end{itemize} - -ToDo: exploit new representation of constructors to make this more -efficient? +%************************************************************************ \begin{code} -tcPat e pat_in@(ConPatIn name pats) - = let - con_id = lookupE_Value e name - in - tcPats e pats `thenTc` \ (pats', lie, tys) -> +tcPat tc_bndr pat@(ConPatIn name arg_pats) pat_ty + = tcConPat tc_bndr pat name arg_pats pat_ty + +tcPat tc_bndr pat@(ConOpPatIn pat1 op _ pat2) pat_ty + = tcConPat tc_bndr pat op [pat1, pat2] pat_ty +\end{code} - matchConArgTys con_id tys (\ ty -> PatCtxt pat_in) `thenTc` \ data_ty -> - returnTc (ConPat con_id data_ty pats', lie, data_ty) +%************************************************************************ +%* * +\subsection{Records} +%* * +%************************************************************************ -tcPat e pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form... - = let - con_id = lookupE_Value e op +\begin{code} +tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty + = tcAddErrCtxt (patCtxt pat) $ + + -- Check the constructor itself + 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_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 + -- will generate an error below). + field_tys = zip (map fieldLabelName (dataConFieldLabels data_con)) + arg_tys in - tcPats e [pat1, pat2] `thenTc` \ ([pat1',pat2'], lie, tys) -> - -- ToDo: there exists a less ugly way, no doubt... - matchConArgTys con_id tys (\ ty -> PatCtxt pat_in) `thenTc` \ data_ty -> + -- Check the fields + tc_fields field_tys rpats `thenTc` \ (rpats', lie_req3, tvs, ids, lie_avail2) -> + + 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) - returnTc (ConOpPat pat1' con_id pat2' data_ty, lie, data_ty) + where + tc_fields field_tys [] + = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE) + + tc_fields field_tys ((field_label, rhs_pat, pun_flag) : rpats) + = tc_fields field_tys rpats `thenTc` \ (rpats', lie_req1, tvs1, ids1, lie_avail1) -> + + (case [ty | (f,ty) <- field_tys, f == field_label] of + + -- No matching field; chances are this field label comes from some + -- other record type (or maybe none). As well as reporting an + -- error we still want to typecheck the pattern, principally to + -- make sure that all the variables it binds are put into the + -- environment, else the type checker crashes later: + -- f (R { foo = (a,b) }) = a+b + -- 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 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 ) + tcLookupGlobalId field_label `thenNF_Tc` \ sel_id -> + returnTc (sel_id, pat_ty) + ) `thenTc` \ (sel_id, pat_ty) -> + + tcPat tc_bndr rhs_pat pat_ty `thenTc` \ (rhs_pat', lie_req2, tvs2, ids2, lie_avail2) -> + + returnTc ((sel_id, rhs_pat', pun_flag) : rpats', + lie_req1 `plusLIE` lie_req2, + tvs1 `unionBags` tvs2, + ids1 `unionBags` ids2, + lie_avail1 `plusLIE` lie_avail2) \end{code} %************************************************************************ %* * -\subsection{Non-overloaded literals} +\subsection{Literals} %* * %************************************************************************ \begin{code} -tcPat e (LitPatIn lit@(CharLit str)) - = returnTc (LitPat lit charTy, nullLIE, charTy) +tcPat tc_bndr (LitPatIn lit@(HsLitLit s _)) pat_ty + -- cf tcExpr on LitLits + = tcLookupClass cCallableClassName `thenNF_Tc` \ cCallableClass -> + newDicts (LitLitOrigin (unpackFS s)) + [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 eqStringName `thenNF_Tc` \ eq_id -> + returnTc (NPat lit stringTy (HsVar eq_id `HsApp` HsLit lit), + emptyLIE, emptyBag, emptyBag, emptyLIE) + +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 origin over_lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) -> + newMethodFromName origin pat_ty eqName `thenNF_Tc` \ eq -> + + 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 +\end{code} -tcPat e (LitPatIn lit@(StringLit str)) - = getSrcLocTc `thenNF_Tc` \ loc -> - let - origin = LiteralOrigin lit loc - eq_id = lookupE_ClassOpByKey e eqClassKey SLIT("==") - in - newMethod origin eq_id [stringTy] `thenNF_Tc` \ eq -> - let - comp_op = App (Var (mkInstId eq)) (Lit lit) - in - returnTc (NPat lit stringTy comp_op, mkLIE [eq], stringTy) +%************************************************************************ +%* * +\subsection{n+k patterns} +%* * +%************************************************************************ -{- OLD: -tcPat e (LitPatIn lit@(StringLit str)) - = returnTc (NPat lit stringTy comp_op, nullLIE, stringTy) +\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) -> + newOverloadedLit origin lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie2) -> + newMethodFromName origin pat_ty geName `thenNF_Tc` \ ge -> + + -- The '-' part is re-mappable syntax + tcLookupId minus_name `thenNF_Tc` \ minus_sel_id -> + 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` lie2 `plusLIE` mkLIE [ge,minus], + emptyBag, unitBag (name, bndr_id), emptyLIE) where - comp_op = App (Var eqStringId) (Lit lit) --} - -tcPat e (LitPatIn lit@(IntPrimLit _)) - = returnTc (LitPat lit intPrimTy, nullLIE, intPrimTy) -tcPat e (LitPatIn lit@(CharPrimLit _)) - = returnTc (LitPat lit charPrimTy, nullLIE, charPrimTy) -tcPat e (LitPatIn lit@(StringPrimLit _)) - = returnTc (LitPat lit addrPrimTy, nullLIE, addrPrimTy) -tcPat e (LitPatIn lit@(FloatPrimLit _)) - = returnTc (LitPat lit floatPrimTy, nullLIE, floatPrimTy) -tcPat e (LitPatIn lit@(DoublePrimLit _)) - = returnTc (LitPat lit doublePrimTy, nullLIE, doublePrimTy) + origin = PatOrigin pat \end{code} %************************************************************************ %* * -\subsection{Overloaded patterns: int literals and \tr{n+k} patterns} +\subsection{Lists of patterns} %* * %************************************************************************ +Helper functions + \begin{code} -tcPat e (LitPatIn lit@(IntLit i)) - = getSrcLocTc `thenNF_Tc` \ loc -> - let - origin = LiteralOrigin lit loc - in - newPolyTyVarTy `thenNF_Tc` \ tyvar_ty -> - let - from_int = lookupE_ClassOpByKey e numClassKey SLIT("fromInt") - from_integer = lookupE_ClassOpByKey e numClassKey SLIT("fromInteger") - eq_id = lookupE_ClassOpByKey e eqClassKey SLIT("==") - in - newOverloadedLit origin - (OverloadedIntegral i from_int from_integer) - tyvar_ty `thenNF_Tc` \ over_lit -> +tcPats :: BinderChecker -- How to deal with variables + -> [RenamedPat] -> [TcType] -- Excess 'expected types' discarded + -> TcM ([TcPat], + LIE, -- Required by n+k and literal pats + Bag TcTyVar, + Bag (Name, TcId), -- Ids bound by the pattern + LIE) -- Dicts bound by the pattern + +tcPats tc_bndr [] tys = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE) + +tcPats tc_bndr (ty:tys) (pat:pats) + = tcPat tc_bndr ty pat `thenTc` \ (pat', lie_req1, tvs1, ids1, lie_avail1) -> + tcPats tc_bndr tys pats `thenTc` \ (pats', lie_req2, tvs2, ids2, lie_avail2) -> + + returnTc (pat':pats', lie_req1 `plusLIE` lie_req2, + tvs1 `unionBags` tvs2, ids1 `unionBags` ids2, + lie_avail1 `plusLIE` lie_avail2) +\end{code} - newMethod origin eq_id [tyvar_ty] `thenNF_Tc` \ eq -> +------------------------------------------------------ +\begin{code} +tcConstructor pat con_name + = -- Check that it's a constructor + tcLookupDataCon con_name `thenNF_Tc` \ data_con -> - returnTc (NPat lit tyvar_ty (App (Var (mkInstId eq)) - (Var (mkInstId over_lit))), - mkLIE [over_lit, eq], - tyvar_ty) + -- Instantiate it + tcInstDataCon (PatOrigin pat) data_con `thenNF_Tc` \ (_, ex_dicts, arg_tys, result_ty, lie_req, ex_lie, ex_tvs) -> -tcPat e (LitPatIn lit@(FracLit f)) - = getSrcLocTc `thenNF_Tc` \ loc -> - let - origin = LiteralOrigin lit loc - in - newPolyTyVarTy `thenNF_Tc` \ tyvar_ty -> - let - eq_id = lookupE_ClassOpByKey e eqClassKey SLIT("==") - from_rational = lookupE_ClassOpByKey e fractionalClassKey SLIT("fromRational") - in - newOverloadedLit origin - (OverloadedFractional f from_rational) - tyvar_ty `thenNF_Tc` \ over_lit -> + returnTc (data_con, lie_req, ex_tvs, ex_dicts, ex_lie, arg_tys, result_ty) +\end{code} - newMethod origin eq_id [tyvar_ty] `thenNF_Tc` \ eq -> +------------------------------------------------------ +\begin{code} +tcConPat tc_bndr pat con_name arg_pats pat_ty + = tcAddErrCtxt (patCtxt pat) $ - returnTc (NPat lit tyvar_ty (App (Var (mkInstId eq)) - (Var (mkInstId over_lit))), - mkLIE [over_lit, eq], - tyvar_ty) + -- Check the constructor itself + tcConstructor pat con_name `thenTc` \ (data_con, lie_req1, ex_tvs, ex_dicts, lie_avail1, arg_tys, con_res_ty) -> -tcPat e (LitPatIn lit@(LitLitLitIn s)) - = error "tcPat: can't handle ``literal-literal'' patterns" -{- - = getSrcLocTc `thenNF_Tc` \ loc -> - let - origin = LiteralOrigin lit loc - in - newPolyTyVarTy `thenNF_Tc` \ tyvar_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_req2) -> + + -- Check correct arity let - eq_id = lookupE_ClassOpByKey e eqClassKey "==" + con_arity = dataConSourceArity data_con + no_of_args = length arg_pats in - newOverloadedLit origin - (OverloadedLitLit s) - tyvar_ty `thenNF_Tc` \ over_lit -> + checkTc (con_arity == no_of_args) + (arityErr "Constructor" data_con con_arity no_of_args) `thenTc_` - newMethod origin eq_id [tyvar_ty] `thenNF_Tc` \ eq -> + -- Check arguments + tcPats tc_bndr arg_pats arg_tys `thenTc` \ (arg_pats', lie_req3, tvs, ids, lie_avail2) -> - returnTc (NPat lit tyvar_ty (App (Var (mkInstId eq)) - (Var (mkInstId over_lit))), - mkLIE [over_lit, eq], - tyvar_ty) --} + 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) +\end{code} -tcPat e (NPlusKPatIn name lit@(IntLit k)) - = getSrcLocTc `thenNF_Tc` \ loc -> - let - origin = LiteralOrigin lit loc - local = lookupE_Binder e name - local_ty = getIdUniType local +%************************************************************************ +%* * +\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) - ge_id = lookupE_ClassOpByKey e ordClassKey SLIT(">=") - minus_id = lookupE_ClassOpByKey e numClassKey SLIT("-") - from_int = lookupE_ClassOpByKey e numClassKey SLIT("fromInt") - from_integer = lookupE_ClassOpByKey e numClassKey SLIT("fromInteger") - in - newOverloadedLit origin - (OverloadedIntegral k from_int from_integer) - local_ty `thenNF_Tc` \ over_lit -> - - newMethod origin ge_id [local_ty] `thenNF_Tc` \ ge -> - newMethod origin minus_id [local_ty] `thenNF_Tc` \ minus -> - - returnTc (NPlusKPat local lit local_ty - (Var (mkInstId over_lit)) - (Var (mkInstId ge)) - (Var (mkInstId minus)), - mkLIE [over_lit, ge, minus], - local_ty) - -tcPat e (NPlusKPatIn pat other) = panic "TcPat:NPlusKPat: not an IntLit" - -#ifdef DPH -tcPat e (ProcessorPatIn pats pat) - = tcPidPats e pats `thenTc` \ (pats',convs, lie, tys)-> - tcPat e pat `thenTc` \ (pat', ty, lie') -> - returnTc (ProcessorPat pats' convs pat', - plusLIE lie lie', - mkProcessorTy tys ty) -#endif {- Data Parallel Haskell -} +\begin{code} +tcSubPat :: TcSigmaType -> TcHoleType -> TcM (PatCoFn, LIE) + +tcSubPat sig_ty exp_ty + = 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 + 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{Lists of patterns} +\subsection{Errors and contexts} %* * %************************************************************************ \begin{code} -tcPats :: E -> [RenamedPat] -> TcM ([TypecheckedPat], LIE, [UniType]) +patCtxt pat = hang (ptext SLIT("When checking the pattern:")) + 4 (ppr pat) -tcPats e [] = returnTc ([], nullLIE, []) +badFieldCon :: Name -> Name -> SDoc +badFieldCon con field + = hsep [ptext SLIT("Constructor") <+> quotes (ppr con), + ptext SLIT("does not have field"), quotes (ppr field)] -tcPats e (pat:pats) - = tcPat e pat `thenTc` \ (pat', lie, ty) -> - tcPats e pats `thenTc` \ (pats', lie', tys) -> +polyPatSig :: TcType -> SDoc +polyPatSig sig_ty + = hang (ptext SLIT("Illegal polymorphic type signature in pattern:")) + 4 (ppr sig_ty) - returnTc (pat':pats', plusLIE lie lie', ty:tys) +badTypePat pat = ptext SLIT("Illegal type pattern") <+> ppr pat \end{code} -@matchConArgTys@ grabs the signature of the data constructor, and -unifies the actual args against the expected ones. - -\begin{code} -matchConArgTys :: Id -> [UniType] -> (UniType -> UnifyErrContext) -> TcM UniType - -matchConArgTys con_id arg_tys err_ctxt - = let - no_of_args = length arg_tys - (sig_tyvars, sig_theta, sig_tys, _) = getDataConSig con_id - -- Ignore the sig_theta; overloaded constructors only - -- behave differently when called, not when used for - -- matching. - con_arity = length sig_tys - in - getSrcLocTc `thenNF_Tc` \ loc -> - checkTc (con_arity /= no_of_args) - (dataConArityErr con_id con_arity no_of_args loc) `thenTc_` - - copyTyVars sig_tyvars `thenNF_Tc` \ (inst_env, _, new_tyvar_tys) -> - let - (_,inst_arg_tys,inst_result_ty) = getInstantiatedDataConSig con_id new_tyvar_tys - in - unifyTauTyLists arg_tys inst_arg_tys (err_ctxt inst_result_ty) `thenTc_` - returnTc inst_result_ty -\end{code}