X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FMatch.lhs;h=1a044d3471be686c021f38bd10d5b2dcefa9400a;hp=a7e9bce188c8b014596d8fee81538034304f8480;hb=ca53c38335cdc671f0b1e0949aa1514fc3fd72a5;hpb=30c122df62ec75f9ed7f392f24c2925675bf1d06 diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index a7e9bce..1a044d3 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -6,13 +6,6 @@ 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" @@ -26,6 +19,7 @@ import Check import CoreSyn import Literal import CoreUtils +import MkCore import DsMonad import DsBinds import DsGRHSs @@ -34,8 +28,8 @@ import Id import DataCon import MatchCon import MatchLit -import PrelInfo import Type +import Coercion import TysWiredIn import ListSetOps import SrcLoc @@ -44,6 +38,9 @@ import Util import Name import Outputable import FastString + +import Control.Monad( when ) +import qualified Data.Map as Map \end{code} This function is a wrapper of @match@, it must be called from all the parts where @@ -60,9 +57,9 @@ matchCheck :: DsMatchContext -> [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 @@ -70,28 +67,31 @@ matchCheck_really :: DynFlags -> 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. @@ -112,11 +112,11 @@ dsShadowWarn ctx@(DsMatchContext kind loc) qs = 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) @@ -124,19 +124,19 @@ dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM () dsIncompleteWarn ctx@(DsMatchContext kind loc) pats = putSrcSpanDs loc (warnDs warn) where - warn = pp_context ctx (ptext SLIT("are non-exhaustive")) - (\_ -> 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 @@ -148,16 +148,16 @@ 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("...")] + = 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 [ppr_pats pats, ptext (sLit "with"), sep (map ppr_constraint constraints)] ppr_constraint :: (Name,[HsLit]) -> SDoc -ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`notElem`"), ppr pats] +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)) @@ -242,7 +242,7 @@ Make all constructor patterns in column~1 into @ConPats@, notably 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). @@ -268,7 +268,7 @@ Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@ corresponds roughly to @matchVarCon@. \begin{code} -match :: [Id] -- Variables rep'ing the exprs we're matching with +match :: [Id] -- Variables rep\'ing the exprs we\'re matching with -> Type -- Type of the case expression -> [EquationInfo] -- Info about patterns, etc. (type synonym below) -> DsM MatchResult -- Desugared result! @@ -285,14 +285,13 @@ 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 + (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 - ; ifOptM 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) $ @@ -302,12 +301,13 @@ match vars@(v:_) ty eqns 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) - PgCon _ -> matchConFamily vars ty (subGroups eqns) - PgLit _ -> matchLiterals vars ty (subGroups eqns) - PgN _ -> matchNPats vars ty (subGroups 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) @@ -332,20 +332,26 @@ 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 (_: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 (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) } + ; var' <- newUniqueId var (hsPatType pat) + ; match_result <- match (var':vars) ty $ + map (decomposeFirstPat getCoPat) eqns + ; co' <- dsHsWrapper co + ; let rhs' = co' (Var var) + ; return (mkCoLetMatchResult (NonRec var' rhs') match_result) } +matchCoercion _ _ _ = panic "matchCoercion" matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- Apply the view function to the match variable and then match that @@ -355,23 +361,27 @@ matchView (var:vars) ty (eqns@(eqn1:_)) -- 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) + ; var' <- newUniqueId var (hsPatType pat) + ; 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} %************************************************************************ @@ -431,9 +441,12 @@ tidyEqnInfo :: Id -> EquationInfo -- 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 @@ -460,11 +473,6 @@ tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty) tidy1 v (VarPat var) = return (wrapBind var v, WildPat (idType var)) -tidy1 v (VarPatOut var binds) - = do { prs <- dsLHsBinds binds - ; 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 (AsPat (L _ var) pat) @@ -485,7 +493,7 @@ tidy1 v (AsPat (L _ var) pat) tidy1 v (LazyPat pat) = do { sel_prs <- mkSelectorBinds pat (Var v) ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] - ; return (mkDsLets sel_binds, WildPat (idType v)) } + ; return (mkCoreLets sel_binds, WildPat (idType v)) } tidy1 _ (ListPat pats ty) = return (idDsWrapper, unLoc list_ConPat) @@ -515,7 +523,21 @@ tidy1 _ (LitPat lit) -- 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 _ (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... @@ -682,21 +704,14 @@ matchEquations :: HsMatchContext Name -> [Id] -> [EquationInfo] -> Type -> DsM CoreExpr matchEquations ctxt vars eqns_info rhs_ty - = do { dflags <- getDOptsDs - ; locn <- getSrcSpanDs - ; let ds_ctxt = DsMatchContext ctxt locn - error_string = matchContextErrString ctxt + = do { locn <- getSrcSpanDs + ; let ds_ctxt = DsMatchContext ctxt locn + error_doc = matchContextErrString ctxt - ; match_result <- match_fun dflags ds_ctxt vars rhs_ty eqns_info + ; match_result <- matchCheck ds_ctxt vars rhs_ty eqns_info - ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string + ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc ; extractMatchResult match_result fail_expr } - where - match_fun dflags ds_ctxt - = case ctxt of - LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchCheck ds_ctxt - | otherwise -> match - _ -> matchCheck ds_ctxt \end{code} %************************************************************************ @@ -716,7 +731,7 @@ matchSimply :: CoreExpr -- Scrutinee -> CoreExpr -- Return this if it matches -> CoreExpr -- Return this if it doesn't -> DsM CoreExpr - +-- Do not warn about incomplete patterns; see matchSinglePat comments matchSimply scrut hs_ctx pat result_expr fail_expr = do let match_result = cantFailMatchResult result_expr @@ -725,24 +740,21 @@ matchSimply scrut hs_ctx pat result_expr fail_expr = do 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 = do - dflags <- getDOptsDs - locn <- getSrcSpanDs - let - match_fn dflags - | dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx - | 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') +-- Do not warn about incomplete patterns +-- Used for things like [ e | pat <- stuff ], where +-- incomplete patterns are just fine +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} @@ -771,24 +783,39 @@ groupEquations :: [EquationInfo] -> [[(PatGroup, EquationInfo)]] -- If the result is of form [g1, g2, g3], -- (a) all the (pg,eq) pairs in g1 have the same pg -- (b) none of the gi are empty +-- The ordering of equations is unchanged groupEquations eqns = runs same_gp [(patGroup (firstPat eqn), eqn) | eqn <- eqns] where same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2 -subGroups :: [(PatGroup, EquationInfo)] -> [[EquationInfo]] +subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]] -- Input is a particular group. The result sub-groups the -- equations by with particular constructor, literal etc they match. --- The order may be swizzled, so the matching should be order-independent -subGroups groups = map (map snd) (equivClasses cmp groups) +-- Each sub-list in the result has the same PatGroup +-- See Note [Take care with pattern order] +subGroup group + = map reverse $ Map.elems $ foldl accumulate Map.empty group where - (pg1, _) `cmp` (pg2, _) = pg1 `cmp_pg` pg2 - (PgCon c1) `cmp_pg` (PgCon c2) = c1 `compare` c2 - (PgLit l1) `cmp_pg` (PgLit l2) = l1 `compare` l2 - (PgN l1) `cmp_pg` (PgN l2) = l1 `compare` l2 - -- These are the only cases that are every sub-grouped + accumulate pg_map (pg, eqn) + = case Map.lookup pg pg_map of + Just eqns -> Map.insert pg (eqn:eqns) pg_map + Nothing -> Map.insert pg [eqn] pg_map + + -- pg_map :: Map a [EquationInfo] + -- Equations seen so far in reverse order of appearance +\end{code} +Note [Take care with pattern order] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the subGroup function we must be very careful about pattern re-ordering, +Consider the patterns [ (True, Nothing), (False, x), (True, y) ] +Then in bringing together the patterns for True, we must not +swap the Nothing and y! + + +\begin{code} sameGroup :: PatGroup -> PatGroup -> Bool -- Same group means that a single case expression -- or test will suffice to match both, *and* the order @@ -797,10 +824,9 @@ sameGroup PgAny PgAny = True sameGroup PgBang PgBang = True sameGroup (PgCon _) (PgCon _) = True -- One case expression sameGroup (PgLit _) (PgLit _) = True -- One case expression -sameGroup (PgN _) (PgN _) = 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 (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 `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 @@ -810,12 +836,12 @@ sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2) -- are "equal"---conservatively, we use syntactic equality sameGroup _ _ = False --- an approximation of syntactic equality used for determining when view +-- An approximation of syntactic equality used for determining when view -- exprs are in the same group. --- this function can always safely return false; +-- 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 +-- Currently: compare applications of literals and variables -- and anything else that we can do without involving other -- HsSyn types in the recursion -- @@ -823,74 +849,87 @@ sameGroup _ _ = False -- 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') - - -- 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 +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 @@ -904,8 +943,8 @@ patGroup (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) patGroup pat = pprPanic "patGroup" (ppr pat) \end{code} -Note [Order of n+k] -~~~~~~~~~~~~~~~~~~~ +Note [Grouping overloaded literal patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ WATCH OUT! Consider f (n+1) = ... @@ -913,9 +952,12 @@ WATCH OUT! Consider f (n+1) = ... We can't group the first and third together, because the second may match -the same thing as the first. Contrast - f 1 = ... - f 2 = ... - f 1 = ... -where we can group the first and third. Hence we don't regard (n+1) and -(n+2) as part of the same group. +the same thing as the first. Same goes for *overloaded* literal patterns + f 1 True = ... + f 2 False = ... + f 1 False = ... +If the first arg matches '1' but the second does not match 'True', we +cannot jump to the third equation! Because the same argument might +match '2'! +Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group. +