Track specified/invisible more carefully.
authorRichard Eisenberg <eir@cis.upenn.edu>
Sat, 19 Mar 2016 20:55:50 +0000 (16:55 -0400)
committerRichard Eisenberg <eir@cis.upenn.edu>
Mon, 21 Mar 2016 16:16:12 +0000 (12:16 -0400)
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.)

29 files changed:
compiler/basicTypes/DataCon.hs
compiler/basicTypes/DataCon.hs-boot
compiler/basicTypes/MkId.hs
compiler/basicTypes/PatSyn.hs
compiler/iface/BuildTyCl.hs
compiler/iface/IfaceSyn.hs
compiler/iface/IfaceType.hs
compiler/iface/MkIface.hs
compiler/iface/TcIface.hs
compiler/prelude/TysWiredIn.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcHsType.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcPatSyn.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/typecheck/TcType.hs
compiler/types/Coercion.hs
compiler/types/TyCoRep.hs
compiler/types/Type.hs
compiler/vectorise/Vectorise/Generic/PData.hs
compiler/vectorise/Vectorise/Type/TyConDecl.hs
docs/users_guide/glasgow_exts.rst
testsuite/tests/ghci/scripts/T11524a.stdout
testsuite/tests/ghci/scripts/TypeAppData.script [new file with mode: 0644]
testsuite/tests/ghci/scripts/TypeAppData.stdout [new file with mode: 0644]
testsuite/tests/ghci/scripts/all.T
testsuite/tests/rename/should_fail/rnfail055.stderr
testsuite/tests/roles/should_compile/Roles1.stderr

index 57a9857..f10b1ba 100644 (file)
@@ -18,7 +18,7 @@ module DataCon (
         -- ** Equality specs
         EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType,
         eqSpecPair, eqSpecPreds,
         -- ** Equality specs
         EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType,
         eqSpecPair, eqSpecPreds,
-        substEqSpec,
+        substEqSpec, filterEqSpec,
 
         -- ** Field labels
         FieldLbl(..), FieldLabel, FieldLabelString,
 
         -- ** Field labels
         FieldLbl(..), FieldLabel, FieldLabelString,
@@ -30,7 +30,9 @@ module DataCon (
         dataConRepType, dataConSig, dataConInstSig, dataConFullSig,
         dataConName, dataConIdentity, dataConTag, dataConTyCon,
         dataConOrigTyCon, dataConUserType,
         dataConRepType, dataConSig, dataConInstSig, dataConFullSig,
         dataConName, dataConIdentity, dataConTag, dataConTyCon,
         dataConOrigTyCon, dataConUserType,
-        dataConUnivTyVars, dataConExTyVars, dataConAllTyVars,
+        dataConUnivTyVars, dataConUnivTyBinders,
+        dataConExTyVars, dataConExTyBinders,
+        dataConAllTyVars,
         dataConEqSpec, dataConTheta,
         dataConStupidTheta,
         dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
         dataConEqSpec, dataConTheta,
         dataConStupidTheta,
         dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
@@ -301,6 +303,13 @@ data DataCon
         dcUnivTyVars   :: [TyVar],      -- Universally-quantified type vars [a,b,c]
                                         -- INVARIANT: length matches arity of the dcRepTyCon
                                         ---           result type of (rep) data con is exactly (T a b c)
         dcUnivTyVars   :: [TyVar],      -- Universally-quantified type vars [a,b,c]
                                         -- INVARIANT: length matches arity of the dcRepTyCon
                                         ---           result type of (rep) data con is exactly (T a b c)
+        dcUnivTyBinders :: [TyBinder],  -- Binders for universal tyvars. These will all
+                                        -- be Named, and all be Invisible or Specified.
+                                        -- Storing these separately from dcUnivTyVars
+                                        -- is solely because we usually don't need the
+                                        -- binders, and the extraction of the tyvars is
+                                        -- unnecessary work. See also
+                                        -- Note [TyBinders in DataCons]
 
         dcExTyVars     :: [TyVar],    -- Existentially-quantified type vars
                 -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE TYVARS
 
         dcExTyVars     :: [TyVar],    -- Existentially-quantified type vars
                 -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE TYVARS
@@ -309,6 +318,8 @@ data DataCon
                 -- [This is a change (Oct05): previously, vanilla datacons guaranteed to
                 --  have the same type variables as their parent TyCon, but that seems ugly.]
 
                 -- [This is a change (Oct05): previously, vanilla datacons guaranteed to
                 --  have the same type variables as their parent TyCon, but that seems ugly.]
 
+        dcExTyBinders  :: [TyBinder],  -- see dcUnivTyBinders
+
         -- INVARIANT: the UnivTyVars and ExTyVars all have distinct OccNames
         -- Reason: less confusing, and easier to generate IfaceSyn
 
         -- INVARIANT: the UnivTyVars and ExTyVars all have distinct OccNames
         -- Reason: less confusing, and easier to generate IfaceSyn
 
@@ -529,6 +540,14 @@ substEqSpec subst (EqSpec tv ty)
   where
     tv' = getTyVar "substEqSpec" (substTyVar subst tv)
 
   where
     tv' = getTyVar "substEqSpec" (substTyVar subst tv)
 
+-- | Filter out any TyBinders mentioned in an EqSpec
+filterEqSpec :: [EqSpec] -> [TyBinder] -> [TyBinder]
+filterEqSpec eq_spec
+  = filter not_in_eq_spec
+  where
+    not_in_eq_spec bndr = let var = binderVar "filterEqSpec" bndr in
+                          all (not . (== var) . eqSpecTyVar) eq_spec
+
 instance Outputable EqSpec where
   ppr (EqSpec tv ty) = ppr (tv, ty)
 
 instance Outputable EqSpec where
   ppr (EqSpec tv ty) = ppr (tv, ty)
 
@@ -705,6 +724,42 @@ isMarkedStrict _               = True   -- All others are strict
 \subsection{Construction}
 *                                                                      *
 ************************************************************************
 \subsection{Construction}
 *                                                                      *
 ************************************************************************
+
+Note [TyBinders in DataCons]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A DataCon needs to keep track of the visibility of its universals and
+existentials, so that visible type application can work properly. This
+is done by storing the universal and existential TyBinders, along with
+the TyVars. These TyBinders should all be Named and should all be
+Invisible or Specified; we don't have Visible or Anon type arguments.
+
+During construction of a DataCon, we often have the TyBinders of the
+parent TyCon. But those TyBinders are *different* than those of the
+DataCon. Here is an example:
+
+  data Proxy a = P
+
+The TyCon has these TyBinders:
+
+  [ Named (k :: *) Invisible, Anon k ]
+
+Note that Proxy's kind is forall k. k -> *. But the DataCon P should
+have (universal) TyBinders
+
+  [ Named (k :: *) Invisible, Named (a :: k) Specified ]
+
+So we want to take the TyCon's TyBinders and the TyCon's TyVars and
+merge them, pulling variable names from the TyVars but visibilities
+from the TyBinders, perserving Invisible but changing Visible to
+Specified. (The `a` in Proxy is indeed Visible, but the `a` in P should
+be Specified.) This merging operation is done in buildDataCon. In contrast,
+the TyBinders passed to mkDataCon are the real TyBinders stored in the
+DataCon. Note that passing the TyVars into mkDataCon is redundant, but
+convenient for both caller and the function's implementation.
+
+In most places in GHC, it's just the TyVars that are needed,
+so that's what's returned from, say, dataConFullSig.
+
 -}
 
 -- | Build a new data constructor
 -}
 
 -- | Build a new data constructor
@@ -714,8 +769,9 @@ mkDataCon :: Name
           -> [HsSrcBang]    -- ^ Strictness/unpack annotations, from user
           -> [FieldLabel]   -- ^ Field labels for the constructor,
                             -- if it is a record, otherwise empty
           -> [HsSrcBang]    -- ^ Strictness/unpack annotations, from user
           -> [FieldLabel]   -- ^ Field labels for the constructor,
                             -- if it is a record, otherwise empty
-          -> [TyVar]        -- ^ Universally quantified type variables
-          -> [TyVar]        -- ^ Existentially quantified type variables
+          -> [TyVar] -> [TyBinder]  -- ^ Universals. See Note [TyBinders in DataCons]
+          -> [TyVar] -> [TyBinder]  -- ^ Existentials.
+                            -- (These last two must be Named and Invisible/Specified)
           -> [EqSpec]       -- ^ GADT equalities
           -> ThetaType      -- ^ Theta-type occuring before the arguments proper
           -> [Type]         -- ^ Original argument types
           -> [EqSpec]       -- ^ GADT equalities
           -> ThetaType      -- ^ Theta-type occuring before the arguments proper
           -> [Type]         -- ^ Original argument types
@@ -732,7 +788,7 @@ mkDataCon :: Name
 mkDataCon name declared_infix prom_info
           arg_stricts   -- Must match orig_arg_tys 1-1
           fields
 mkDataCon name declared_infix prom_info
           arg_stricts   -- Must match orig_arg_tys 1-1
           fields
-          univ_tvs ex_tvs
+          univ_tvs univ_bndrs ex_tvs ex_bndrs
           eq_spec theta
           orig_arg_tys orig_res_ty rep_info rep_tycon
           stupid_theta work_id rep
           eq_spec theta
           orig_arg_tys orig_res_ty rep_info rep_tycon
           stupid_theta work_id rep
@@ -749,7 +805,8 @@ mkDataCon name declared_infix prom_info
     is_vanilla = null ex_tvs && null eq_spec && null theta
     con = MkData {dcName = name, dcUnique = nameUnique name,
                   dcVanilla = is_vanilla, dcInfix = declared_infix,
     is_vanilla = null ex_tvs && null eq_spec && null theta
     con = MkData {dcName = name, dcUnique = nameUnique name,
                   dcVanilla = is_vanilla, dcInfix = declared_infix,
-                  dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
+                  dcUnivTyVars = univ_tvs, dcUnivTyBinders = univ_bndrs,
+                  dcExTyVars = ex_tvs, dcExTyBinders = ex_bndrs,
                   dcEqSpec = eq_spec,
                   dcOtherTheta = theta,
                   dcStupidTheta = stupid_theta,
                   dcEqSpec = eq_spec,
                   dcOtherTheta = theta,
                   dcStupidTheta = stupid_theta,
@@ -769,16 +826,14 @@ mkDataCon name declared_infix prom_info
 
     tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con
     rep_arg_tys = dataConRepArgTys con
 
     tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con
     rep_arg_tys = dataConRepArgTys con
-      -- NB: This type is user-facing for datatypes that don't need wrappers;
-      --     so it's important to use mkSpecForAllTys
-    rep_ty = mkSpecForAllTys univ_tvs $ mkSpecForAllTys ex_tvs $
+
+    rep_ty = mkForAllTys univ_bndrs $ mkForAllTys ex_bndrs $
              mkFunTys rep_arg_tys $
              mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
 
       -- See Note [Promoted data constructors] in TyCon
              mkFunTys rep_arg_tys $
              mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
 
       -- See Note [Promoted data constructors] in TyCon
-    prom_binders = map (mkNamedBinder Specified)
-                       ((univ_tvs `minusList` map eqSpecTyVar eq_spec) ++
-                        ex_tvs) ++
+    prom_binders = filterEqSpec eq_spec univ_bndrs ++
+                   ex_bndrs ++
                    map mkAnonBinder theta ++
                    map mkAnonBinder orig_arg_tys
     prom_res_kind = orig_res_ty
                    map mkAnonBinder theta ++
                    map mkAnonBinder orig_arg_tys
     prom_res_kind = orig_res_ty
@@ -821,10 +876,18 @@ dataConIsInfix = dcInfix
 dataConUnivTyVars :: DataCon -> [TyVar]
 dataConUnivTyVars = dcUnivTyVars
 
 dataConUnivTyVars :: DataCon -> [TyVar]
 dataConUnivTyVars = dcUnivTyVars
 
+-- | 'TyBinder's for the universally-quantified type variables
+dataConUnivTyBinders :: DataCon -> [TyBinder]
+dataConUnivTyBinders = dcUnivTyBinders
+
 -- | The existentially-quantified type variables of the constructor
 dataConExTyVars :: DataCon -> [TyVar]
 dataConExTyVars = dcExTyVars
 
 -- | The existentially-quantified type variables of the constructor
 dataConExTyVars :: DataCon -> [TyVar]
 dataConExTyVars = dcExTyVars
 
+-- | 'TyBinder's for the existentially-quantified type variables
+dataConExTyBinders :: DataCon -> [TyBinder]
+dataConExTyBinders = dcExTyBinders
+
 -- | Both the universal and existentiatial type variables of the constructor
 dataConAllTyVars :: DataCon -> [TyVar]
 dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs })
 -- | Both the universal and existentiatial type variables of the constructor
 dataConAllTyVars :: DataCon -> [TyVar]
 dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs })
@@ -1030,15 +1093,16 @@ dataConUserType :: DataCon -> Type
 --
 -- NB: If the constructor is part of a data instance, the result type
 -- mentions the family tycon, not the internal one.
 --
 -- NB: If the constructor is part of a data instance, the result type
 -- mentions the family tycon, not the internal one.
-dataConUserType (MkData { dcUnivTyVars = univ_tvs,
-                          dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
+dataConUserType (MkData { dcUnivTyBinders = univ_bndrs,
+                          dcExTyBinders = ex_bndrs, dcEqSpec = eq_spec,
                           dcOtherTheta = theta, dcOrigArgTys = arg_tys,
                           dcOrigResTy = res_ty })
                           dcOtherTheta = theta, dcOrigArgTys = arg_tys,
                           dcOrigResTy = res_ty })
-  = mkSpecForAllTys ((univ_tvs `minusList` map eqSpecTyVar eq_spec) ++
-                      ex_tvs) $
+  = mkForAllTys (filterEqSpec eq_spec univ_bndrs) $
+    mkForAllTys ex_bndrs $
     mkFunTys theta $
     mkFunTys arg_tys $
     res_ty
     mkFunTys theta $
     mkFunTys arg_tys $
     res_ty
+  where
 
 -- | Finds the instantiated types of the arguments required to construct a 'DataCon' representation
 -- NB: these INCLUDE any dictionary args
 
 -- | Finds the instantiated types of the arguments required to construct a 'DataCon' representation
 -- NB: these INCLUDE any dictionary args
