[commit: ghc] wip/gadtpm: replaced Eq instance for PmLit with explicit function eqPmLit (05b99e4)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/gadtpm
Link       : http://ghc.haskell.org/trac/ghc/changeset/05b99e42e67277d36c0114be8f4475c2ec6e96ac/ghc

>---------------------------------------------------------------

commit 05b99e42e67277d36c0114be8f4475c2ec6e96ac
Author: George Karachalias <george.karachalias at gmail.com>
Date:   Mon Oct 12 12:10:37 2015 +0200

    replaced Eq instance for PmLit with explicit function eqPmLit


>---------------------------------------------------------------

05b99e42e67277d36c0114be8f4475c2ec6e96ac
 compiler/deSugar/Check.hs    | 12 ++++++------
 compiler/deSugar/PmExpr.hs   | 18 ++++++++++++------
 compiler/deSugar/TmOracle.hs | 16 ++++++++--------
 3 files changed, 26 insertions(+), 20 deletions(-)

diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 3c0efed..406806f 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -927,8 +927,8 @@ cMatcher us gvsa (p@(PmCon { pm_con_con = c1, pm_con_args = args1 })) ps
 
 -- CLitLit
 cMatcher us gvsa (PmLit l1) ps (va@(PmLit l2)) vsa
-  | l1 /= l2  = Empty
-  | otherwise = VA va `mkCons` covered us gvsa ps vsa
+  | eqPmLit l1 l2  = VA va `mkCons` covered us gvsa ps vsa
+  | otherwise      = Empty
 
 -- CConVar
 cMatcher us gvsa (p@(PmCon { pm_con_con = con })) ps (PmVar x) vsa
@@ -979,8 +979,8 @@ uMatcher us gvsa ( p@(PmCon { pm_con_con = c1, pm_con_args = args1 })) ps
 
 -- ULitLit
 uMatcher us gvsa (PmLit l1) ps (va@(PmLit l2)) vsa
-  | l1 /= l2  = VA va `mkCons` vsa
-  | otherwise = VA va `mkCons` uncovered us gvsa ps vsa
+  | eqPmLit l1 l2 = VA va `mkCons` uncovered us gvsa ps vsa
+  | otherwise     = VA va `mkCons` vsa
 
 -- UConVar
 uMatcher us gvsa (p@(PmCon { pm_con_con = con })) ps (PmVar x) vsa
@@ -1043,8 +1043,8 @@ dMatcher us gvsa (p@(PmCon { pm_con_con = c1, pm_con_args = args1 })) ps
 
 -- DLitLit
 dMatcher us gvsa (PmLit l1) ps (va@(PmLit l2)) vsa
-  | l1 /= l2  = Empty
-  | otherwise = VA va `mkCons` divergent us gvsa ps vsa
+  | eqPmLit l1 l2 = VA va `mkCons` divergent us gvsa ps vsa
+  | otherwise     = Empty
 
 -- DConVar
 dMatcher us gvsa (p@(PmCon { pm_con_con = con })) ps (PmVar x) vsa
diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs
index 2ff624d..7360453 100644
--- a/compiler/deSugar/PmExpr.hs
+++ b/compiler/deSugar/PmExpr.hs
@@ -28,7 +28,7 @@ module PmExpr (
         filterComplex, runPmPprM, pprPmExprWithParens,
 
         -- Misc
-        truePmExpr, falsePmExpr, toComplex
+        truePmExpr, falsePmExpr, toComplex, eqPmLit
     ) where
 
 #include "HsVersions.h"
@@ -95,10 +95,16 @@ data PmExpr = PmExprVar   Id
 data PmLit = PmSLit HsLit                                    -- simple
            | PmOLit Bool {- is it negated? -} (HsOverLit Id) -- overloaded
 
-instance Eq PmLit where
-  PmSLit    l1 == PmSLit l2    = l1 == l2
-  PmOLit b1 l1 == PmOLit b2 l2 = b1 == b2 && l1 == l2
-  _ == _ = False
+-- do not make it an instance of Eq, we just need it for printing
+eqPmLit :: PmLit -> PmLit -> Bool
+eqPmLit (PmSLit    l1) (PmSLit l2   ) = l1 == l2 -- check the instances too for lits and olits
+eqPmLit (PmOLit b1 l1) (PmOLit b2 l2) = b1 == b2 && l1 == l2
+eqPmLit _               _             = False
+
+nubPmLit :: [PmLit] -> [PmLit]
+nubPmLit []     = []
+nubPmLit [x]    = [x]
+nubPmLit (x:xs) = x : nubPmLit (filter (not . eqPmLit x) xs)
 
 -- ----------------------------------------------------------------------------
 -- | Term equalities
@@ -336,7 +342,7 @@ filterComplex = zipWith rename nameList . map mkGroup
   where
     order x y = compare (fst x) (fst y)
     name  x y = fst x == fst y
-    mkGroup l = (fst (head l), nub $ map snd l)
+    mkGroup l = (fst (head l), nubPmLit $ map snd l)
     rename new (old, lits) = (old, (new, lits))
 
     isNegLitCs (e1,e2)
diff --git a/compiler/deSugar/TmOracle.hs b/compiler/deSugar/TmOracle.hs
index 94dc7d0..bbd888c 100644
--- a/compiler/deSugar/TmOracle.hs
+++ b/compiler/deSugar/TmOracle.hs
@@ -10,7 +10,7 @@
 module TmOracle (
           PmExpr(..), PmLit(..), PmVarEnv, SimpleEq, ComplexEq, PmNegLitCt,
           hsExprToPmExpr, lhsExprToPmExpr, isNotPmExprOther,
-          pmLitType, tmOracle, notForced, flattenPmVarEnv,
+          pmLitType, eqPmLit, tmOracle, notForced, flattenPmVarEnv,
           falsePmExpr, getValuePmExpr, filterComplex, runPmPprM,
           pprPmExprWithParens
           -- -- Incremental version
@@ -212,8 +212,8 @@ simplifyComplexEq eq =
 
     -- literals
     (PmExprLit l1, PmExprLit l2)
-      | l1 == l2  -> return (True, [])
-      | otherwise -> mismatch eq
+      | eqPmLit l1 l2 -> return (True, [])
+      | otherwise     -> mismatch eq
 
     -- constructors
     (PmExprCon c1 es1, PmExprCon c2 es2)
@@ -275,12 +275,12 @@ certainlyEqual e1 e2 =
     eqLit :: PmLit -> PmLit -> PmExpr
     eqLit l1 l2 = case (l1, l2) of
       (PmSLit {}, PmSLit {})
-        | l1 == l2  -> truePmExpr
-        | otherwise -> falsePmExpr
+        | eqPmLit l1 l2 -> truePmExpr
+        | otherwise     -> falsePmExpr
       (PmOLit {}, PmOLit {})
-        | l1 == l2  -> truePmExpr
-        | otherwise -> falsePmExpr
-      _overloaded   -> expr
+        | eqPmLit l1 l2 -> truePmExpr
+        | otherwise     -> falsePmExpr
+      _overloaded       -> expr
 
     certainlyEqualMany :: [PmExpr] -> [PmExpr] -> PmExpr
     certainlyEqualMany es1 es2 =