X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatch.lhs;h=c0ad86d312d32668308e54f16ed15b5caf6e2d5e;hb=36436bc62a98f53e126ec02fe946337c4c766c3f;hp=3d95b713d0a4c2cd82cd4fa6bd71f9ae0e97591c;hpb=d1c1b7d0e7b94ede238845c91f58582bad3b3ef3;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 3d95b71..c0ad86d 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -15,7 +15,7 @@ import Check ( check, ExhaustivePat ) import CoreSyn import CoreUtils ( bindNonRec, exprType ) import DsMonad -import DsBinds ( dsHsNestedBinds ) +import DsBinds ( dsLHsBinds ) import DsGRHSs ( dsGRHSs ) import DsUtils import Id ( idName, idType, Id ) @@ -24,12 +24,12 @@ import MatchCon ( matchConFamily ) import MatchLit ( matchLiterals, matchNPlusKPats, matchNPats, tidyLitPat, tidyNPat ) import PrelInfo ( pAT_ERROR_ID ) import TcType ( Type, tcTyConAppArgs ) -import Type ( splitFunTysN ) +import Type ( splitFunTysN, mkTyVarTys ) import TysWiredIn ( consDataCon, mkTupleTy, mkListTy, tupleCon, parrFakeCon, mkPArrTy ) import BasicTypes ( Boxity(..) ) import ListSetOps ( runs ) -import SrcLoc ( noSrcSpan, noLoc, unLoc, Located(..) ) +import SrcLoc ( noLoc, unLoc, Located(..) ) import Util ( lengthExceeds, notNull ) import Name ( Name ) import Outputable @@ -90,19 +90,21 @@ The next two functions create the warning message. \begin{code} dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM () -dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn - where - warn | qs `lengthExceeds` maximum_output - = pp_context ctx (ptext SLIT("are overlapped")) - (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$ - ptext SLIT("...")) - | otherwise - = pp_context ctx (ptext SLIT("are overlapped")) - (\ f -> vcat $ map (ppr_eqn f kind) qs) +dsShadowWarn ctx@(DsMatchContext kind _ loc) qs + = putSrcSpanDs loc (dsWarn warn) + where + warn | qs `lengthExceeds` maximum_output + = pp_context ctx (ptext SLIT("are overlapped")) + (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$ + ptext SLIT("...")) + | otherwise + = pp_context ctx (ptext SLIT("are overlapped")) + (\ f -> vcat $ map (ppr_eqn f kind) qs) dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM () -dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn +dsIncompleteWarn ctx@(DsMatchContext kind _ loc) pats + = putSrcSpanDs loc (dsWarn warn) where warn = pp_context ctx (ptext SLIT("are non-exhaustive")) (\f -> hang (ptext SLIT("Patterns not matched:")) @@ -113,12 +115,9 @@ dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn dots | pats `lengthExceeds` maximum_output = ptext SLIT("...") | otherwise = empty -pp_context NoMatchContext msg rest_of_msg_fun - = (noSrcSpan, ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id)) - -pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun - = (loc, vcat [ptext SLIT("Pattern match(es)") <+> msg, - sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]) +pp_context (DsMatchContext kind pats _loc) msg rest_of_msg_fun + = vcat [ptext SLIT("Pattern match(es)") <+> msg, + sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]] where (ppr_match, pref) = case kind of @@ -284,19 +283,19 @@ match vars@(v:_) ty eqns_info match_block eqns = case firstPat (head eqns) of - WildPat {} -> matchVariables vars ty eqns - ConPatOut {} -> matchConFamily vars ty eqns - NPlusKPatOut {} -> matchNPlusKPats vars ty eqns - NPatOut {} -> matchNPats vars ty eqns - LitPat {} -> matchLiterals vars ty eqns + WildPat {} -> matchVariables vars ty eqns + ConPatOut {} -> matchConFamily vars ty eqns + NPlusKPat {} -> matchNPlusKPats vars ty eqns + NPat {} -> matchNPats vars ty eqns + LitPat {} -> matchLiterals vars ty eqns -- After tidying, there are only five kinds of patterns -samePatFamily (WildPat {}) (WildPat {}) = True -samePatFamily (ConPatOut {}) (ConPatOut {}) = True -samePatFamily (NPlusKPatOut {}) (NPlusKPatOut {}) = True -samePatFamily (NPatOut {}) (NPatOut {}) = True -samePatFamily (LitPat {}) (LitPat {}) = True -samePatFamily _ _ = False +samePatFamily (WildPat {}) (WildPat {}) = True +samePatFamily (ConPatOut {}) (ConPatOut {}) = True +samePatFamily (NPlusKPat {}) (NPlusKPat {}) = True +samePatFamily (NPat {}) (NPat {}) = True +samePatFamily (LitPat {}) (LitPat {}) = True +samePatFamily _ _ = False matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- Real true variables, just like in matchVar, SLPJ p 94 @@ -344,7 +343,7 @@ Float, Double, at least) are converted to unboxed form; e.g., \begin{code} tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo - -- DsM'd because of internal call to dsHsNestedBinds + -- DsM'd because of internal call to dsLHsBinds -- and mkSelectorBinds. -- "tidy1" does the interesting stuff, looking at -- one pattern and fiddling the list of bindings. @@ -402,7 +401,7 @@ tidy1 v wrap (VarPat var) = returnDs (wrap . wrapBind var v, WildPat (idType var)) tidy1 v wrap (VarPatOut var binds) - = do { prs <- dsHsNestedBinds binds + = do { prs <- dsLHsBinds binds ; return (wrap . wrapBind var v . mkDsLet (Rec prs), WildPat (idType var)) } @@ -435,7 +434,7 @@ tidy1 v wrap (LazyPat pat) tidy1 v wrap (ConPatOut (L loc con) ex_tvs dicts binds ps pat_ty) = returnDs (wrap, ConPatOut (L loc con) ex_tvs dicts binds tidy_ps pat_ty) where - tidy_ps = PrefixCon (tidy_con con pat_ty ps) + tidy_ps = PrefixCon (tidy_con con ex_tvs pat_ty ps) tidy1 v wrap (ListPat pats ty) = returnDs (wrap, unLoc list_ConPat) @@ -474,8 +473,8 @@ tidy1 v wrap pat@(LitPat lit) = returnDs (wrap, unLoc (tidyLitPat lit (noLoc pat))) -- NPats: we *might* be able to replace these w/ a simpler form -tidy1 v wrap pat@(NPatOut lit lit_ty _) - = returnDs (wrap, unLoc (tidyNPat lit lit_ty (noLoc pat))) +tidy1 v wrap pat@(NPat lit mb_neg _ lit_ty) + = returnDs (wrap, unLoc (tidyNPat lit mb_neg lit_ty (noLoc pat))) -- and everything else goes through unchanged... @@ -483,9 +482,9 @@ tidy1 v wrap non_interesting_pat = returnDs (wrap, non_interesting_pat) -tidy_con data_con pat_ty (PrefixCon ps) = ps -tidy_con data_con pat_ty (InfixCon p1 p2) = [p1,p2] -tidy_con data_con pat_ty (RecCon rpats) +tidy_con data_con ex_tvs pat_ty (PrefixCon ps) = ps +tidy_con data_con ex_tvs pat_ty (InfixCon p1 p2) = [p1,p2] +tidy_con data_con ex_tvs pat_ty (RecCon rpats) | null rpats = -- Special case for C {}, which can be used for -- a constructor that isn't declared to have @@ -493,14 +492,13 @@ tidy_con data_con pat_ty (RecCon rpats) map (noLoc . WildPat) con_arg_tys' | otherwise - = ASSERT( isVanillaDataCon data_con ) - -- We're in a record case, so the data con must be vanilla - -- and hence no existentials to worry about - map mk_pat tagged_arg_tys + = map mk_pat tagged_arg_tys where -- Boring stuff to find the arg-tys of the constructor - inst_tys = tcTyConAppArgs pat_ty -- Newtypes must be opaque + inst_tys | isVanillaDataCon data_con = tcTyConAppArgs pat_ty -- Newtypes must be opaque + | otherwise = mkTyVarTys ex_tvs + con_arg_tys' = dataConInstOrigArgTys data_con inst_tys tagged_arg_tys = con_arg_tys' `zip` dataConFieldLabels data_con @@ -700,33 +698,35 @@ matchSimply :: CoreExpr -- Scrutinee -> CoreExpr -- Return this if it doesn't -> DsM CoreExpr -matchSimply scrut kind pat result_expr fail_expr - = getSrcSpanDs `thenDs` \ locn -> - let - ctx = DsMatchContext kind [unLoc pat] locn +matchSimply scrut hs_ctx pat result_expr fail_expr + = let match_result = cantFailMatchResult result_expr rhs_ty = exprType fail_expr -- Use exprType of fail_expr, because won't refine in the case of failure! in - matchSinglePat scrut ctx pat rhs_ty match_result `thenDs` \ match_result' -> + matchSinglePat scrut hs_ctx pat rhs_ty match_result `thenDs` \ match_result' -> extractMatchResult match_result' fail_expr -matchSinglePat :: CoreExpr -> DsMatchContext -> LPat Id +matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id -> Type -> MatchResult -> DsM MatchResult -matchSinglePat (Var var) ctx pat ty match_result - = getDOptsDs `thenDs` \ dflags -> +matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result + = getDOptsDs `thenDs` \ dflags -> + getSrcSpanDs `thenDs` \ locn -> + let + match_fn dflags + | dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx + | otherwise = match + where + ds_ctx = DsMatchContext hs_ctx [pat] locn + in match_fn dflags [var] ty [EqnInfo { eqn_wrap = idWrapper, - eqn_pats = [unLoc pat], + eqn_pats = [pat], eqn_rhs = match_result }] - where - match_fn dflags - | dopt Opt_WarnSimplePatterns dflags = matchCheck ctx - | otherwise = match -matchSinglePat scrut ctx pat ty match_result +matchSinglePat scrut hs_ctx pat ty match_result = selectSimpleMatchVarL pat `thenDs` \ var -> - matchSinglePat (Var var) ctx pat ty match_result `thenDs` \ match_result' -> + matchSinglePat (Var var) hs_ctx pat ty match_result `thenDs` \ match_result' -> returnDs (adjustMatchResult (bindNonRec var scrut) match_result') \end{code}