+ | 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
+groupEquations eqns
+ = runs same_gp [(patGroup (firstPat eqn), eqn) | eqn <- eqns]
+ where
+ same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
+ (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2
+
+subGroups :: [(PatGroup, EquationInfo)] -> [[EquationInfo]]
+-- Input is a particular group. The result sub-groups the
+-- equations by with particular constructor, literal etc they match.
+-- The order may be swizzled, so the matching should be order-independent
+subGroups groups = map (map snd) (equivClasses cmp groups)
+ where
+ (pg1, _) `cmp` (pg2, _) = pg1 `cmp_pg` pg2
+ (PgCon c1) `cmp_pg` (PgCon c2) = c1 `compare` c2
+ (PgLit l1) `cmp_pg` (PgLit l2) = l1 `compare` l2
+ (PgN l1) `cmp_pg` (PgN l2) = l1 `compare` l2
+ -- These are the only cases that are every sub-grouped
+
+sameGroup :: PatGroup -> PatGroup -> Bool
+-- Same group means that a single case expression
+-- or test will suffice to match both, *and* the order
+-- of testing within the group is insignificant.
+sameGroup PgAny PgAny = True
+sameGroup PgBang PgBang = True
+sameGroup (PgCon _) (PgCon _) = True -- One case expression
+sameGroup (PgLit _) (PgLit _) = True -- One case expression
+sameGroup (PgN _) (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
+ -- 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')
+
+ -- 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