X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FMatch.lhs;h=d64a649b3717215fe2ee94381a5f33ea4bec0e5a;hp=d72d6adf173a55e47c5e9db12720bbfac13a96da;hb=7fc01c4671980ea3c66d549c0ece4d82fd3f5ade;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index d72d6ad..d64a649 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -1,38 +1,50 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[Main_match]{The @match@ function} + +The @match@ function \begin{code} +{-# OPTIONS -fno-warn-incomplete-patterns #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where #include "HsVersions.h" -import DynFlags ( DynFlag(..), dopt ) +import {-#SOURCE#-} DsExpr (dsLExpr) + +import DynFlags import HsSyn -import TcHsSyn ( mkVanillaTuplePat ) -import Check ( check, ExhaustivePat ) +import TcHsSyn +import Check import CoreSyn -import CoreUtils ( bindNonRec, exprType ) +import Literal +import CoreUtils +import MkCore import DsMonad -import DsBinds ( dsLHsBinds ) -import DsGRHSs ( dsGRHSs ) +import DsBinds +import DsGRHSs import DsUtils -import Id ( idName, idType, Id ) -import DataCon ( dataConFieldLabels, dataConInstOrigArgTys, isVanillaDataCon ) -import MatchCon ( matchConFamily ) -import MatchLit ( matchLiterals, matchNPlusKPats, matchNPats, tidyLitPat, tidyNPat ) -import PrelInfo ( pAT_ERROR_ID ) -import TcType ( Type, tcTyConAppArgs ) -import Type ( splitFunTysN, mkTyVarTys ) -import TysWiredIn ( consDataCon, mkListTy, unitTy, - tupleCon, parrFakeCon, mkPArrTy ) -import BasicTypes ( Boxity(..) ) -import ListSetOps ( runs ) -import SrcLoc ( noLoc, unLoc, Located(..) ) -import Util ( lengthExceeds, notNull ) -import Name ( Name ) +import Id +import DataCon +import MatchCon +import MatchLit +import Type +import TysWiredIn +import ListSetOps +import SrcLoc +import Maybes +import Util +import Name +import FiniteMap import Outputable +import FastString \end{code} This function is a wrapper of @match@, it must be called from all the parts where @@ -49,20 +61,26 @@ matchCheck :: DsMatchContext -> [EquationInfo] -- Info about patterns, etc. (type synonym below) -> DsM MatchResult -- Desugared result! -matchCheck ctx vars ty qs - = getDOptsDs `thenDs` \ dflags -> - matchCheck_really dflags ctx vars ty qs +matchCheck ctx vars ty qs = do + dflags <- getDOptsDs + matchCheck_really dflags ctx vars ty qs +matchCheck_really :: DynFlags + -> DsMatchContext + -> [Id] + -> Type + -> [EquationInfo] + -> DsM MatchResult matchCheck_really dflags ctx vars ty qs - | incomplete && shadow = - dsShadowWarn ctx eqns_shadow `thenDs` \ () -> - dsIncompleteWarn ctx pats `thenDs` \ () -> + | incomplete && shadow = do + dsShadowWarn ctx eqns_shadow + dsIncompleteWarn ctx pats match vars ty qs - | incomplete = - dsIncompleteWarn ctx pats `thenDs` \ () -> + | incomplete = do + dsIncompleteWarn ctx pats match vars ty qs - | shadow = - dsShadowWarn ctx eqns_shadow `thenDs` \ () -> + | shadow = do + dsShadowWarn ctx eqns_shadow match vars ty qs | otherwise = match vars ty qs @@ -83,6 +101,7 @@ It will limit the number of patterns/equations displayed to@ maximum_output@. (ToDo: add command-line option?) \begin{code} +maximum_output :: Int maximum_output = 4 \end{code} @@ -91,56 +110,67 @@ The next two functions create the warning message. \begin{code} dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM () dsShadowWarn ctx@(DsMatchContext kind loc) qs - = putSrcSpanDs loc (dsWarn warn) + = putSrcSpanDs loc (warnDs warn) where warn | qs `lengthExceeds` maximum_output - = pp_context ctx (ptext SLIT("are overlapped")) + = pp_context ctx (ptext (sLit "are overlapped")) (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$ - ptext SLIT("...")) + ptext (sLit "...")) | otherwise - = pp_context ctx (ptext SLIT("are overlapped")) + = pp_context ctx (ptext (sLit "are overlapped")) (\ f -> vcat $ map (ppr_eqn f kind) qs) dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM () dsIncompleteWarn ctx@(DsMatchContext kind loc) pats - = putSrcSpanDs loc (dsWarn warn) + = putSrcSpanDs loc (warnDs warn) where - warn = pp_context ctx (ptext SLIT("are non-exhaustive")) - (\f -> hang (ptext SLIT("Patterns not matched:")) + warn = pp_context ctx (ptext (sLit "are non-exhaustive")) + (\_ -> hang (ptext (sLit "Patterns not matched:")) 4 ((vcat $ map (ppr_incomplete_pats kind) (take maximum_output pats)) $$ dots)) - dots | pats `lengthExceeds` maximum_output = ptext SLIT("...") + dots | pats `lengthExceeds` maximum_output = ptext (sLit "...") | otherwise = empty +pp_context :: DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc pp_context (DsMatchContext kind _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)]] + = 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 - FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) - other -> (pprMatchContext kind, \ pp -> pp) + FunRhs fun _ -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) + _ -> (pprMatchContext kind, \ pp -> pp) +ppr_pats :: Outputable a => [a] -> SDoc ppr_pats pats = sep (map ppr pats) +ppr_shadow_pats :: HsMatchContext Name -> [Pat Id] -> SDoc ppr_shadow_pats kind pats - = sep [ppr_pats pats, matchSeparator kind, ptext SLIT("...")] - -ppr_incomplete_pats kind (pats,[]) = ppr_pats pats -ppr_incomplete_pats kind (pats,constraints) = - sep [ppr_pats pats, ptext SLIT("with"), + = sep [ppr_pats pats, matchSeparator kind, ptext (sLit "...")] + +ppr_incomplete_pats :: HsMatchContext Name -> ExhaustivePat -> SDoc +ppr_incomplete_pats _ (pats,[]) = ppr_pats pats +ppr_incomplete_pats _ (pats,constraints) = + sep [ppr_pats pats, ptext (sLit "with"), sep (map ppr_constraint constraints)] - -ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`notElem`"), ppr pats] +ppr_constraint :: (Name,[HsLit]) -> SDoc +ppr_constraint (var,pats) = sep [ppr var, ptext (sLit "`notElem`"), ppr pats] +ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> EquationInfo -> SDoc ppr_eqn prefixF kind eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn)) \end{code} +%************************************************************************ +%* * + The main matching function +%* * +%************************************************************************ + The function @match@ is basically the same as in the Wadler chapter, except it is monadised, to carry around the name supply, info about annotations, etc. @@ -191,13 +221,6 @@ Leaving out this third argument to @match@ (and slamming in lots of impossible to share the default expressions. (Also, it stands no chance of working in our post-upheaval world of @Locals@.) \end{enumerate} -So, the full type signature: -\begin{code} -match :: [Id] -- Variables rep'ing the exprs we're matching with - -> Type -- Type of the case expression - -> [EquationInfo] -- Info about patterns, etc. (type synonym below) - -> DsM MatchResult -- Desugared result! -\end{code} Note: @match@ is often called via @matchWrapper@ (end of this module), a function that does much of the house-keeping that goes with a call @@ -220,7 +243,7 @@ Make all constructor patterns in column~1 into @ConPats@, notably Handle any irrefutable (or ``twiddle'') @LazyPats@. \end{itemize} \item -Now {\em unmix} the equations into {\em blocks} [w/ local function +Now {\em unmix} the equations into {\em blocks} [w\/ local function @unmix_eqns@], in which the equations in a block all have variable patterns in column~1, or they all have constructor patterns in ... (see ``the mixture rule'' in SLPJ). @@ -230,35 +253,10 @@ appropriate thing for each kind of column-1 pattern, usually ending up in a recursive call to @match@. \end{enumerate} -%************************************************************************ -%* * -%* match: empty rule * -%* * -%************************************************************************ -\subsection[Match-empty-rule]{The ``empty rule''} - We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87) than the Wadler-chapter code for @match@ (p.~93, first @match@ clause). And gluing the ``success expressions'' together isn't quite so pretty. -\begin{code} -match [] ty eqns_info - = ASSERT( not (null eqns_info) ) - returnDs (foldr1 combineMatchResults match_results) - where - match_results = [ ASSERT( null (eqn_pats eqn) ) - adjustMatchResult (eqn_wrap eqn) (eqn_rhs eqn) - | eqn <- eqns_info ] -\end{code} - - -%************************************************************************ -%* * -%* match: non-empty rule * -%* * -%************************************************************************ -\subsection[Match-nonempty]{@match@ when non-empty: unmixing} - This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@ (a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and (b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em @@ -271,41 +269,119 @@ Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@ corresponds roughly to @matchVarCon@. \begin{code} -match vars@(v:_) ty eqns_info - = do { tidy_eqns <- mappM (tidyEqnInfo v) eqns_info - ; let eqns_blks = runs same_family tidy_eqns - ; match_results <- mappM match_block eqns_blks - ; ASSERT( not (null match_results) ) - return (foldr1 combineMatchResults match_results) } +match :: [Id] -- Variables rep\'ing the exprs we\'re matching with + -> Type -- Type of the case expression + -> [EquationInfo] -- Info about patterns, etc. (type synonym below) + -> DsM MatchResult -- Desugared result! + +match [] ty eqns + = ASSERT2( not (null eqns), ppr ty ) + return (foldr1 combineMatchResults match_results) + where + match_results = [ ASSERT( null (eqn_pats eqn) ) + eqn_rhs eqn + | eqn <- eqns ] + +match vars@(v:_) ty eqns + = ASSERT( not (null eqns ) ) + do { -- Tidy the first pattern, generating + -- auxiliary bindings if necessary + (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns + + -- Group the equations and match each group in turn + ; let grouped = groupEquations tidy_eqns + + -- print the view patterns that are commoned up to help debug + ; ifOptM Opt_D_dump_view_pattern_commoning (debug grouped) + + ; match_results <- mapM match_group grouped + ; return (adjustMatchResult (foldr1 (.) aux_binds) $ + foldr1 combineMatchResults match_results) } where - same_family eqn1 eqn2 - = samePatFamily (firstPat eqn1) (firstPat eqn2) - - match_block eqns - = case firstPat (head eqns) of - 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 (NPlusKPat {}) (NPlusKPat {}) = True -samePatFamily (NPat {}) (NPat {}) = True -samePatFamily (LitPat {}) (LitPat {}) = True -samePatFamily _ _ = False + dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo] + dropGroup = map snd + + match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult + match_group eqns@((group,_) : _) + = case group of + PgCon _ -> matchConFamily vars ty (subGroup [(c,e) | (PgCon c, e) <- eqns]) + PgLit _ -> matchLiterals vars ty (subGroup [(l,e) | (PgLit l, e) <- eqns]) + + PgAny -> matchVariables vars ty (dropGroup eqns) + PgN _ -> matchNPats vars ty (dropGroup eqns) + PgNpK _ -> matchNPlusKPats vars ty (dropGroup eqns) + PgBang -> matchBangs vars ty (dropGroup eqns) + PgCo _ -> matchCoercion vars ty (dropGroup eqns) + PgView _ _ -> matchView vars ty (dropGroup eqns) + + -- FIXME: we should also warn about view patterns that should be + -- commoned up but are not + + -- print some stuff to see what's getting grouped + -- use -dppr-debug to see the resolution of overloaded lits + debug eqns = + let gs = map (\group -> foldr (\ (p,_) -> \acc -> + case p of PgView e _ -> e:acc + _ -> acc) [] group) eqns + maybeWarn [] = return () + maybeWarn l = warnDs (vcat l) + in + maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g)) + (filter (not . null) gs)) matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- Real true variables, just like in matchVar, SLPJ p 94 -- No binding to do: they'll all be wildcards by now (done in tidy) -matchVariables (var:vars) ty eqns = match vars ty (shiftEqns eqns) -\end{code} - +matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns) + +matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +matchBangs (var:vars) ty eqns + = do { match_result <- match (var:vars) ty (map decomposeFirst_Bang eqns) + ; return (mkEvalMatchResult var ty match_result) } + +matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +-- Apply the coercion to the match variable and then match that +matchCoercion (var:vars) ty (eqns@(eqn1:_)) + = do { let CoPat co pat _ = firstPat eqn1 + ; var' <- newUniqueId var (hsPatType pat) + ; match_result <- match (var':vars) ty (map decomposeFirst_Coercion eqns) + ; co' <- dsHsWrapper co + ; let rhs' = co' (Var var) + ; return (mkCoLetMatchResult (NonRec var' rhs') match_result) } + +matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +-- Apply the view function to the match variable and then match that +matchView (var:vars) ty (eqns@(eqn1:_)) + = do { -- we could pass in the expr from the PgView, + -- but this needs to extract the pat anyway + -- to figure out the type of the fresh variable + let ViewPat viewExpr (L _ pat) _ = firstPat eqn1 + -- do the rest of the compilation + ; var' <- newUniqueId var (hsPatType pat) + ; match_result <- match (var':vars) ty (map decomposeFirst_View eqns) + -- compile the view expressions + ; viewExpr' <- dsLExpr viewExpr + ; return (mkViewMatchResult var' viewExpr' var match_result) } + +-- decompose the first pattern and leave the rest alone +decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo +decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) + = eqn { eqn_pats = extractpat pat : pats} + +decomposeFirst_Coercion, decomposeFirst_Bang, decomposeFirst_View :: EquationInfo -> EquationInfo + +decomposeFirst_Coercion = decomposeFirstPat (\ (CoPat _ pat _) -> pat) +decomposeFirst_Bang = decomposeFirstPat (\ (BangPat pat ) -> unLoc pat) +decomposeFirst_View = decomposeFirstPat (\ (ViewPat _ pat _) -> unLoc pat) \end{code} +%************************************************************************ +%* * + Tidying patterns +%* * +%************************************************************************ + Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@ which will be scrutinised. This means: \begin{itemize} @@ -342,7 +418,8 @@ Float, Double, at least) are converted to unboxed form; e.g., \end{description} \begin{code} -tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo +tidyEqnInfo :: Id -> EquationInfo + -> DsM (DsWrapper, EquationInfo) -- DsM'd because of internal call to dsLHsBinds -- and mkSelectorBinds. -- "tidy1" does the interesting stuff, looking at @@ -356,30 +433,15 @@ tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo -- NPlusKPat -- but no other -tidyEqnInfo v eqn@(EqnInfo { eqn_wrap = wrap, eqn_pats = pat : pats }) - = tidy1 v wrap pat `thenDs` \ (wrap', pat') -> - returnDs (eqn { eqn_wrap = wrap', eqn_pats = pat' : pats }) +tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats }) = do + (wrap, pat') <- tidy1 v pat + return (wrap, eqn { eqn_pats = do pat' : pats }) tidy1 :: Id -- The Id being scrutinised - -> DsWrapper -- Previous wrapping bindings -> Pat Id -- The pattern against which it is to be matched - -> DsM (DsWrapper, -- Extra bindings around what to do afterwards + -> DsM (DsWrapper, -- Extra bindings to do before the match Pat Id) -- Equivalent pattern --- The extra bindings etc are all wrapped around the RHS of the match --- so they are only available when matching is complete. But that's ok --- becuase, for example, in the pattern x@(...), the x can only be --- used in the RHS, not in the nested pattern, nor subsquent patterns --- --- However this does have an awkward consequence. The bindings in --- a VarPatOut get wrapped around the result in right to left order, --- rather than left to right. This only matters if one set of --- bindings can mention things used in another, and that can happen --- if we allow equality dictionary bindings of form d1=d2. --- bindIInstsOfLocalFuns is now careful not to do this, but it's a wart. --- (Without this care in bindInstsOfLocalFuns, compiling --- Data.Generics.Schemes.hs fails in function everywhereBut.) - ------------------------------------------------------- -- (pat', mr') = tidy1 v pat mr -- tidies the *outer level only* of pat, giving pat' @@ -391,27 +453,25 @@ tidy1 :: Id -- The Id being scrutinised -- NPat -- NPlusKPat -tidy1 v wrap (ParPat pat) = tidy1 v wrap (unLoc pat) -tidy1 v wrap (SigPatOut pat _) = tidy1 v wrap (unLoc pat) -tidy1 v wrap (WildPat ty) = returnDs (wrap, WildPat ty) +tidy1 v (ParPat pat) = tidy1 v (unLoc pat) +tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat) +tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty) -- case v of { x -> mr[] } -- = case v of { _ -> let x=v in mr[] } -tidy1 v wrap (VarPat var) - = returnDs (wrap . wrapBind var v, WildPat (idType var)) +tidy1 v (VarPat var) + = return (wrapBind var v, WildPat (idType var)) -tidy1 v wrap (VarPatOut var binds) - = do { prs <- dsLHsBinds binds - ; return (wrap . wrapBind var v . mkDsLet (Rec prs), +tidy1 v (VarPatOut var binds) + = do { ds_ev_binds <- dsTcEvBinds binds + ; return (wrapBind var v . wrapDsEvBinds ds_ev_binds, WildPat (idType var)) } -- case v of { x@p -> mr[] } -- = case v of { p -> let x=v in mr[] } -tidy1 v wrap (AsPat (L _ var) pat) - = tidy1 v (wrap . wrapBind var v) (unLoc pat) - -tidy1 v wrap (BangPat pat) - = tidy1 v (wrap . seqVar v) (unLoc pat) +tidy1 v (AsPat (L _ var) pat) + = do { (wrap, pat') <- tidy1 v (unLoc pat) + ; return (wrapBind var v . wrap, pat') } {- now, here we handle lazy patterns: tidy1 v ~p bs = (v, v1 = case v of p -> v1 : @@ -424,22 +484,13 @@ tidy1 v wrap (BangPat pat) The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr -} -tidy1 v wrap (LazyPat pat) - = do { v' <- newSysLocalDs (idType v) - ; sel_prs <- mkSelectorBinds pat (Var v) +tidy1 v (LazyPat pat) + = do { sel_prs <- mkSelectorBinds pat (Var v) ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] - ; returnDs (wrap . wrapBind v' v . mkDsLets sel_binds, - WildPat (idType v)) } - --- re-express as (ConPat ...) [directly] + ; return (mkCoreLets sel_binds, WildPat (idType v)) } -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 ex_tvs pat_ty ps) - -tidy1 v wrap (ListPat pats ty) - = returnDs (wrap, unLoc list_ConPat) +tidy1 _ (ListPat pats ty) + = return (idDsWrapper, unLoc list_ConPat) where list_ty = mkListTy ty list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty) @@ -448,67 +499,45 @@ tidy1 v wrap (ListPat pats ty) -- Introduce fake parallel array constructors to be able to handle parallel -- arrays with the existing machinery for constructor pattern -tidy1 v wrap (PArrPat pats ty) - = returnDs (wrap, unLoc parrConPat) +tidy1 _ (PArrPat pats ty) + = return (idDsWrapper, unLoc parrConPat) where arity = length pats parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty) -tidy1 v wrap (TuplePat pats boxity ty) - = returnDs (wrap, unLoc tuple_ConPat) +tidy1 _ (TuplePat pats boxity ty) + = return (idDsWrapper, unLoc tuple_ConPat) where arity = length pats tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty -tidy1 v wrap (DictPat dicts methods) - = case num_of_d_and_ms of - 0 -> tidy1 v wrap (TuplePat [] Boxed unitTy) - 1 -> tidy1 v wrap (unLoc (head dict_and_method_pats)) - _ -> tidy1 v wrap (mkVanillaTuplePat dict_and_method_pats Boxed) - where - num_of_d_and_ms = length dicts + length methods - dict_and_method_pats = map nlVarPat (dicts ++ methods) - -- LitPats: we *might* be able to replace these w/ a simpler form -tidy1 v wrap pat@(LitPat lit) - = returnDs (wrap, unLoc (tidyLitPat lit (noLoc pat))) +tidy1 _ (LitPat lit) + = return (idDsWrapper, tidyLitPat lit) -- NPats: we *might* be able to replace these w/ a simpler form -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... - -tidy1 v wrap non_interesting_pat - = returnDs (wrap, non_interesting_pat) - - -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 - -- fields at all - map (noLoc . WildPat) con_arg_tys' - - | otherwise - = map mk_pat tagged_arg_tys - where - -- Boring stuff to find the arg-tys of the constructor - - 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 - - -- mk_pat picks a WildPat of the appropriate type for absent fields, - -- and the specified pattern for present fields - mk_pat (arg_ty, lbl) = - case [ pat | (sel_id,pat) <- rpats, idName (unLoc sel_id) == lbl] of - (pat:pats) -> ASSERT( null pats ) pat - [] -> noLoc (WildPat arg_ty) +tidy1 _ (NPat lit mb_neg eq) + = return (idDsWrapper, tidyNPat lit mb_neg eq) + +-- BangPatterns: Pattern matching is already strict in constructors, +-- tuples etc, so the last case strips off the bang for thoses patterns. +tidy1 v (BangPat (L _ (LazyPat p))) = tidy1 v (BangPat p) +tidy1 v (BangPat (L _ (ParPat p))) = tidy1 v (BangPat p) +tidy1 _ p@(BangPat (L _(VarPat _))) = return (idDsWrapper, p) +tidy1 _ p@(BangPat (L _(VarPatOut _ _))) = return (idDsWrapper, p) +tidy1 _ p@(BangPat (L _ (WildPat _))) = return (idDsWrapper, p) +tidy1 _ p@(BangPat (L _ (CoPat _ _ _))) = return (idDsWrapper, p) +tidy1 _ p@(BangPat (L _ (SigPatIn _ _))) = return (idDsWrapper, p) +tidy1 _ p@(BangPat (L _ (SigPatOut _ _))) = return (idDsWrapper, p) +tidy1 v (BangPat (L _ (AsPat (L _ var) pat))) + = do { (wrap, pat') <- tidy1 v (BangPat pat) + ; return (wrapBind var v . wrap, pat') } +tidy1 v (BangPat (L _ p)) = tidy1 v p + +-- Everything else goes through unchanged... + +tidy1 _ non_interesting_pat + = return (idDsWrapper, non_interesting_pat) \end{code} \noindent @@ -650,21 +679,20 @@ JJQC 30-Nov-1997 \begin{code} matchWrapper ctxt (MatchGroup matches match_ty) - = do { eqns_info <- mapM mk_eqn_info matches - ; new_vars <- selectMatchVars arg_pats pat_tys + = ASSERT( notNull matches ) + do { eqns_info <- mapM mk_eqn_info matches + ; new_vars <- selectMatchVars arg_pats ; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty ; return (new_vars, result_expr) } where - arg_pats = map unLoc (hsLMatchPats (head matches)) - n_pats = length arg_pats - (pat_tys, rhs_ty) = splitFunTysN n_pats match_ty + arg_pats = map unLoc (hsLMatchPats (head matches)) + n_pats = length arg_pats + (_, rhs_ty) = splitFunTysN n_pats match_ty mk_eqn_info (L _ (Match pats _ grhss)) = do { let upats = map unLoc pats ; match_result <- dsGRHSs ctxt upats grhss rhs_ty - ; return (EqnInfo { eqn_wrap = idWrapper, - eqn_pats = upats, - eqn_rhs = match_result}) } + ; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) } matchEquations :: HsMatchContext Name @@ -674,11 +702,11 @@ matchEquations ctxt vars eqns_info rhs_ty = do { dflags <- getDOptsDs ; locn <- getSrcSpanDs ; let ds_ctxt = DsMatchContext ctxt locn - error_string = matchContextErrString ctxt + error_doc = matchContextErrString ctxt ; match_result <- match_fun dflags ds_ctxt vars rhs_ty eqns_info - ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string + ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc ; extractMatchResult match_result fail_expr } where match_fun dflags ds_ctxt @@ -706,35 +734,224 @@ matchSimply :: CoreExpr -- Scrutinee -> CoreExpr -- Return this if it doesn't -> DsM CoreExpr -matchSimply scrut hs_ctx pat result_expr fail_expr - = let +matchSimply scrut hs_ctx pat result_expr fail_expr = do + 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 hs_ctx pat rhs_ty match_result `thenDs` \ match_result' -> + rhs_ty = exprType fail_expr + -- Use exprType of fail_expr, because won't refine in the case of failure! + match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result extractMatchResult match_result' fail_expr matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id -> Type -> MatchResult -> DsM MatchResult -matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result - = getDOptsDs `thenDs` \ dflags -> - getSrcSpanDs `thenDs` \ locn -> +matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result = do + dflags <- getDOptsDs + locn <- getSrcSpanDs let - match_fn dflags + match_fn dflags | dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx - | otherwise = match - where - ds_ctx = DsMatchContext hs_ctx locn + | otherwise = match + where + ds_ctx = DsMatchContext hs_ctx locn + match_fn dflags [var] ty [EqnInfo { eqn_pats = [pat], eqn_rhs = match_result }] + +matchSinglePat scrut hs_ctx pat ty match_result = do + var <- selectSimpleMatchVarL pat + match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result + return (adjustMatchResult (bindNonRec var scrut) match_result') +\end{code} + + +%************************************************************************ +%* * + Pattern classification +%* * +%************************************************************************ + +\begin{code} +data PatGroup + = PgAny -- Immediate match: variables, wildcards, + -- lazy patterns + | PgCon DataCon -- Constructor patterns (incl list, tuple) + | PgLit Literal -- Literal patterns + | PgN Literal -- Overloaded literals + | PgNpK Literal -- n+k patterns + | PgBang -- Bang patterns + | PgCo Type -- Coercion patterns; the type is the type + -- of the pattern *inside* + | PgView (LHsExpr Id) -- view pattern (e -> p): + -- the LHsExpr is the expression e + Type -- the Type is the type of p (equivalently, the result type of e) + +groupEquations :: [EquationInfo] -> [[(PatGroup, EquationInfo)]] +-- If the result is of form [g1, g2, g3], +-- (a) all the (pg,eq) pairs in g1 have the same pg +-- (b) none of the gi are empty +-- The ordering of equations is unchanged +groupEquations eqns + = runs same_gp [(patGroup (firstPat eqn), eqn) | eqn <- eqns] + where + same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool + (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2 + +subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]] +-- Input is a particular group. The result sub-groups the +-- equations by with particular constructor, literal etc they match. +-- Each sub-list in the result has the same PatGroup +-- See Note [Take care with pattern order] +subGroup group + = map reverse $ eltsFM $ foldl accumulate emptyFM group + where + accumulate pg_map (pg, eqn) + = case lookupFM pg_map pg of + Just eqns -> addToFM pg_map pg (eqn:eqns) + Nothing -> addToFM pg_map pg [eqn] + + -- pg_map :: FiniteMap a [EquationInfo] + -- Equations seen so far in reverse order of appearance +\end{code} + +Note [Take care with pattern order] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the subGroup function we must be very careful about pattern re-ordering, +Consider the patterns [ (True, Nothing), (False, x), (True, y) ] +Then in bringing together the patterns for True, we must not +swap the Nothing and y! + + +\begin{code} +sameGroup :: PatGroup -> PatGroup -> Bool +-- Same group means that a single case expression +-- or test will suffice to match both, *and* the order +-- of testing within the group is insignificant. +sameGroup PgAny PgAny = True +sameGroup PgBang PgBang = True +sameGroup (PgCon _) (PgCon _) = True -- One case expression +sameGroup (PgLit _) (PgLit _) = True -- One case expression +sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant +sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns] +sameGroup (PgCo t1) (PgCo t2) = t1 `coreEqType` t2 + -- CoPats are in the same goup only if the type of the + -- enclosed pattern is the same. The patterns outside the CoPat + -- always have the same type, so this boils down to saying that + -- the two coercions are identical. +sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2) + -- ViewPats are in the same gorup iff the expressions + -- are "equal"---conservatively, we use syntactic equality +sameGroup _ _ = False + +-- An approximation of syntactic equality used for determining when view +-- exprs are in the same group. +-- This function can always safely return false; +-- but doing so will result in the application of the view function being repeated. +-- +-- Currently: compare applications of literals and variables +-- and anything else that we can do without involving other +-- HsSyn types in the recursion +-- +-- NB we can't assume that the two view expressions have the same type. Consider +-- f (e1 -> True) = ... +-- f (e2 -> "hi") = ... +viewLExprEq :: (LHsExpr Id,Type) -> (LHsExpr Id,Type) -> Bool +viewLExprEq (e1,_) (e2,_) = + let + -- short name for recursive call on unLoc + lexp e e' = exp (unLoc e) (unLoc e') + + eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool + eq_list _ [] [] = True + eq_list _ [] (_:_) = False + eq_list _ (_:_) [] = False + eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys + + -- conservative, in that it demands that wrappers be + -- syntactically identical and doesn't look under binders + -- + -- coarser notions of equality are possible + -- (e.g., reassociating compositions, + -- equating different ways of writing a coercion) + wrap WpHole WpHole = True + wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2' + wrap (WpCast c) (WpCast c') = tcEqType c c' + wrap (WpEvApp _) (WpEvApp _) = panic "ToDo: Match.viewLExprEq" + wrap (WpTyApp t) (WpTyApp t') = tcEqType t t' + -- Enhancement: could implement equality for more wrappers + -- if it seems useful (lams and lets) + wrap _ _ = False + + -- real comparison is on HsExpr's + -- strip parens + exp (HsPar (L _ e)) e' = exp e e' + exp e (HsPar (L _ e')) = exp e e' + -- because the expressions do not necessarily have the same type, + -- we have to compare the wrappers + exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e' + exp (HsVar i) (HsVar i') = i == i' + -- the instance for IPName derives using the id, so this works if the + -- above does + exp (HsIPVar i) (HsIPVar i') = i == i' + exp (HsOverLit l) (HsOverLit l') = + -- Overloaded lits are equal if they have the same type + -- and the data is the same. + -- this is coarser than comparing the SyntaxExpr's in l and l', + -- which resolve the overloading (e.g., fromInteger 1), + -- because these expressions get written as a bunch of different variables + -- (presumably to improve sharing) + tcEqType (overLitType l) (overLitType l') && l == l' + exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2' + -- the fixities have been straightened out by now, so it's safe + -- to ignore them? + exp (OpApp l o _ ri) (OpApp l' o' _ ri') = + lexp l l' && lexp o o' && lexp ri ri' + exp (NegApp e n) (NegApp e' n') = lexp e e' && exp n n' + exp (SectionL e1 e2) (SectionL e1' e2') = + lexp e1 e1' && lexp e2 e2' + exp (SectionR e1 e2) (SectionR e1' e2') = + lexp e1 e1' && lexp e2 e2' + exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) = + eq_list tup_arg es1 es2 + exp (HsIf e e1 e2) (HsIf e' e1' e2') = + lexp e e' && lexp e1 e1' && lexp e2 e2' + + -- Enhancement: could implement equality for more expressions + -- if it seems useful + -- But no need for HsLit, ExplicitList, ExplicitTuple, + -- because they cannot be functions + exp _ _ = False + + tup_arg (Present e1) (Present e2) = lexp e1 e2 + tup_arg (Missing t1) (Missing t2) = tcEqType t1 t2 + tup_arg _ _ = False in - match_fn dflags [var] ty [EqnInfo { eqn_wrap = idWrapper, - eqn_pats = [pat], - eqn_rhs = match_result }] - -matchSinglePat scrut hs_ctx pat ty match_result - = selectSimpleMatchVarL pat `thenDs` \ var -> - matchSinglePat (Var var) hs_ctx pat ty match_result `thenDs` \ match_result' -> - returnDs (adjustMatchResult (bindNonRec var scrut) match_result') + lexp e1 e2 + +patGroup :: Pat Id -> PatGroup +patGroup (WildPat {}) = PgAny +patGroup (BangPat {}) = PgBang +patGroup (ConPatOut { pat_con = dc }) = PgCon (unLoc dc) +patGroup (LitPat lit) = PgLit (hsLitKey lit) +patGroup (NPat olit mb_neg _) = PgN (hsOverLitKey olit (isJust mb_neg)) +patGroup (NPlusKPat _ olit _ _) = PgNpK (hsOverLitKey olit False) +patGroup (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern +patGroup (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) +patGroup pat = pprPanic "patGroup" (ppr pat) \end{code} +Note [Grouping overloaded literal patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +WATCH OUT! Consider + + f (n+1) = ... + f (n+2) = ... + f (n+1) = ... + +We can't group the first and third together, because the second may match +the same thing as the first. Same goes for *overloaded* literal patterns + f 1 True = ... + f 2 False = ... + f 1 False = ... +If the first arg matches '1' but the second does not match 'True', we +cannot jump to the third equation! Because the same argument might +match '2'! +Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.