index d609774..d8e3230 100644 (file)
@@ -6,16 +6,18 @@ import FieldLabel ( FieldLabel )
 import Unique ( Uniquable )
 import Outputable ( Outputable, OutputableBndr )
 import BasicTypes (Arity)
 import Unique ( Uniquable )
 import Outputable ( Outputable, OutputableBndr )
 import BasicTypes (Arity)
-import {-# SOURCE #-} TyCoRep (Type, ThetaType)
+import {-# SOURCE #-} TyCoRep (Type, ThetaType, TyBinder)
 
 data DataCon
 data DataConRep
 data EqSpec
 
 data DataCon
 data DataConRep
 data EqSpec
-eqSpecTyVar :: EqSpec -> TyVar
+filterEqSpec :: [EqSpec] -> [TyBinder] -> [TyBinder]
 
 dataConName      :: DataCon -> Name
 dataConTyCon     :: DataCon -> TyCon
 
 dataConName      :: DataCon -> Name
 dataConTyCon     :: DataCon -> TyCon
+dataConUnivTyBinders :: DataCon -> [TyBinder]
 dataConExTyVars  :: DataCon -> [TyVar]
 dataConExTyVars  :: DataCon -> [TyVar]
+dataConExTyBinders :: DataCon -> [TyBinder]
 dataConSourceArity  :: DataCon -> Arity
 dataConFieldLabels :: DataCon -> [FieldLabel]
 dataConInstOrigArgTys  :: DataCon -> [Type] -> [Type]
 dataConSourceArity  :: DataCon -> Arity
 dataConFieldLabels :: DataCon -> [FieldLabel]
 dataConInstOrigArgTys  :: DataCon -> [Type] -> [Type]
index 5bab875..fe301d5 100644 (file)
@@ -274,25 +274,15 @@ mkDictSelId name clas
     sel_names      = map idName (classAllSelIds clas)
     new_tycon      = isNewTyCon tycon
     [data_con]     = tyConDataCons tycon
     sel_names      = map idName (classAllSelIds clas)
     new_tycon      = isNewTyCon tycon
     [data_con]     = tyConDataCons tycon
+    binders        = dataConUnivTyBinders data_con
     tyvars         = dataConUnivTyVars data_con
     tyvars         = dataConUnivTyVars data_con
-    tc_binders     = tyConBinders tycon
     arg_tys        = dataConRepArgTys data_con  -- Includes the dictionary superclasses
     val_index      = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name
 
     arg_tys        = dataConRepArgTys data_con  -- Includes the dictionary superclasses
     val_index      = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name
 
-    sel_ty = mkForAllTys (zipWith mk_binder tc_binders tyvars) $
+    sel_ty = mkForAllTys binders $
              mkFunTy (mkClassPred clas (mkTyVarTys tyvars)) $
              getNth arg_tys val_index
 
              mkFunTy (mkClassPred clas (mkTyVarTys tyvars)) $
              getNth arg_tys val_index
 
-      -- copy the visibility from the tycon binders. Consider:
-      --   class C a where foo :: Proxy a
-      -- In the type of foo, `a` must be Specified but `k` must be Invisible
-    mk_binder tc_binder tyvar
-      | Invisible <- binderVisibility tc_binder
-      = mkNamedBinder Invisible tyvar
-      | otherwise
-      = mkNamedBinder Specified tyvar   -- don't just copy from tc_binder, because
-                                        -- tc_binders can be Visible
-
     base_info = noCafIdInfo
                 `setArityInfo`         1
                 `setStrictnessInfo`    strict_sig
     base_info = noCafIdInfo
                 `setArityInfo`         1
                 `setStrictnessInfo`    strict_sig
index cef9476..d636430 100644 (file)
@@ -15,7 +15,7 @@ module PatSyn (
         patSynName, patSynArity, patSynIsInfix,
         patSynArgs, patSynType,
         patSynMatcher, patSynBuilder,
         patSynName, patSynArity, patSynIsInfix,
         patSynArgs, patSynType,
         patSynMatcher, patSynBuilder,
-        patSynExTyVars, patSynSig,
+        patSynUnivTyBinders, patSynExTyVars, patSynExTyBinders, patSynSig,
         patSynInstArgTys, patSynInstResTy, patSynFieldLabels,
         patSynFieldType,
 
         patSynInstArgTys, patSynInstResTy, patSynFieldLabels,
         patSynFieldType,
 
@@ -65,12 +65,14 @@ data PatSyn
                                        -- psArgs
 
         psUnivTyVars  :: [TyVar],      -- Universially-quantified type variables
                                        -- psArgs
 
         psUnivTyVars  :: [TyVar],      -- Universially-quantified type variables
+        psUnivTyBinders :: [TyBinder], -- same, with visibility info
         psReqTheta    :: ThetaType,    -- Required dictionaries
                                        -- these constraints are very much like
                                        -- stupid thetas (which is a useful
                                        -- guideline when implementing)
                                        -- but are actually needed.
         psExTyVars    :: [TyVar],      -- Existentially-quantified type vars
         psReqTheta    :: ThetaType,    -- Required dictionaries
                                        -- these constraints are very much like
                                        -- stupid thetas (which is a useful
                                        -- guideline when implementing)
                                        -- but are actually needed.
         psExTyVars    :: [TyVar],      -- Existentially-quantified type vars
+        psExTyBinders :: [TyBinder],   -- same, with visibility info
         psProvTheta   :: ThetaType,    -- Provided dictionaries
         psOrigResTy   :: Type,         -- Mentions only psUnivTyVars
 
         psProvTheta   :: ThetaType,    -- Provided dictionaries
         psOrigResTy   :: Type,         -- Mentions only psUnivTyVars
 
@@ -288,9 +290,11 @@ instance Data.Data PatSyn where
 -- | Build a new pattern synonym
 mkPatSyn :: Name
          -> Bool                 -- ^ Is the pattern synonym declared infix?
 -- | Build a new pattern synonym
 mkPatSyn :: Name
          -> Bool                 -- ^ Is the pattern synonym declared infix?
-         -> ([TyVar], ThetaType) -- ^ Universially-quantified type variables
+         -> ([TyVar], [TyBinder], ThetaType)
+                                 -- ^ Universially-quantified type variables
                                  --   and required dicts
                                  --   and required dicts
-         -> ([TyVar], ThetaType) -- ^ Existentially-quantified type variables
+         -> ([TyVar], [TyBinder], ThetaType)
+                                 -- ^ Existentially-quantified type variables
                                  --   and provided dicts
          -> [Type]               -- ^ Original arguments
          -> Type                 -- ^ Original result type
                                  --   and provided dicts
          -> [Type]               -- ^ Original arguments
          -> Type                 -- ^ Original result type
@@ -299,14 +303,17 @@ mkPatSyn :: Name
          -> [FieldLabel]         -- ^ Names of fields for
                                  --   a record pattern synonym
          -> PatSyn
          -> [FieldLabel]         -- ^ Names of fields for
                                  --   a record pattern synonym
          -> PatSyn
+ -- NB: The univ and ex vars are both in TyBinder form and TyVar form for
+ -- convenience. All the TyBinders should be Named!
 mkPatSyn name declared_infix
 mkPatSyn name declared_infix
-         (univ_tvs, req_theta)
-         (ex_tvs, prov_theta)
+         (univ_tvs, univ_bndrs, req_theta)
+         (ex_tvs, ex_bndrs, prov_theta)
          orig_args
          orig_res_ty
          matcher builder field_labels
     = MkPatSyn {psName = name, psUnique = getUnique name,
          orig_args
          orig_res_ty
          matcher builder field_labels
     = MkPatSyn {psName = name, psUnique = getUnique name,
-                psUnivTyVars = univ_tvs, psExTyVars = ex_tvs,
+                psUnivTyVars = univ_tvs, psUnivTyBinders = univ_bndrs,
+                psExTyVars = ex_tvs, psExTyBinders = ex_bndrs,
                 psProvTheta = prov_theta, psReqTheta = req_theta,
                 psInfix = declared_infix,
                 psArgs = orig_args,
                 psProvTheta = prov_theta, psReqTheta = req_theta,
                 psInfix = declared_infix,
                 psArgs = orig_args,
@@ -352,9 +359,15 @@ patSynFieldType ps label
       Just (_, ty) -> ty
       Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label)
 
       Just (_, ty) -> ty
       Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label)
 
+patSynUnivTyBinders :: PatSyn -> [TyBinder]
+patSynUnivTyBinders = psUnivTyBinders
+
 patSynExTyVars :: PatSyn -> [TyVar]
 patSynExTyVars = psExTyVars
 
 patSynExTyVars :: PatSyn -> [TyVar]
 patSynExTyVars = psExTyVars
 
+patSynExTyBinders :: PatSyn -> [TyBinder]
+patSynExTyBinders = psExTyBinders
+
 patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type)
 patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
                     , psProvTheta = prov, psReqTheta = req
 patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type)
 patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
                     , psProvTheta = prov, psReqTheta = req
index 87b5f36..e20a6c6 100644 (file)
@@ -111,7 +111,9 @@ buildDataCon :: FamInstEnvs
             -> Maybe [HsImplBang]
                 -- See Note [Bangs on imported data constructors] in MkId
            -> [FieldLabel]             -- Field labels
             -> 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
            -> [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)
 --   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
 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
   = 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
         ; 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 }
 
         ; 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)
 ------------------------------------------------------
 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
             -> [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
             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
                     , 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
              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
 
 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
            -> [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 -}]
                                    (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
                                    [{- No GADT equalities -}]
                                    [{- No theta -}]
                                    arg_tys
index e5315b3..de582bf 100644 (file)
@@ -146,8 +146,8 @@ data IfaceDecl
                   ifPatBuilder    :: Maybe (IfExtName, Bool),
                   -- Everything below is redundant,
                   -- but needed to implement pprIfaceDecl
                   ifPatBuilder    :: Maybe (IfExtName, Bool),
                   -- Everything below is redundant,
                   -- but needed to implement pprIfaceDecl
-                  ifPatUnivTvs    :: [IfaceTvBndr],
-                  ifPatExTvs      :: [IfaceTvBndr],
+                  ifPatUnivBndrs  :: [IfaceForAllBndr],
+                  ifPatExBndrs    :: [IfaceForAllBndr],
                   ifPatProvCtxt   :: IfaceContext,
                   ifPatReqCtxt    :: IfaceContext,
                   ifPatArgs       :: [IfaceType],
                   ifPatProvCtxt   :: IfaceContext,
                   ifPatReqCtxt    :: IfaceContext,
                   ifPatArgs       :: [IfaceType],
@@ -215,7 +215,7 @@ data IfaceConDecl
         -- but it's not so easy for the original TyCon/DataCon
         -- So this guarantee holds for IfaceConDecl, but *not* for DataCon
 
         -- but it's not so easy for the original TyCon/DataCon
         -- So this guarantee holds for IfaceConDecl, but *not* for DataCon
 
-        ifConExTvs   :: [IfaceTvBndr],      -- Existential tyvars
+        ifConExTvs   :: [IfaceForAllBndr],  -- Existential tyvars (w/ visibility)
         ifConEqSpec  :: IfaceEqSpec,        -- Equality constraints
         ifConCtxt    :: IfaceContext,       -- Non-stupid context
         ifConArgTys  :: [IfaceType],        -- Arg types
         ifConEqSpec  :: IfaceEqSpec,        -- Equality constraints
         ifConCtxt    :: IfaceContext,       -- Non-stupid context
         ifConArgTys  :: [IfaceType],        -- Arg types
@@ -753,7 +753,7 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon
     pp_branches _ = Outputable.empty
 
 pprIfaceDecl _ (IfacePatSyn { ifName = name,
     pp_branches _ = Outputable.empty
 
 pprIfaceDecl _ (IfacePatSyn { ifName = name,
-                              ifPatUnivTvs = univ_tvs, ifPatExTvs = ex_tvs,
+                              ifPatUnivBndrs = univ_bndrs, ifPatExBndrs = ex_bndrs,
                               ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
                               ifPatArgs = arg_tys,
                               ifPatTy = pat_ty} )
                               ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
                               ifPatArgs = arg_tys,
                               ifPatTy = pat_ty} )
@@ -766,8 +766,8 @@ pprIfaceDecl _ (IfacePatSyn { ifName = name,
              , ex_msg, pprIfaceContextArr prov_ctxt
              , pprIfaceType $ foldr IfaceFunTy pat_ty arg_tys]
       where
              , ex_msg, pprIfaceContextArr prov_ctxt
              , pprIfaceType $ foldr IfaceFunTy pat_ty arg_tys]
       where
-        univ_msg = pprUserIfaceForAll $ map tv_to_forall_bndr univ_tvs
-        ex_msg   = pprUserIfaceForAll $ map tv_to_forall_bndr ex_tvs
+        univ_msg = pprUserIfaceForAll univ_bndrs
+        ex_msg   = pprUserIfaceForAll ex_bndrs
 
         insert_empty_ctxt = null req_ctxt
             && not (null prov_ctxt && isEmpty dflags ex_msg)
 
         insert_empty_ctxt = null req_ctxt
             && not (null prov_ctxt && isEmpty dflags ex_msg)
@@ -883,7 +883,7 @@ pprIfaceConDecl ss gadt_style fls tycon tc_binders parent
     pp_prefix_con = pprPrefixIfDeclBndr ss name
 
     (univ_tvs, pp_res_ty) = mk_user_con_res_ty eq_spec
     pp_prefix_con = pprPrefixIfDeclBndr ss name
 
     (univ_tvs, pp_res_ty) = mk_user_con_res_ty eq_spec
-    ppr_ty = pprIfaceForAllPart (map tv_to_forall_bndr (univ_tvs ++ ex_tvs))
+    ppr_ty = pprIfaceForAllPart (map tv_to_forall_bndr univ_tvs ++ ex_tvs)
                                 ctxt pp_tau
 
         -- A bit gruesome this, but we can't form the full con_tau, and ppr it,
                                 ctxt pp_tau
 
         -- A bit gruesome this, but we can't form the full con_tau, and ppr it,
@@ -1177,8 +1177,8 @@ freeNamesIfDecl d@IfaceAxiom{} =
 freeNamesIfDecl d@IfacePatSyn{} =
   unitNameSet (fst (ifPatMatcher d)) &&&
   maybe emptyNameSet (unitNameSet . fst) (ifPatBuilder d) &&&
 freeNamesIfDecl d@IfacePatSyn{} =
   unitNameSet (fst (ifPatMatcher d)) &&&
   maybe emptyNameSet (unitNameSet . fst) (ifPatBuilder d) &&&
-  freeNamesIfTvBndrs (ifPatUnivTvs d) &&&
-  freeNamesIfTvBndrs (ifPatExTvs d) &&&
+  fnList freeNamesIfForAllBndr (ifPatUnivBndrs d) &&&
+  fnList freeNamesIfForAllBndr (ifPatExBndrs d) &&&
   freeNamesIfContext (ifPatProvCtxt d) &&&
   freeNamesIfContext (ifPatReqCtxt d) &&&
   fnList freeNamesIfType (ifPatArgs d) &&&
   freeNamesIfContext (ifPatProvCtxt d) &&&
   freeNamesIfContext (ifPatReqCtxt d) &&&
   fnList freeNamesIfType (ifPatArgs d) &&&
@@ -1234,7 +1234,7 @@ freeNamesIfConDecls _                   = emptyNameSet
 
 freeNamesIfConDecl :: IfaceConDecl -> NameSet
 freeNamesIfConDecl c
 
 freeNamesIfConDecl :: IfaceConDecl -> NameSet
 freeNamesIfConDecl c
-  = freeNamesIfTvBndrs (ifConExTvs c) &&&
+  = fnList freeNamesIfForAllBndr (ifConExTvs c) &&&
     freeNamesIfContext (ifConCtxt c) &&&
     fnList freeNamesIfType (ifConArgTys c) &&&
     fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints
     freeNamesIfContext (ifConCtxt c) &&&
     fnList freeNamesIfType (ifConArgTys c) &&&
     fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints
index ca31283..45732ca 100644 (file)
@@ -32,6 +32,7 @@ module IfaceType (
         toIfaceTyCon, toIfaceTyCon_name,
         toIfaceTcArgs, toIfaceTvBndrs,
         zipIfaceBinders, toDegenerateBinders,
         toIfaceTyCon, toIfaceTyCon_name,
         toIfaceTcArgs, toIfaceTvBndrs,
         zipIfaceBinders, toDegenerateBinders,
+        binderToIfaceForAllBndr,
 
         -- Conversion from IfaceTcArgs -> IfaceType
         tcArgsIfaceTypes,
 
         -- Conversion from IfaceTcArgs -> IfaceType
         tcArgsIfaceTypes,
@@ -1341,6 +1342,11 @@ varToIfaceForAllBndr :: TyVar -> VisibilityFlag -> IfaceForAllBndr
 varToIfaceForAllBndr v vis
   = IfaceTv (toIfaceTvBndr v) vis
 
 varToIfaceForAllBndr v vis
   = IfaceTv (toIfaceTvBndr v) vis
 
+binderToIfaceForAllBndr :: TyBinder -> IfaceForAllBndr
+binderToIfaceForAllBndr (Named v vis) = IfaceTv (toIfaceTvBndr v) vis
+binderToIfaceForAllBndr binder
+  = pprPanic "binderToIfaceForAllBndr" (ppr binder)
+
 ----------------
 toIfaceTyCon :: TyCon -> IfaceTyCon
 toIfaceTyCon tc
 ----------------
 toIfaceTyCon :: TyCon -> IfaceTyCon
 toIfaceTyCon tc
index 6970b08..196dd19 100644 (file)
@@ -1304,8 +1304,8 @@ patSynToIfaceDecl ps
                 , ifPatMatcher    = to_if_pr (patSynMatcher ps)
                 , ifPatBuilder    = fmap to_if_pr (patSynBuilder ps)
                 , ifPatIsInfix    = patSynIsInfix ps
                 , ifPatMatcher    = to_if_pr (patSynMatcher ps)
                 , ifPatBuilder    = fmap to_if_pr (patSynBuilder ps)
                 , ifPatIsInfix    = patSynIsInfix ps
-                , ifPatUnivTvs    = toIfaceTvBndrs univ_tvs'
-                , ifPatExTvs      = toIfaceTvBndrs ex_tvs'
+                , ifPatUnivBndrs  = map binderToIfaceForAllBndr univ_bndrs'
+                , ifPatExBndrs    = map binderToIfaceForAllBndr ex_bndrs'
                 , ifPatProvCtxt   = tidyToIfaceContext env2 prov_theta
                 , ifPatReqCtxt    = tidyToIfaceContext env2 req_theta
                 , ifPatArgs       = map (tidyToIfaceType env2) args
                 , ifPatProvCtxt   = tidyToIfaceContext env2 prov_theta
                 , ifPatReqCtxt    = tidyToIfaceContext env2 req_theta
                 , ifPatArgs       = map (tidyToIfaceType env2) args
@@ -1313,9 +1313,11 @@ patSynToIfaceDecl ps
                 , ifFieldLabels   = (patSynFieldLabels ps)
                 }
   where
                 , ifFieldLabels   = (patSynFieldLabels ps)
                 }
   where
-    (univ_tvs, req_theta, ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps
-    (env1, univ_tvs') = tidyTyCoVarBndrs emptyTidyEnv univ_tvs
-    (env2, ex_tvs')   = tidyTyCoVarBndrs env1 ex_tvs
+    (_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps
+    univ_bndrs = patSynUnivTyBinders ps
+    ex_bndrs   = patSynExTyBinders ps
+    (env1, univ_bndrs') = tidyTyBinders emptyTidyEnv univ_bndrs
+    (env2, ex_bndrs')   = tidyTyBinders env1 ex_bndrs
     to_if_pr (id, needs_dummy) = (idName id, needs_dummy)
 
 --------------------------
     to_if_pr (id, needs_dummy) = (idName id, needs_dummy)
 
 --------------------------
@@ -1470,7 +1472,7 @@ tyConToIfaceDecl env tycon
         = IfCon   { ifConOcc     = getOccName (dataConName data_con),
                     ifConInfix   = dataConIsInfix data_con,
                     ifConWrapper = isJust (dataConWrapId_maybe data_con),
         = IfCon   { ifConOcc     = getOccName (dataConName data_con),
                     ifConInfix   = dataConIsInfix data_con,
                     ifConWrapper = isJust (dataConWrapId_maybe data_con),
-                    ifConExTvs   = toIfaceTvBndrs ex_tvs',
+                    ifConExTvs   = map binderToIfaceForAllBndr ex_bndrs',
                     ifConEqSpec  = map (to_eq_spec . eqSpecPair) eq_spec,
                     ifConCtxt    = tidyToIfaceContext con_env2 theta,
                     ifConArgTys  = map (tidyToIfaceType con_env2) arg_tys,
                     ifConEqSpec  = map (to_eq_spec . eqSpecPair) eq_spec,
                     ifConCtxt    = tidyToIfaceContext con_env2 theta,
                     ifConArgTys  = map (tidyToIfaceType con_env2) arg_tys,
@@ -1481,8 +1483,9 @@ tyConToIfaceDecl env tycon
                     ifConSrcStricts = map toIfaceSrcBang
                                           (dataConSrcBangs data_con)}
         where
                     ifConSrcStricts = map toIfaceSrcBang
                                           (dataConSrcBangs data_con)}
         where
-          (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)
+          (univ_tvs, _ex_tvs, eq_spec, theta, arg_tys, _)
             = dataConFullSig data_con
             = dataConFullSig data_con
+          ex_bndrs = dataConExTyBinders data_con
 
           -- Tidy the univ_tvs of the data constructor to be identical
           -- to the tyConTyVars of the type constructor.  This means
 
           -- Tidy the univ_tvs of the data constructor to be identical
           -- to the tyConTyVars of the type constructor.  This means
@@ -1494,7 +1497,7 @@ tyConToIfaceDecl env tycon
           con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))
                      -- A bit grimy, perhaps, but it's simple!
 
           con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))
                      -- A bit grimy, perhaps, but it's simple!
 
-          (con_env2, ex_tvs') = tidyTyCoVarBndrs con_env1 ex_tvs
+          (con_env2, ex_bndrs') = tidyTyBinders con_env1 ex_bndrs
           to_eq_spec (tv,ty)  = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty)
 
     ifaceOverloaded flds = case fsEnvElts flds of
           to_eq_spec (tv,ty)  = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty)
 
     ifaceOverloaded flds = case fsEnvElts flds of
index 8599afa..25fa227 100644 (file)
@@ -325,7 +325,7 @@ tc_iface_decl _ _ (IfaceData {ifName = occ_name,
     ; tycon <- fixM $ \ tycon -> do
             { stupid_theta <- tcIfaceCtxt ctxt
             ; parent' <- tc_parent tc_name mb_parent
     ; tycon <- fixM $ \ tycon -> do
             { stupid_theta <- tcIfaceCtxt ctxt
             ; parent' <- tc_parent tc_name mb_parent
-            ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
+            ; cons <- tcIfaceDataCons tc_name tycon tyvars binders' rdr_cons
             ; return (mkAlgTyCon tc_name binders' res_kind' tyvars roles cType stupid_theta
                                     cons parent' is_rec gadt_syn) }
     ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
             ; return (mkAlgTyCon tc_name binders' res_kind' tyvars roles cType stupid_theta
                                     cons parent' is_rec gadt_syn) }
     ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
@@ -476,8 +476,8 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
                               , ifPatMatcher = if_matcher
                               , ifPatBuilder = if_builder
                               , ifPatIsInfix = is_infix
                               , ifPatMatcher = if_matcher
                               , ifPatBuilder = if_builder
                               , ifPatIsInfix = is_infix
-                              , ifPatUnivTvs = univ_tvs
-                              , ifPatExTvs = ex_tvs
+                              , ifPatUnivBndrs = univ_bndrs
+                              , ifPatExBndrs = ex_bndrs
                               , ifPatProvCtxt = prov_ctxt
                               , ifPatReqCtxt = req_ctxt
                               , ifPatArgs = args
                               , ifPatProvCtxt = prov_ctxt
                               , ifPatReqCtxt = req_ctxt
                               , ifPatArgs = args
@@ -487,15 +487,16 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
        ; traceIf (text "tc_iface_decl" <+> ppr name)
        ; matcher <- tc_pr if_matcher
        ; builder <- fmapMaybeM tc_pr if_builder
        ; traceIf (text "tc_iface_decl" <+> ppr name)
        ; matcher <- tc_pr if_matcher
        ; builder <- fmapMaybeM tc_pr if_builder
-       ; bindIfaceTvBndrs univ_tvs $ \univ_tvs -> do
-       { bindIfaceTvBndrs ex_tvs $ \ex_tvs -> do
+       ; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs univ_bndrs -> do
+       { bindIfaceForAllBndrs ex_bndrs $ \ex_tvs ex_bndrs -> do
        { patsyn <- forkM (mk_doc name) $
              do { prov_theta <- tcIfaceCtxt prov_ctxt
                 ; req_theta  <- tcIfaceCtxt req_ctxt
                 ; pat_ty     <- tcIfaceType pat_ty
                 ; arg_tys    <- mapM tcIfaceType args
                 ; return $ buildPatSyn name is_infix matcher builder
        { patsyn <- forkM (mk_doc name) $
              do { prov_theta <- tcIfaceCtxt prov_ctxt
                 ; req_theta  <- tcIfaceCtxt req_ctxt
                 ; pat_ty     <- tcIfaceType pat_ty
                 ; arg_tys    <- mapM tcIfaceType args
                 ; return $ buildPatSyn name is_infix matcher builder
-                                       (univ_tvs, req_theta) (ex_tvs, prov_theta)
+                                       (univ_tvs, univ_bndrs, req_theta)
+                                       (ex_tvs, ex_bndrs, prov_theta)
                                        arg_tys pat_ty field_labels }
        ; return $ AConLike . PatSynCon $ patsyn }}}
   where
                                        arg_tys pat_ty field_labels }
        ; return $ AConLike . PatSynCon $ patsyn }}}
   where
@@ -527,8 +528,8 @@ tc_ax_branch prev_branches
                           , cab_incomps = map (prev_branches `getNth`) incomps }
     ; return (prev_branches ++ [br]) }
 
                           , cab_incomps = map (prev_branches `getNth`) incomps }
     ; return (prev_branches ++ [br]) }
 
-tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs
-tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
+tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> [TyBinder] -> IfaceConDecls -> IfL AlgTyConRhs
+tcIfaceDataCons tycon_name tycon tc_tyvars tc_tybinders if_cons
   = case if_cons of
         IfAbstractTyCon dis -> return (AbstractTyCon dis)
         IfDataTyCon cons _ _ -> do  { field_lbls <- mapM (traverse lookupIfaceTop) (ifaceConDeclFields if_cons)
   = case if_cons of
         IfAbstractTyCon dis -> return (AbstractTyCon dis)
         IfDataTyCon cons _ _ -> do  { field_lbls <- mapM (traverse lookupIfaceTop) (ifaceConDeclFields if_cons)
@@ -539,14 +540,14 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
                                     ; mkNewTyConRhs tycon_name tycon data_con }
   where
     tc_con_decl field_lbls (IfCon { ifConInfix = is_infix,
                                     ; mkNewTyConRhs tycon_name tycon data_con }
   where
     tc_con_decl field_lbls (IfCon { ifConInfix = is_infix,
-                         ifConExTvs = ex_tvs,
+                         ifConExTvs = ex_bndrs,
                          ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
                          ifConArgTys = args, ifConFields = my_lbls,
                          ifConStricts = if_stricts,
                          ifConSrcStricts = if_src_stricts})
      = -- Universally-quantified tyvars are shared with
        -- parent TyCon, and are alrady in scope
                          ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
                          ifConArgTys = args, ifConFields = my_lbls,
                          ifConStricts = if_stricts,
                          ifConSrcStricts = if_src_stricts})
      = -- Universally-quantified tyvars are shared with
        -- parent TyCon, and are alrady in scope
-       bindIfaceTvBndrs ex_tvs    $ \ ex_tyvars -> do
+       bindIfaceForAllBndrs ex_bndrs    $ \ ex_tvs ex_binders' -> do
         { traceIf (text "Start interface-file tc_con_decl" <+> ppr occ)
         ; dc_name  <- lookupIfaceTop occ
 
         { traceIf (text "Start interface-file tc_con_decl" <+> ppr occ)
         ; dc_name  <- lookupIfaceTop occ
 
@@ -588,7 +589,7 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
                        -- worker.
                        -- See Note [Bangs on imported data constructors] in MkId
                        lbl_names
                        -- worker.
                        -- See Note [Bangs on imported data constructors] in MkId
                        lbl_names
-                       tc_tyvars ex_tyvars
+                       tc_tyvars tc_tybinders ex_tvs ex_binders'
                        eq_spec theta
                        arg_tys orig_res_ty tycon
         ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name)
                        eq_spec theta
                        arg_tys orig_res_ty tycon
         ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name)
@@ -891,7 +892,7 @@ tcIfaceType = go
            ; tks' <- mapM go (tcArgsIfaceTypes tks)
            ; return (mkTyConApp tc' tks') }
     go (IfaceForAllTy bndr t)
            ; tks' <- mapM go (tcArgsIfaceTypes tks)
            ; return (mkTyConApp tc' tks') }
     go (IfaceForAllTy bndr t)
-      = bindIfaceBndrTy bndr $ \ tv' vis -> mkNamedForAllTy tv' vis <$> go t
+      = bindIfaceForAllBndr bndr $ \ tv' vis -> mkNamedForAllTy tv' vis <$> go t
     go (IfaceCastTy ty co)   = CastTy <$> go ty <*> tcIfaceCo co
     go (IfaceCoercionTy co)  = CoercionTy <$> tcIfaceCo co
 
     go (IfaceCastTy ty co)   = CastTy <$> go ty <*> tcIfaceCo co
     go (IfaceCoercionTy co)  = CoercionTy <$> tcIfaceCo co
 
@@ -1408,8 +1409,15 @@ bindIfaceBndrs (b:bs) thing_inside
     thing_inside (b':bs')
 
 -----------------------
     thing_inside (b':bs')
 
 -----------------------
-bindIfaceBndrTy :: IfaceForAllBndr -> (TyVar -> VisibilityFlag -> IfL a) -> IfL a
-bindIfaceBndrTy (IfaceTv tv vis) thing_inside
+bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyVar] -> [TyBinder] -> IfL a) -> IfL a
+bindIfaceForAllBndrs [] thing_inside = thing_inside [] []
+bindIfaceForAllBndrs (bndr:bndrs) thing_inside
+  = bindIfaceForAllBndr bndr $ \tv vis ->
+    bindIfaceForAllBndrs bndrs $ \tvs bndrs' ->
+    thing_inside (tv:tvs) (mkNamedBinder vis tv : bndrs')
+
+bindIfaceForAllBndr :: IfaceForAllBndr -> (TyVar -> VisibilityFlag -> IfL a) -> IfL a
+bindIfaceForAllBndr (IfaceTv tv vis) thing_inside
   = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis
 
 bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
   = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis
 
 bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
@@ -1418,13 +1426,6 @@ bindIfaceTyVar (occ,kind) thing_inside
         ; tyvar <- mk_iface_tyvar name kind
         ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
 
         ; tyvar <- mk_iface_tyvar name kind
         ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
 
-bindIfaceTvBndrs :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
-bindIfaceTvBndrs []       thing_inside = thing_inside []
-bindIfaceTvBndrs (tv:tvs) thing_inside
-  = bindIfaceTyVar tv $ \tv' ->
-    bindIfaceTvBndrs tvs $ \tvs' ->
-    thing_inside (tv':tvs')
-
 mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
 mk_iface_tyvar name ifKind
    = do { kind <- tcIfaceType ifKind
 mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
 mk_iface_tyvar name ifKind
    = do { kind <- tcIfaceType ifKind
index 98a5665..067b32b 100644 (file)
@@ -409,8 +409,8 @@ pcDataConWithFixity' declared_infix dc_name wrk_key rri tyvars ex_tyvars arg_tys
     data_con = mkDataCon dc_name declared_infix prom_info
                 (map (const no_bang) arg_tys)
                 []      -- No labelled fields
     data_con = mkDataCon dc_name declared_infix prom_info
                 (map (const no_bang) arg_tys)
                 []      -- No labelled fields
-                tyvars
-                ex_tyvars
+                tyvars    (mkNamedBinders Specified tyvars)
+                ex_tyvars (mkNamedBinders Specified ex_tyvars)
                 []      -- No equality spec
                 []      -- No theta
                 arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))
                 []      -- No equality spec
                 []      -- No theta
                 arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))
@@ -674,7 +674,7 @@ mk_tuple boxity arity = (tycon, tuple_con)
             in
             ( UnboxedTuple
             , gHC_PRIM
             in
             ( UnboxedTuple
             , gHC_PRIM
-            , map (mkNamedBinder Specified) rr_tvs ++
+            , mkNamedBinders Specified rr_tvs ++
               map (mkAnonBinder . tyVarKind) open_tvs
             , tYPE res_rep
             , arity * 2
               map (mkAnonBinder . tyVarKind) open_tvs
             , tYPE res_rep
             , arity * 2
index c1609c0..0a3c5aa 100644 (file)
@@ -26,7 +26,7 @@ module TcHsSyn (
         -- | For a description of "zonking", see Note [What is zonking?]
         -- in TcMType
         zonkTopDecls, zonkTopExpr, zonkTopLExpr,
         -- | For a description of "zonking", see Note [What is zonking?]
         -- in TcMType
         zonkTopDecls, zonkTopExpr, zonkTopLExpr,
-        zonkTopBndrs, zonkTyBndrsX,
+        zonkTopBndrs, zonkTyBndrsX, zonkTyBinders,
         emptyZonkEnv, mkEmptyZonkEnv,
         zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc,
         zonkCoToCo, zonkTcKindToKind
         emptyZonkEnv, mkEmptyZonkEnv,
         zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc,
         zonkCoToCo, zonkTcKindToKind
index 2b226f2..34c2144 100644 (file)
@@ -512,7 +512,7 @@ tc_hs_type mode (HsForAllTy { hst_bndrs = hs_tvs, hst_body = ty }) exp_kind
     -- Why exp_kind?  See Note [Body kind of HsForAllTy]
     do { ty' <- tc_lhs_type mode ty exp_kind
        ; let bound_vars = allBoundVariables ty'
     -- Why exp_kind?  See Note [Body kind of HsForAllTy]
     do { ty' <- tc_lhs_type mode ty exp_kind
        ; let bound_vars = allBoundVariables ty'
-             bndrs      = map (mkNamedBinder Specified) tvs'
+             bndrs      = mkNamedBinders Specified tvs'
        ; return (mkForAllTys bndrs ty', bound_vars) }
 
 tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind
        ; return (mkForAllTys bndrs ty', bound_vars) }
 
 tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind
@@ -1238,7 +1238,7 @@ kcHsTyVarBndrs cusk open_fam all_kind_vars
        ; when (not (null meta_tvs)) $
          report_non_cusk_tvs (qkvs ++ tvs)
 
        ; when (not (null meta_tvs)) $
          report_non_cusk_tvs (qkvs ++ tvs)
 
-       ; return ( map (mkNamedBinder Specified) good_tvs ++ binders
+       ; return ( mkNamedBinders Specified good_tvs ++ binders
                 , res_kind, stuff ) }}
 
   | otherwise
                 , res_kind, stuff ) }}
 
   | otherwise
index 9da27bf..de309d5 100644 (file)
@@ -672,9 +672,10 @@ tcDataFamInstDecl mb_clsinfo
              orig_res_ty          = mkTyConApp fam_tc pats'
 
        ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) ->
              orig_res_ty          = mkTyConApp fam_tc pats'
 
        ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) ->
-           do { data_cons <- tcConDecls new_or_data
+           do { let ty_binders = mkTyBindersPreferAnon full_tvs liftedTypeKind
+              ; data_cons <- tcConDecls new_or_data
                                         rec_rep_tc
                                         rec_rep_tc
-                                        (full_tvs, orig_res_ty) cons
+                                        (full_tvs, ty_binders, orig_res_ty) cons
               ; tc_rhs <- case new_or_data of
                      DataType -> return (mkDataTyConRhs data_cons)
                      NewType  -> ASSERT( not (null data_cons) )
               ; tc_rhs <- case new_or_data of
                      DataType -> return (mkDataTyConRhs data_cons)
                      NewType  -> ASSERT( not (null data_cons) )
@@ -684,7 +685,6 @@ tcDataFamInstDecl mb_clsinfo
                                              axiom_name eta_tvs [] fam_tc eta_pats
                                              (mkTyConApp rep_tc (mkTyVarTys eta_tvs))
                     parent = DataFamInstTyCon axiom fam_tc pats'
                                              axiom_name eta_tvs [] fam_tc eta_pats
                                              (mkTyConApp rep_tc (mkTyVarTys eta_tvs))
                     parent = DataFamInstTyCon axiom fam_tc pats'
-                    ty_binders = mkTyBindersPreferAnon full_tvs liftedTypeKind
 
 
                       -- NB: Use the full_tvs from the pats. See bullet toward
 
 
                       -- NB: Use the full_tvs from the pats. See bullet toward
index 8be9791..6536b67 100644 (file)
@@ -35,6 +35,7 @@ import BasicTypes
 import TcSimplify
 import TcUnify
 import TcType
 import TcSimplify
 import TcUnify
 import TcType
+import Type
 import TcEvidence
 import BuildTyCl
 import VarSet
 import TcEvidence
 import BuildTyCl
 import VarSet
@@ -150,26 +151,30 @@ tcPatSynSig name sig_ty
          -- Split [Splitting the implicit tyvars in a pattern synonym]
        ; let univ_fvs = closeOverKinds $
                         (tyCoVarsOfTypes (body_ty : req) `extendVarSetList` univ_tvs)
          -- Split [Splitting the implicit tyvars in a pattern synonym]
        ; let univ_fvs = closeOverKinds $
                         (tyCoVarsOfTypes (body_ty : req) `extendVarSetList` univ_tvs)
-             (extra_univ, extra_ex) = partition (`elemVarSet` univ_fvs) $
-                                      kvs ++ implicit_tvs
+             (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) .
+                                                 binderVar "tcPatSynSig") $
+                                      mkNamedBinders Invisible kvs ++
+                                      mkNamedBinders Specified implicit_tvs
        ; traceTc "tcTySig }" $
          vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs
               , text "kvs" <+> ppr_tvs kvs
        ; traceTc "tcTySig }" $
          vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs
               , text "kvs" <+> ppr_tvs kvs
-              , text "extra_univ" <+> ppr_tvs extra_univ
+              , text "extra_univ" <+> ppr extra_univ
               , text "univ_tvs" <+> ppr_tvs univ_tvs
               , text "req" <+> ppr req
               , text "univ_tvs" <+> ppr_tvs univ_tvs
               , text "req" <+> ppr req
-              , text "extra_ex" <+> ppr_tvs extra_ex
+              , text "extra_ex" <+> ppr extra_ex
               , text "ex_tvs" <+> ppr_tvs ex_tvs
               , text "prov" <+> ppr prov
               , text "arg_tys" <+> ppr arg_tys
               , text "body_ty" <+> ppr body_ty ]
        ; return (TPSI { patsig_name = name
               , text "ex_tvs" <+> ppr_tvs ex_tvs
               , text "prov" <+> ppr prov
               , text "arg_tys" <+> ppr arg_tys
               , text "body_ty" <+> ppr body_ty ]
        ; return (TPSI { patsig_name = name
-                      , patsig_univ_tvs = extra_univ ++ univ_tvs
-                      , patsig_req      = req
-                      , patsig_ex_tvs   = extra_ex   ++ ex_tvs
-                      , patsig_prov     = prov
-                      , patsig_arg_tys  = arg_tys
-                      , patsig_body_ty  = body_ty }) }
+                      , patsig_univ_bndrs = extra_univ ++
+                                            mkNamedBinders Specified univ_tvs
+                      , patsig_req        = req
+                      , patsig_ex_bndrs   = extra_ex   ++
+                                            mkNamedBinders Specified ex_tvs
+                      , patsig_prov       = prov
+                      , patsig_arg_tys    = arg_tys
+                      , patsig_body_ty    = body_ty }) }
   where
 
 ppr_tvs :: [TyVar] -> SDoc
   where
 
 ppr_tvs :: [TyVar] -> SDoc
@@ -213,9 +218,11 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
              req_theta  = map evVarPred req_dicts
 
        ; traceTc "tcInferPatSynDecl }" $ ppr name
              req_theta  = map evVarPred req_dicts
 
        ; traceTc "tcInferPatSynDecl }" $ ppr name
-       ; tc_patsyn_finish lname dir False {- no sig -} is_infix lpat'
-                          (univ_tvs, req_theta,  ev_binds, req_dicts)
-                          (ex_tvs,   mkTyVarTys ex_tvs, prov_theta, map EvId prov_dicts)
+       ; tc_patsyn_finish lname dir is_infix lpat'
+                          (univ_tvs, mkNamedBinders Invisible univ_tvs
+                            , req_theta,  ev_binds, req_dicts)
+                          (ex_tvs,   mkNamedBinders Invisible ex_tvs
+                            , mkTyVarTys ex_tvs, prov_theta, map EvId prov_dicts)
                           (map nlHsVar args, map idType args)
                           pat_ty rec_fields }
 
                           (map nlHsVar args, map idType args)
                           pat_ty rec_fields }
 
@@ -225,9 +232,9 @@ tcCheckPatSynDecl :: PatSynBind Name Name
                   -> TcM (LHsBinds Id, TcGblEnv)
 tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
                          , psb_def = lpat, psb_dir = dir }
                   -> TcM (LHsBinds Id, TcGblEnv)
 tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
                          , psb_def = lpat, psb_dir = dir }
