[commit: ghc] wip/orf-reboot: Simplify rnField to take [FieldLabel] instead of looking it up from constructor Name (454b0f7)

[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/454b0f7c4d29727bd8da4e460f11040212d42e37/ghc

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

commit 454b0f7c4d29727bd8da4e460f11040212d42e37
Author: Adam Gundry <adam at well-typed.com>
Date:   Mon Feb 23 16:17:10 2015 +0000

    Simplify rnField to take [FieldLabel] instead of looking it up from constructor Name


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

454b0f7c4d29727bd8da4e460f11040212d42e37
 compiler/rename/RnSource.hs        |  5 +++--
 compiler/rename/RnTypes.hs         | 23 +++++++++++------------
 compiler/typecheck/TcTyClsDecls.hs |  2 +-
 3 files changed, 15 insertions(+), 15 deletions(-)

diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 356f799..330062b 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -1401,7 +1401,7 @@ rnConDecl decl@(ConDecl { con_names = names, con_qvars = tvs
 
         ; bindHsTyVars doc Nothing free_kvs new_tvs $ \new_tyvars -> do
         { (new_context, fvs1) <- rnContext doc lcxt
-        ; (new_details, fvs2) <- rnConDeclDetails (unLoc $ head new_names) doc details -- AMG TODO ?
+        ; (new_details, fvs2) <- rnConDeclDetails (unLoc $ head new_names) doc details
         ; (new_details', new_res_ty, fvs3)
                      <- rnConResult doc (map unLoc new_names) new_details res_ty
         ; return (decl { con_names = new_names, con_qvars = new_tyvars
@@ -1450,7 +1450,8 @@ rnConDeclDetails _ doc (InfixCon ty1 ty2)
        ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
 
 rnConDeclDetails con doc (RecCon (L l fields))
-  = do  { (new_fields, fvs) <- rnConDeclFields con doc fields
+  = do  { fls <- lookupConstructorFields con
+        ; (new_fields, fvs) <- rnConDeclFields fls doc fields
                 -- No need to check for duplicate fields
                 -- since that is done by RnNames.extendGlobalRdrEnvRn
         ; return (RecCon (L l new_fields), fvs) }
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index 29528f2..e62f74f 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -215,8 +215,7 @@ rnHsTyKi isType doc (HsBangTy b ty)
 rnHsTyKi _ doc ty@(HsRecTy flds)
   = do { addErr (hang (ptext (sLit "Record syntax is illegal here:"))
                     2 (ppr ty))
-       ; let bogus_con = mkUnboundName (mkRdrUnqual (mkTcOcc "bogus_con"))
-       ; (flds', fvs) <- rnConDeclFields bogus_con doc flds
+       ; (flds', fvs) <- rnConDeclFields [] doc flds
        ; return (HsRecTy flds', fvs) }
 
 rnHsTyKi isType doc (HsFunTy ty1 ty2)
@@ -515,23 +514,23 @@ dataKindsErr is_type thing
 *********************************************************
 -}
 
-rnConDeclFields :: Name -> HsDocContext -> [LConDeclField RdrName]
+rnConDeclFields :: [FieldLabel] -> HsDocContext -> [LConDeclField RdrName]
                 -> RnM ([LConDeclField Name], FreeVars)
-rnConDeclFields con doc fields = mapFvRn (rnField con doc) fields
+rnConDeclFields fls doc fields = mapFvRn (rnField fls doc) fields
 
-rnField :: Name -> HsDocContext -> LConDeclField RdrName
+rnField :: [FieldLabel] -> HsDocContext -> LConDeclField RdrName
         -> RnM (LConDeclField Name, FreeVars)
-rnField con doc (L l (ConDeclField names ty haddock_doc))
-  = do { new_names <- mapM help names
+rnField fls doc (L l (ConDeclField names ty haddock_doc))
+  = do { let new_names = map lookupField names
        ; (new_ty, fvs) <- rnLHsType doc ty
        ; new_haddock_doc <- rnMbLHsDoc haddock_doc
        ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) }
   where
-    help :: (Located RdrName, PlaceHolder) -> RnM (Located RdrName, Name)
-    help (l_rdr_name, _) = do { flds <- lookupConstructorFields con
-                              ; let lbl = occNameFS $ rdrNameOcc $ unLoc l_rdr_name
-                              ; let fl = expectJust "rnField" $ find ((== lbl) . flLabel) flds
-                              ; return (l_rdr_name, flSelector fl) }
+    lookupField :: (Located RdrName, PlaceHolder) -> (Located RdrName, Name)
+    lookupField (l_rdr_name, _) = (l_rdr_name, flSelector fl)
+      where
+        lbl = occNameFS $ rdrNameOcc $ unLoc l_rdr_name
+        fl  = expectJust "rnField" $ find ((== lbl) . flLabel) fls
 
 rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
 rnContext doc (L loc cxt)
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 1c85505..de83432 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -1166,7 +1166,7 @@ tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl        -- Data types
               do { ctxt    <- tcHsContext hs_ctxt
                  ; btys    <- tcConArgs new_or_data hs_details
                  ; res_ty  <- tcConRes hs_res_ty
-                 ; field_lbls <- lookupConstructorFields (unLoc $ head names) -- AMG TODO ???
+                 ; field_lbls <- lookupConstructorFields (unLoc $ head names)
                  ; let (arg_tys, stricts) = unzip btys
                  ; return (ctxt, arg_tys, res_ty, field_lbls, stricts)
                  }