X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FMatch.lhs;h=f545930a48c44826faf1a38aaf5de112a27d880d;hb=860e92c1dd65f2a7a617c253849d7ce84ed9bbc9;hp=d793343e4177b8ec2180e7420265ab8d05fcc8c6;hpb=3cec5683766a13019c2835a4e79cc7e7dc066b96;p=ghc-hetmet.git diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index d793343..f545930 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -1,41 +1,49 @@ % +% (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, hsPatType ) -import Check ( check, ExhaustivePat ) +import TcHsSyn +import Check import CoreSyn -import Literal ( Literal ) -import CoreUtils ( bindNonRec, exprType ) +import Literal +import CoreUtils import DsMonad -import DsBinds ( dsLHsBinds, dsCoercion ) -import DsGRHSs ( dsGRHSs ) +import DsBinds +import DsGRHSs import DsUtils -import Id ( idName, idType, Id ) -import DataCon ( DataCon ) -import MatchCon ( matchConFamily ) -import MatchLit ( matchLiterals, matchNPlusKPats, matchNPats, - tidyLitPat, tidyNPat, hsLitKey, hsOverLitKey ) -import PrelInfo ( pAT_ERROR_ID ) -import TcType ( Type ) -import Type ( splitFunTysN, coreEqType ) -import TysWiredIn ( consDataCon, mkListTy, unitTy, - tupleCon, parrFakeCon, mkPArrTy ) -import BasicTypes ( Boxity(..) ) -import ListSetOps ( equivClasses, runs ) -import SrcLoc ( unLoc, Located(..) ) -import Maybes ( isJust ) -import Util ( lengthExceeds, notNull ) -import Name ( Name ) +import Id +import DataCon +import MatchCon +import MatchLit +import PrelInfo +import Type +import TysWiredIn +import ListSetOps +import SrcLoc +import Maybes +import Util +import Name import Outputable +import FastString \end{code} This function is a wrapper of @match@, it must be called from all the parts where @@ -52,20 +60,26 @@ matchCheck :: DsMatchContext -> [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 @@ -86,6 +100,7 @@ It will limit the number of patterns/equations displayed to@ maximum_output@. (ToDo: add command-line option?) \begin{code} +maximum_output :: Int maximum_output = 4 \end{code} @@ -97,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) @@ -109,37 +124,42 @@ dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM () 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} @@ -254,8 +274,8 @@ match :: [Id] -- Variables rep'ing the exprs we're matching with -> DsM MatchResult -- Desugared result! match [] ty eqns - = ASSERT( not (null eqns) ) - returnDs (foldr1 combineMatchResults match_results) + = ASSERT2( not (null eqns), ppr ty ) + return (foldr1 combineMatchResults match_results) where match_results = [ ASSERT( null (eqn_pats eqn) ) eqn_rhs eqn @@ -268,8 +288,13 @@ match vars@(v:_) ty eqns (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) + ; 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 @@ -278,39 +303,75 @@ match vars@(v:_) ty eqns 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) + = case group of + PgAny -> matchVariables vars ty (dropGroup eqns) + PgCon _ -> matchConFamily vars ty (subGroups eqns) + PgLit _ -> matchLiterals vars ty (subGroups eqns) + PgN _ -> matchNPats vars ty (subGroups 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) +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 shift eqns) + = do { match_result <- match (var:vars) ty (map decomposeFirst_Bang 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) +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 shift (eqn1:eqns)) + ; match_result <- match (var':vars) ty (map decomposeFirst_Coercion 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 } + +matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +-- Apply the view function to the match variable and then match that +matchView (var:vars) ty (eqns@(eqn1:_)) + = do { -- we could pass in the expr from the PgView, + -- but this needs to extract the pat anyway + -- to figure out the type of the fresh variable + let ViewPat viewExpr (L _ pat) _ = firstPat eqn1 + -- do the rest of the compilation + ; var' <- newUniqueId (idName var) (hsPatType pat) + ; match_result <- match (var':vars) ty (map decomposeFirst_View eqns) + -- compile the view expressions + ; viewExpr' <- dsLExpr viewExpr + ; return (mkViewMatchResult var' viewExpr' var match_result) } + +-- decompose the first pattern and leave the rest alone +decomposeFirstPat :: (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} %************************************************************************ @@ -370,9 +431,9 @@ tidyEqnInfo :: Id -> EquationInfo -- NPlusKPat -- but no other -tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats }) - = tidy1 v pat `thenDs` \ (wrap, pat') -> - returnDs (wrap, eqn { 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 -> Pat Id -- The pattern against which it is to be matched @@ -392,12 +453,12 @@ tidy1 :: Id -- The Id being scrutinised tidy1 v (ParPat pat) = tidy1 v (unLoc pat) tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat) -tidy1 v (WildPat ty) = returnDs (idWrapper, WildPat ty) +tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty) -- case v of { x -> mr[] } -- = case v of { _ -> let x=v in mr[] } tidy1 v (VarPat var) - = returnDs (wrapBind var v, WildPat (idType var)) + = return (wrapBind var v, WildPat (idType var)) tidy1 v (VarPatOut var binds) = do { prs <- dsLHsBinds binds @@ -424,10 +485,10 @@ 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] - ; returnDs (mkDsLets sel_binds, WildPat (idType v)) } + ; return (mkDsLets sel_binds, WildPat (idType v)) } -tidy1 v (ListPat pats ty) - = returnDs (idWrapper, 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) @@ -436,39 +497,30 @@ tidy1 v (ListPat pats ty) -- Introduce fake parallel array constructors to be able to handle parallel -- arrays with the existing machinery for constructor pattern -tidy1 v (PArrPat pats ty) - = returnDs (idWrapper, unLoc parrConPat) +tidy1 _ (PArrPat pats ty) + = return (idDsWrapper, unLoc parrConPat) where arity = length pats parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty) -tidy1 v (TuplePat pats boxity ty) - = returnDs (idWrapper, 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 (DictPat dicts methods) - = case num_of_d_and_ms of - 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 (LitPat lit) - = returnDs (idWrapper, tidyLitPat lit) +tidy1 _ (LitPat lit) + = return (idDsWrapper, tidyLitPat lit) -- NPats: we *might* be able to replace these w/ a simpler form -tidy1 v (NPat lit mb_neg eq lit_ty) - = returnDs (idWrapper, tidyNPat lit mb_neg eq lit_ty) +tidy1 _ (NPat lit mb_neg eq) + = return (idDsWrapper, tidyNPat lit mb_neg eq) -- Everything else goes through unchanged... -tidy1 v non_interesting_pat - = returnDs (idWrapper, non_interesting_pat) +tidy1 _ non_interesting_pat + = return (idDsWrapper, non_interesting_pat) \end{code} \noindent @@ -610,7 +662,8 @@ JJQC 30-Nov-1997 \begin{code} matchWrapper ctxt (MatchGroup matches match_ty) - = do { eqns_info <- mapM mk_eqn_info matches + = 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) } @@ -664,34 +717,32 @@ matchSimply :: CoreExpr -- Scrutinee -> 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 - in + | 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 - = selectSimpleMatchVarL pat `thenDs` \ var -> - matchSinglePat (Var var) hs_ctx pat ty match_result `thenDs` \ match_result' -> - returnDs (adjustMatchResult (bindNonRec var scrut) 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} @@ -712,9 +763,14 @@ data PatGroup | PgBang -- Bang patterns | PgCo Type -- Coercion patterns; the type is the type -- of the pattern *inside* - + | PgView (LHsExpr Id) -- view pattern (e -> p): + -- the LHsExpr is the expression e + Type -- the Type is the type of p (equivalently, the result type of e) groupEquations :: [EquationInfo] -> [[(PatGroup, EquationInfo)]] +-- If the result is of form [g1, g2, g3], +-- (a) all the (pg,eq) pairs in g1 have the same pg +-- (b) none of the gi are empty groupEquations eqns = runs same_gp [(patGroup (firstPat eqn), eqn) | eqn <- eqns] where @@ -741,7 +797,7 @@ 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 (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 @@ -749,16 +805,102 @@ sameGroup (PgCo t1) (PgCo t2) = t1 `coreEqType` t2 -- 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') + + -- 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 (WpCast c) (WpCast c') = tcEqType c c' + wrap (WpApp d) (WpApp d') = d == d' + wrap (WpTyApp t) (WpTyApp t') = tcEqType t t' + -- Enhancement: could implement equality for more wrappers + -- if it seems useful (lams and lets) + wrap _ _ = False + + -- real comparison is on HsExpr's + -- strip parens + exp (HsPar (L _ e)) e' = exp e e' + exp e (HsPar (L _ e')) = exp e e' + -- because the expressions do not necessarily have the same type, + -- we have to compare the wrappers + exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e' + exp (HsVar i) (HsVar i') = i == i' + -- the instance for IPName derives using the id, so this works if the + -- above does + exp (HsIPVar i) (HsIPVar i') = i == i' + exp (HsOverLit l) (HsOverLit l') = + -- overloaded lits are equal if they have the same type + -- and the data is the same. + -- this is coarser than comparing the SyntaxExpr's in l and l', + -- which resolve the overloading (e.g., fromInteger 1), + -- because these expressions get written as a bunch of different variables + -- (presumably to improve sharing) + tcEqType (overLitType l) (overLitType l') && l == l' + -- comparing the constants seems right + exp (HsLit l) (HsLit l') = l == l' + exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2' + -- the fixities have been straightened out by now, so it's safe + -- to ignore them? + exp (OpApp l o _ ri) (OpApp l' o' _ ri') = + lexp l l' && lexp o o' && lexp ri ri' + exp (NegApp e n) (NegApp e' n') = lexp e e' && exp n n' + exp (SectionL e1 e2) (SectionL e1' e2') = + lexp e1 e1' && lexp e2 e2' + exp (SectionR e1 e2) (SectionR e1' e2') = + lexp e1 e1' && lexp e2 e2' + exp (HsIf e e1 e2) (HsIf e' e1' e2') = + lexp e e' && lexp e1 e1' && lexp e2 e2' + exp (ExplicitList _ ls) (ExplicitList _ ls') = lexps ls ls' + exp (ExplicitPArr _ ls) (ExplicitPArr _ ls') = lexps ls ls' + exp (ExplicitTuple ls _) (ExplicitTuple ls' _) = lexps ls ls' + -- Enhancement: could implement equality for more expressions + -- if it seems useful + exp _ _ = False + in + lexp e1 e2 + patGroup :: Pat Id -> PatGroup patGroup (WildPat {}) = PgAny patGroup (BangPat {}) = PgBang patGroup (ConPatOut { pat_con = dc }) = PgCon (unLoc dc) patGroup (LitPat lit) = PgLit (hsLitKey lit) -patGroup (NPat olit mb_neg _ _) = PgN (hsOverLitKey olit (isJust mb_neg)) +patGroup (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 (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}