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 MatchCon
import MatchLit
import Type
+import Coercion
import TysWiredIn
import ListSetOps
import SrcLoc
import Outputable
import FastString
+import Control.Monad( when )
import qualified Data.Map as Map
\end{code}
-> [EquationInfo] -- Info about patterns, etc. (type synonym below)
-> DsM MatchResult -- Desugared result!
-matchCheck ctx vars ty qs = do
- dflags <- getDOptsDs
- 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
-> Type
-> [EquationInfo]
-> DsM MatchResult
-matchCheck_really dflags ctx vars ty qs
- | incomplete && shadow = do
- dsShadowWarn ctx eqns_shadow
- dsIncompleteWarn ctx pats
- match vars ty qs
- | incomplete = do
- dsIncompleteWarn ctx pats
- match vars ty qs
- | shadow = do
- dsShadowWarn ctx eqns_shadow
- match vars ty qs
- | otherwise =
- match vars ty qs
- where (pats, eqns_shadow) = check qs
- incomplete = want_incomplete && (notNull pats)
- want_incomplete = case ctx of
- DsMatchContext RecUpd _ ->
- dopt Opt_WarnIncompletePatternsRecUpd dflags
- _ ->
- dopt Opt_WarnIncompletePatterns dflags
- shadow = dopt Opt_WarnOverlappingPatterns dflags
- && not (null eqns_shadow)
+matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs
+ = do { when shadow (dsShadowWarn ctx eqns_shadow)
+ ; when incomplete (dsIncompleteWarn ctx pats)
+ ; match vars ty qs }
+ where
+ (pats, eqns_shadow) = check qs
+ incomplete = incomplete_flag hs_ctx && (notNull pats)
+ shadow = dopt Opt_WarnOverlappingPatterns dflags
+ && notNull eqns_shadow
+
+ incomplete_flag :: HsMatchContext id -> Bool
+ incomplete_flag (FunRhs {}) = dopt Opt_WarnIncompletePatterns dflags
+ incomplete_flag CaseAlt = dopt Opt_WarnIncompletePatterns dflags
+
+ incomplete_flag LambdaExpr = dopt Opt_WarnIncompleteUniPatterns dflags
+ incomplete_flag PatBindRhs = dopt Opt_WarnIncompleteUniPatterns dflags
+ incomplete_flag ProcExpr = dopt Opt_WarnIncompleteUniPatterns dflags
+
+ incomplete_flag RecUpd = dopt Opt_WarnIncompletePatternsRecUpd dflags
+
+ incomplete_flag ThPatQuote = False
+ incomplete_flag (StmtCtxt {}) = False -- Don't warn about incomplete patterns
+ -- in list comprehensions, pattern guards
+ -- etc. They are often *supposed* to be
+ -- incomplete
\end{code}
This variable shows the maximum number of lines of output generated for warnings.
= ASSERT( not (null eqns ) )
do { -- Tidy the first pattern, generating
-- auxiliary bindings if necessary
- (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
+ (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
-- Group the equations and match each group in turn
- ; let grouped = groupEquations tidy_eqns
+ ; let grouped = groupEquations tidy_eqns
-- print the view patterns that are commoned up to help debug
- ; ifDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
+ ; ifDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
; match_results <- mapM match_group grouped
; return (adjustMatchResult (foldr1 (.) aux_binds) $
dropGroup = map snd
match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
+ match_group [] = panic "match_group"
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)
-- 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 (_:vars) ty eqns = match vars ty (shiftEqns eqns)
+matchVariables [] _ _ = panic "matchVariables"
matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
matchBangs (var:vars) ty eqns
- = do { match_result <- match (var:vars) ty (map decomposeFirst_Bang eqns)
+ = do { match_result <- match (var:vars) ty $
+ map (decomposeFirstPat getBangPat) eqns
; return (mkEvalMatchResult var ty match_result) }
+matchBangs [] _ _ = panic "matchBangs"
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)
+ ; match_result <- match (var':vars) ty $
+ map (decomposeFirstPat getCoPat) eqns
; co' <- dsHsWrapper co
; let rhs' = co' (Var var)
; return (mkCoLetMatchResult (NonRec var' rhs') match_result) }
+matchCoercion _ _ _ = panic "matchCoercion"
matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
-- Apply the view function to the match variable and then match that
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)
+ ; match_result <- match (var':vars) ty $
+ map (decomposeFirstPat getViewPat) eqns
-- compile the view expressions
- ; viewExpr' <- dsLExpr viewExpr
+ ; viewExpr' <- dsLExpr viewExpr
; return (mkViewMatchResult var' viewExpr' var match_result) }
+matchView _ _ _ = panic "matchView"
-- decompose the first pattern and leave the rest alone
decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo
decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
= eqn { eqn_pats = extractpat pat : pats}
-
-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)
-
+decomposeFirstPat _ _ = panic "decomposeFirstPat"
+
+getCoPat, getBangPat, getViewPat :: Pat Id -> Pat Id
+getCoPat (CoPat _ pat _) = pat
+getCoPat _ = panic "getCoPat"
+getBangPat (BangPat pat ) = unLoc pat
+getBangPat _ = panic "getBangPat"
+getViewPat (ViewPat _ pat _) = unLoc pat
+getViewPat _ = panic "getBangPat"
\end{code}
%************************************************************************
-- NPlusKPat
-- but no other
-tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats }) = do
- (wrap, pat') <- tidy1 v pat
- return (wrap, eqn { eqn_pats = do pat' : pats })
+tidyEqnInfo _ (EqnInfo { eqn_pats = [] })
+ = panic "tidyEqnInfo"
+
+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
-> Pat Id -- The pattern against which it is to be matched
tidy1 v (VarPat var)
= return (wrapBind var v, WildPat (idType var))
-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 (AsPat (L _ var) pat)
-- NPats: we *might* be able to replace these w/ a simpler form
tidy1 _ (NPat lit mb_neg eq)
- = return (idDsWrapper, tidyNPat lit mb_neg eq)
+ = return (idDsWrapper, tidyNPat tidyLitPat 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)
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
-- Do not warn about incomplete patterns
-- Used for things like [ e | pat <- stuff ], where
-- incomplete patterns are just fine
-matchSinglePat (Var var) _ (L _ pat) ty match_result
- = match [var] ty [EqnInfo { eqn_pats = [pat], eqn_rhs = match_result }]
-
-matchSinglePat scrut hs_ctx pat ty match_result = do
- var <- selectSimpleMatchVarL pat
- match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result
- return (adjustMatchResult (bindNonRec var scrut) match_result')
+matchSinglePat (Var var) ctx (L _ pat) ty match_result
+ = do { locn <- getSrcSpanDs
+ ; matchCheck (DsMatchContext ctx locn)
+ [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}
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
+sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` 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
-- 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
- lexp e1 e2
+viewLExprEq (e1,_) (e2,_) = lexp e1 e2
+ where
+ lexp :: LHsExpr Id -> LHsExpr Id -> Bool
+ lexp e e' = exp (unLoc e) (unLoc e')
+
+ ---------
+ exp :: HsExpr Id -> HsExpr Id -> Bool
+ -- real comparison is on HsExpr's
+ -- strip parens
+ exp (HsPar (L _ e)) e' = exp e e'
+ exp e (HsPar (L _ e')) = exp e e'
+ -- because the expressions do not necessarily have the same type,
+ -- we have to compare the wrappers
+ exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e'
+ exp (HsVar i) (HsVar i') = i == i'
+ -- the instance for IPName derives using the id, so this works if the
+ -- above does
+ exp (HsIPVar i) (HsIPVar i') = i == i'
+ exp (HsOverLit l) (HsOverLit l') =
+ -- Overloaded lits are equal if they have the same type
+ -- and the data is the same.
+ -- this is coarser than comparing the SyntaxExpr's in l and l',
+ -- which resolve the overloading (e.g., fromInteger 1),
+ -- because these expressions get written as a bunch of different variables
+ -- (presumably to improve sharing)
+ eqType (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) = eqType t1 t2
+ tup_arg _ _ = False
+
+ ---------
+ wrap :: HsWrapper -> HsWrapper -> Bool
+ -- Conservative, in that it demands that wrappers be
+ -- syntactically identical and doesn't look under binders
+ --
+ -- Coarser notions of equality are possible
+ -- (e.g., reassociating compositions,
+ -- equating different ways of writing a coercion)
+ wrap WpHole WpHole = True
+ wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
+ wrap (WpCast c) (WpCast c') = coreEqCoercion c c'
+ wrap (WpEvApp et1) (WpEvApp et2) = ev_term et1 et2
+ wrap (WpTyApp t) (WpTyApp t') = eqType t t'
+ -- Enhancement: could implement equality for more wrappers
+ -- if it seems useful (lams and lets)
+ wrap _ _ = False
+
+ ---------
+ ev_term :: EvTerm -> EvTerm -> Bool
+ ev_term (EvId a) (EvId b) = a==b
+ ev_term (EvCoercion a) (EvCoercion b) = coreEqCoercion a b
+ ev_term _ _ = False
+
+ ---------
+ eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool
+ eq_list _ [] [] = True
+ eq_list _ [] (_:_) = False
+ eq_list _ (_:_) [] = False
+ eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
patGroup :: Pat Id -> PatGroup
patGroup (WildPat {}) = PgAny
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