+
+-- 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,t1) (e2,t2) =
+ 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
+