-                  TPSI{ patsig_univ_tvs = univ_tvs, patsig_prov = prov_theta
-                      , patsig_ex_tvs   = ex_tvs,   patsig_req  = req_theta
-                      , patsig_arg_tys  = arg_tys,  patsig_body_ty = pat_ty }
+                  TPSI{ patsig_univ_bndrs = univ_bndrs, patsig_prov = prov_theta
+                      , patsig_ex_bndrs   = ex_bndrs,   patsig_req  = req_theta
+                      , patsig_arg_tys    = arg_tys,    patsig_body_ty = pat_ty }
   = addPatSynCtxt lname $
     do { let origin     = ProvCtxtOrigin psb
              skol_info  = SigSkol (PatSynCtxt name) (mkCheckExpType $
   = addPatSynCtxt lname $
     do { let origin     = ProvCtxtOrigin psb
              skol_info  = SigSkol (PatSynCtxt name) (mkCheckExpType $
@@ -236,8 +243,11 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
              ty_arity   = length arg_tys
              (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
 
              ty_arity   = length arg_tys
              (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
 
+             univ_tvs   = map (binderVar "tcCheckPatSynDecl 1") univ_bndrs
+             ex_tvs     = map (binderVar "tcCheckPatSynDecl 2") ex_bndrs
+
        ; traceTc "tcCheckPatSynDecl" $
        ; traceTc "tcCheckPatSynDecl" $
-         vcat [ ppr univ_tvs, ppr req_theta, ppr ex_tvs
+         vcat [ ppr univ_bndrs, ppr req_theta, ppr ex_bndrs
               , ppr prov_theta, ppr arg_tys, ppr pat_ty ]
 
        ; checkTc (decl_arity == ty_arity)
               , ppr prov_theta, ppr arg_tys, ppr pat_ty ]
 
        ; checkTc (decl_arity == ty_arity)
@@ -282,9 +292,9 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
        -- when that should be impossible
 
        ; traceTc "tcCheckPatSynDecl }" $ ppr name
        -- when that should be impossible
 
        ; traceTc "tcCheckPatSynDecl }" $ ppr name
-       ; tc_patsyn_finish lname dir True {- has a sig -} is_infix lpat'
-                          (univ_tvs, req_theta, ev_binds, req_dicts)
-                          (ex_tvs, mkTyVarTys ex_tvs', prov_theta, prov_dicts)
+       ; tc_patsyn_finish lname dir is_infix lpat'
+                          (univ_tvs, univ_bndrs, req_theta, ev_binds, req_dicts)
+                          (ex_tvs, ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts)
                           (args', arg_tys)
                           pat_ty rec_fields }
   where
                           (args', arg_tys)
                           pat_ty rec_fields }
   where
@@ -379,19 +389,18 @@ wrongNumberOfParmsErr name decl_arity ty_arity
 -- Shared by both tcInferPatSyn and tcCheckPatSyn
 tc_patsyn_finish :: Located Name  -- ^ PatSyn Name
                  -> HsPatSynDir Name  -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)
 -- Shared by both tcInferPatSyn and tcCheckPatSyn
 tc_patsyn_finish :: Located Name  -- ^ PatSyn Name
                  -> HsPatSynDir Name  -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)
-                 -> Bool              -- ^ True <=> signature provided
                  -> Bool              -- ^ Whether infix
                  -> LPat Id           -- ^ Pattern of the PatSyn
                  -> Bool              -- ^ Whether infix
                  -> LPat Id           -- ^ Pattern of the PatSyn
-                 -> ([TcTyVar], [PredType], TcEvBinds, [EvVar])
-                 -> ([TcTyVar], [TcType], [PredType], [EvTerm])
+                 -> ([TcTyVar], [TcTyBinder], [PredType], TcEvBinds, [EvVar])
+                 -> ([TcTyVar], [TcTyBinder], [TcType], [PredType], [EvTerm])
                  -> ([LHsExpr TcId], [TcType])   -- ^ Pattern arguments and types
                  -> TcType              -- ^ Pattern type
                  -> [Name]              -- ^ Selector names
                  -- ^ Whether fields, empty if not record PatSyn
                  -> TcM (LHsBinds Id, TcGblEnv)
                  -> ([LHsExpr TcId], [TcType])   -- ^ Pattern arguments and types
                  -> TcType              -- ^ Pattern type
                  -> [Name]              -- ^ Selector names
                  -- ^ Whether fields, empty if not record PatSyn
                  -> TcM (LHsBinds Id, TcGblEnv)
-tc_patsyn_finish lname dir has_sig is_infix lpat'
-                 (univ_tvs, req_theta, req_ev_binds, req_dicts)
-                 (ex_tvs, ex_tys, prov_theta, prov_dicts)
+tc_patsyn_finish lname dir is_infix lpat'
+                 (univ_tvs, univ_bndrs, req_theta, req_ev_binds, req_dicts)
+                 (ex_tvs, ex_bndrs, ex_tys, prov_theta, prov_dicts)
                  (args, arg_tys)
                  pat_ty field_labels
   = do { -- Zonk everything.  We are about to build a final PatSyn
                  (args, arg_tys)
                  pat_ty field_labels
   = do { -- Zonk everything.  We are about to build a final PatSyn
@@ -403,16 +412,34 @@ tc_patsyn_finish lname dir has_sig is_infix lpat'
        ; pat_ty       <- zonkTcType pat_ty
        ; arg_tys      <- zonkTcTypes arg_tys
 
        ; pat_ty       <- zonkTcType pat_ty
        ; arg_tys      <- zonkTcTypes arg_tys
 
+          -- We need to update the univ and ex binders after zonking.
+          -- But zonking may have defaulted some erstwhile binders,
+          -- so we need to make sure the tyvars and tybinders remain
+          -- lined up
+       ; let update_binders :: [TyVar] -> [TcTyBinder] -> [TyBinder]
+             update_binders [] _ = []
+             update_binders all_tvs@(tv:tvs) (bndr:bndrs)
+               | tv == bndr_var
+               = mkNamedBinder (binderVisibility bndr) tv : update_binders tvs bndrs
+               | otherwise
+               = update_binders all_tvs bndrs
+               where
+                 bndr_var = binderVar "tc_patsyn_finish" bndr
+             update_binders tvs _ = pprPanic "tc_patsyn_finish" (ppr lname $$ ppr tvs)
+
+             univ_bndrs' = update_binders univ_tvs univ_bndrs
+             ex_bndrs'   = update_binders ex_tvs   ex_bndrs
+
        ; traceTc "tc_patsyn_finish {" $
            ppr (unLoc lname) $$ ppr (unLoc lpat') $$
        ; traceTc "tc_patsyn_finish {" $
            ppr (unLoc lname) $$ ppr (unLoc lpat') $$
-           ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$
-           ppr (ex_tvs, prov_theta, prov_dicts) $$
+           ppr (univ_tvs, univ_bndrs', req_theta, req_ev_binds, req_dicts) $$
+           ppr (ex_tvs, ex_bndrs', prov_theta, prov_dicts) $$
            ppr args $$
            ppr arg_tys $$
            ppr pat_ty
 
        -- Make the 'matcher'
            ppr args $$
            ppr arg_tys $$
            ppr pat_ty
 
        -- Make the 'matcher'
-       ; (matcher_id, matcher_bind) <- tcPatSynMatcher has_sig lname lpat'
+       ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
                                          (univ_tvs, req_theta, req_ev_binds, req_dicts)
                                          (ex_tvs, ex_tys, prov_theta, prov_dicts)
                                          (args, arg_tys)
                                          (univ_tvs, req_theta, req_ev_binds, req_dicts)
                                          (ex_tvs, ex_tys, prov_theta, prov_dicts)
                                          (args, arg_tys)
@@ -420,9 +447,9 @@ tc_patsyn_finish lname dir has_sig is_infix lpat'
 
 
        -- Make the 'builder'
 
 
        -- Make the 'builder'
-       ; builder_id <- mkPatSynBuilderId has_sig dir lname
-                                         univ_tvs req_theta
-                                         ex_tvs   prov_theta
+       ; builder_id <- mkPatSynBuilderId dir lname
+                                         univ_bndrs' req_theta
+                                         ex_bndrs'   prov_theta
                                          arg_tys pat_ty
 
          -- TODO: Make this have the proper information
                                          arg_tys pat_ty
 
          -- TODO: Make this have the proper information
@@ -432,8 +459,8 @@ tc_patsyn_finish lname dir has_sig is_infix lpat'
 
        -- Make the PatSyn itself
        ; let patSyn = mkPatSyn (unLoc lname) is_infix
 
        -- Make the PatSyn itself
        ; let patSyn = mkPatSyn (unLoc lname) is_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_id builder_id
                         arg_tys
                         pat_ty
                         matcher_id builder_id
@@ -459,8 +486,7 @@ tc_patsyn_finish lname dir has_sig is_infix lpat'
 ************************************************************************
 -}
 
 ************************************************************************
 -}
 
-tcPatSynMatcher :: Bool  -- True <=> signature provided
-                -> Located Name
+tcPatSynMatcher :: Located Name
                 -> LPat Id
                 -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
                 -> ([TcTyVar], [TcType], ThetaType, [EvTerm])
                 -> LPat Id
                 -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
                 -> ([TcTyVar], [TcType], ThetaType, [EvTerm])
@@ -468,7 +494,7 @@ tcPatSynMatcher :: Bool  -- True <=> signature provided
                 -> TcType
                 -> TcM ((Id, Bool), LHsBinds Id)
 -- See Note [Matchers and builders for pattern synonyms] in PatSyn
                 -> TcType
                 -> TcM ((Id, Bool), LHsBinds Id)
 -- See Note [Matchers and builders for pattern synonyms] in PatSyn
-tcPatSynMatcher has_sig (L loc name) lpat
+tcPatSynMatcher (L loc name) lpat
                 (univ_tvs, req_theta, req_ev_binds, req_dicts)
                 (ex_tvs, ex_tys, prov_theta, prov_dicts)
                 (args, arg_tys) pat_ty
                 (univ_tvs, req_theta, req_ev_binds, req_dicts)
                 (ex_tvs, ex_tys, prov_theta, prov_dicts)
                 (args, arg_tys) pat_ty
@@ -484,8 +510,7 @@ tcPatSynMatcher has_sig (L loc name) lpat
              (cont_args, cont_arg_tys)
                | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy])
                | otherwise   = (args,                 arg_tys)
              (cont_args, cont_arg_tys)
                | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy])
                | otherwise   = (args,                 arg_tys)
-             mk_sigma = if has_sig then mkSpecSigmaTy else mkInvSigmaTy
-             cont_ty = mk_sigma ex_tvs prov_theta $
+             cont_ty = mkInvSigmaTy ex_tvs prov_theta $
                        mkFunTys cont_arg_tys res_ty
 
              fail_ty  = mkFunTy voidPrimTy res_ty
                        mkFunTys cont_arg_tys res_ty
 
              fail_ty  = mkFunTy voidPrimTy res_ty
@@ -569,25 +594,26 @@ isUnidirectional ExplicitBidirectional{} = False
 ************************************************************************
 -}
 
 ************************************************************************
 -}
 
-mkPatSynBuilderId :: Bool  -- True <=> signature provided
-                  -> HsPatSynDir a -> Located Name
-                  -> [TyVar] -> ThetaType
-                  -> [TyVar] -> ThetaType
+mkPatSynBuilderId :: HsPatSynDir a -> Located Name
+                  -> [TyBinder] -> ThetaType
+                  -> [TyBinder] -> ThetaType
                   -> [Type] -> Type
                   -> TcM (Maybe (Id, Bool))
                   -> [Type] -> Type
                   -> TcM (Maybe (Id, Bool))
-mkPatSynBuilderId has_sig dir (L _ name)
-                  univ_tvs req_theta ex_tvs prov_theta
+mkPatSynBuilderId dir (L _ name)
+                  univ_bndrs req_theta ex_bndrs prov_theta
                   arg_tys pat_ty
   | isUnidirectional dir
   = return Nothing
   | otherwise
   = do { builder_name <- newImplicitBinder name mkBuilderOcc
                   arg_tys pat_ty
   | isUnidirectional dir
   = return Nothing
   | otherwise
   = do { builder_name <- newImplicitBinder name mkBuilderOcc
-       ; let qtvs           = univ_tvs ++ ex_tvs
-             theta          = req_theta ++ prov_theta
-             mk_sigma       = if has_sig then mkSpecSigmaTy else mkInvSigmaTy
+       ; let theta          = req_theta ++ prov_theta
              need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta
              builder_sigma  = add_void need_dummy_arg $
              need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta
              builder_sigma  = add_void need_dummy_arg $
-                              mk_sigma qtvs theta (mkFunTys arg_tys pat_ty)
+                              mkForAllTys univ_bndrs $
+                              mkForAllTys ex_bndrs $
+                              mkFunTys theta $
+                              mkFunTys arg_tys $
+                              pat_ty
              builder_id     = mkExportedVanillaId builder_name builder_sigma
               -- See Note [Exported LocalIds] in Id
 
              builder_id     = mkExportedVanillaId builder_name builder_sigma
               -- See Note [Exported LocalIds] in Id
 
@@ -660,12 +686,12 @@ tcPatSynBuilderBind sig_fun PSB{ psb_id = L loc name, psb_def = lpat
 get_builder_sig :: TcSigFun -> Name -> Id -> Bool -> TcM TcIdSigInfo
 get_builder_sig sig_fun name builder_id need_dummy_arg
   | Just (TcPatSynSig sig) <- sig_fun name
 get_builder_sig :: TcSigFun -> Name -> Id -> Bool -> TcM TcIdSigInfo
 get_builder_sig sig_fun name builder_id need_dummy_arg
   | Just (TcPatSynSig sig) <- sig_fun name
-  , TPSI { patsig_univ_tvs = univ_tvs
-         , patsig_req      = req
-         , patsig_ex_tvs   = ex_tvs
-         , patsig_prov     = prov
-         , patsig_arg_tys  = arg_tys
-         , patsig_body_ty  = body_ty } <- sig
+  , TPSI { patsig_univ_bndrs = univ_bndrs
+         , patsig_req        = req
+         , patsig_ex_bndrs   = ex_bndrs
+         , patsig_prov       = prov
+         , patsig_arg_tys    = arg_tys
+         , patsig_body_ty    = body_ty } <- sig
   = -- Constuct a TcIdSigInfo from a TcPatSynInfo
     -- This does unfortunately mean that we have to know how to
     -- make the builder Id's type from the TcPatSynInfo, which
   = -- Constuct a TcIdSigInfo from a TcPatSynInfo
     -- This does unfortunately mean that we have to know how to
     -- make the builder Id's type from the TcPatSynInfo, which
@@ -673,7 +699,9 @@ get_builder_sig sig_fun name builder_id need_dummy_arg
     -- But we really want to use the scoped type variables from
     -- the actual sigature, so this is really the Right Thing
     return (TISI { sig_bndr  = CompleteSig builder_id
     -- But we really want to use the scoped type variables from
     -- the actual sigature, so this is really the Right Thing
     return (TISI { sig_bndr  = CompleteSig builder_id
-                 , sig_skols = [(tyVarName tv, tv) | tv <- univ_tvs ++ ex_tvs]
+                 , sig_skols = [ (tyVarName tv, tv)
+                               | bndr <- univ_bndrs ++ ex_bndrs
+                               , let tv = binderVar "get_builder_sig" bndr ]
                  , sig_theta = req ++ prov
                  , sig_tau   = add_void need_dummy_arg $
                                mkFunTys arg_tys body_ty
                  , sig_theta = req ++ prov
                  , sig_tau   = add_void need_dummy_arg $
                                mkFunTys arg_tys body_ty
index 309bb97..d89ddf2 100644 (file)
@@ -1203,13 +1203,13 @@ data TcIdSigBndr   -- See Note [Complete and partial type signatures]
 
 data TcPatSynInfo
   = TPSI {
 
 data TcPatSynInfo
   = TPSI {
-        patsig_name     :: Name,
-        patsig_univ_tvs :: [TcTyVar],
-        patsig_req      :: TcThetaType,
-        patsig_ex_tvs   :: [TcTyVar],
-        patsig_prov     :: TcThetaType,
-        patsig_arg_tys  :: [TcSigmaType],
-        patsig_body_ty  :: TcSigmaType
+        patsig_name       :: Name,
+        patsig_univ_bndrs :: [TcTyBinder],
+        patsig_req        :: TcThetaType,
+        patsig_ex_bndrs   :: [TcTyBinder],
+        patsig_prov       :: TcThetaType,
+        patsig_arg_tys    :: [TcSigmaType],
+        patsig_body_ty    :: TcSigmaType
     }
 
 findScopedTyVars  -- See Note [Binding scoped type variables]
     }
 
 findScopedTyVars  -- See Note [Binding scoped type variables]
index 8fa967d..ffabeb3 100644 (file)
@@ -33,6 +33,7 @@ import TcClassDcl
 import TcUnify
 import TcHsType
 import TcMType
 import TcUnify
 import TcHsType
 import TcMType
+import TysWiredIn ( unitTy )
 import TcType
 import FamInst
 import FamInstEnv
 import TcType
 import FamInst
 import FamInstEnv
@@ -324,7 +325,7 @@ kcTyClGroup (TyClGroup { group_tyclds = decls })
                   , ppr kvs, ppr kc_binders', ppr kc_res_kind' ]
 
            ; return (mkTcTyCon name
                   , ppr kvs, ppr kc_binders', ppr kc_res_kind' ]
 
            ; return (mkTcTyCon name
-                               (map (mkNamedBinder Invisible) kvs ++ kc_binders')
+                               (mkNamedBinders Invisible kvs ++ kc_binders')
                                kc_res_kind'
                                (mightBeUnsaturatedTyCon tc)) }
 
                                kc_res_kind'
                                (mightBeUnsaturatedTyCon tc)) }
 
@@ -900,8 +901,9 @@ tcDataDefn rec_info     -- Knot-tied; don't look at this eagerly
                      , dd_ctxt = ctxt, dd_kindSig = mb_ksig
                      , dd_cons = cons })
  =  do { (extra_tvs, extra_bndrs, real_res_kind) <- tcDataKindSig res_kind
                      , dd_ctxt = ctxt, dd_kindSig = mb_ksig
                      , dd_cons = cons })
  =  do { (extra_tvs, extra_bndrs, real_res_kind) <- tcDataKindSig res_kind
-       ; let final_tvs  = tvs `chkAppend` extra_tvs
-             roles      = rti_roles rec_info tc_name
+       ; let final_bndrs  = tycon_binders `chkAppend` extra_bndrs
+             final_tvs    = tvs `chkAppend` extra_tvs
+             roles        = rti_roles rec_info tc_name
 
        ; stupid_tc_theta <- solveEqualities $ tcHsContext ctxt
        ; stupid_theta    <- zonkTcTypeToTypes emptyZonkEnv
 
        ; stupid_tc_theta <- solveEqualities $ tcHsContext ctxt
        ; stupid_theta    <- zonkTcTypeToTypes emptyZonkEnv
@@ -917,7 +919,8 @@ tcDataDefn rec_info     -- Knot-tied; don't look at this eagerly
 
        ; tycon <- fixM $ \ tycon -> do
              { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
 
        ; tycon <- fixM $ \ tycon -> do
              { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
-             ; data_cons <- tcConDecls new_or_data tycon (final_tvs, res_ty) cons
+             ; data_cons <- tcConDecls new_or_data tycon
+                                       (final_tvs, final_bndrs, res_ty) cons
              ; tc_rhs    <- mk_tc_rhs is_boot tycon data_cons
              ; tc_rep_nm <- newTyConRepName tc_name
              ; return (mkAlgTyCon tc_name (tycon_binders `chkAppend` extra_bndrs)
              ; tc_rhs    <- mk_tc_rhs is_boot tycon data_cons
              ; tc_rep_nm <- newTyConRepName tc_name
              ; return (mkAlgTyCon tc_name (tycon_binders `chkAppend` extra_bndrs)
@@ -1388,20 +1391,23 @@ consUseGadtSyntax _                           = False
                  -- All constructors have same shape
 
 -----------------------------------
                  -- All constructors have same shape
 
 -----------------------------------
-tcConDecls :: NewOrData -> TyCon -> ([TyVar], Type)
+tcConDecls :: NewOrData -> TyCon -> ([TyVar], [TyBinder], Type)
            -> [LConDecl Name] -> TcM [DataCon]
            -> [LConDecl Name] -> TcM [DataCon]
-tcConDecls new_or_data rep_tycon (tmpl_tvs, res_tmpl)
+  -- Why both the tycon tyvars and binders? Because the tyvars
+  -- have all the names and the binders have the visibilities.
+tcConDecls new_or_data rep_tycon (tmpl_tvs, tmpl_bndrs, res_tmpl)
   = concatMapM $ addLocM $
   = concatMapM $ addLocM $
-    tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl
+    tcConDecl new_or_data rep_tycon tmpl_tvs tmpl_bndrs res_tmpl
 
 tcConDecl :: NewOrData
           -> TyCon             -- Representation tycon. Knot-tied!
 
 tcConDecl :: NewOrData
           -> TyCon             -- Representation tycon. Knot-tied!
-          -> [TyVar] -> Type   -- Return type template (with its template tyvars)
-                               --    (tvs, T tys), where T is the family TyCon
+          -> [TyVar] -> [TyBinder] -> Type
+                 -- Return type template (with its template tyvars)
+                 --    (tvs, T tys), where T is the family TyCon
           -> ConDecl Name
           -> TcM [DataCon]
 
           -> ConDecl Name
           -> TcM [DataCon]
 
-tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl
+tcConDecl new_or_data rep_tycon tmpl_tvs tmpl_bndrs res_tmpl
           (ConDeclH98 { con_name = name
                       , con_qvars = hs_qvars, con_cxt = hs_ctxt
                       , con_details = hs_details })
           (ConDeclH98 { con_name = name
                       , con_qvars = hs_qvars, con_cxt = hs_ctxt
                       , con_details = hs_details })
@@ -1411,41 +1417,61 @@ tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl
                Nothing -> ([], [])
                Just (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs })
                        -> (kvs, tvs)
                Nothing -> ([], [])
                Just (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs })
                        -> (kvs, tvs)
-       ; (_, (ctxt, arg_tys, field_lbls, stricts))
+       ; (imp_tvs, (exp_tvs, ctxt, arg_tys, field_lbls, stricts))
            <- solveEqualities $
               tcImplicitTKBndrs hs_kvs $
            <- solveEqualities $
               tcImplicitTKBndrs hs_kvs $
-              tcExplicitTKBndrs hs_tvs $ \ _ ->
+              tcExplicitTKBndrs hs_tvs $ \ exp_tvs ->
               do { traceTc "tcConDecl" (ppr name <+> text "tvs:" <+> ppr hs_tvs)
                  ; ctxt <- tcHsContext (fromMaybe (noLoc []) hs_ctxt)
                  ; btys <- tcConArgs new_or_data hs_details
                  ; field_lbls <- lookupConstructorFields (unLoc name)
                  ; let (arg_tys, stricts) = unzip btys
               do { traceTc "tcConDecl" (ppr name <+> text "tvs:" <+> ppr hs_tvs)
                  ; ctxt <- tcHsContext (fromMaybe (noLoc []) hs_ctxt)
                  ; btys <- tcConArgs new_or_data hs_details
                  ; field_lbls <- lookupConstructorFields (unLoc name)
                  ; let (arg_tys, stricts) = unzip btys
-                       bound_vars = allBoundVariabless ctxt `unionVarSet`
-                                    allBoundVariabless arg_tys
-                 ; return ((ctxt, arg_tys, field_lbls, stricts), bound_vars)
+                       bound_vars  = allBoundVariabless ctxt `unionVarSet`
+                                     allBoundVariabless arg_tys
+                 ; return ((exp_tvs, ctxt, arg_tys, field_lbls, stricts), bound_vars)
                  }
                  }
+         -- imp_tvs are user-written kind variables, without an explicit binding site
+         -- exp_tvs have binding sites
+         -- the kvs below are those kind variables entirely unmentioned by the user
+         --   and discovered only by generalization
 
              -- Kind generalisation
 
              -- Kind generalisation
-       ; tkvs <- quantifyTyVars (mkVarSet tmpl_tvs)
-                                (splitDepVarsOfTypes (ctxt++arg_tys))
+       ; let all_user_tvs = imp_tvs ++ exp_tvs
+       ; kvs <- quantifyTyVars (mkVarSet tmpl_tvs)
+                               (splitDepVarsOfType (mkSpecForAllTys all_user_tvs $
+                                                    mkFunTys ctxt $
+                                                    mkFunTys arg_tys $
+                                                    unitTy))
+                 -- That type is a lie, of course. (It shouldn't end in ()!)
+                 -- And we could construct a proper result type from the info
+                 -- at hand. But the result would mention only the tmpl_tvs,
+                 -- and so it just creates more work to do it right. Really,
+                 -- we're doing this to get the right behavior around removing
+                 -- any vars bound in exp_binders.
 
              -- Zonk to Types
 
              -- Zonk to Types
-       ; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv tkvs
-       ; arg_tys     <- zonkTcTypeToTypes ze arg_tys
-       ; ctxt        <- zonkTcTypeToTypes ze ctxt
+       ; (ze, qkvs)      <- zonkTyBndrsX emptyZonkEnv kvs
+       ; (ze, user_qtvs) <- zonkTyBndrsX ze all_user_tvs
+       ; arg_tys         <- zonkTcTypeToTypes ze arg_tys
+       ; ctxt            <- zonkTcTypeToTypes ze ctxt
 
        ; fam_envs <- tcGetFamInstEnvs
 
        -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here
        ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls)
        ; let
 
        ; fam_envs <- tcGetFamInstEnvs
 
        -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here
        ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls)
        ; let
+           ex_tvs     = qkvs ++ user_qtvs
+           ex_binders = mkNamedBinders Invisible qkvs ++
+                        mkNamedBinders Specified user_qtvs
            buildOneDataCon (L _ name) = do
              { is_infix <- tcConIsInfixH98 name hs_details
              ; rep_nm   <- newTyConRepName name
 
              ; buildDataCon fam_envs name is_infix rep_nm
                             stricts Nothing field_lbls
            buildOneDataCon (L _ name) = do
              { is_infix <- tcConIsInfixH98 name hs_details
              ; rep_nm   <- newTyConRepName name
 
              ; buildDataCon fam_envs name is_infix rep_nm
                             stricts Nothing field_lbls
-                            tmpl_tvs qtkvs [{- no eq_preds -}] ctxt arg_tys
+                            tmpl_tvs tmpl_bndrs
+                            ex_tvs ex_binders
+                            [{- no eq_preds -}] ctxt arg_tys
                             res_tmpl rep_tycon
                   -- NB:  we put data_tc, the type constructor gotten from the
                   --      constructor type signature into the data constructor;
                             res_tmpl rep_tycon
                   -- NB:  we put data_tc, the type constructor gotten from the
                   --      constructor type signature into the data constructor;
@@ -1455,17 +1481,20 @@ tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl
        ; mapM buildOneDataCon [name]
        }
 
        ; mapM buildOneDataCon [name]
        }
 
-tcConDecl _new_or_data rep_tycon tmpl_tvs res_tmpl
+tcConDecl _new_or_data rep_tycon tmpl_tvs _tmpl_bndrs res_tmpl
           (ConDeclGADT { con_names = names, con_type = ty })
   = addErrCtxt (dataConCtxtName names) $
     do { traceTc "tcConDecl 1" (ppr names)
           (ConDeclGADT { con_names = names, con_type = ty })
   = addErrCtxt (dataConCtxtName names) $
     do { traceTc "tcConDecl 1" (ppr names)
-       ; (ctxt, stricts, field_lbls, arg_tys, res_ty,hs_details)
+       ; (user_tvs, ctxt, stricts, field_lbls, arg_tys, res_ty,hs_details)
            <- tcGadtSigType (ppr names) (unLoc $ head names) ty
        ; tkvs <- quantifyTyVars emptyVarSet
            <- tcGadtSigType (ppr names) (unLoc $ head names) ty
        ; tkvs <- quantifyTyVars emptyVarSet
-                                (splitDepVarsOfTypes (res_ty:ctxt++arg_tys))
+                                (splitDepVarsOfType (mkSpecForAllTys user_tvs $
+                                                     mkFunTys ctxt $
+                                                     mkFunTys arg_tys $
+                                                     res_ty))
 
              -- Zonk to Types
 
              -- Zonk to Types
-       ; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv tkvs
+       ; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv (tkvs ++ user_tvs)
        ; arg_tys <- zonkTcTypeToTypes ze arg_tys
        ; ctxt    <- zonkTcTypeToTypes ze ctxt
        ; res_ty  <- zonkTcTypeToType ze res_ty
        ; arg_tys <- zonkTcTypeToTypes ze arg_tys
        ; ctxt    <- zonkTcTypeToTypes ze ctxt
        ; res_ty  <- zonkTcTypeToType ze res_ty
@@ -1476,6 +1505,10 @@ tcConDecl _new_or_data rep_tycon tmpl_tvs res_tmpl
              --     without yet forcing the guards in rejigConRes
              -- See Note [Checking GADT return types]
 
              --     without yet forcing the guards in rejigConRes
              -- See Note [Checking GADT return types]
 
+             -- See Note [Wrong visibility for GADTs]
+             univ_bndrs = mkNamedBinders Specified univ_tvs
+             ex_bndrs   = mkNamedBinders Specified ex_tvs
+
        ; fam_envs <- tcGetFamInstEnvs
 
        -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here
        ; fam_envs <- tcGetFamInstEnvs
 
        -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here
@@ -1488,7 +1521,7 @@ tcConDecl _new_or_data rep_tycon tmpl_tvs res_tmpl
              ; buildDataCon fam_envs name is_infix
                             rep_nm
                             stricts Nothing field_lbls
              ; buildDataCon fam_envs name is_infix
                             rep_nm
                             stricts Nothing field_lbls
-                            univ_tvs ex_tvs eq_preds
+                            univ_tvs univ_bndrs ex_tvs ex_bndrs eq_preds
                             (substTys arg_subst ctxt)
                             (substTys arg_subst arg_tys)
                             (substTy  arg_subst res_ty')
                             (substTys arg_subst ctxt)
                             (substTys arg_subst arg_tys)
                             (substTy  arg_subst res_ty')
@@ -1503,16 +1536,16 @@ tcConDecl _new_or_data rep_tycon tmpl_tvs res_tmpl
 
 
 tcGadtSigType :: SDoc -> Name -> LHsSigType Name
 
 
 tcGadtSigType :: SDoc -> Name -> LHsSigType Name
-              -> TcM ( [PredType],[HsSrcBang], [FieldLabel], [Type], Type
+              -> TcM ( [TcTyVar], [PredType],[HsSrcBang], [FieldLabel], [Type], Type
                      , HsConDetails (LHsType Name)
                                     (Located [LConDeclField Name]) )
 tcGadtSigType doc name ty@(HsIB { hsib_vars = vars })
   = do { let (hs_details', res_ty', cxt, gtvs) = gadtDeclDetails ty
        ; (hs_details, res_ty) <- updateGadtResult failWithTc doc hs_details' res_ty'
                      , HsConDetails (LHsType Name)
                                     (Located [LConDeclField Name]) )
 tcGadtSigType doc name ty@(HsIB { hsib_vars = vars })
   = do { let (hs_details', res_ty', cxt, gtvs) = gadtDeclDetails ty
        ; (hs_details, res_ty) <- updateGadtResult failWithTc doc hs_details' res_ty'
-       ; (_, (ctxt, arg_tys, res_ty, field_lbls, stricts))
+       ; (imp_tvs, (exp_tvs, ctxt, arg_tys, res_ty, field_lbls, stricts))
            <- solveEqualities $
               tcImplicitTKBndrs vars $
            <- solveEqualities $
               tcImplicitTKBndrs vars $
-              tcExplicitTKBndrs gtvs $ \ _ ->
+              tcExplicitTKBndrs gtvs $ \ exp_tvs ->
               do { ctxt <- tcHsContext cxt
                  ; btys <- tcConArgs DataType hs_details
                  ; ty' <- tcHsLiftedType res_ty
               do { ctxt <- tcHsContext cxt
                  ; btys <- tcConArgs DataType hs_details
                  ; ty' <- tcHsLiftedType res_ty
@@ -1521,9 +1554,9 @@ tcGadtSigType doc name ty@(HsIB { hsib_vars = vars })
                        bound_vars = allBoundVariabless ctxt `unionVarSet`
                                     allBoundVariabless arg_tys
 
                        bound_vars = allBoundVariabless ctxt `unionVarSet`
                                     allBoundVariabless arg_tys
 
-                 ; return ((ctxt, arg_tys, ty', field_lbls, stricts), bound_vars)
+                 ; return ((exp_tvs, ctxt, arg_tys, ty', field_lbls, stricts), bound_vars)
                  }
                  }
-       ; return (ctxt, stricts, field_lbls, arg_tys, res_ty, hs_details)
+       ; return (imp_tvs ++ exp_tvs, ctxt, stricts, field_lbls, arg_tys, res_ty, hs_details)
        }
 
 tcConIsInfixH98 :: Name
        }
 
 tcConIsInfixH98 :: Name
@@ -1548,8 +1581,6 @@ tcConIsInfixGADT con details
                         ; return (con `elemNameEnv` fix_env) }
                | otherwise -> return False
 
                         ; return (con `elemNameEnv` fix_env) }
                | otherwise -> return False
 
-
-
 tcConArgs :: NewOrData -> HsConDeclDetails Name
           -> TcM [(TcType, HsSrcBang)]
 tcConArgs new_or_data (PrefixCon btys)
 tcConArgs :: NewOrData -> HsConDeclDetails Name
           -> TcM [(TcType, HsSrcBang)]
 tcConArgs new_or_data (PrefixCon btys)
@@ -1576,6 +1607,58 @@ tcConArg new_or_data bty
         ; return (arg_ty, getBangStrictness bty) }
 
 {-
         ; return (arg_ty, getBangStrictness bty) }
 
 {-
+Note [Wrong visibility for GADTs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+GADT tyvars shouldn't all be specified, but it's hard to do much better, as
+described in #11721, which is duplicated here for convenience:
+
+Consider
+
+  data X a where
+    MkX :: b -> Proxy a -> X a
+
+According to the rules around specified vs. generalized variables around
+TypeApplications, the type of MkX should be
+
+  MkX :: forall {k} (b :: *) (a :: k). b -> Proxy a -> X a
+
+A few things to note:
+
+  * The k isn't available for TypeApplications (that's why it's in braces),
+    because it is not user-written.
+
+  * The b is quantified before the a, because b comes before a in the
+    user-written type signature for MkX.
+
+Both of these bullets are currently violated. GHCi reports MkX's type as
+
+  MkX :: forall k (a :: k) b. b -> Proxy a -> X a
+
+It turns out that this is a hard to fix. The problem is that GHC expects data
+constructors to have their universal variables followed by their existential
+variables, always. And yet that's violated in the desired type for MkX.
+Furthermore, given the way that GHC deals with GADT return types ("rejigging",
+in technical parlance), it's inconvenient to get the specified/generalized
+distinction correct.
+
+Given time constraints, I'm afraid fixing this all won't make it for 8.0.
+
+Happily, there is are easy-to-articulate rules governing GHC's current (wrong)
+behavior. In a GADT-syntax data constructor:
+
+  * All kind and type variables are considered specified and available for
+    visible type application.
+
+  * Universal variables always come first, in precisely the order they appear
+    in the tycon. Note that universals that are constrained by a GADT return
+    type are missing from the datacon.
+
+  * Existential variables come next. Their order is determined by a
+    user-written forall; or, if there is none, by taking the left-to-right
+    order in the datacon's type and doing a stable topological sort. (This
+    stable topological sort step is the same as for other user-written type
+    signatures.)
+
 Note [Infix GADT constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We do not currently have syntax to declare an infix constructor in GADT syntax,
 Note [Infix GADT constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We do not currently have syntax to declare an infix constructor in GADT syntax,
@@ -1660,8 +1743,6 @@ rejigConRes tmpl_tvs res_tmpl dc_tvs res_ty
         (arg_subst, substed_ex_tvs)
           = mapAccumL substTyVarBndr kind_subst raw_ex_tvs
 
         (arg_subst, substed_ex_tvs)
           = mapAccumL substTyVarBndr kind_subst raw_ex_tvs
 
-       -- don't use substCoVarBndr because we don't want fresh uniques!
-       -- substed_ex_tvs and raw_eq_cvs may dependent on one another
         substed_eqs = map (substEqSpec arg_subst) raw_eqs
     in
     (univ_tvs, substed_ex_tvs, substed_eqs, res_ty, arg_subst)
         substed_eqs = map (substEqSpec arg_subst) raw_eqs
     in
     (univ_tvs, substed_ex_tvs, substed_eqs, res_ty, arg_subst)
index 494b50d..08e2335 100644 (file)
@@ -1010,13 +1010,13 @@ mkSigmaTy bndrs theta tau = mkForAllTys bndrs (mkPhiTy theta tau)
 
 mkInvSigmaTy :: [TyVar] -> [PredType] -> Type -> Type
 mkInvSigmaTy tyvars
 
 mkInvSigmaTy :: [TyVar] -> [PredType] -> Type -> Type
 mkInvSigmaTy tyvars
-  = mkSigmaTy (map (mkNamedBinder Invisible) tyvars)
+  = mkSigmaTy (mkNamedBinders Invisible tyvars)
 
 -- | Make a sigma ty where all type variables are "specified". That is,
 -- they can be used with visible type application
 mkSpecSigmaTy :: [TyVar] -> [PredType] -> Type -> Type
 mkSpecSigmaTy tyvars
 
 -- | Make a sigma ty where all type variables are "specified". That is,
 -- they can be used with visible type application
 mkSpecSigmaTy :: [TyVar] -> [PredType] -> Type -> Type
 mkSpecSigmaTy tyvars
-  = mkSigmaTy (map (mkNamedBinder Specified) tyvars)
+  = mkSigmaTy (mkNamedBinders Specified tyvars)
 
 mkPhiTy :: [PredType] -> Type -> Type
 mkPhiTy = mkFunTys
 
 mkPhiTy :: [PredType] -> Type -> Type
 mkPhiTy = mkFunTys
index 7473fb9..e8d1d6c 100644 (file)
@@ -300,7 +300,7 @@ ppr_co_ax_branch ppr_rhs
                           , cab_rhs = rhs
                           , cab_loc = loc })
   = foldr1 (flip hangNotEmpty 2)
                           , cab_rhs = rhs
                           , cab_loc = loc })
   = foldr1 (flip hangNotEmpty 2)
-        [ pprUserForAll (map (mkNamedBinder Invisible) (tvs ++ cvs))
+        [ pprUserForAll (mkNamedBinders Invisible (tvs ++ cvs))
         , pprTypeApp fam_tc lhs <+> equals <+> ppr_rhs fam_tc rhs
         , text "-- Defined" <+> pprLoc loc ]
   where
         , pprTypeApp fam_tc lhs <+> equals <+> ppr_rhs fam_tc rhs
         , text "-- Defined" <+> pprLoc loc ]
   where
index f2efb5f..5b54e6b 100644 (file)
@@ -118,13 +118,15 @@ module TyCoRep (
         tidyTyVarOcc,
         tidyTopType,
         tidyKind,
         tidyTyVarOcc,
         tidyTopType,
         tidyKind,
-        tidyCo, tidyCos
+        tidyCo, tidyCos,
+        tidyTyBinder, tidyTyBinders
     ) where
 
 #include "HsVersions.h"
 
 import {-# SOURCE #-} DataCon( dataConTyCon, dataConFullSig
     ) where
 
 #include "HsVersions.h"
 
 import {-# SOURCE #-} DataCon( dataConTyCon, dataConFullSig
-                              , DataCon, eqSpecTyVar )
+                              , dataConUnivTyBinders, dataConExTyBinders
+                              , DataCon, filterEqSpec )
 import {-# SOURCE #-} Type( isPredTy, isCoercionTy, mkAppTy
                           , tyCoVarsOfTypesWellScoped, varSetElemsWellScoped
                           , partitionInvisibles, coreView, typeKind
 import {-# SOURCE #-} Type( isPredTy, isCoercionTy, mkAppTy
                           , tyCoVarsOfTypesWellScoped, varSetElemsWellScoped
                           , partitionInvisibles, coreView, typeKind
@@ -154,7 +156,6 @@ import StaticFlags ( opt_PprStyle_Debug )
 import FastString
 import Pair
 import UniqSupply
 import FastString
 import Pair
 import UniqSupply
-import ListSetOps
 import Util
 import UniqFM
 
 import Util
 import UniqFM
 
@@ -2669,9 +2670,10 @@ pprDataCons = sepWithVBars . fmap pprDataConWithArgs . tyConDataCons
 pprDataConWithArgs :: DataCon -> SDoc
 pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc]
   where
 pprDataConWithArgs :: DataCon -> SDoc
 pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc]
   where
-    (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc
-    forAllDoc = pprUserForAll $ map (\tv -> Named tv Specified) $
-                ((univ_tvs `minusList` map eqSpecTyVar eq_spec) ++ ex_tvs)
+    (_univ_tvs, _ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc
+    univ_bndrs = dataConUnivTyBinders dc
+    ex_bndrs   = dataConExTyBinders dc
+    forAllDoc = pprUserForAll $ (filterEqSpec eq_spec univ_bndrs ++ ex_bndrs)
     thetaDoc  = pprThetaArrowTy theta
     argsDoc   = hsep (fmap pprParendType arg_tys)
 
     thetaDoc  = pprThetaArrowTy theta
     argsDoc   = hsep (fmap pprParendType arg_tys)
 
@@ -2937,6 +2939,17 @@ tidyTyCoVarBndr tidy_env@(occ_env, subst) tyvar
            else mkVarOcc   (occNameString occ ++ "0")
          | otherwise         = occ
 
            else mkVarOcc   (occNameString occ ++ "0")
          | otherwise         = occ
 
+tidyTyBinder :: TidyEnv -> TyBinder -> (TidyEnv, TyBinder)
+tidyTyBinder tidy_env (Named tv vis)
+  = (tidy_env', Named tv' vis)
+  where
+    (tidy_env', tv') = tidyTyCoVarBndr tidy_env tv
+tidyTyBinder tidy_env (Anon ty)
+  = (tidy_env, Anon $ tidyType tidy_env ty)
+
+tidyTyBinders :: TidyEnv -> [TyBinder] -> (TidyEnv, [TyBinder])
+tidyTyBinders = mapAccumL tidyTyBinder
+
 ---------------
 tidyFreeTyCoVars :: TidyEnv -> TyCoVarSet -> TidyEnv
 -- ^ Add the free 'TyVar's to the env in tidy form,
 ---------------
 tidyFreeTyCoVars :: TidyEnv -> TyCoVarSet -> TidyEnv
 -- ^ Add the free 'TyVar's to the env in tidy form,
index 180624d..fa62765 100644 (file)
@@ -84,7 +84,8 @@ module Type (
 
         -- ** Binders
         sameVis,
 
         -- ** Binders
         sameVis,
-        mkNamedBinder, mkAnonBinder, isNamedBinder, isAnonBinder,
+        mkNamedBinder, mkNamedBinders,
+        mkAnonBinder, isNamedBinder, isAnonBinder,
         isIdLikeBinder, binderVisibility, binderVar_maybe,
         binderVar, binderRelevantType_maybe, caseBinder,
         partitionBinders, partitionBindersIntoBinders,
         isIdLikeBinder, binderVisibility, binderVar_maybe,
         binderVar, binderRelevantType_maybe, caseBinder,
         partitionBinders, partitionBindersIntoBinders,
@@ -188,7 +189,8 @@ module Type (
         tidyOpenTyCoVar, tidyOpenTyCoVars,
         tidyTyVarOcc,
         tidyTopType,
         tidyOpenTyCoVar, tidyOpenTyCoVars,
         tidyTyVarOcc,
         tidyTopType,
-        tidyKind
+        tidyKind,
+        tidyTyBinder, tidyTyBinders
     ) where
 
 #include "HsVersions.h"
     ) where
 
 #include "HsVersions.h"
@@ -1506,6 +1508,10 @@ applyTysX tvs body_ty arg_tys
 mkNamedBinder :: VisibilityFlag -> Var -> TyBinder
 mkNamedBinder vis var = Named var vis
 
 mkNamedBinder :: VisibilityFlag -> Var -> TyBinder
 mkNamedBinder vis var = Named var vis
 
+-- | Make many named binders
+mkNamedBinders :: VisibilityFlag -> [TyVar] -> [TyBinder]
+mkNamedBinders vis = map (mkNamedBinder vis)
+
 -- | Make an anonymous binder
 mkAnonBinder :: Type -> TyBinder
 mkAnonBinder = Anon
 -- | Make an anonymous binder
 mkAnonBinder :: Type -> TyBinder
 mkAnonBinder = Anon
index 4f31128..54f5ace 100644 (file)
@@ -85,8 +85,8 @@ buildPDataDataCon orig_name vect_tc repr_tc repr
                             (map (const no_bang) comp_tys)
                             (Just $ map (const HsLazy) comp_tys)
                             []                     -- no field labels
                             (map (const no_bang) comp_tys)
                             (Just $ map (const HsLazy) comp_tys)
                             []                     -- no field labels
-                            tvs
-                            []                     -- no existentials
+                            tvs (mkNamedBinders Specified tvs)
+                            [] []                  -- no existentials
                             []                     -- no eq spec
                             []                     -- no context
                             comp_tys
                             []                     -- no eq spec
                             []                     -- no context
                             comp_tys
@@ -129,8 +129,8 @@ buildPDatasDataCon orig_name vect_tc repr_tc repr
                             (map (const no_bang) comp_tys)
                             (Just $ map (const HsLazy) comp_tys)
                             []                     -- no field labels
                             (map (const no_bang) comp_tys)
                             (Just $ map (const HsLazy) comp_tys)
                             []                     -- no field labels
-                            tvs
-                            []                     -- no existentials
+                            tvs (mkNamedBinders Specified tvs)
+                            [] []                  -- no existentials
                             []                     -- no eq spec
                             []                     -- no context
                             comp_tys
                             []                     -- no eq spec
                             []                     -- no context
                             comp_tys
index 4847aa8..4bf6515 100644 (file)
@@ -191,8 +191,8 @@ vectDataCon dc
                     (dataConSrcBangs dc)           -- strictness as original constructor
                     (Just $ dataConImplBangs dc)
                     []                             -- no labelled fields for now
                     (dataConSrcBangs dc)           -- strictness as original constructor
                     (Just $ dataConImplBangs dc)
                     []                             -- no labelled fields for now
-                    univ_tvs                       -- universally quantified vars
-                    []                             -- no existential tvs for now
+                    univ_tvs univ_bndrs            -- universally quantified vars
+                    [] []                          -- no existential tvs for now
                     []                             -- no equalities for now
                     []                             -- no context for now
                     arg_tys                        -- argument types
                     []                             -- no equalities for now
                     []                             -- no context for now
                     arg_tys                        -- argument types
@@ -204,3 +204,4 @@ vectDataCon dc
     rep_arg_tys = dataConRepArgTys dc
     tycon       = dataConTyCon dc
     (univ_tvs, ex_tvs, eq_spec, theta, _arg_tys, _res_ty) = dataConFullSig dc
     rep_arg_tys = dataConRepArgTys dc
     tycon       = dataConTyCon dc
     (univ_tvs, ex_tvs, eq_spec, theta, _arg_tys, _res_ty) = dataConFullSig dc
+    univ_bndrs  = dataConUnivTyBinders dc
index 25fbb23..f5f266a 100644 (file)
@@ -8709,6 +8709,19 @@ Here are the details:
   signature, ``myLength``'s inferred type will be
   ``forall {f} {a}. Foldable f => f a -> Int``.
 
   signature, ``myLength``'s inferred type will be
   ``forall {f} {a}. Foldable f => f a -> Int``.
 
+- Data constructors declared with GADT syntax follow different rules
+  for the time being; it is expected that these will be brought in line
+  with other declarations in the future. The rules for GADT
+  data constructors are as follows:
+     * All kind and type variables are considered specified and available for
+       visible type application.
+     * Universal variables always come first, in precisely the order they
+       appear in the type delcaration. Universal variables that are
+       constrained by a GADT return type are not included in the data constructor.
+     * Existential variables come next. Their order is determined by a user-
+       written `forall`; or, if there is none, by taking the left-to-right order
+       in the data constructor's type and doing a stable topological sort.
+  
 .. _implicit-parameters:
 
 Implicit parameters
 .. _implicit-parameters:
 
 Implicit parameters
index dca7dbd..91d51d3 100644 (file)
@@ -24,26 +24,26 @@ pattern Puep :: () => Show a => a -> t -> (ExProv, t)
 with -fprint-explicit-foralls
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 pattern P :: Bool      -- Defined at <interactive>:16:1
 with -fprint-explicit-foralls
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 pattern P :: Bool      -- Defined at <interactive>:16:1
-pattern Pe :: () => forall a. a -> Ex
+pattern Pe :: () => forall {a}. a -> Ex
        -- Defined at <interactive>:17:1
        -- Defined at <interactive>:17:1
-pattern Pu :: forall t. t -> t         -- Defined at <interactive>:18:1
-pattern Pue :: forall t. () => forall a. t -> a -> (t, Ex)
+pattern Pu :: forall {t}. t -> t       -- Defined at <interactive>:18:1
+pattern Pue :: forall {t}. () => forall {a}. t -> a -> (t, Ex)
        -- Defined at <interactive>:19:1
        -- Defined at <interactive>:19:1
-pattern Pur :: forall a. (Num a, Eq a) => a -> [a]
+pattern Pur :: forall {a}. (Num a, Eq a) => a -> [a]
        -- Defined at <interactive>:20:1
        -- Defined at <interactive>:20:1
-pattern Purp :: forall a t. (Num a, Eq a) => Show t => a
-                                                       -> t -> ([a], UnivProv t)
+pattern Purp :: forall {a} {t}. (Num a, Eq a) => Show t => a
+                                                           -> t -> ([a], UnivProv t)
        -- Defined at <interactive>:21:1
        -- Defined at <interactive>:21:1
-pattern Pure :: forall a. (Num a, Eq a) => forall a1. a
-                                                      -> a1 -> ([a], Ex)
+pattern Pure :: forall {a}. (Num a, Eq a) => forall {a1}. a
+                                                          -> a1 -> ([a], Ex)
        -- Defined at <interactive>:22:1
        -- Defined at <interactive>:22:1
-pattern Purep :: forall a. (Num a, Eq a) => forall a1. Show a1 => a
-                                                                  -> a1 -> ([a], ExProv)
+pattern Purep :: forall {a}. (Num a, Eq a) => forall {a1}. Show
+                                                             a1 => a -> a1 -> ([a], ExProv)
        -- Defined at <interactive>:23:1
        -- Defined at <interactive>:23:1
-pattern Pep :: () => forall a. Show a => a -> ExProv
+pattern Pep :: () => forall {a}. Show a => a -> ExProv
        -- Defined at <interactive>:24:1
        -- Defined at <interactive>:24:1
-pattern Pup :: forall t. () => Show t => t -> UnivProv t
+pattern Pup :: forall {t}. () => Show t => t -> UnivProv t
        -- Defined at <interactive>:25:1
        -- Defined at <interactive>:25:1
-pattern Puep :: forall t. () => forall a. Show a => a
-                                                    -> t -> (ExProv, t)
+pattern Puep :: forall {t}. () => forall {a}. Show a => a
+                                                        -> t -> (ExProv, t)
        -- Defined at <interactive>:26:1
        -- Defined at <interactive>:26:1
diff --git a/testsuite/tests/ghci/scripts/TypeAppData.script b/testsuite/tests/ghci/scripts/TypeAppData.script
new file mode 100644 (file)
index 0000000..9d571e1
--- /dev/null
@@ -0,0 +1,31 @@
+-- tests detection of specified variables in datatypes and patterns
+:set -fprint-explicit-foralls
+:set -XTypeInType -XExistentialQuantification -XPatternSynonyms
+data P1 a = P1
+data P2 (a :: k) = P2
+data P3 k (a :: k) = P3
+data P4 a = P4 (P1 a)
+:type P1
+:type P2
+:type P3
+:type P4
+data P5 = forall a. P5 (P1 a)
+data P6 = forall k (a :: k). P6 (P1 a)
+:type P5
+:type P6
+pattern P7 :: P1 a ; pattern P7 = P1
+pattern P8 :: forall a. P1 a ; pattern P8 = P1
+pattern P9 :: forall k (a :: k). P1 a ; pattern P9 = P1
+pattern P10 :: forall (a :: k). P1 a ; pattern P10 = P1
+pattern P11 :: () => P1 a -> P5 ; pattern P11 a = P5 a
+pattern P12 :: () => forall a. P1 a -> P5 ; pattern P12 a = P5 a
+pattern P13 :: () => forall k (a :: k). P1 a -> P5 ; pattern P13 a = P5 a
+pattern P14 :: () => forall (a :: k). P1 a -> P5 ; pattern P14 a = P5 a
+:type P7
+:type P8
+:type P9
+:type P10
+:type P11
+:type P12
+:type P13
+:type P14
diff --git a/testsuite/tests/ghci/scripts/TypeAppData.stdout b/testsuite/tests/ghci/scripts/TypeAppData.stdout
new file mode 100644 (file)
index 0000000..5a4880a
--- /dev/null
@@ -0,0 +1,14 @@
+P1 :: forall {k} (a :: k). P1 a
+P2 :: forall k (a :: k). P2 a
+P3 :: forall k (a :: k). P3 k a
+P4 :: forall {k} (a :: k). P1 a -> P4 a
+P5 :: forall {k} (a :: k). P1 a -> P5
+P6 :: forall k (a :: k). P1 a -> P6
+P7 :: forall {k} (a :: k). P1 a
+P8 :: forall {k} (a :: k). P1 a
+P9 :: forall k (a :: k). P1 a
+P10 :: forall k (a :: k). P1 a
+P11 :: forall {k} (a :: k). P1 a -> P5
+P12 :: forall {k} (a :: k). P1 a -> P5
+P13 :: forall k (a :: k). P1 a -> P5
+P14 :: forall k (a :: k). P1 a -> P5
index 62326a2..f6de93b 100755 (executable)
@@ -246,3 +246,4 @@ test('T11266', check_stdout(lambda *args: 1), ghci_script, ['T11266.script'])
 test('T11389', req_interp, run_command, ['$MAKE -s --no-print-directory T11389'])
 test('T11524a', normal, ghci_script, ['T11524a.script'])
 test('T11456', normal, ghci_script, ['T11456.script'])
 test('T11389', req_interp, run_command, ['$MAKE -s --no-print-directory T11389'])
 test('T11524a', normal, ghci_script, ['T11524a.script'])
 test('T11456', normal, ghci_script, ['T11456.script'])
+test('TypeAppData', normal, ghci_script, ['TypeAppData.script'])
index d87054e..e7e6a3a 100644 (file)
@@ -73,7 +73,8 @@ RnFail055.hs-boot:25:1: error:
     Main module: type role T7 phantom
                  data T7 a where
                    T7 :: a1 -> T7 a
     Main module: type role T7 phantom
                  data T7 a where
                    T7 :: a1 -> T7 a
-    Boot file:   data T7 a = T7 a
+    Boot file:   data T7 a where
+                   T7 :: a -> T7 a
     The roles do not match.
     Roles on abstract types default to ‘representational’ in boot files.
     The constructors do not match: The types for ‘T7’ differ
     The roles do not match.
     Roles on abstract types default to ‘representational’ in boot files.
     The constructors do not match: The types for ‘T7’ differ
index fe0658b..b44ff8f 100644 (file)
@@ -4,8 +4,8 @@ TYPE SIGNATURES
   Roles1.K3 :: forall k (a :: k). T3 a
   Roles1.K4 :: forall (a :: * -> *) b. a b -> T4 a b
   Roles1.K5 :: forall a. a -> T5 a
   Roles1.K3 :: forall k (a :: k). T3 a
   Roles1.K4 :: forall (a :: * -> *) b. a b -> T4 a b
   Roles1.K5 :: forall a. a -> T5 a
-  Roles1.K6 :: forall k (a :: k). T6 a
-  Roles1.K7 :: forall k (a :: k) b. b -> T7 a b
+  Roles1.K6 :: forall {k} (a :: k). T6 a
+  Roles1.K7 :: forall {k} (a :: k) b. b -> T7 a b
 TYPE CONSTRUCTORS
   type role T1 nominal
   data T1 a = K1 a
 TYPE CONSTRUCTORS
   type role T1 nominal
   data T1 a = K1 a