%
+% (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}
\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"))
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:"))
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)
\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.
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
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
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}
\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
-- 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'
-- 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 :
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 <con-something> 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)
-- 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
\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
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 ->
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.
projects / ghc-hetmet.git / blobdiff