Refactor renamer datastructures

This patch significantly refactors key renamer datastructures (primarily Avail
and GlobalRdrElt) in order to treat DuplicateRecordFields in a more robust way.
In particular it allows the extension to be used with pattern synonyms (fixes
where mangled record selector names could be printed instead of field labels
(e.g. with -Wpartial-fields or hole fits, see new tests).

The key idea is the introduction of a new type GreName for names that may
represent either normal entities or field labels.  This is then used in
GlobalRdrElt and AvailInfo, in place of the old way of representing fields
using FldParent (yuck) and an extra list in AvailTC.

Updates the haddock submodule.

1 files changed, 12 insertions, 25 deletions

diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 13b5da759f..ae9dd613d3 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -57,6 +57,7 @@ import GHC.Types.Id.Make
 import GHC.Tc.TyCl.Utils
 import GHC.Core.ConLike
 import GHC.Types.FieldLabel
+import GHC.Rename.Env
 import GHC.Data.Bag
 import GHC.Utils.Misc
 import GHC.Utils.Error
@@ -95,7 +96,7 @@ recoverPSB (PSB { psb_id = L _ name
       ; gbl_env <- tcExtendGlobalEnv [placeholder] getGblEnv
       ; return (emptyBag, gbl_env) }
   where
-    (_arg_names, _rec_fields, is_infix) = collectPatSynArgInfo details
+    (_arg_names, is_infix) = collectPatSynArgInfo details
     mk_placeholder matcher_name
       = mkPatSyn name is_infix
                         ([mkTyVarBinder SpecifiedSpec alphaTyVar], []) ([], [])
@@ -144,7 +145,7 @@ tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details
   = addPatSynCtxt lname $
     do { traceTc "tcInferPatSynDecl {" $ ppr name
 
-       ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
+       ; let (arg_names, is_infix) = collectPatSynArgInfo details
        ; (tclvl, wanted, ((lpat', args), pat_ty))
             <- pushLevelAndCaptureConstraints  $
                tcInferPat PatSyn lpat          $
@@ -184,6 +185,7 @@ tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details
        ; mapM_ dependentArgErr bad_args
 
        ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs)
+       ; rec_fields <- lookupConstructorFields name
        ; tc_patsyn_finish lname dir is_infix lpat'
                           (mkTyVarBinders InferredSpec univ_tvs
                             , req_theta,  ev_binds, req_dicts)
@@ -355,7 +357,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
               , ppr explicit_ex_bndrs, ppr prov_theta, ppr sig_body_ty ]
 
        ; let decl_arity = length arg_names
-             (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
+             (arg_names, is_infix) = collectPatSynArgInfo details
 
        ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of
                                  Right stuff  -> return stuff
@@ -440,6 +442,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
 
        ; traceTc "tcCheckPatSynDecl }" $ ppr name
 
+       ; rec_fields <- lookupConstructorFields name
        ; tc_patsyn_finish lname dir is_infix lpat'
                           (skol_univ_bndrs, skol_req_theta, ev_binds, req_dicts)
                           (skol_ex_bndrs, mkTyVarTys ex_tvs', skol_prov_theta, prov_dicts)
@@ -623,21 +626,12 @@ a pattern synonym.  What about the /building/ side?
 -}
 
 collectPatSynArgInfo :: HsPatSynDetails GhcRn
-                     -> ([Name], [Name], Bool)
+                     -> ([Name], Bool)
 collectPatSynArgInfo details =
   case details of
-    PrefixCon _ names    -> (map unLoc names, [], False)
-    InfixCon name1 name2 -> (map unLoc [name1, name2], [], True)
-    RecCon names         -> (vars, sels, False)
-                         where
-                            (vars, sels) = unzip (map splitRecordPatSyn names)
-  where
-    splitRecordPatSyn :: RecordPatSynField (Located Name)
-                      -> (Name, Name)
-    splitRecordPatSyn (RecordPatSynField
-                       { recordPatSynPatVar     = L _ patVar
-                       , recordPatSynSelectorId = L _ selId })
-      = (patVar, selId)
+    PrefixCon _ names    -> (map unLoc names, False)
+    InfixCon name1 name2 -> (map unLoc [name1, name2], True)
+    RecCon names         -> (map (unLoc . recordPatSynPatVar) names, False)
 
 addPatSynCtxt :: Located Name -> TcM a -> TcM a
 addPatSynCtxt (L loc name) thing_inside
@@ -663,7 +657,7 @@ tc_patsyn_finish :: Located Name      -- ^ PatSyn Name
                  -> ([TcInvisTVBinder], [TcType], [PredType], [EvTerm])
                  -> ([LHsExpr GhcTc], [TcType])  -- ^ Pattern arguments and types
                  -> TcType            -- ^ Pattern type
-                 -> [Name]            -- ^ Selector names
+                 -> [FieldLabel]      -- ^ Selector names
                  -- ^ Whether fields, empty if not record PatSyn
                  -> TcM (LHsBinds GhcTc, TcGblEnv)
 tc_patsyn_finish lname dir is_infix lpat'
@@ -709,13 +703,6 @@ tc_patsyn_finish lname dir is_infix lpat'
                                          ex_tvs   prov_theta
                                          arg_tys pat_ty
 
-         -- TODO: Make this have the proper information
-       ; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name)
-                                            , flIsOverloaded = False
-                                            , flSelector = name }
-             field_labels' = map mkFieldLabel field_labels
-
-
        -- Make the PatSyn itself
        ; let patSyn = mkPatSyn (unLoc lname) is_infix
                         (univ_tvs, req_theta)
@@ -723,7 +710,7 @@ tc_patsyn_finish lname dir is_infix lpat'
                         arg_tys
                         pat_ty
                         matcher_id builder_id
-                        field_labels'
+                        field_labels
 
        -- Selectors
        ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn)