%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section[Main_match]{The @match@ function}
+
+The @match@ function
\begin{code}
+{-# OPTIONS -fno-warn-incomplete-patterns #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where
#include "HsVersions.h"
-import DynFlags ( DynFlag(..), dopt )
+import {-#SOURCE#-} DsExpr (dsLExpr)
+
+import DynFlags
import HsSyn
-import TcHsSyn ( mkVanillaTuplePat )
-import Check ( check, ExhaustivePat )
+import TcHsSyn
+import Check
import CoreSyn
-import CoreUtils ( bindNonRec, exprType )
+import Literal
+import CoreUtils
+import MkCore
import DsMonad
-import DsBinds ( dsLHsBinds )
-import DsGRHSs ( dsGRHSs )
+import DsBinds
+import DsGRHSs
import DsUtils
-import Id ( idName, idType, Id )
-import DataCon ( dataConFieldLabels, dataConInstOrigArgTys, isVanillaDataCon )
-import MatchCon ( matchConFamily )
-import MatchLit ( matchLiterals, matchNPlusKPats, matchNPats, tidyLitPat, tidyNPat )
-import PrelInfo ( pAT_ERROR_ID )
-import TcType ( Type, tcTyConAppArgs )
-import Type ( splitFunTysN, mkTyVarTys )
-import TysWiredIn ( consDataCon, mkListTy, unitTy,
- tupleCon, parrFakeCon, mkPArrTy )
-import BasicTypes ( Boxity(..) )
-import ListSetOps ( runs )
-import SrcLoc ( noLoc, unLoc, Located(..) )
-import Util ( lengthExceeds, notNull )
-import Name ( Name )
+import Id
+import DataCon
+import MatchCon
+import MatchLit
+import Type
+import TysWiredIn
+import ListSetOps
+import SrcLoc
+import Maybes
+import Util
+import Name
+import FiniteMap
import Outputable
+import FastString
\end{code}
This function is a wrapper of @match@, it must be called from all the parts where
-> [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}
+%************************************************************************
+%* *
+ 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
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).
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 )
+ return (foldr1 combineMatchResults match_results)
+ where
+ match_results = [ ASSERT( null (eqn_pats eqn) )
+ eqn_rhs eqn
+ | eqn <- eqns ]
+
+match vars@(v:_) ty eqns
+ = ASSERT( not (null eqns ) )
+ do { -- Tidy the first pattern, generating
+ -- auxiliary bindings if necessary
+ (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
+
+ -- Group the equations and match each group in turn
+ ; let grouped = groupEquations tidy_eqns
+
+ -- print the view patterns that are commoned up to help debug
+ ; ifOptM Opt_D_dump_view_pattern_commoning (debug grouped)
+
+ ; match_results <- mapM match_group grouped
+ ; return (adjustMatchResult (foldr1 (.) aux_binds) $
+ foldr1 combineMatchResults match_results) }
where
- same_family eqn1 eqn2
- = samePatFamily (firstPat eqn1) (firstPat eqn2)
-
- match_block eqns
- = case firstPat (head eqns) of
- WildPat {} -> matchVariables vars ty eqns
- ConPatOut {} -> matchConFamily vars ty eqns
- NPlusKPat {} -> matchNPlusKPats vars ty eqns
- NPat {} -> matchNPats vars ty eqns
- LitPat {} -> matchLiterals vars ty eqns
-
--- After tidying, there are only five kinds of patterns
-samePatFamily (WildPat {}) (WildPat {}) = True
-samePatFamily (ConPatOut {}) (ConPatOut {}) = True
-samePatFamily (NPlusKPat {}) (NPlusKPat {}) = True
-samePatFamily (NPat {}) (NPat {}) = True
-samePatFamily (LitPat {}) (LitPat {}) = True
-samePatFamily _ _ = False
+ dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo]
+ dropGroup = map snd
+
+ match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
+ match_group eqns@((group,_) : _)
+ = case group of
+ PgCon _ -> matchConFamily vars ty (subGroup [(c,e) | (PgCon c, e) <- eqns])
+ PgLit _ -> matchLiterals vars ty (subGroup [(l,e) | (PgLit l, e) <- eqns])
+
+ PgAny -> matchVariables vars ty (dropGroup eqns)
+ PgN _ -> matchNPats vars ty (dropGroup eqns)
+ PgNpK _ -> matchNPlusKPats vars ty (dropGroup eqns)
+ PgBang -> matchBangs vars ty (dropGroup eqns)
+ PgCo _ -> matchCoercion vars ty (dropGroup eqns)
+ PgView _ _ -> matchView vars ty (dropGroup eqns)
+
+ -- FIXME: we should also warn about view patterns that should be
+ -- commoned up but are not
+
+ -- print some stuff to see what's getting grouped
+ -- use -dppr-debug to see the resolution of overloaded lits
+ debug eqns =
+ let gs = map (\group -> foldr (\ (p,_) -> \acc ->
+ case p of PgView e _ -> e:acc
+ _ -> acc) [] group) eqns
+ maybeWarn [] = return ()
+ maybeWarn l = warnDs (vcat l)
+ in
+ maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))
+ (filter (not . null) gs))
matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
-- Real true variables, just like in matchVar, SLPJ p 94
-- No binding to do: they'll all be wildcards by now (done in tidy)
-matchVariables (var:vars) ty eqns = match vars ty (shiftEqns eqns)
-\end{code}
-
+matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)
+
+matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+matchBangs (var:vars) ty eqns
+ = do { match_result <- match (var:vars) ty (map decomposeFirst_Bang eqns)
+ ; return (mkEvalMatchResult var ty match_result) }
+
+matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+-- Apply the coercion to the match variable and then match that
+matchCoercion (var:vars) ty (eqns@(eqn1:_))
+ = do { let CoPat co pat _ = firstPat eqn1
+ ; var' <- newUniqueId var (hsPatType pat)
+ ; match_result <- match (var':vars) ty (map decomposeFirst_Coercion eqns)
+ ; co' <- dsHsWrapper co
+ ; let rhs' = co' (Var var)
+ ; return (mkCoLetMatchResult (NonRec var' rhs') match_result) }
+
+matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+-- Apply the view function to the match variable and then match that
+matchView (var:vars) ty (eqns@(eqn1:_))
+ = do { -- we could pass in the expr from the PgView,
+ -- but this needs to extract the pat anyway
+ -- to figure out the type of the fresh variable
+ let ViewPat viewExpr (L _ pat) _ = firstPat eqn1
+ -- do the rest of the compilation
+ ; var' <- newUniqueId var (hsPatType pat)
+ ; match_result <- match (var':vars) ty (map decomposeFirst_View eqns)
+ -- compile the view expressions
+ ; viewExpr' <- dsLExpr viewExpr
+ ; return (mkViewMatchResult var' viewExpr' var match_result) }
+
+-- decompose the first pattern and leave the rest alone
+decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo
+decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
+ = eqn { eqn_pats = extractpat pat : pats}
+
+decomposeFirst_Coercion, decomposeFirst_Bang, decomposeFirst_View :: EquationInfo -> EquationInfo
+
+decomposeFirst_Coercion = decomposeFirstPat (\ (CoPat _ pat _) -> pat)
+decomposeFirst_Bang = decomposeFirstPat (\ (BangPat pat ) -> unLoc pat)
+decomposeFirst_View = decomposeFirstPat (\ (ViewPat _ pat _) -> unLoc pat)
\end{code}
+%************************************************************************
+%* *
+ Tidying patterns
+%* *
+%************************************************************************
+
Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
which will be scrutinised. This means:
\begin{itemize}
\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 }) = do
+ (wrap, pat') <- tidy1 v pat
+ return (wrap, eqn { eqn_pats = do pat' : pats })
tidy1 :: Id -- The Id being scrutinised
- -> DsWrapper -- Previous wrapping bindings
-> Pat Id -- The pattern against which it is to be matched
- -> DsM (DsWrapper, -- Extra bindings around what to do afterwards
+ -> DsM (DsWrapper, -- Extra bindings to do before the match
Pat Id) -- Equivalent pattern
--- The extra bindings etc are all wrapped around the RHS of the match
--- so they are only available when matching is complete. But that's ok
--- becuase, for example, in the pattern x@(...), the x can only be
--- used in the RHS, not in the nested pattern, nor subsquent patterns
---
--- However this does have an awkward consequence. The bindings in
--- a VarPatOut get wrapped around the result in right to left order,
--- rather than left to right. This only matters if one set of
--- bindings can mention things used in another, and that can happen
--- if we allow equality dictionary bindings of form d1=d2.
--- bindIInstsOfLocalFuns is now careful not to do this, but it's a wart.
--- (Without this care in bindInstsOfLocalFuns, compiling
--- Data.Generics.Schemes.hs fails in function everywhereBut.)
-
-------------------------------------------------------
-- (pat', mr') = tidy1 v pat mr
-- tidies the *outer level only* of pat, giving pat'
-- NPat
-- NPlusKPat
-tidy1 v wrap (ParPat pat) = tidy1 v wrap (unLoc pat)
-tidy1 v wrap (SigPatOut pat _) = tidy1 v wrap (unLoc pat)
-tidy1 v wrap (WildPat ty) = returnDs (wrap, WildPat ty)
+tidy1 v (ParPat pat) = tidy1 v (unLoc pat)
+tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat)
+tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty)
-- case v of { x -> mr[] }
-- = case v of { _ -> let x=v in mr[] }
-tidy1 v wrap (VarPat var)
- = returnDs (wrap . wrapBind var v, WildPat (idType var))
+tidy1 v (VarPat var)
+ = return (wrapBind var v, WildPat (idType var))
-tidy1 v wrap (VarPatOut var binds)
- = do { prs <- dsLHsBinds binds
- ; return (wrap . wrapBind var v . mkDsLet (Rec prs),
+tidy1 v (VarPatOut var binds)
+ = do { ds_ev_binds <- dsTcEvBinds binds
+ ; return (wrapBind var v . wrapDsEvBinds ds_ev_binds,
WildPat (idType var)) }
-- case v of { x@p -> mr[] }
-- = case v of { p -> let x=v in mr[] }
-tidy1 v wrap (AsPat (L _ var) pat)
- = tidy1 v (wrap . wrapBind var v) (unLoc pat)
-
-tidy1 v wrap (BangPat pat)
- = tidy1 v (wrap . seqVar v) (unLoc pat)
+tidy1 v (AsPat (L _ var) pat)
+ = do { (wrap, pat') <- tidy1 v (unLoc pat)
+ ; return (wrapBind var v . wrap, pat') }
{- now, here we handle lazy patterns:
tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
-}
-tidy1 v wrap (LazyPat pat)
- = do { v' <- newSysLocalDs (idType v)
- ; sel_prs <- mkSelectorBinds pat (Var v)
+tidy1 v (LazyPat pat)
+ = do { sel_prs <- mkSelectorBinds pat (Var v)
; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
- ; returnDs (wrap . wrapBind v' v . mkDsLets sel_binds,
- WildPat (idType v)) }
-
--- re-express <con-something> as (ConPat ...) [directly]
+ ; return (mkCoreLets sel_binds, WildPat (idType v)) }
-tidy1 v wrap (ConPatOut (L loc con) ex_tvs dicts binds ps pat_ty)
- = returnDs (wrap, ConPatOut (L loc con) ex_tvs dicts binds tidy_ps pat_ty)
- where
- tidy_ps = PrefixCon (tidy_con con ex_tvs pat_ty ps)
-
-tidy1 v wrap (ListPat pats ty)
- = returnDs (wrap, unLoc list_ConPat)
+tidy1 _ (ListPat pats ty)
+ = return (idDsWrapper, unLoc list_ConPat)
where
list_ty = mkListTy ty
list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty)
-- Introduce fake parallel array constructors to be able to handle parallel
-- arrays with the existing machinery for constructor pattern
-tidy1 v wrap (PArrPat pats ty)
- = returnDs (wrap, unLoc parrConPat)
+tidy1 _ (PArrPat pats ty)
+ = return (idDsWrapper, unLoc parrConPat)
where
arity = length pats
parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
-tidy1 v wrap (TuplePat pats boxity ty)
- = returnDs (wrap, unLoc tuple_ConPat)
+tidy1 _ (TuplePat pats boxity ty)
+ = return (idDsWrapper, unLoc tuple_ConPat)
where
arity = length pats
tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty
-tidy1 v wrap (DictPat dicts methods)
- = case num_of_d_and_ms of
- 0 -> tidy1 v wrap (TuplePat [] Boxed unitTy)
- 1 -> tidy1 v wrap (unLoc (head dict_and_method_pats))
- _ -> tidy1 v wrap (mkVanillaTuplePat dict_and_method_pats Boxed)
- where
- num_of_d_and_ms = length dicts + length methods
- dict_and_method_pats = map nlVarPat (dicts ++ methods)
-
-- LitPats: we *might* be able to replace these w/ a simpler form
-tidy1 v wrap pat@(LitPat lit)
- = returnDs (wrap, unLoc (tidyLitPat lit (noLoc pat)))
+tidy1 _ (LitPat lit)
+ = return (idDsWrapper, tidyLitPat lit)
-- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 v wrap pat@(NPat lit mb_neg _ lit_ty)
- = returnDs (wrap, unLoc (tidyNPat lit mb_neg lit_ty (noLoc pat)))
-
--- and everything else goes through unchanged...
-
-tidy1 v wrap non_interesting_pat
- = returnDs (wrap, non_interesting_pat)
-
-
-tidy_con data_con ex_tvs pat_ty (PrefixCon ps) = ps
-tidy_con data_con ex_tvs pat_ty (InfixCon p1 p2) = [p1,p2]
-tidy_con data_con ex_tvs pat_ty (RecCon rpats)
- | null rpats
- = -- Special case for C {}, which can be used for
- -- a constructor that isn't declared to have
- -- fields at all
- map (noLoc . WildPat) con_arg_tys'
-
- | otherwise
- = map mk_pat tagged_arg_tys
- where
- -- Boring stuff to find the arg-tys of the constructor
-
- inst_tys | isVanillaDataCon data_con = tcTyConAppArgs pat_ty -- Newtypes must be opaque
- | otherwise = mkTyVarTys ex_tvs
-
- con_arg_tys' = dataConInstOrigArgTys data_con inst_tys
- tagged_arg_tys = con_arg_tys' `zip` dataConFieldLabels data_con
-
- -- mk_pat picks a WildPat of the appropriate type for absent fields,
- -- and the specified pattern for present fields
- mk_pat (arg_ty, lbl) =
- case [ pat | (sel_id,pat) <- rpats, idName (unLoc sel_id) == lbl] of
- (pat:pats) -> ASSERT( null pats ) pat
- [] -> noLoc (WildPat arg_ty)
+tidy1 _ (NPat lit mb_neg eq)
+ = return (idDsWrapper, tidyNPat lit mb_neg eq)
+
+-- BangPatterns: Pattern matching is already strict in constructors,
+-- tuples etc, so the last case strips off the bang for thoses patterns.
+tidy1 v (BangPat (L _ (LazyPat p))) = tidy1 v (BangPat p)
+tidy1 v (BangPat (L _ (ParPat p))) = tidy1 v (BangPat p)
+tidy1 _ p@(BangPat (L _(VarPat _))) = return (idDsWrapper, p)
+tidy1 _ p@(BangPat (L _(VarPatOut _ _))) = return (idDsWrapper, p)
+tidy1 _ p@(BangPat (L _ (WildPat _))) = return (idDsWrapper, p)
+tidy1 _ p@(BangPat (L _ (CoPat _ _ _))) = return (idDsWrapper, p)
+tidy1 _ p@(BangPat (L _ (SigPatIn _ _))) = return (idDsWrapper, p)
+tidy1 _ p@(BangPat (L _ (SigPatOut _ _))) = return (idDsWrapper, p)
+tidy1 v (BangPat (L _ (AsPat (L _ var) pat)))
+ = do { (wrap, pat') <- tidy1 v (BangPat pat)
+ ; return (wrapBind var v . wrap, pat') }
+tidy1 v (BangPat (L _ p)) = tidy1 v p
+
+-- Everything else goes through unchanged...
+
+tidy1 _ non_interesting_pat
+ = return (idDsWrapper, non_interesting_pat)
\end{code}
\noindent
\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
= do { dflags <- getDOptsDs
; locn <- getSrcSpanDs
; let ds_ctxt = DsMatchContext ctxt locn
- error_string = matchContextErrString ctxt
+ error_doc = matchContextErrString ctxt
; match_result <- match_fun dflags ds_ctxt vars rhs_ty eqns_info
- ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string
+ ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc
; extractMatchResult match_result fail_expr }
where
match_fun dflags ds_ctxt
-> CoreExpr -- Return this if it doesn't
-> DsM CoreExpr
-matchSimply scrut hs_ctx pat result_expr fail_expr
- = let
+matchSimply scrut hs_ctx pat result_expr fail_expr = do
+ let
match_result = cantFailMatchResult result_expr
- rhs_ty = exprType fail_expr
- -- Use exprType of fail_expr, because won't refine in the case of failure!
- in
- matchSinglePat scrut hs_ctx pat rhs_ty match_result `thenDs` \ match_result' ->
+ rhs_ty = exprType fail_expr
+ -- Use exprType of fail_expr, because won't refine in the case of failure!
+ match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result
extractMatchResult match_result' fail_expr
matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
-> Type -> MatchResult -> DsM MatchResult
-matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result
- = getDOptsDs `thenDs` \ dflags ->
- getSrcSpanDs `thenDs` \ locn ->
+matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result = do
+ dflags <- getDOptsDs
+ locn <- getSrcSpanDs
let
- match_fn dflags
+ match_fn dflags
| dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx
- | otherwise = match
- where
- ds_ctx = DsMatchContext hs_ctx locn
+ | otherwise = match
+ where
+ ds_ctx = DsMatchContext hs_ctx locn
+ match_fn dflags [var] ty [EqnInfo { eqn_pats = [pat], eqn_rhs = match_result }]
+
+matchSinglePat scrut hs_ctx pat ty match_result = do
+ var <- selectSimpleMatchVarL pat
+ match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result
+ return (adjustMatchResult (bindNonRec var scrut) match_result')
+\end{code}
+
+
+%************************************************************************
+%* *
+ Pattern classification
+%* *
+%************************************************************************
+
+\begin{code}
+data PatGroup
+ = PgAny -- Immediate match: variables, wildcards,
+ -- lazy patterns
+ | PgCon DataCon -- Constructor patterns (incl list, tuple)
+ | PgLit Literal -- Literal patterns
+ | PgN Literal -- Overloaded literals
+ | PgNpK Literal -- n+k patterns
+ | PgBang -- Bang patterns
+ | PgCo Type -- Coercion patterns; the type is the type
+ -- of the pattern *inside*
+ | PgView (LHsExpr Id) -- view pattern (e -> p):
+ -- the LHsExpr is the expression e
+ Type -- the Type is the type of p (equivalently, the result type of e)
+
+groupEquations :: [EquationInfo] -> [[(PatGroup, EquationInfo)]]
+-- If the result is of form [g1, g2, g3],
+-- (a) all the (pg,eq) pairs in g1 have the same pg
+-- (b) none of the gi are empty
+-- The ordering of equations is unchanged
+groupEquations eqns
+ = runs same_gp [(patGroup (firstPat eqn), eqn) | eqn <- eqns]
+ where
+ same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
+ (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2
+
+subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
+-- Input is a particular group. The result sub-groups the
+-- equations by with particular constructor, literal etc they match.
+-- Each sub-list in the result has the same PatGroup
+-- See Note [Take care with pattern order]
+subGroup group
+ = map reverse $ eltsFM $ foldl accumulate emptyFM group
+ where
+ accumulate pg_map (pg, eqn)
+ = case lookupFM pg_map pg of
+ Just eqns -> addToFM pg_map pg (eqn:eqns)
+ Nothing -> addToFM pg_map pg [eqn]
+
+ -- pg_map :: FiniteMap a [EquationInfo]
+ -- Equations seen so far in reverse order of appearance
+\end{code}
+
+Note [Take care with pattern order]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the subGroup function we must be very careful about pattern re-ordering,
+Consider the patterns [ (True, Nothing), (False, x), (True, y) ]
+Then in bringing together the patterns for True, we must not
+swap the Nothing and y!
+
+
+\begin{code}
+sameGroup :: PatGroup -> PatGroup -> Bool
+-- Same group means that a single case expression
+-- or test will suffice to match both, *and* the order
+-- of testing within the group is insignificant.
+sameGroup PgAny PgAny = True
+sameGroup PgBang PgBang = True
+sameGroup (PgCon _) (PgCon _) = True -- One case expression
+sameGroup (PgLit _) (PgLit _) = True -- One case expression
+sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant
+sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns]
+sameGroup (PgCo t1) (PgCo t2) = t1 `coreEqType` t2
+ -- CoPats are in the same goup only if the type of the
+ -- enclosed pattern is the same. The patterns outside the CoPat
+ -- always have the same type, so this boils down to saying that
+ -- the two coercions are identical.
+sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2)
+ -- ViewPats are in the same gorup iff the expressions
+ -- are "equal"---conservatively, we use syntactic equality
+sameGroup _ _ = False
+
+-- An approximation of syntactic equality used for determining when view
+-- exprs are in the same group.
+-- This function can always safely return false;
+-- but doing so will result in the application of the view function being repeated.
+--
+-- Currently: compare applications of literals and variables
+-- and anything else that we can do without involving other
+-- HsSyn types in the recursion
+--
+-- NB we can't assume that the two view expressions have the same type. Consider
+-- f (e1 -> True) = ...
+-- f (e2 -> "hi") = ...
+viewLExprEq :: (LHsExpr Id,Type) -> (LHsExpr Id,Type) -> Bool
+viewLExprEq (e1,_) (e2,_) =
+ let
+ -- short name for recursive call on unLoc
+ lexp e e' = exp (unLoc e) (unLoc e')
+
+ eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool
+ eq_list _ [] [] = True
+ eq_list _ [] (_:_) = False
+ eq_list _ (_:_) [] = False
+ eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
+
+ -- conservative, in that it demands that wrappers be
+ -- syntactically identical and doesn't look under binders
+ --
+ -- coarser notions of equality are possible
+ -- (e.g., reassociating compositions,
+ -- equating different ways of writing a coercion)
+ wrap WpHole WpHole = True
+ wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
+ wrap (WpCast c) (WpCast c') = tcEqType c c'
+ wrap (WpEvApp _) (WpEvApp _) = panic "ToDo: Match.viewLExprEq"
+ wrap (WpTyApp t) (WpTyApp t') = tcEqType t t'
+ -- Enhancement: could implement equality for more wrappers
+ -- if it seems useful (lams and lets)
+ wrap _ _ = False
+
+ -- real comparison is on HsExpr's
+ -- strip parens
+ exp (HsPar (L _ e)) e' = exp e e'
+ exp e (HsPar (L _ e')) = exp e e'
+ -- because the expressions do not necessarily have the same type,
+ -- we have to compare the wrappers
+ exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e'
+ exp (HsVar i) (HsVar i') = i == i'
+ -- the instance for IPName derives using the id, so this works if the
+ -- above does
+ exp (HsIPVar i) (HsIPVar i') = i == i'
+ exp (HsOverLit l) (HsOverLit l') =
+ -- Overloaded lits are equal if they have the same type
+ -- and the data is the same.
+ -- this is coarser than comparing the SyntaxExpr's in l and l',
+ -- which resolve the overloading (e.g., fromInteger 1),
+ -- because these expressions get written as a bunch of different variables
+ -- (presumably to improve sharing)
+ tcEqType (overLitType l) (overLitType l') && l == l'
+ exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'
+ -- the fixities have been straightened out by now, so it's safe
+ -- to ignore them?
+ exp (OpApp l o _ ri) (OpApp l' o' _ ri') =
+ lexp l l' && lexp o o' && lexp ri ri'
+ exp (NegApp e n) (NegApp e' n') = lexp e e' && exp n n'
+ exp (SectionL e1 e2) (SectionL e1' e2') =
+ lexp e1 e1' && lexp e2 e2'
+ exp (SectionR e1 e2) (SectionR e1' e2') =
+ lexp e1 e1' && lexp e2 e2'
+ exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) =
+ eq_list tup_arg es1 es2
+ exp (HsIf e e1 e2) (HsIf e' e1' e2') =
+ lexp e e' && lexp e1 e1' && lexp e2 e2'
+
+ -- Enhancement: could implement equality for more expressions
+ -- if it seems useful
+ -- But no need for HsLit, ExplicitList, ExplicitTuple,
+ -- because they cannot be functions
+ exp _ _ = False
+
+ tup_arg (Present e1) (Present e2) = lexp e1 e2
+ tup_arg (Missing t1) (Missing t2) = tcEqType t1 t2
+ tup_arg _ _ = False
in
- match_fn dflags [var] ty [EqnInfo { eqn_wrap = idWrapper,
- eqn_pats = [pat],
- eqn_rhs = match_result }]
-
-matchSinglePat scrut hs_ctx pat ty match_result
- = selectSimpleMatchVarL pat `thenDs` \ var ->
- matchSinglePat (Var var) hs_ctx pat ty match_result `thenDs` \ match_result' ->
- returnDs (adjustMatchResult (bindNonRec var scrut) match_result')
+ lexp e1 e2
+
+patGroup :: Pat Id -> PatGroup
+patGroup (WildPat {}) = PgAny
+patGroup (BangPat {}) = PgBang
+patGroup (ConPatOut { pat_con = dc }) = PgCon (unLoc dc)
+patGroup (LitPat lit) = PgLit (hsLitKey lit)
+patGroup (NPat olit mb_neg _) = PgN (hsOverLitKey olit (isJust mb_neg))
+patGroup (NPlusKPat _ olit _ _) = PgNpK (hsOverLitKey olit False)
+patGroup (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern
+patGroup (ViewPat expr p _) = PgView expr (hsPatType (unLoc p))
+patGroup pat = pprPanic "patGroup" (ppr pat)
\end{code}
+Note [Grouping overloaded literal patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+WATCH OUT! Consider
+
+ f (n+1) = ...
+ f (n+2) = ...
+ f (n+1) = ...
+
+We can't group the first and third together, because the second may match
+the same thing as the first. Same goes for *overloaded* literal patterns
+ f 1 True = ...
+ f 2 False = ...
+ f 1 False = ...
+If the first arg matches '1' but the second does not match 'True', we
+cannot jump to the third equation! Because the same argument might
+match '2'!
+Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.
projects / ghc-hetmet.git / blobdiff