X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FMatch.lhs;h=3f3a1272bbb7298ec93cedb8c05cdb568d501130;hp=d72d6adf173a55e47c5e9db12720bbfac13a96da;hb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index d72d6ad..3f3a127 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -1,37 +1,48 @@ % +% (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 -w #-} +-- 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 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 PrelInfo +import Type +import TysWiredIn +import BasicTypes +import ListSetOps +import SrcLoc +import Maybes +import Util +import Name import Outputable \end{code} @@ -91,7 +102,7 @@ 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")) @@ -104,7 +115,7 @@ dsShadowWarn ctx@(DsMatchContext kind loc) 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:")) @@ -121,8 +132,8 @@ pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun 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) + other -> (pprMatchContext kind, \ pp -> pp) ppr_pats pats = sep (map ppr pats) @@ -141,6 +152,12 @@ 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 +208,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 @@ -230,35 +240,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 +256,115 @@ 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 ) + returnDs (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 + ; ifOptDs 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 + PgAny -> matchVariables vars ty (dropGroup eqns) + PgCon _ -> matchConFamily vars ty (subGroups eqns) + PgLit _ -> matchLiterals vars ty (subGroups eqns) + PgN lit -> matchNPats vars ty (subGroups eqns) + PgNpK lit -> 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} +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 (idName var) (hsPatType pat) + ; match_result <- match (var':vars) ty (map decomposeFirst_Coercion eqns) + ; rhs <- dsCoercion co (return (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 (idName 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 extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) + = eqn { eqn_pats = extractpat pat : pats} + +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 +401,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 +416,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 }) + = tidy1 v pat `thenDs` \ (wrap, pat') -> + returnDs (wrap, eqn { eqn_pats = 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 +436,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 v (WildPat ty) = returnDs (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) + = returnDs (wrapBind var v, WildPat (idType var)) -tidy1 v wrap (VarPatOut var binds) +tidy1 v (VarPatOut var binds) = do { prs <- dsLHsBinds binds - ; return (wrap . wrapBind var v . mkDsLet (Rec prs), + ; return (wrapBind var v . mkDsLet (Rec prs), 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 +467,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)) } + ; returnDs (mkDsLets sel_binds, WildPat (idType v)) } --- re-express as (ConPat ...) [directly] - -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 v (ListPat pats ty) + = returnDs (idDsWrapper, unLoc list_ConPat) where list_ty = mkListTy ty list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty) @@ -448,67 +482,30 @@ 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 v (PArrPat pats ty) + = returnDs (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 v (TuplePat pats boxity ty) + = returnDs (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 v (LitPat lit) + = returnDs (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) +tidy1 v (NPat lit mb_neg eq) + = returnDs (idDsWrapper, tidyNPat lit mb_neg eq) +-- Everything else goes through unchanged... -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 v non_interesting_pat + = returnDs (idDsWrapper, non_interesting_pat) \end{code} \noindent @@ -650,21 +647,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 @@ -728,9 +724,7 @@ matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result where ds_ctx = DsMatchContext hs_ctx locn in - match_fn dflags [var] ty [EqnInfo { eqn_wrap = idWrapper, - eqn_pats = [pat], - eqn_rhs = match_result }] + match_fn dflags [var] ty [EqnInfo { eqn_pats = [pat], eqn_rhs = match_result }] matchSinglePat scrut hs_ctx pat ty match_result = selectSimpleMatchVarL pat `thenDs` \ var -> @@ -738,3 +732,177 @@ matchSinglePat scrut hs_ctx pat ty match_result returnDs (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 +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 + +subGroups :: [(PatGroup, EquationInfo)] -> [[EquationInfo]] +-- Input is a particular group. The result sub-groups the +-- equations by with particular constructor, literal etc they match. +-- The order may be swizzled, so the matching should be order-independent +subGroups groups = map (map snd) (equivClasses cmp groups) + where + (pg1, _) `cmp` (pg2, _) = pg1 `cmp_pg` pg2 + (PgCon c1) `cmp_pg` (PgCon c2) = c1 `compare` c2 + (PgLit l1) `cmp_pg` (PgLit l2) = l1 `compare` l2 + (PgN l1) `cmp_pg` (PgN l2) = l1 `compare` l2 + -- These are the only cases that are every sub-grouped + +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) = True -- Needs conditionals +sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- Order is significant + -- See Note [Order of n+k] +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,t1) (e2,t2) = + let + -- short name for recursive call on unLoc + lexp e e' = exp (unLoc e) (unLoc e') + + -- check that two lists have the same length + -- and that they match up pairwise + lexps [] [] = True + lexps [] (_:_) = False + lexps (_:_) [] = False + lexps (x:xs) (y:ys) = lexp x y && lexps 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 (WpCo c) (WpCo c') = tcEqType c c' + wrap (WpApp d) (WpApp d') = d == d' + 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' + -- comparing the constants seems right + exp (HsLit l) (HsLit 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 (HsIf e e1 e2) (HsIf e' e1' e2') = + lexp e e' && lexp e1 e1' && lexp e2 e2' + exp (ExplicitList _ ls) (ExplicitList _ ls') = lexps ls ls' + exp (ExplicitPArr _ ls) (ExplicitPArr _ ls') = lexps ls ls' + exp (ExplicitTuple ls _) (ExplicitTuple ls' _) = lexps ls ls' + -- Enhancement: could implement equality for more expressions + -- if it seems useful + exp _ _ = False + in + 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 [Order of n+k] +~~~~~~~~~~~~~~~~~~~ +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. Contrast + f 1 = ... + f 2 = ... + f 1 = ... +where we can group the first and third. Hence we don't regard (n+1) and +(n+2) as part of the same group.