%
+% (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}
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, hsPatType )
-import Check ( check, ExhaustivePat )
+import TcHsSyn
+import Check
import CoreSyn
-import Literal ( Literal )
-import CoreUtils ( bindNonRec, exprType )
+import Literal
+import CoreUtils
+import MkCore
import DsMonad
-import DsBinds ( dsLHsBinds, dsCoercion )
-import DsGRHSs ( dsGRHSs )
+import DsBinds
+import DsGRHSs
import DsUtils
-import Id ( idName, idType, Id )
-import DataCon ( DataCon )
-import MatchCon ( matchConFamily )
-import MatchLit ( matchLiterals, matchNPlusKPats, matchNPats,
- tidyLitPat, tidyNPat, hsLitKey, hsOverLitKey )
-import PrelInfo ( pAT_ERROR_ID )
-import TcType ( Type )
-import Type ( splitFunTysN, coreEqType )
-import TysWiredIn ( consDataCon, mkListTy, unitTy,
- tupleCon, parrFakeCon, mkPArrTy )
-import BasicTypes ( Boxity(..) )
-import ListSetOps ( equivClasses, runs )
-import SrcLoc ( unLoc, Located(..) )
-import Maybes ( isJust )
-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 Outputable
+import FastString
+
+import qualified Data.Map as Map
\end{code}
This function is a wrapper of @match@, it must be called from all the parts where
-> [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
(ToDo: add command-line option?)
\begin{code}
+maximum_output :: Int
maximum_output = 4
\end{code}
= 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 ctx@(DsMatchContext kind loc) pats
= 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}
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).
corresponds roughly to @matchVarCon@.
\begin{code}
-match :: [Id] -- Variables rep'ing the exprs we're matching with
+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
- = ASSERT( not (null eqns) )
- returnDs (foldr1 combineMatchResults match_results)
+ = ASSERT2( not (null eqns), ppr ty )
+ return (foldr1 combineMatchResults match_results)
where
match_results = [ ASSERT( null (eqn_pats eqn) )
eqn_rhs eqn
= ASSERT( not (null eqns ) )
do { -- Tidy the first pattern, generating
-- auxiliary bindings if necessary
- (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
+ (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
-- Group the equations and match each group in turn
- ; match_results <- mapM match_group (groupEquations tidy_eqns)
+ ; let grouped = groupEquations tidy_eqns
+
+ -- print the view patterns that are commoned up to help debug
+ ; ifDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
+ ; match_results <- mapM match_group grouped
; return (adjustMatchResult (foldr1 (.) aux_binds) $
foldr1 combineMatchResults match_results) }
where
dropGroup = map snd
match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
+ match_group [] = panic "match_group"
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)
+ = 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)
+matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)
+matchVariables [] _ _ = panic "matchVariables"
matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
matchBangs (var:vars) ty eqns
- = do { match_result <- match (var:vars) ty (map shift eqns)
+ = do { match_result <- match (var:vars) ty $
+ map (decomposeFirstPat getBangPat) eqns
; return (mkEvalMatchResult var ty match_result) }
- where
- shift eqn@(EqnInfo { eqn_pats = BangPat pat : pats })
- = eqn { eqn_pats = unLoc pat : pats }
+matchBangs [] _ _ = panic "matchBangs"
matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
-- Apply the coercion to the match variable and then match that
-matchCoercion (var:vars) ty (eqn1:eqns)
+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 shift (eqn1:eqns))
- ; rhs <- dsCoercion co (return (Var var))
- ; return (mkCoLetMatchResult (NonRec var' rhs) match_result) }
- where
- shift eqn@(EqnInfo { eqn_pats = CoPat _ pat _ : pats })
- = eqn { eqn_pats = pat : pats }
+ ; var' <- newUniqueId var (hsPatType pat)
+ ; match_result <- match (var':vars) ty $
+ map (decomposeFirstPat getCoPat) eqns
+ ; co' <- dsHsWrapper co
+ ; let rhs' = co' (Var var)
+ ; return (mkCoLetMatchResult (NonRec var' rhs') match_result) }
+matchCoercion _ _ _ = panic "matchCoercion"
+
+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 (decomposeFirstPat getViewPat) eqns
+ -- compile the view expressions
+ ; viewExpr' <- dsLExpr viewExpr
+ ; return (mkViewMatchResult var' viewExpr' var match_result) }
+matchView _ _ _ = panic "matchView"
+
+-- 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}
+decomposeFirstPat _ _ = panic "decomposeFirstPat"
+
+getCoPat, getBangPat, getViewPat :: Pat Id -> Pat Id
+getCoPat (CoPat _ pat _) = pat
+getCoPat _ = panic "getCoPat"
+getBangPat (BangPat pat ) = unLoc pat
+getBangPat _ = panic "getBangPat"
+getViewPat (ViewPat _ pat _) = unLoc pat
+getViewPat _ = panic "getBangPat"
\end{code}
%************************************************************************
-- NPlusKPat
-- but no other
+tidyEqnInfo _ (EqnInfo { eqn_pats = [] })
+ = panic "tidyEqnInfo"
+
tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats })
- = tidy1 v pat `thenDs` \ (wrap, pat') ->
- returnDs (wrap, eqn { eqn_pats = pat' : pats })
+ = do { (wrap, pat') <- tidy1 v pat
+ ; return (wrap, eqn { eqn_pats = do pat' : pats }) }
tidy1 :: Id -- The Id being scrutinised
-> Pat Id -- The pattern against which it is to be matched
tidy1 v (ParPat pat) = tidy1 v (unLoc pat)
tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat)
-tidy1 v (WildPat ty) = returnDs (idWrapper, WildPat ty)
+tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty)
-- case v of { x -> mr[] }
-- = case v of { _ -> let x=v in mr[] }
tidy1 v (VarPat var)
- = returnDs (wrapBind var v, WildPat (idType var))
+ = return (wrapBind var v, WildPat (idType var))
tidy1 v (VarPatOut var binds)
- = do { prs <- dsLHsBinds binds
- ; return (wrapBind var v . mkDsLet (Rec prs),
+ = do { ds_ev_binds <- dsTcEvBinds binds
+ ; return (wrapBind var v . wrapDsEvBinds ds_ev_binds,
WildPat (idType var)) }
-- case v of { x@p -> mr[] }
tidy1 v (LazyPat pat)
= do { sel_prs <- mkSelectorBinds pat (Var v)
; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
- ; returnDs (mkDsLets sel_binds, WildPat (idType v)) }
+ ; return (mkCoreLets sel_binds, WildPat (idType v)) }
-tidy1 v (ListPat pats ty)
- = returnDs (idWrapper, 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)
-- Introduce fake parallel array constructors to be able to handle parallel
-- arrays with the existing machinery for constructor pattern
-tidy1 v (PArrPat pats ty)
- = returnDs (idWrapper, unLoc parrConPat)
+tidy1 _ (PArrPat pats ty)
+ = return (idDsWrapper, unLoc parrConPat)
where
arity = length pats
parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
-tidy1 v (TuplePat pats boxity ty)
- = returnDs (idWrapper, 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 (DictPat dicts methods)
- = case num_of_d_and_ms of
- 0 -> tidy1 v (TuplePat [] Boxed unitTy)
- 1 -> tidy1 v (unLoc (head dict_and_method_pats))
- _ -> tidy1 v (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 (LitPat lit)
- = returnDs (idWrapper, tidyLitPat lit)
+tidy1 _ (LitPat lit)
+ = return (idDsWrapper, tidyLitPat lit)
-- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 v (NPat lit mb_neg eq lit_ty)
- = returnDs (idWrapper, tidyNPat lit mb_neg eq lit_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 v non_interesting_pat
- = returnDs (idWrapper, non_interesting_pat)
+tidy1 _ non_interesting_pat
+ = return (idDsWrapper, non_interesting_pat)
\end{code}
\noindent
\begin{code}
matchWrapper ctxt (MatchGroup matches match_ty)
- = do { eqns_info <- mapM mk_eqn_info matches
+ = 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) }
-> [Id] -> [EquationInfo] -> Type
-> DsM CoreExpr
matchEquations ctxt vars eqns_info rhs_ty
- = do { dflags <- getDOptsDs
- ; locn <- getSrcSpanDs
- ; let ds_ctxt = DsMatchContext ctxt locn
- error_string = matchContextErrString ctxt
+ = do { locn <- getSrcSpanDs
+ ; let ds_ctxt = DsMatchContext ctxt locn
+ error_doc = matchContextErrString ctxt
- ; match_result <- match_fun dflags ds_ctxt vars rhs_ty eqns_info
+ ; match_result <- matchCheck 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
- = case ctxt of
- LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchCheck ds_ctxt
- | otherwise -> match
- _ -> matchCheck ds_ctxt
\end{code}
%************************************************************************
-> CoreExpr -- Return this if it matches
-> CoreExpr -- Return this if it doesn't
-> DsM CoreExpr
-
-matchSimply scrut hs_ctx pat result_expr fail_expr
- = let
+-- Do not warn about incomplete patterns; see matchSinglePat comments
+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 ->
- let
- match_fn dflags
- | dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx
- | otherwise = match
- where
- ds_ctx = DsMatchContext hs_ctx locn
- in
- 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 ->
- matchSinglePat (Var var) hs_ctx pat ty match_result `thenDs` \ match_result' ->
- returnDs (adjustMatchResult (bindNonRec var scrut) match_result')
+-- Do not warn about incomplete patterns
+-- Used for things like [ e | pat <- stuff ], where
+-- incomplete patterns are just fine
+matchSinglePat (Var var) _ (L _ pat) ty match_result
+ = match [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}
| 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
-subGroups :: [(PatGroup, EquationInfo)] -> [[EquationInfo]]
+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.
--- The order may be swizzled, so the matching should be order-independent
-subGroups groups = map (map snd) (equivClasses cmp groups)
+-- Each sub-list in the result has the same PatGroup
+-- See Note [Take care with pattern order]
+subGroup group
+ = map reverse $ Map.elems $ foldl accumulate Map.empty group
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
+ accumulate pg_map (pg, eqn)
+ = case Map.lookup pg pg_map of
+ Just eqns -> Map.insert pg (eqn:eqns) pg_map
+ Nothing -> Map.insert pg [eqn] pg_map
+
+ -- pg_map :: Map 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
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 (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,_) = lexp e1 e2
+ where
+ lexp :: LHsExpr Id -> LHsExpr Id -> Bool
+ lexp e e' = exp (unLoc e) (unLoc e')
+
+ ---------
+ exp :: HsExpr Id -> HsExpr Id -> Bool
+ -- 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
+
+ ---------
+ wrap :: HsWrapper -> HsWrapper -> Bool
+ -- 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 et1) (WpEvApp et2) = ev_term et1 et2
+ wrap (WpTyApp t) (WpTyApp t') = tcEqType t t'
+ -- Enhancement: could implement equality for more wrappers
+ -- if it seems useful (lams and lets)
+ wrap _ _ = False
+
+ ---------
+ ev_term :: EvTerm -> EvTerm -> Bool
+ ev_term (EvId a) (EvId b) = a==b
+ ev_term (EvCoercion a) (EvCoercion b) = tcEqType a b
+ ev_term _ _ = False
+
+ ---------
+ 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
+
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 (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 inner pattern
+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]
-~~~~~~~~~~~~~~~~~~~
+Note [Grouping overloaded literal patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WATCH OUT! Consider
f (n+1) = ...
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.
+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.