Refactor RecordPatSynField, FieldLabel

This patch uses the named fields of
 * FieldLabel
 * RecordPatSynField
in construction and pattern matching. The fields
existed before, but we were often using positional notation.

Also a minor refactor of the API of mkPatSynRecSelBinds

No change in functionality

7 files changed, 51 insertions, 38 deletions

diff --git a/compiler/basicTypes/FieldLabel.hs b/compiler/basicTypes/FieldLabel.hs
index 922c3d33e1..01af19b667 100644
--- a/compiler/basicTypes/FieldLabel.hs
+++ b/compiler/basicTypes/FieldLabel.hs
@@ -119,7 +119,8 @@ instance Binary a => Binary (FieldLbl a) where
 -- See Note [Why selector names include data constructors].
 mkFieldLabelOccs :: FieldLabelString -> OccName -> Bool -> FieldLbl OccName
 mkFieldLabelOccs lbl dc is_overloaded
-  = FieldLabel lbl is_overloaded sel_occ
+  = FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded
+               , flSelector = sel_occ }
   where
     str     = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc
     sel_occ | is_overloaded = mkRecFldSelOcc str
diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs
index d2597269ee..ee63882d11 100644
--- a/compiler/basicTypes/RdrName.hs
+++ b/compiler/basicTypes/RdrName.hs
@@ -612,7 +612,8 @@ gresFromAvail prov_fn avail
           Just is -> GRE { gre_name = n, gre_par = mkParent n avail
                          , gre_lcl = False, gre_imp = [is] }
 
-    mk_fld_gre (FieldLabel lbl is_overloaded n)
+    mk_fld_gre (FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded
+                           , flSelector = n })
       = case prov_fn n of  -- Nothing => bound locally
                            -- Just is => imported from 'is'
           Nothing -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl
@@ -676,12 +677,19 @@ mkParent n (AvailTC m _ _) | n == m    = NoParent
 availFromGRE :: GlobalRdrElt -> AvailInfo
 availFromGRE (GRE { gre_name = me, gre_par = parent })
   = case parent of
+      PatternSynonym              -> patSynAvail me
       ParentIs p                  -> AvailTC p [me] []
       NoParent   | isTyConName me -> AvailTC me [me] []
                  | otherwise      -> avail   me
-      FldParent p Nothing         -> AvailTC p [] [FieldLabel (occNameFS $ nameOccName me) False me]
-      FldParent p (Just lbl)      -> AvailTC p [] [FieldLabel lbl True me]
-      PatternSynonym              -> patSynAvail me
+      FldParent p mb_lbl -> AvailTC p [] [fld]
+        where
+         fld = case mb_lbl of
+                 Nothing  -> FieldLabel { flLabel = occNameFS (nameOccName me)
+                                        , flIsOverloaded = False
+                                        , flSelector = me }
+                 Just lbl -> FieldLabel { flLabel = lbl
+                                        , flIsOverloaded = True
+                                        , flSelector = me }
 
 emptyGlobalRdrEnv :: GlobalRdrEnv
 emptyGlobalRdrEnv = emptyOccEnv
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index 2799c0e68d..f83958978c 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -977,19 +977,25 @@ the distinction between the two names clear
 
 -}
 instance Functor RecordPatSynField where
-    fmap f (RecordPatSynField visible hidden) =
-      RecordPatSynField (f visible) (f hidden)
+    fmap f (RecordPatSynField { recordPatSynSelectorId = visible
+                              , recordPatSynPatVar = hidden })
+      = RecordPatSynField { recordPatSynSelectorId = f visible
+                          , recordPatSynPatVar = f hidden }
 
 instance Outputable a => Outputable (RecordPatSynField a) where
-    ppr (RecordPatSynField v _) = ppr v
+    ppr (RecordPatSynField { recordPatSynSelectorId = v }) = ppr v
 
 instance Foldable RecordPatSynField  where
-    foldMap f (RecordPatSynField visible hidden) =
-      f visible `mappend` f hidden
+    foldMap f (RecordPatSynField { recordPatSynSelectorId = visible
+                                 , recordPatSynPatVar = hidden })
+      = f visible `mappend` f hidden
 
 instance Traversable RecordPatSynField where
