import DynFlags ( DynFlag(..), dopt )
import HsSyn
-import TcHsSyn ( mkVanillaTuplePat )
+import TcHsSyn ( mkVanillaTuplePat, hsPatType )
import Check ( check, ExhaustivePat )
import CoreSyn
+import Literal ( Literal )
import CoreUtils ( bindNonRec, exprType )
import DsMonad
-import DsBinds ( dsLHsBinds )
+import DsBinds ( dsLHsBinds, dsCoercion )
import DsGRHSs ( dsGRHSs )
import DsUtils
import Id ( idName, idType, Id )
-import DataCon ( dataConFieldLabels, dataConInstOrigArgTys, isVanillaDataCon )
+import DataCon ( DataCon )
import MatchCon ( matchConFamily )
-import MatchLit ( matchLiterals, matchNPlusKPats, matchNPats, tidyLitPat, tidyNPat )
+import MatchLit ( matchLiterals, matchNPlusKPats, matchNPats,
+ tidyLitPat, tidyNPat, hsLitKey, hsOverLitKey )
import PrelInfo ( pAT_ERROR_ID )
-import TcType ( Type, tcTyConAppArgs )
-import Type ( splitFunTysN, mkTyVarTys )
+import TcType ( Type )
+import Type ( splitFunTysN, coreEqType )
import TysWiredIn ( consDataCon, mkListTy, unitTy,
tupleCon, parrFakeCon, mkPArrTy )
import BasicTypes ( Boxity(..) )
-import ListSetOps ( runs )
-import SrcLoc ( noLoc, unLoc, Located(..) )
+import ListSetOps ( equivClasses, runs )
+import SrcLoc ( unLoc, Located(..) )
+import Maybes ( isJust )
import Util ( lengthExceeds, notNull )
import Name ( Name )
import Outputable
\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
+ = ASSERT( not (null eqns) )
+ returnDs (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
+ 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
+ ; match_results <- mapM match_group (groupEquations tidy_eqns)
+
+ ; return (adjustMatchResult (foldr1 (.) aux_binds) $
+ foldr1 combineMatchResults match_results) }
+ where
+ 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)
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 shift eqns)
+ ; return (mkEvalMatchResult var ty match_result) }
+ where
+ shift eqn@(EqnInfo { eqn_pats = BangPat pat : pats })
+ = eqn { eqn_pats = unLoc pat : pats }
+
+matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+-- Apply the coercion to the match variable and then match that
+matchCoercion (var:vars) ty (eqn1:eqns)
+ = 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 }
\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 (idWrapper, 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 (idWrapper, 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 (idWrapper, 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 (idWrapper, unLoc tuple_ConPat)
where
arity = length pats
tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty
-tidy1 v wrap (DictPat dicts methods)
+tidy1 v (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)
+ 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 wrap pat@(LitPat lit)
- = returnDs (wrap, unLoc (tidyLitPat lit (noLoc pat)))
+tidy1 v (LitPat lit)
+ = returnDs (idWrapper, 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 lit_ty)
+ = returnDs (idWrapper, tidyNPat lit mb_neg eq lit_ty)
+-- 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 (idWrapper, 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
+ ; 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*
+
+
+groupEquations :: [EquationInfo] -> [[(PatGroup, EquationInfo)]]
+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
+sameGroup _ _ = False
+
+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 inner pattern
+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.
#include "HsVersions.h"
-import Id( idType )
-
import {-# SOURCE #-} Match ( match )
-import HsSyn ( Pat(..), HsConDetails(..) )
+import HsSyn ( Pat(..), LPat, HsConDetails(..) )
import DsBinds ( dsLHsBinds )
-import DataCon ( isVanillaDataCon, dataConInstOrigArgTys )
+import DataCon ( DataCon, dataConInstOrigArgTys,
+ dataConFieldLabels, dataConSourceArity )
import TcType ( tcTyConAppArgs )
import Type ( mkTyVarTys )
import CoreSyn
import DsMonad
import DsUtils
-import Id ( Id )
+import Id ( Id, idName )
import Type ( Type )
-import ListSetOps ( equivClassesByUniq )
import SrcLoc ( unLoc, Located(..) )
-import Unique ( Uniquable(..) )
import Outputable
\end{code}
\begin{code}
matchConFamily :: [Id]
-> Type
- -> [EquationInfo]
+ -> [[EquationInfo]]
-> DsM MatchResult
-matchConFamily (var:vars) ty eqns_info
- = let
- -- Sort into equivalence classes by the unique on the constructor
- -- All the EqnInfos should start with a ConPat
- groups = equivClassesByUniq get_uniq eqns_info
- get_uniq (EqnInfo { eqn_pats = ConPatOut (L _ data_con) _ _ _ _ _ : _}) = getUnique data_con
-
- -- Get the wrapper from the head of each group. We're going to
- -- use it as the pattern in this case expression, so we need to
- -- ensure that any type variables it mentions in the pattern are
- -- in scope. So we put its wrappers outside the case, and
- -- zap the wrapper for it.
- wraps :: [CoreExpr -> CoreExpr]
- wraps = map (eqn_wrap . head) groups
-
- groups' = [ eqn { eqn_wrap = idWrapper } : eqns | eqn:eqns <- groups ]
- in
- -- Now make a case alternative out of each group
- mappM (match_con vars ty) groups' `thenDs` \ alts ->
- returnDs (adjustMatchResult (foldr (.) idWrapper wraps) $
- mkCoAlgCaseMatchResult var ty alts)
-\end{code}
-
-And here is the local function that does all the work. It is
-more-or-less the @matchCon@/@matchClause@ functions on page~94 in
-Wadler's chapter in SLPJ. The function @shift_con_pats@ does what the
-list comprehension in @matchClause@ (SLPJ, p.~94) does, except things
-are trickier in real life. Works for @ConPats@, and we want it to
-fail catastrophically for anything else (which a list comprehension
-wouldn't). Cf.~@shift_lit_pats@ in @MatchLits@.
-
-\begin{code}
-match_con vars ty eqns
- = do { -- Make new vars for the con arguments; avoid new locals where possible
- arg_vars <- selectMatchVars (map unLoc arg_pats1) arg_tys
- ; eqns' <- mapM shift eqns
+-- Each group of eqns is for a single constructor
+matchConFamily (var:vars) ty groups
+ = do { alts <- mapM (matchOneCon vars ty) groups
+ ; return (mkCoAlgCaseMatchResult var ty alts) }
+
+matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor
+ = do { (wraps, eqns') <- mapAndUnzipM shift (eqn1:eqns)
+ ; arg_vars <- selectMatchVars (take (dataConSourceArity con)
+ (eqn_pats (head eqns')))
+ -- Use the new arugment patterns as a source of
+ -- suggestions for the new variables
; match_result <- match (arg_vars ++ vars) ty eqns'
- ; return (con, tvs1 ++ dicts1 ++ arg_vars, match_result) }
+ ; return (con, tvs1 ++ dicts1 ++ arg_vars,
+ adjustMatchResult (foldr1 (.) wraps) match_result) }
where
- ConPatOut (L _ con) tvs1 dicts1 _ (PrefixCon arg_pats1) pat_ty = firstPat (head eqns)
-
- shift eqn@(EqnInfo { eqn_wrap = wrap,
- eqn_pats = ConPatOut _ tvs ds bind (PrefixCon arg_pats) _ : pats })
+ ConPatOut { pat_con = L _ con, pat_ty = pat_ty1,
+ pat_tvs = tvs1, pat_dicts = dicts1 } = firstPat eqn1
+
+ arg_tys = dataConInstOrigArgTys con inst_tys
+ inst_tys = tcTyConAppArgs pat_ty1 ++ mkTyVarTys tvs1
+ -- Newtypes opaque, hence tcTyConAppArgs
+
+ shift eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds,
+ pat_binds = bind, pat_args = args
+ } : pats })
= do { prs <- dsLHsBinds bind
- ; return (eqn { eqn_wrap = wrap . wrapBinds (tvs `zip` tvs1)
- . wrapBinds (ds `zip` dicts1)
- . mkDsLet (Rec prs),
- eqn_pats = map unLoc arg_pats ++ pats }) }
-
- -- Get the arg types, which we use to type the new vars
- -- to match on, from the "outside"; the types of pats1 may
- -- be more refined, and hence won't do
- arg_tys = dataConInstOrigArgTys con inst_tys
- inst_tys | isVanillaDataCon con = tcTyConAppArgs pat_ty -- Newtypes opaque!
- | otherwise = mkTyVarTys tvs1
+ ; return (wrapBinds (tvs `zip` tvs1)
+ . wrapBinds (ds `zip` dicts1)
+ . mkDsLet (Rec prs),
+ eqn { eqn_pats = conArgPats con arg_tys args ++ pats }) }
+
+conArgPats :: DataCon
+ -> [Type] -- Instantiated argument types
+ -> HsConDetails Id (LPat Id)
+ -> [Pat Id]
+conArgPats data_con arg_tys (PrefixCon ps) = map unLoc ps
+conArgPats data_con arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]
+conArgPats data_con arg_tys (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 WildPat arg_tys
+
+ | otherwise
+ = zipWith mk_pat (dataConFieldLabels data_con) arg_tys
+ where
+ -- mk_pat picks a WildPat of the appropriate type for absent fields,
+ -- and the specified pattern for present fields
+ mk_pat lbl arg_ty
+ = case [ pat | (sel_id,pat) <- rpats, idName (unLoc sel_id) == lbl] of
+ (pat:pats) -> ASSERT( null pats ) unLoc pat
+ [] -> WildPat arg_ty
\end{code}
Note [Existentials in shift_con_pat]
\section[MatchLit]{Pattern-matching literal patterns}
\begin{code}
-module MatchLit ( dsLit, dsOverLit,
- tidyLitPat, tidyNPat,
+module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey,
+ tidyLitPat, tidyNPat,
matchLiterals, matchNPlusKPats, matchNPats ) where
#include "HsVersions.h"
import Id ( Id, idType )
import CoreSyn
import TyCon ( tyConDataCons )
+import DataCon ( DataCon )
import TcType ( tcSplitTyConApp, isIntegerTy, isIntTy,
isFloatTy, isDoubleTy, isStringTy )
import Type ( Type )
import Unique ( hasKey )
import Literal ( mkMachInt, Literal(..) )
import SrcLoc ( noLoc )
-import ListSetOps ( equivClasses, runs )
import Ratio ( numerator, denominator )
-import SrcLoc ( Located(..) )
+import SrcLoc ( Located(..), unLoc )
import Outputable
+import Util ( mapAndUnzip )
import FastString ( lengthFS, unpackFS )
\end{code}
\begin{code}
dsLit :: HsLit -> DsM CoreExpr
-dsLit (HsChar c) = returnDs (mkCharExpr c)
+dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s))
dsLit (HsCharPrim c) = returnDs (mkLit (MachChar c))
+dsLit (HsIntPrim i) = returnDs (mkLit (MachInt i))
+dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f))
+dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
+
+dsLit (HsChar c) = returnDs (mkCharExpr c)
dsLit (HsString str) = mkStringExprFS str
-dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s))
dsLit (HsInteger i _) = mkIntegerExpr i
dsLit (HsInt i) = returnDs (mkIntExpr i)
-dsLit (HsIntPrim i) = returnDs (mkIntLit i)
-dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f))
-dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
dsLit (HsRat r ty)
= mkIntegerExpr (numerator r) `thenDs` \ num ->
dsOverLit (HsFractional _ lit) = dsExpr lit
\end{code}
+\begin{code}
+hsLitKey :: HsLit -> Literal
+-- Get a Core literal to use (only) a grouping key
+-- Hence its type doesn't need to match the type of the original literal
+-- (and doesn't for strings)
+-- It only works for primitive types and strings;
+-- others have been removed by tidy
+hsLitKey (HsIntPrim i) = mkMachInt i
+hsLitKey (HsCharPrim c) = MachChar c
+hsLitKey (HsStringPrim s) = MachStr s
+hsLitKey (HsFloatPrim f) = MachFloat f
+hsLitKey (HsDoublePrim d) = MachDouble d
+hsLitKey (HsString s) = MachStr s
+
+hsOverLitKey :: HsOverLit a -> Bool -> Literal
+-- Ditto for HsOverLit; the boolean indicates to negate
+hsOverLitKey (HsIntegral i _) False = MachInt i
+hsOverLitKey (HsIntegral i _) True = MachInt (-i)
+hsOverLitKey (HsFractional r _) False = MachFloat r
+hsOverLitKey (HsFractional r _) True = MachFloat (-r)
+\end{code}
+
%************************************************************************
%* *
Tidying lit pats
%************************************************************************
\begin{code}
-tidyLitPat :: HsLit -> LPat Id -> LPat Id
+tidyLitPat :: HsLit -> Pat Id
-- Result has only the following HsLits:
-- HsIntPrim, HsCharPrim, HsFloatPrim
-- HsDoublePrim, HsStringPrim, HsString
-- * HsInteger, HsRat, HsInt can't show up in LitPats
-- * We get rid of HsChar right here
-tidyLitPat (HsChar c) pat = mkCharLitPat c
-tidyLitPat (HsString s) pat
+tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)
+tidyLitPat (HsString s)
| lengthFS s <= 1 -- Short string literals only
- = foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c,pat] stringTy)
- (mkNilPat stringTy) (unpackFS s)
+ = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
+ (mkNilPat stringTy) (unpackFS s)
-- The stringTy is the type of the whole pattern, not
-- the type to instantiate (:) or [] with!
-tidyLitPat lit pat = pat
+tidyLitPat lit = LitPat lit
----------------
-tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> Type -> LPat Id -> LPat Id
-tidyNPat over_lit mb_neg lit_ty default_pat
+tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id
+ -> Type -> Pat Id
+tidyNPat over_lit mb_neg eq lit_ty
| isIntTy lit_ty = mk_con_pat intDataCon (HsIntPrim int_val)
| isFloatTy lit_ty = mk_con_pat floatDataCon (HsFloatPrim rat_val)
| isDoubleTy lit_ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
- | otherwise = default_pat
+ | otherwise = NPat over_lit mb_neg eq lit_ty
where
- mk_con_pat con lit = mkPrefixConPat con [noLoc $ LitPat lit] lit_ty
+ mk_con_pat :: DataCon -> HsLit -> Pat Id
+ mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] lit_ty)
neg_lit = case (mb_neg, over_lit) of
(Nothing, _) -> over_lit
(Just _, HsIntegral i s) -> HsIntegral (-i) s
\begin{code}
matchLiterals :: [Id]
- -> Type -- Type of the whole case expression
- -> [EquationInfo]
+ -> Type -- Type of the whole case expression
+ -> [[EquationInfo]] -- All PgLits
-> DsM MatchResult
--- All the EquationInfos have LitPats at the front
-
-matchLiterals (var:vars) ty eqns
- = do { -- Group by literal
- let groups :: [[(Literal, EquationInfo)]]
- groups = equivClasses cmpTaggedEqn (tagLitEqns eqns)
- -- Deal with each group
- ; alts <- mapM match_group groups
+matchLiterals (var:vars) ty sub_groups
+ = do { -- Deal with each group
+ ; alts <- mapM match_group sub_groups
-- Combine results. For everything except String
-- we can use a case expression; for String we need
-- a chain of if-then-else
; if isStringTy (idType var) then
- do { mrs <- mapM wrap_str_guard alts
+ do { eq_str <- dsLookupGlobalId eqStringName
+ ; mrs <- mapM (wrap_str_guard eq_str) alts
; return (foldr1 combineMatchResults mrs) }
else
return (mkCoPrimCaseMatchResult var ty alts)
}
where
- match_group :: [(Literal, EquationInfo)] -> DsM (Literal, MatchResult)
- match_group group
- = do { let (lits, eqns) = unzip group
+ match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
+ match_group eqns
+ = do { let LitPat hs_lit = firstPat (head eqns)
; match_result <- match vars ty (shiftEqns eqns)
- ; return (head lits, match_result) }
+ ; return (hsLitKey hs_lit, match_result) }
- wrap_str_guard :: (Literal,MatchResult) -> DsM MatchResult
+ wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
-- Equality check for string literals
- wrap_str_guard (MachStr s, mr)
- = do { eq_str <- dsLookupGlobalId eqStringName
- ; lit <- mkStringExprFS s
+ wrap_str_guard eq_str (MachStr s, mr)
+ = do { lit <- mkStringExprFS s
; let pred = mkApps (Var eq_str) [Var var, lit]
; return (mkGuardedMatchResult pred mr) }
\end{code}
+
%************************************************************************
%* *
Pattern matching on NPat
%************************************************************************
\begin{code}
-matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
--- All the EquationInfos have NPat at the front
-
-matchNPats (var:vars) ty eqns
- = do { let groups :: [[(Literal, EquationInfo)]]
- groups = equivClasses cmpTaggedEqn (tagLitEqns eqns)
-
- ; match_results <- mapM (match_group . map snd) groups
-
- ; ASSERT( not (null match_results) )
- return (foldr1 combineMatchResults match_results) }
- where
- match_group :: [EquationInfo] -> DsM MatchResult
- match_group (eqn1:eqns)
- = do { lit_expr <- dsOverLit lit
- ; neg_lit <- case mb_neg of
+matchNPats :: [Id] -> Type -> [[EquationInfo]] -> DsM MatchResult
+ -- All NPats, but perhaps for different literals
+matchNPats vars ty groups
+ = do { match_results <- mapM (matchOneNPat vars ty) groups
+ ; return (foldr1 combineMatchResults match_results) }
+
+matchOneNPat (var:vars) ty (eqn1:eqns) -- All for the same literal
+ = do { let NPat lit mb_neg eq_chk _ = firstPat eqn1
+ ; lit_expr <- dsOverLit lit
+ ; neg_lit <- case mb_neg of
Nothing -> return lit_expr
Just neg -> do { neg_expr <- dsExpr neg
; return (App neg_expr lit_expr) }
- ; eq_expr <- dsExpr eq_chk
- ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
- ; match_result <- match vars ty (eqn1' : shiftEqns eqns)
- ; return (adjustMatchResult (eqn_wrap eqn1) $
- -- Bring the eqn1 wrapper stuff into scope because
- -- it may be used in pred_expr
- mkGuardedMatchResult pred_expr match_result) }
- where
- NPat lit mb_neg eq_chk _ : pats1 = eqn_pats eqn1
- eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 }
+ ; eq_expr <- dsExpr eq_chk
+ ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
+ ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
+ ; return (mkGuardedMatchResult pred_expr match_result) }
\end{code}
<try-next-pattern-or-whatever>
\end{verbatim}
-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 'runs' rather than 'equivClasses'
\begin{code}
-matchNPlusKPats all_vars@(var:vars) ty eqns
- = do { let groups :: [[(Literal, EquationInfo)]]
- groups = runs eqTaggedEqn (tagLitEqns eqns)
-
- ; match_results <- mapM (match_group . map snd) groups
-
- ; ASSERT( not (null match_results) )
- return (foldr1 combineMatchResults match_results) }
+matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+ -- All NPlusKPats, for the *same* literal k
+matchNPlusKPats all_vars@(var:vars) ty (eqn1:eqns)
+ = do { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
+ ; ge_expr <- dsExpr ge
+ ; minus_expr <- dsExpr minus
+ ; lit_expr <- dsOverLit lit
+ ; let pred_expr = mkApps ge_expr [Var var, lit_expr]
+ minusk_expr = mkApps minus_expr [Var var, lit_expr]
+ (wraps, eqns') = mapAndUnzip (shift n1) eqns
+ ; match_result <- match vars ty eqns'
+ ; return (mkGuardedMatchResult pred_expr $
+ mkCoLetMatchResult (NonRec n1 minusk_expr) $
+ adjustMatchResult (foldr1 (.) wraps) $
+ match_result) }
where
- match_group :: [EquationInfo] -> DsM MatchResult
- match_group (eqn1:eqns)
- = do { ge_expr <- dsExpr ge
- ; minus_expr <- dsExpr minus
- ; lit_expr <- dsOverLit lit
- ; let pred_expr = mkApps ge_expr [Var var, lit_expr]
- minusk_expr = mkApps minus_expr [Var var, lit_expr]
- ; match_result <- match vars ty (eqn1' : map shift eqns)
- ; return (adjustMatchResult (eqn_wrap eqn1) $
- -- Bring the eqn1 wrapper stuff into scope because
- -- it may be used in ge_expr, minusk_expr
- mkGuardedMatchResult pred_expr $
- mkCoLetMatchResult (NonRec n1 minusk_expr) $
- match_result) }
- where
- NPlusKPat (L _ n1) lit ge minus : pats1 = eqn_pats eqn1
- eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 }
-
- shift eqn@(EqnInfo { eqn_wrap = wrap,
- eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
- = eqn { eqn_wrap = wrap . wrapBind n n1, eqn_pats = pats }
-\end{code}
-
-
-%************************************************************************
-%* *
- Grouping functions
-%* *
-%************************************************************************
-
-Given a blob of @LitPat@s/@NPat@s, we want to split them into those
-that are ``same''/different as one we are looking at. We need to know
-whether we're looking at a @LitPat@/@NPat@, and what literal we're after.
-
-\begin{code}
--- Tag equations by the leading literal
--- NB: we have ordering on Core Literals, but not on HsLits
-cmpTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Ordering
-cmpTaggedEqn (lit1,_) (lit2,_) = lit1 `compare` lit2
-
-eqTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Bool
-eqTaggedEqn (lit1,_) (lit2,_) = lit1 == lit2
-
-tagLitEqns :: [EquationInfo] -> [(Literal, EquationInfo)]
-tagLitEqns eqns = [(get_lit (firstPat eqn), eqn) | eqn <- eqns]
-
-get_lit :: Pat Id -> Literal
--- Get a Core literal to use (only) a grouping key
--- Hence its type doesn't need to match the type of the original literal
-get_lit (LitPat (HsIntPrim i)) = mkMachInt i
-get_lit (LitPat (HsCharPrim c)) = MachChar c
-get_lit (LitPat (HsStringPrim s)) = MachStr s
-get_lit (LitPat (HsFloatPrim f)) = MachFloat f
-get_lit (LitPat (HsDoublePrim d)) = MachDouble d
-get_lit (LitPat (HsString s)) = MachStr s
-
-get_lit (NPat (HsIntegral i _) Nothing _ _) = MachInt i
-get_lit (NPat (HsIntegral i _) (Just _) _ _) = MachInt (-i)
-get_lit (NPat (HsFractional r _) Nothing _ _) = MachFloat r
-get_lit (NPat (HsFractional r _) (Just _) _ _) = MachFloat (-r)
-
-get_lit (NPlusKPat _ (HsIntegral i _) _ _) = MachInt i
-
--- These ones can't happen
--- get_lit (LitPat (HsChar c))
--- get_lit (LitPat (HsInt i))
-get_lit other = pprPanic "get_lit:bad pattern" (ppr other)
+ shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
+ = (wrapBind n n1, eqn { eqn_pats = pats })
+ -- The wrapBind is a no-op for the first equation
\end{code}
-
projects / ghc-hetmet.git / commitdiff