X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcPat.lhs;h=69c5666811225d5fc15e455d1d0d925fda1fbf4d;hb=380148608fa354ac972d45aa933400a1a5c4dd7f;hp=0ae701318cecb81f7e7af876e0f8e2fb96c81fae;hpb=af3dc1ff536671f3e4d0ca8d9c072c92d8e47ca0;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 0ae7013..69c5666 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -8,41 +8,41 @@ module TcPat ( tcPat, tcPats, PatCtxt(..), badFieldCon, polyPatSig, refineTyVars #include "HsVersions.h" -import HsSyn ( Pat(..), LPat, HsConDetails(..), HsLit(..), HsOverLit(..), - HsExpr(..), LHsBinds, emptyLHsBinds, isEmptyLHsBinds ) -import HsUtils +import {-# SOURCE #-} TcExpr( tcSyntaxOp ) +import HsSyn ( Pat(..), LPat, HsConDetails(..), + LHsBinds, emptyLHsBinds, isEmptyLHsBinds ) import TcHsSyn ( TcId, hsLitType ) import TcRnMonad -import Inst ( InstOrigin(..), - newMethodFromName, newOverloadedLit, newDicts, - instToId, tcInstStupidTheta, tcSyntaxName +import Inst ( InstOrigin(..), tcOverloadedLit, + newDicts, instToId, tcInstStupidTheta ) import Id ( Id, idType, mkLocalId ) +import Var ( tyVarName ) import Name ( Name ) import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns ) import TcEnv ( newLocalName, tcExtendIdEnv1, tcExtendTyVarEnv2, tcLookupClass, tcLookupDataCon, tcLookupId ) import TcMType ( newTyFlexiVarTy, arityErr, tcSkolTyVars, readMetaTyVar ) import TcType ( TcType, TcTyVar, TcSigmaType, TcTauType, zipTopTvSubst, - SkolemInfo(PatSkol), isSkolemTyVar, pprSkolemTyVar, - TvSubst, mkTvSubst, substTyVar, substTy, MetaDetails(..), - mkTyVarTys, mkClassPred, mkTyConApp, isOverloadedTy ) + SkolemInfo(PatSkol), isMetaTyVar, pprTcTyVar, + TvSubst, mkOpenTvSubst, substTyVar, substTy, MetaDetails(..), + mkTyVarTys, mkClassPred, mkTyConApp, isOverloadedTy, + mkFunTy, mkFunTys ) import VarEnv ( mkVarEnv ) -- ugly import Kind ( argTypeKind, liftedTypeKind ) import TcUnify ( tcSubPat, Expected(..), zapExpectedType, zapExpectedTo, zapToListTy, zapToTyConApp ) import TcHsType ( UserTypeCtxt(..), TcSigInfo( sig_tau ), TcSigFun, tcHsPatSigType ) -import TysWiredIn ( stringTy, parrTyCon, tupleTyCon ) -import Unify ( MaybeErr(..), gadtRefineTys, gadtMatchTys ) +import TysWiredIn ( boolTy, parrTyCon, tupleTyCon ) +import Unify ( MaybeErr(..), gadtRefineTys, BindFlag(..) ) import Type ( substTys, substTheta ) -import CmdLineOpts ( opt_IrrefutableTuples ) +import StaticFlags ( opt_IrrefutableTuples ) import TyCon ( TyCon ) import DataCon ( DataCon, dataConTyCon, isVanillaDataCon, dataConInstOrigArgTys, dataConFieldLabels, dataConSourceArity, dataConSig ) -import PrelNames ( eqStringName, eqName, geName, negateName, minusName, - integralClassName ) +import PrelNames ( integralClassName ) import BasicTypes ( isBoxed ) -import SrcLoc ( Located(..), SrcSpan, noLoc, unLoc ) +import SrcLoc ( Located(..), SrcSpan, noLoc ) import Maybes ( catMaybes ) import ErrUtils ( Message ) import Outputable @@ -75,13 +75,21 @@ tcPat :: PatCtxt [TcTyVar], -- Existential binders a) -- Result of thing inside -tcPat ctxt pat exp_ty thing_inside - = do { err_ctxt <- getErrCtxt - ; maybeAddErrCtxt (patCtxt (unLoc pat)) $ - tc_lpat ctxt pat exp_ty $ - setErrCtxt err_ctxt thing_inside } - -- Restore error context before doing thing_inside - -- See note [Nesting] above +tcPat ctxt (L span pat) exp_ty thing_inside + = do { -- Restore error context before doing thing_inside + -- See note [Nesting] above + err_ctxt <- getErrCtxt + ; let real_thing_inside = setErrCtxt err_ctxt thing_inside + + -- It's OK to keep setting the SrcSpan; + -- it just overwrites the previous value + ; (pat', tvs, res) <- setSrcSpan span $ + maybeAddErrCtxt (patCtxt pat) $ + tc_pat ctxt pat exp_ty $ + real_thing_inside + + ; return (L span pat', tvs, res) + } -------------------- tcPats :: PatCtxt @@ -117,18 +125,17 @@ tcCheckPats ctxt pats tys thing_inside -- A trivial wrapper %************************************************************************ \begin{code} -data PatCtxt = LamPat Bool -- Used for lambda, case, do-notation etc +data PatCtxt = LamPat -- Used for lambda, case, do-notation etc | LetPat TcSigFun -- Used for let(rec) bindings - -- True <=> we are checking the case expression, - -- so can do full-blown refinement - -- False <=> inferring, do no refinement ------------------- tcPatBndr :: PatCtxt -> Name -> Expected TcSigmaType -> TcM TcId -tcPatBndr (LamPat _) bndr_name pat_ty +tcPatBndr LamPat bndr_name pat_ty = do { pat_ty' <- zapExpectedType pat_ty argTypeKind -- If pat_ty is Expected, this returns the appropriate -- SigmaType. In Infer mode, we create a fresh type variable. + -- Note argTypeKind: the variable can have an unboxed type, + -- but not an unboxed tuple. -- Note the SigmaType: we can get -- data T = MkT (forall a. a->a) -- f t = case t of { MkT g -> ... } @@ -168,21 +175,13 @@ bindInstsOfPatId id thing_inside %************************************************************************ \begin{code} -tc_lpat :: PatCtxt - -> LPat Name -> Expected TcSigmaType +tc_pat :: PatCtxt + -> Pat Name -> Expected TcSigmaType -> TcM a -- Thing inside - -> TcM (LPat TcId, -- Translated pattern + -> TcM (Pat TcId, -- Translated pattern [TcTyVar], -- Existential binders a) -- Result of thing inside -tc_lpat ctxt (L span pat) pat_ty thing_inside - = setSrcSpan span $ - -- It's OK to keep setting the SrcSpan; - -- it just overwrites the previous value - do { (pat', tvs, res) <- tc_pat ctxt pat pat_ty thing_inside - ; return (L span pat', tvs, res) } - ---------------------- tc_pat ctxt (VarPat name) pat_ty thing_inside = do { id <- tcPatBndr ctxt name pat_ty ; (res, binds) <- bindInstsOfPatId id $ @@ -194,7 +193,7 @@ tc_pat ctxt (VarPat name) pat_ty thing_inside ; return (pat', [], res) } tc_pat ctxt (ParPat pat) pat_ty thing_inside - = do { (pat', tvs, res) <- tc_lpat ctxt pat pat_ty thing_inside + = do { (pat', tvs, res) <- tcPat ctxt pat pat_ty thing_inside ; return (ParPat pat', tvs, res) } -- There's a wrinkle with irrefuatable patterns, namely that we @@ -209,7 +208,7 @@ tc_pat ctxt (ParPat pat) pat_ty thing_inside -- because they won't be in scope when we do the desugaring tc_pat ctxt lpat@(LazyPat pat) pat_ty thing_inside = do { reft <- getTypeRefinement - ; (pat', pat_tvs, res) <- tc_lpat ctxt pat pat_ty $ + ; (pat', pat_tvs, res) <- tcPat ctxt pat pat_ty $ setTypeRefinement reft thing_inside ; if (null pat_tvs) then return () else lazyPatErr lpat pat_tvs @@ -230,7 +229,7 @@ tc_pat ctxt (WildPat _) pat_ty thing_inside tc_pat ctxt (AsPat (L nm_loc name) pat) pat_ty thing_inside = do { bndr_id <- setSrcSpan nm_loc (tcPatBndr ctxt name pat_ty) ; (pat', tvs, res) <- tcExtendIdEnv1 name bndr_id $ - tc_lpat ctxt pat (Check (idType bndr_id)) thing_inside + tcPat ctxt pat (Check (idType bndr_id)) thing_inside -- NB: if we do inference on: -- \ (y@(x::forall a. a->a)) = e -- we'll fail. The as-pattern infers a monotype for 'y', which then @@ -245,13 +244,13 @@ tc_pat ctxt (SigPatIn pat sig) pat_ty thing_inside (sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt sig ; tcSubPat sig_ty pat_ty ; subst <- refineTyVars sig_tvs -- See note [Type matching] - ; let tv_binds = [(tv, substTyVar subst tv) | tv <- sig_tvs] + ; let tv_binds = [(tyVarName tv, substTyVar subst tv) | tv <- sig_tvs] sig_ty' = substTy subst sig_ty ; (pat', tvs, res) <- tcExtendTyVarEnv2 tv_binds $ - tc_lpat ctxt pat (Check sig_ty') thing_inside + tcPat ctxt pat (Check sig_ty') thing_inside - ; return (SigPatOut pat' sig_ty, tvs, res) } + ; return (SigPatOut pat' sig_ty', tvs, res) } tc_pat ctxt pat@(TypePat ty) pat_ty thing_inside = failWithTc (badTypePat pat) @@ -295,16 +294,8 @@ tc_pat ctxt pat_in@(ConPatIn (L con_span con_name) arg_pats) pat_ty thing_inside ; (pat', tvs, res) <- tcConPat ctxt con_span data_con tycon ty_args arg_pats thing_inside ; return (pat', tvs, res) } - ------------------------ -- Literal patterns -tc_pat ctxt pat@(LitPat lit@(HsString _)) pat_ty thing_inside - = do { -- Strings are mapped to NPatOuts, which have a guard expression - zapExpectedTo pat_ty stringTy - ; eq_id <- tcLookupId eqStringName - ; res <- thing_inside - ; returnM (NPatOut lit stringTy (nlHsVar eq_id `HsApp` nlHsLit lit), [], res) } - tc_pat ctxt (LitPat simple_lit) pat_ty thing_inside = do { -- All other simple lits zapExpectedTo pat_ty (hsLitType simple_lit) @@ -313,52 +304,38 @@ tc_pat ctxt (LitPat simple_lit) pat_ty thing_inside ------------------------ -- Overloaded patterns: n, and n+k -tc_pat ctxt pat@(NPatIn over_lit mb_neg) pat_ty thing_inside +tc_pat ctxt pat@(NPat over_lit mb_neg eq _) pat_ty thing_inside = do { pat_ty' <- zapExpectedType pat_ty liftedTypeKind - ; let origin = LiteralOrigin over_lit - ; pos_lit_expr <- newOverloadedLit origin over_lit pat_ty' - ; eq <- newMethodFromName origin pat_ty' eqName - ; lit_expr <- case mb_neg of - Nothing -> returnM pos_lit_expr -- Positive literal + ; let orig = LiteralOrigin over_lit + ; lit' <- tcOverloadedLit orig over_lit pat_ty' + ; eq' <- tcSyntaxOp orig eq (mkFunTys [pat_ty', pat_ty'] boolTy) + ; mb_neg' <- case mb_neg of + Nothing -> return Nothing -- Positive literal Just neg -> -- Negative literal -- The 'negate' is re-mappable syntax - do { (_, neg_expr) <- tcSyntaxName origin pat_ty' - (negateName, HsVar neg) - ; returnM (mkHsApp (noLoc neg_expr) pos_lit_expr) } - - ; let -- The literal in an NPatIn is always positive... - -- But in NPatOut, 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 pat_ty' - (HsIntegral i _, Just _) -> HsInteger (-i) pat_ty' - (HsFractional f _, Nothing) -> HsRat f pat_ty' - (HsFractional f _, Just _) -> HsRat (-f) pat_ty' - + do { neg' <- tcSyntaxOp orig neg (mkFunTy pat_ty' pat_ty') + ; return (Just neg') } ; res <- thing_inside - ; returnM (NPatOut lit' pat_ty' (HsApp (nlHsVar eq) lit_expr), [], res) } + ; returnM (NPat lit' mb_neg' eq' pat_ty', [], res) } -tc_pat ctxt pat@(NPlusKPatIn (L nm_loc name) lit@(HsIntegral i _) minus_name) pat_ty thing_inside +tc_pat ctxt pat@(NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside = do { bndr_id <- setSrcSpan nm_loc (tcPatBndr ctxt name pat_ty) ; let pat_ty' = idType bndr_id - origin = LiteralOrigin lit - ; over_lit_expr <- newOverloadedLit origin lit pat_ty' - ; ge <- newMethodFromName origin pat_ty' geName + orig = LiteralOrigin lit + ; lit' <- tcOverloadedLit orig lit pat_ty' - -- The '-' part is re-mappable syntax - ; (_, minus_expr) <- tcSyntaxName origin pat_ty' (minusName, HsVar minus_name) + -- The '>=' and '-' parts are re-mappable syntax + ; ge' <- tcSyntaxOp orig ge (mkFunTys [pat_ty', pat_ty'] boolTy) + ; minus' <- tcSyntaxOp orig minus (mkFunTys [pat_ty', pat_ty'] pat_ty') -- The Report says that n+k patterns must be in Integral -- We may not want this when using re-mappable syntax, though (ToDo?) ; icls <- tcLookupClass integralClassName - ; dicts <- newDicts origin [mkClassPred icls [pat_ty']] + ; dicts <- newDicts orig [mkClassPred icls [pat_ty']] ; extendLIEs dicts ; res <- tcExtendIdEnv1 name bndr_id thing_inside - ; returnM (NPlusKPatOut (L nm_loc bndr_id) i - (SectionR (nlHsVar ge) over_lit_expr) - (SectionR (noLoc minus_expr) over_lit_expr), - [], res) } + ; returnM (NPlusKPat (L nm_loc bndr_id) lit' ge' minus', [], res) } \end{code} @@ -385,6 +362,7 @@ tcConPat ctxt span data_con tycon ty_args arg_pats thing_inside | otherwise -- GADT case = do { let (tvs, theta, arg_tys, _, res_tys) = dataConSig data_con + ; traceTc (text "tcConPat: GADT" <+> ppr data_con) ; span <- getSrcSpanM ; let rigid_info = PatSkol data_con span ; tvs' <- tcSkolTyVars rigid_info tvs @@ -500,17 +478,15 @@ refineAlt :: PatCtxt -> DataCon -> TcM a -> TcM a refineAlt ctxt con ex_tvs ctxt_tys pat_tys thing_inside = do { old_subst <- getTypeRefinement - ; let refiner | can_i_refine ctxt = gadtRefineTys - | otherwise = gadtMatchTys - ; case refiner ex_tvs old_subst pat_tys ctxt_tys of + ; case gadtRefineTys bind_fn old_subst pat_tys ctxt_tys of Failed msg -> failWithTc (inaccessibleAlt msg) Succeeded new_subst -> do { traceTc (text "refineTypes:match" <+> ppr con <+> ppr new_subst) ; setTypeRefinement new_subst thing_inside } } where - can_i_refine (LamPat can_refine) = can_refine - can_i_refine other_ctxt = False + bind_fn tv | isMetaTyVar tv = WildCard -- Wobbly types behave as wild cards + | otherwise = BindMe \end{code} Note [Type matching] @@ -539,7 +515,7 @@ refineTyVars :: [TcTyVar] -- Newly instantiated meta-tyvars of the function -- Just one level of de-wobblification though. What a hack! refineTyVars tvs = do { mb_prs <- mapM mk_pr tvs - ; return (mkTvSubst (mkVarEnv (catMaybes mb_prs))) } + ; return (mkOpenTvSubst (mkVarEnv (catMaybes mb_prs))) } where mk_pr tv = do { details <- readMetaTyVar tv ; case details of @@ -638,9 +614,7 @@ badTypePat pat = ptext SLIT("Illegal type pattern") <+> ppr pat lazyPatErr pat tvs = failWithTc $ hang (ptext SLIT("A lazy (~) pattern connot bind existential type variables")) - 2 (vcat (map get tvs)) - where - get tv = ASSERT( isSkolemTyVar tv ) pprSkolemTyVar tv + 2 (vcat (map pprTcTyVar tvs)) inaccessibleAlt msg = hang (ptext SLIT("Inaccessible case alternative:")) 2 msg