-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
+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)
+ 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
+
+ ---------
+ 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') = tcEqType c c'
+ wrap (WpEvApp et1) (WpEvApp et2) = ev_term et1 et2
+ wrap (WpTyApp t) (WpTyApp t') = tcEqType 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) = tcEqType 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