-    traverse f (RecordPatSynField visible hidden) =
-      RecordPatSynField <$> f visible <*> f hidden
+    traverse f (RecordPatSynField { recordPatSynSelectorId =visible
+                                  , recordPatSynPatVar = hidden })
+      = (\ sel_id pat_var -> RecordPatSynField { recordPatSynSelectorId = sel_id
+                                               , recordPatSynPatVar = pat_var })
+          <$> f visible <*> f hidden
 
 
 instance Functor HsPatSynDetails where
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index 76a13f7433..45ca7050ad 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -639,10 +639,12 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L _ name
                RecordPatSyn vars ->
                    do { checkDupRdrNames (map recordPatSynSelectorId vars)
                       ; let rnRecordPatSynField
-                              (RecordPatSynField visible hidden) = do {
-                              ; visible' <- lookupLocatedTopBndrRn visible
-                              ; hidden'  <- lookupVar hidden
-                              ; return $ RecordPatSynField visible' hidden' }
+                              (RecordPatSynField { recordPatSynSelectorId = visible
+                                                 , recordPatSynPatVar = hidden })
+                              = do { visible' <- lookupLocatedTopBndrRn visible
+                                   ; hidden'  <- lookupVar hidden
+                                   ; return $ RecordPatSynField { recordPatSynSelectorId = visible'
+                                                                , recordPatSynPatVar = hidden' } }
                       ; names <- mapM rnRecordPatSynField  vars
                       ; return ( (pat', RecordPatSyn names)
                                , mkFVs (map (unLoc . recordPatSynPatVar) names)) }
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 1a39febef6..eb1494f765 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -1997,12 +1997,10 @@ extendPatSynEnv :: HsValBinds RdrName -> MiniFixityEnv
                 -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a
 extendPatSynEnv val_decls local_fix_env thing = do {
      names_with_fls <- new_ps val_decls
-   ; let pat_syn_bndrs =
-          concat [name: map flSelector fields | (name, fields) <- names_with_fls]
+   ; let pat_syn_bndrs = concat [ name: map flSelector fields
+                                | (name, fields) <- names_with_fls ]
    ; let avails = map patSynAvail pat_syn_bndrs
-   ; (gbl_env, lcl_env) <-
-        extendGlobalRdrEnvRn avails local_fix_env
-
+   ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env
 
    ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls
          final_gbl_env = gbl_env { tcg_field_env = field_env' }
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index df4e4569dd..002ab04fd8 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -467,8 +467,10 @@ tc_patsyn_finish lname dir is_infix lpat'
                                          arg_tys pat_ty
 
          -- TODO: Make this have the proper information
-       ; let mkFieldLabel name = FieldLabel (occNameFS (nameOccName name)) False name
-             field_labels' = (map mkFieldLabel field_labels)
+       ; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name)
+                                            , flIsOverloaded = False
+                                            , flSelector = name }
+             field_labels' = map mkFieldLabel field_labels
 
 
        -- Make the PatSyn itself
@@ -481,13 +483,10 @@ tc_patsyn_finish lname dir is_infix lpat'
                         field_labels'
 
        -- Selectors
-       ; let (sigs, selector_binds) =
-                unzip (mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn))
-       ; let tything = AConLike (PatSynCon patSyn)
-       ; tcg_env <-
-          tcExtendGlobalEnv [tything] $
-            tcRecSelBinds
-              (ValBindsOut (zip (repeat NonRecursive) selector_binds) sigs)
+       ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn)
+             tything = AConLike (PatSynCon patSyn)
+       ; tcg_env <- tcExtendGlobalEnv [tything] $
+                    tcRecSelBinds rn_rec_sel_binds
 
        ; traceTc "tc_patsyn_finish }" empty
        ; return (matcher_bind, tcg_env) }
@@ -586,14 +585,13 @@ tcPatSynMatcher (L loc name) lpat
        ; return ((matcher_id, is_unlifted), matcher_bind) }
 
 mkPatSynRecSelBinds :: PatSyn
-                    -> [FieldLabel]
-                    -- ^ Visible field labels
-                    -> [(LSig Name, LHsBinds Name)]
-mkPatSynRecSelBinds ps fields = map mkRecSel fields
+                    -> [FieldLabel]  -- ^ Visible field labels
+                    -> HsValBinds Name
+mkPatSynRecSelBinds ps fields
+  = ValBindsOut selector_binds sigs
   where
-    mkRecSel fld_lbl =
-      case mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl of
-        (name, (_rec_flag, binds)) -> (name, binds)
+    (sigs, selector_binds) = unzip (map mkRecSel fields)
+    mkRecSel fld_lbl = mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl
 
 isUnidirectional :: HsPatSynDir a -> Bool
 isUnidirectional Unidirectional          = True
diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs
index bbfccc590f..62933b5923 100644
--- a/compiler/typecheck/TcTyDecls.hs
+++ b/compiler/typecheck/TcTyDecls.hs
@@ -913,7 +913,7 @@ mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, (RecFlag, LHsBinds Name))
 mkRecSelBind (tycon, fl)
   = mkOneRecordSelector all_cons (RecSelData tycon) fl
   where
-    all_cons     = map RealDataCon (tyConDataCons tycon)
+    all_cons = map RealDataCon (tyConDataCons tycon)
 
 mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel
                     -> (LSig Name, (RecFlag, LHsBinds Name))