[commit: ghc] wip/orf-reboot: lookupOccRn_overloaded need not return FieldLabelString (8791b7e)

[git at git.haskell.org]

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

On branch  : wip/orf-reboot
Link       : http://ghc.haskell.org/trac/ghc/changeset/8791b7e741a5711178fe55fac0e7c9889e6bcecd/ghc

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

commit 8791b7e741a5711178fe55fac0e7c9889e6bcecd
Author: Adam Gundry <adam at well-typed.com>
Date:   Mon Feb 23 16:29:46 2015 +0000

    lookupOccRn_overloaded need not return FieldLabelString


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

8791b7e741a5711178fe55fac0e7c9889e6bcecd
 compiler/rename/RnEnv.hs | 31 ++++++++++++++-----------------
 compiler/rename/RnPat.hs |  3 +--
 2 files changed, 15 insertions(+), 19 deletions(-)

diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index e927ff7..b505a28 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -826,12 +826,12 @@ lookupGlobalOccRn_maybe rdr_name
 
 
 -- The following are possible results of lookupOccRn_overloaded:
---   Nothing              -> name not in scope (no error reported)
---   Just (Left x)        -> name uniquely refers to x, or there is a name clash (reported)
---   Just (Right (l, xs)) -> ambiguous between the fields xs with label l;
---                           fields are represented as (parent, selector) pairs
+--   Nothing         -> name not in scope (no error reported)
+--   Just (Left x)   -> name uniquely refers to x, or there is a name clash (reported)
+--   Just (Right xs) -> ambiguous between the fields xs;
+--                      fields are represented as (parent, selector) pairs
 
-lookupOccRn_overloaded  :: RdrName -> RnM (Maybe (Either Name (FieldLabelString, [(Name, Name)])))
+lookupOccRn_overloaded  :: RdrName -> RnM (Maybe (Either Name [(Name, Name)]))
 lookupOccRn_overloaded rdr_name
   = do { local_env <- getLocalRdrEnv
        ; case lookupLocalRdrEnv local_env rdr_name of {
@@ -846,7 +846,7 @@ lookupOccRn_overloaded rdr_name
                                 -- and only happens for failed lookups
        ; lookupQualifiedNameGHCi_overloaded dflags is_ghci rdr_name } } } } }
 
-lookupGlobalOccRn_overloaded :: RdrName -> RnM (Maybe (Either Name (FieldLabelString, [(Name, Name)])))
+lookupGlobalOccRn_overloaded :: RdrName -> RnM (Maybe (Either Name [(Name, Name)]))
 lookupGlobalOccRn_overloaded rdr_name
   | Just n <- isExact_maybe rdr_name   -- This happens in derived code
   = do { n' <- lookupExactOcc n; return (Just (Left n')) }
@@ -860,14 +860,11 @@ lookupGlobalOccRn_overloaded rdr_name
         ; overload_ok <- xoptM Opt_OverloadedRecordFields
         ; case lookupGRE_RdrName rdr_name env of
                 []    -> return Nothing
-                [gre] | Just lbl <- greLabel gre
-                         -> do { addUsedRdrName True gre rdr_name
-                               ; return (Just (Right (lbl, [greBits gre]))) }
                 [gre]    -> do { addUsedRdrName True gre rdr_name
                                ; return (Just (Left (gre_name gre))) }
                 gres  | all isRecFldGRE gres && overload_ok
                          -> do { mapM_ (\ gre -> addUsedRdrName True gre rdr_name) gres
-                               ; return (Just (Right (expectJust "greLabel" (greLabel (head gres)), map greBits gres))) }
+                               ; return (Just (Right (map greBits gres))) }
                 gres     -> do { addNameClashErrRn rdr_name gres
                                ; return (Just (Left (gre_name (head gres)))) } }
   where
@@ -1081,7 +1078,7 @@ lookupQualifiedNameGHCi rdr_name
 -- should never be overloaded, so when we check for overloaded field
 -- matches, generate name clash errors if we find more than one.
 lookupQualifiedNameGHCi_overloaded :: DynFlags -> Bool -> RdrName
-                                   -> RnM (Maybe (Either Name (FieldLabelString, [(Name, Name)])))
+                                   -> RnM (Maybe (Either Name [(Name, Name)]))
 lookupQualifiedNameGHCi_overloaded dflags is_ghci rdr_name
   | Just (mod,occ) <- isQual_maybe rdr_name
   , is_ghci
@@ -1099,14 +1096,14 @@ lookupQualifiedNameGHCi_overloaded dflags is_ghci rdr_name
                          , nameOccName name == occ ]
              -> ASSERT(null ns) return (Just (Left n))
 
-             | xs@((p, lbl, sel):ys) <- [ (availName avail, lbl, sel)
-                                        | iface <- ifaces
-                                        , avail <- mi_exports iface
-                                        , (lbl, sel) <- availOverloadedFlds avail
-                                        , lbl == occNameFS occ ]
+             | xs@((p, _, sel):ys) <- [ (availName avail, lbl, sel)
+                                      | iface <- ifaces
+                                      , avail <- mi_exports iface
+                                      , (lbl, sel) <- availOverloadedFlds avail
+                                      , lbl == occNameFS occ ]
              -> do { when (not (null ys)) $
                          addNameClashErrRn rdr_name (map (toFakeGRE mod) xs)
-                   ; return (Just (Right (lbl, [(p, sel)]))) }
+                   ; return (Just (Right [(p, sel)])) }
 
            _ -> -- Either we couldn't load the interface, or
                 -- we could but we didn't find the name in it
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index afd0d24..1249154 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -571,8 +571,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
                              ; case mb of
                                  Nothing -> do { addErr (unknownSubordinateErr doc lbl)
                                                ; return (Right []) }
-                                 Just (Left sel) -> return (Left sel)
-                                 Just (Right (_, xs)) -> return (Right xs) }
+                                 Just r  -> return r }
                       _ -> fmap Left $ lookupSubBndrOcc True parent doc lbl
            ; arg' <- if pun
                      then do { checkErr pun_ok (badPun (L loc lbl))