[commit: ghc] wip/gadtpm: separate and cleaner NPat translation (218241b)

[git at git.haskell.org]

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

On branch  : wip/gadtpm
Link       : http://ghc.haskell.org/trac/ghc/changeset/218241b604623dabc427e34e694e08a5048626f9/ghc

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

commit 218241b604623dabc427e34e694e08a5048626f9
Author: George Karachalias <george.karachalias at gmail.com>
Date:   Sun Nov 29 00:26:21 2015 +0100

    separate and cleaner NPat translation


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

218241b604623dabc427e34e694e08a5048626f9
 compiler/deSugar/Check.hs                          | 43 ++++++++++------------
 compiler/deSugar/PmExpr.hs                         |  2 +-
 .../tests/deSugar/should_compile/T5117.stderr      |  2 +-
 3 files changed, 22 insertions(+), 25 deletions(-)

diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 6fb673c..ecbaed5 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -217,22 +217,6 @@ mkListPatVec ty xs ys = [NonGuard $ PmCon { pm_con_con = consDataCon
 mkLitPattern :: HsLit -> Pattern
 mkLitPattern lit = NonGuard $ PmLit { pm_lit_lit = PmSLit lit }
 
-mkPosLitPattern :: HsOverLit Id -> Pattern
-mkPosLitPattern lit = NonGuard $ PmLit { pm_lit_lit = PmOLit False lit }
-
-mkNegLitPattern :: HsOverLit Id -> Pattern
-mkNegLitPattern lit = NonGuard $ PmLit { pm_lit_lit = PmOLit True lit }
-
--- Specifically for overloaded strings. If we know that an overloaded x is a
--- string, we can remove the fromString function since we know that it is the
--- identity.
-oStrToHsLit_mb :: HsOverLit Id -> Maybe HsLit
-oStrToHsLit_mb olit
-  | ol_type olit == stringTy
-  , HsIsString src fs <- ol_val olit
-  = Just (HsString src fs)
-  | otherwise = Nothing
-
 -- -----------------------------------------------------------------------
 -- * Transform (Pat Id) into of (PmPat Id)
 
@@ -315,10 +299,7 @@ translatePat pat = case pat of
                               , pm_con_dicts   = dicts
                               , pm_con_args    = args }]
 
-  NPat (L _ lit) mb_neg _eq
-    | Just hs_lit <- oStrToHsLit_mb lit -> translatePat (LitPat hs_lit) -- overloaded string
-    | Just _  <- mb_neg -> return [mkNegLitPattern lit] -- negated literal
-    | Nothing <- mb_neg -> return [mkPosLitPattern lit] -- non-negated literal
+  NPat (L _ ol) mb_neg _eq -> translateNPat ol mb_neg
 
   LitPat lit
       -- If it is a string then convert it to a list of characters
@@ -339,9 +320,25 @@ translatePat pat = case pat of
 
   -- --------------------------------------------------------------------------
   -- Not supposed to happen
-  ConPatIn {}      -> panic "Check.translatePat: ConPatIn"
-  SplicePat {}     -> panic "Check.translatePat: SplicePat"
-  SigPatIn {}      -> panic "Check.translatePat: SigPatIn"
+  ConPatIn  {} -> panic "Check.translatePat: ConPatIn"
+  SplicePat {} -> panic "Check.translatePat: SplicePat"
+  SigPatIn  {} -> panic "Check.translatePat: SigPatIn"
+
+-- replicate of tidyNPat
+translateNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> UniqSM PatVec
+translateNPat (OverLit val False _ ty) mb_neg
+  | isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg
+  = translatePat (LitPat (HsString src s))
+  | isIntTy    ty, HsIntegral src i <- val
+  = translatePat (mk_num_lit HsInt src i)
+  | isWordTy   ty, HsIntegral src i <- val
+  = translatePat (mk_num_lit HsWordPrim src i)
+  where
+    mk_num_lit c src i = LitPat $ case mb_neg of
+      Nothing -> c src i
+      Just _  -> c src (-i)
+translateNPat ol mb_neg
+  = return [NonGuard $ PmLit { pm_lit_lit = PmOLit (isJust mb_neg) ol }]
 
 translatePatVec :: [Pat Id] -> UniqSM [PatVec] -- Do not concatenate them (sometimes we need them separately)
 translatePatVec pats = mapM translatePat pats
diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs
index 02ae3db..aa566fb 100644
--- a/compiler/deSugar/PmExpr.hs
+++ b/compiler/deSugar/PmExpr.hs
@@ -71,7 +71,7 @@ eqPmLit :: PmLit -> PmLit -> Maybe Bool
 eqPmLit (PmSLit    l1) (PmSLit l2   ) = Just (l1 == l2) -- check the instances too for lits and olits
 eqPmLit (PmOLit b1 l1) (PmOLit b2 l2) = if res then Just True else Nothing
   where res = b1 == b2 && l1 == l2
-eqPmLit _ _ = Nothing
+eqPmLit _ _ = Just False -- this should not even happen I think
 
 nubPmLit :: [PmLit] -> [PmLit]
 nubPmLit []     = []
diff --git a/testsuite/tests/deSugar/should_compile/T5117.stderr b/testsuite/tests/deSugar/should_compile/T5117.stderr
index 93de2cf..954844d 100644
--- a/testsuite/tests/deSugar/should_compile/T5117.stderr
+++ b/testsuite/tests/deSugar/should_compile/T5117.stderr
@@ -1,4 +1,4 @@
 
 T5117.hs:15:1: Warning:
-    Pattern match(es) are overlapped
+    Pattern match(es) are redundant
     In an equation for ‘f3’: f3 (MyString "a") = ...