Track specified/invisible more carefully.

In particular, this allows correct tracking of specified/invisible
for variables in Haskell98 data constructors and in pattern synonyms.
GADT-syntax constructors are harder, and are left until #11721.

This was all inspired by Simon's comments to my fix for #11512,
which this subsumes.

Test case: ghci/scripts/TypeAppData

[skip ci]  (The test case fails because of an unrelated problem
fixed in the next commit.)

1 files changed, 30 insertions, 18 deletions

diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs
index 87b5f36b7e..e20a6c6a8d 100644
--- a/compiler/iface/BuildTyCl.hs
+++ b/compiler/iface/BuildTyCl.hs
@@ -111,7 +111,9 @@ buildDataCon :: FamInstEnvs
             -> Maybe [HsImplBang]
                 -- See Note [Bangs on imported data constructors] in MkId
            -> [FieldLabel]             -- Field labels
-           -> [TyVar] -> [TyVar]       -- Univ and ext
+           -> [TyVar] -> [TyBinder]    -- Universals; see
+                                       -- Note [TyBinders in DataCons] in DataCon
+           -> [TyVar] -> [TyBinder]    -- existentials
            -> [EqSpec]                 -- Equality spec
            -> ThetaType                -- Does not include the "stupid theta"
                                        -- or the GADT equalities
@@ -122,8 +124,9 @@ buildDataCon :: FamInstEnvs
 --   a) makes the worker Id
 --   b) makes the wrapper Id if necessary, including
 --      allocating its unique (hence monadic)
+--   c) Sorts out the TyBinders. See Note [TyBinders in DataCons] in DataCon
 buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs field_lbls
-             univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
+             univ_tvs univ_bndrs ex_tvs ex_bndrs eq_spec ctxt arg_tys res_ty rep_tycon
   = do  { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
         ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
         -- This last one takes the name of the data constructor in the source
@@ -133,16 +136,23 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs fie
         ; traceIf (text "buildDataCon 1" <+> ppr src_name)
         ; us <- newUniqueSupply
         ; dflags <- getDynFlags
-        ; let
-                stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
-                data_con = mkDataCon src_name declared_infix prom_info
-                                     src_bangs field_lbls
-                                     univ_tvs ex_tvs eq_spec ctxt
-                                     arg_tys res_ty NoRRI rep_tycon
-                                     stupid_ctxt dc_wrk dc_rep
-                dc_wrk = mkDataConWorkId work_name data_con
-                dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
-                                                  impl_bangs data_con)
+        ; let   -- See Note [TyBinders in DataCons] in DataCon
+              dc_bndrs = zipWith mk_binder univ_tvs univ_bndrs
+              mk_binder tv bndr = mkNamedBinder vis tv
+                where
+                  vis = case binderVisibility bndr of
+                    Invisible -> Invisible
+                    _         -> Specified
+
+              stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
+              data_con = mkDataCon src_name declared_infix prom_info
+                                   src_bangs field_lbls
+                                   univ_tvs dc_bndrs ex_tvs ex_bndrs eq_spec ctxt
+                                   arg_tys res_ty NoRRI rep_tycon
+                                   stupid_ctxt dc_wrk dc_rep
+              dc_wrk = mkDataConWorkId work_name data_con
+              dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
+                                                impl_bangs data_con)
 
         ; traceIf (text "buildDataCon 2" <+> ppr src_name)
         ; return data_con }
@@ -170,15 +180,15 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
 ------------------------------------------------------
 buildPatSyn :: Name -> Bool
             -> (Id,Bool) -> Maybe (Id, Bool)
-            -> ([TyVar], ThetaType) -- ^ Univ and req
-            -> ([TyVar], ThetaType) -- ^ Ex and prov
+            -> ([TyVar], [TyBinder], ThetaType) -- ^ Univ and req
+            -> ([TyVar], [TyBinder], ThetaType) -- ^ Ex and prov
             -> [Type]               -- ^ Argument types
             -> Type                 -- ^ Result type
             -> [FieldLabel]         -- ^ Field labels for
                                     --   a record pattern synonym
             -> PatSyn
 buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
-            (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys
+            (univ_tvs, univ_bndrs, req_theta) (ex_tvs, ex_bndrs, prov_theta) arg_tys
             pat_ty field_labels
   = -- The assertion checks that the matcher is
     -- compatible with the pattern synonym
@@ -196,7 +206,7 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
                     , ppr req_theta <+> twiddle <+> ppr req_theta1
                     , ppr arg_tys <+> twiddle <+> ppr arg_tys1]))
     mkPatSyn src_name declared_infix
-             (univ_tvs, req_theta) (ex_tvs, prov_theta)
+             (univ_tvs, univ_bndrs, req_theta) (ex_tvs, ex_bndrs, prov_theta)
              arg_tys pat_ty
              matcher builder field_labels
   where
@@ -215,7 +225,7 @@ type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type))
 
 buildClass :: Name  -- Name of the class/tycon (they have the same Name)
            -> [TyVar] -> [Role] -> ThetaType
-           -> [TyBinder]
+           -> [TyBinder]                   -- of the tycon
            -> [FunDep TyVar]               -- Functional dependencies
            -> [ClassATItem]                -- Associated types
            -> [TcMethInfo]                 -- Method info
@@ -273,7 +283,9 @@ buildClass tycon_name tvs roles sc_theta binders
                                    (map (const no_bang) args)
                                    (Just (map (const HsLazy) args))
                                    [{- No fields -}]
-                                   tvs [{- no existentials -}]
+                                   tvs binders
+                                   [{- no existentials -}]
+                                   [{- no existentials -}]
                                    [{- No GADT equalities -}]
                                    [{- No theta -}]
                                    arg_tys