[commit: ghc] wip/orf-reboot: Return FieldOccs from lookupOccRn_overloaded (c874a85)

[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/c874a8519c7ca60fcd6a8e4ed4760212183aa81a/ghc

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

commit c874a8519c7ca60fcd6a8e4ed4760212183aa81a
Author: Adam Gundry <adam at well-typed.com>
Date:   Tue Jul 14 09:32:15 2015 +0100

    Return FieldOccs from lookupOccRn_overloaded


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

c874a8519c7ca60fcd6a8e4ed4760212183aa81a
 compiler/rename/RnEnv.hs  | 20 ++++++++++++--------
 compiler/rename/RnExpr.hs |  5 ++---
 compiler/rename/RnPat.hs  |  3 +--
 3 files changed, 15 insertions(+), 13 deletions(-)

diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index d203a58..15a3a0a 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -833,10 +833,10 @@ lookupGlobalOccRn_maybe rdr_name
 --   * 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) -> name refers to one or more (parent, record selector)
---                        pairs; if overload_ok was False, this list will be
+--   * Just (Right xs) -> name refers to one or more record selectors;
+--                        if overload_ok was False, this list will be
 --                        a singleton.
-lookupOccRn_overloaded  :: Bool -> RdrName -> RnM (Maybe (Either Name [(Name, Name)]))
+lookupOccRn_overloaded  :: Bool -> RdrName -> RnM (Maybe (Either Name [FieldOcc Name]))
 lookupOccRn_overloaded overload_ok rdr_name
   = do { local_env <- getLocalRdrEnv
        ; case lookupLocalRdrEnv local_env rdr_name of {
@@ -853,7 +853,7 @@ lookupOccRn_overloaded overload_ok rdr_name
            (n:_) -> return $ Just $ Left n  -- Unlikely to be more than one...?
            []    -> return Nothing  } } } } }
 
-lookupGlobalOccRn_overloaded :: Bool -> RdrName -> RnM (Maybe (Either Name [(Name, Name)]))
+lookupGlobalOccRn_overloaded :: Bool -> RdrName -> RnM (Maybe (Either Name [FieldOcc Name]))
 lookupGlobalOccRn_overloaded overload_ok rdr_name
   | Just n <- isExact_maybe rdr_name   -- This happens in derived code
   = do { n' <- lookupExactOcc n; return (Just (Left n')) }
@@ -868,18 +868,22 @@ lookupGlobalOccRn_overloaded overload_ok rdr_name
                 []    -> return Nothing
                 [gre] | isOverloadedRecFldGRE gre
                          -> do { addUsedRdrName True gre rdr_name
-                               ; return (Just (Right [greBits gre])) }
+                               ; return (Just (Right [greToFieldOcc gre])) }
                       | otherwise
                          -> 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 (map greBits gres))) }
+                               ; return (Just (Right (map greToFieldOcc gres))) }
                 gres     -> do { addNameClashErrRn rdr_name gres
                                ; return (Just (Left (gre_name (head gres)))) } }
   where
-    greBits (GRE{ gre_name = n, gre_par = FldParent { par_is = p }}) = (p, n)
-    greBits gre = pprPanic "lookupGlobalOccRn_overloaded/greBits" (ppr gre)
+    greToFieldOcc :: GlobalRdrElt -> FieldOcc Name
+    greToFieldOcc gre = FieldOcc rdr_name (FieldLabel lbl is_overloaded sel)
+      where
+        lbl           = occNameFS $ rdrNameOcc rdr_name
+        is_overloaded = isOverloadedRecFldGRE gre
+        sel           = gre_name gre
 
 
 --------------------------------------------------
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index f73686e..52947c0 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -109,9 +109,8 @@ rnExpr (HsVar v)
 
               | otherwise
               -> finishHsVar name ;
-           Just (Right ((_, sel_name):ns)) -> ASSERT( null ns )
-                                              -- AMG TODO push up into lookupOccRn_overloaded? False is wrong!
-                                              return (HsSingleRecFld (FieldOcc v (FieldLabel (occNameFS $ rdrNameOcc v) False sel_name)), unitFV sel_name) ;
+           Just (Right (f:fs)) -> ASSERT( null fs )
+                                  return (HsSingleRecFld f, unitFV (flSelector (labelFieldOcc f))) ;
            Just (Right [])                 -> error "runExpr/HsVar" } }
 
 rnExpr (HsIPVar v)
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index 19fada3..d10e5a6 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -55,7 +55,6 @@ import NameSet
 import RdrName
 import BasicTypes
 import Util
-import Maybes
 import ListSetOps          ( removeDups )
 import Outputable
 import SrcLoc
@@ -694,7 +693,7 @@ rnHsRecUpdFields flds
            ; return (L l (HsRecUpdField { hsRecUpdFieldLbl = L loc lbl
                                         , hsRecUpdFieldSel = case sel of
                                                                Left sel_name -> [sel_name]
-                                                               Right xs      -> map snd xs
+                                                               Right xs      -> map (flSelector . labelFieldOcc) xs
                                         , hsRecUpdFieldArg = arg''
                                         , hsRecUpdPun      = pun }), fvs') }