Commit 0b5eede9 authored by Vladislav Zavialov's avatar Vladislav Zavialov
Browse files

Standalone kind signatures (#16794)

Implements GHC Proposal #54: .../ghc-proposals/blob/master/proposals/0054-kind-signatures.rst

With this patch, a type constructor can now be given an explicit
standalone kind signature:

  {-# LANGUAGE StandaloneKindSignatures #-}
  type Functor :: (Type -> Type) -> Constraint
  class Functor f where
    fmap :: (a -> b) -> f a -> f b

This is a replacement for CUSKs (complete user-specified
kind signatures), which are now scheduled for deprecation.

User-facing changes
-------------------

* A new extension flag has been added, -XStandaloneKindSignatures, which
  implies -XNoCUSKs.

* There is a new syntactic construct, a standalone kind signature:

    type <name> :: <kind>

  Declarations of data types, classes, data families, type families, and
  type synonyms may be accompanied by a standalone kind signature.

* A standalone kind signature enables polymorphic recursion in types,
  just like a function type signature enables polymorphic recursion in
  terms. This obviates the need for CUSKs.

* TemplateHaskell AST has been extended with 'KiSigD' to represent
  standalone kind signatures.

* GHCi :info command now prints the kind signature of type constructors:

    ghci> :info Functor
    type Functor :: (Type -> Type) -> Constraint
    ...

Limitations
-----------

* 'forall'-bound type variables of a standalone kind signature do not
  scope over the declaration body, even if the -XScopedTypeVariables is
  enabled. See #16635 and #16734.

* Wildcards are not allowed in standalone kind signatures, as partial
  signatures do not allow for polymorphic recursion.

* Associated types may not be given an explicit standalone kind
  signature. Instead, they are assumed to have a CUSK if the parent class
  has a standalone kind signature and regardless of the -XCUSKs flag.

* Standalone kind signatures do not support multiple names at the moment:

    type T1, T2 :: Type -> Type   -- rejected
    type T1 = Maybe
    type T2 = Either String

  See #16754.

* Creative use of equality constraints in standalone kind signatures may
  lead to GHC panics:

    type C :: forall (a :: Type) -> a ~ Int => Constraint
    class C a where
      f :: C a => a -> Int

  See #16758.

Implementation notes
--------------------

* The heart of this patch is the 'kcDeclHeader' function, which is used to
  kind-check a declaration header against its standalone kind signature.
  It does so in two rounds:

    1. check user-written binders
    2. instantiate invisible binders a la 'checkExpectedKind'

* 'kcTyClGroup' now partitions declarations into declarations with a
  standalone kind signature or a CUSK (kinded_decls) and declarations
  without either (kindless_decls):

    * 'kinded_decls' are kind-checked with 'checkInitialKinds'
    * 'kindless_decls' are kind-checked with 'getInitialKinds'

* DerivInfo has been extended with a new field:

    di_scoped_tvs :: ![(Name,TyVar)]

  These variables must be added to the context in case the deriving clause
  references tcTyConScopedTyVars. See #16731.
parent 795986aa
Pipeline #10628 failed with stages
in 427 minutes and 21 seconds
...@@ -20,18 +20,20 @@ module GHC.Hs.Decls ( ...@@ -20,18 +20,20 @@ module GHC.Hs.Decls (
-- * Toplevel declarations -- * Toplevel declarations
HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep,
HsDerivingClause(..), LHsDerivingClause, NewOrData(..), newOrDataToFlavour, HsDerivingClause(..), LHsDerivingClause, NewOrData(..), newOrDataToFlavour,
StandaloneKindSig(..), LStandaloneKindSig, standaloneKindSigName,
-- ** Class or type declarations -- ** Class or type declarations
TyClDecl(..), LTyClDecl, DataDeclRn(..), TyClDecl(..), LTyClDecl, DataDeclRn(..),
TyClGroup(..), TyClGroup(..),
tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls, tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,
tyClGroupKindSigs,
isClassDecl, isDataDecl, isSynDecl, tcdName, isClassDecl, isDataDecl, isSynDecl, tcdName,
isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl, isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,
isOpenTypeFamilyInfo, isClosedTypeFamilyInfo, isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,
tyFamInstDeclName, tyFamInstDeclLName, tyFamInstDeclName, tyFamInstDeclLName,
countTyClDecls, pprTyClDeclFlavour, countTyClDecls, pprTyClDeclFlavour,
tyClDeclLName, tyClDeclTyVars, tyClDeclLName, tyClDeclTyVars,
hsDeclHasCusk, famDeclHasCusk, hsDeclHasCusk, famResultKindSignature,
FamilyDecl(..), LFamilyDecl, FamilyDecl(..), LFamilyDecl,
-- ** Instance declarations -- ** Instance declarations
...@@ -136,6 +138,7 @@ data HsDecl p ...@@ -136,6 +138,7 @@ data HsDecl p
| DerivD (XDerivD p) (DerivDecl p) -- ^ Deriving declaration | DerivD (XDerivD p) (DerivDecl p) -- ^ Deriving declaration
| ValD (XValD p) (HsBind p) -- ^ Value declaration | ValD (XValD p) (HsBind p) -- ^ Value declaration
| SigD (XSigD p) (Sig p) -- ^ Signature declaration | SigD (XSigD p) (Sig p) -- ^ Signature declaration
| KindSigD (XKindSigD p) (StandaloneKindSig p) -- ^ Standalone kind signature
| DefD (XDefD p) (DefaultDecl p) -- ^ 'default' declaration | DefD (XDefD p) (DefaultDecl p) -- ^ 'default' declaration
| ForD (XForD p) (ForeignDecl p) -- ^ Foreign declaration | ForD (XForD p) (ForeignDecl p) -- ^ Foreign declaration
| WarningD (XWarningD p) (WarnDecls p) -- ^ Warning declaration | WarningD (XWarningD p) (WarnDecls p) -- ^ Warning declaration
...@@ -152,6 +155,7 @@ type instance XInstD (GhcPass _) = NoExtField ...@@ -152,6 +155,7 @@ type instance XInstD (GhcPass _) = NoExtField
type instance XDerivD (GhcPass _) = NoExtField type instance XDerivD (GhcPass _) = NoExtField
type instance XValD (GhcPass _) = NoExtField type instance XValD (GhcPass _) = NoExtField
type instance XSigD (GhcPass _) = NoExtField type instance XSigD (GhcPass _) = NoExtField
type instance XKindSigD (GhcPass _) = NoExtField
type instance XDefD (GhcPass _) = NoExtField type instance XDefD (GhcPass _) = NoExtField
type instance XForD (GhcPass _) = NoExtField type instance XForD (GhcPass _) = NoExtField
type instance XWarningD (GhcPass _) = NoExtField type instance XWarningD (GhcPass _) = NoExtField
...@@ -278,6 +282,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsDecl p) where ...@@ -278,6 +282,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsDecl p) where
ppr (DerivD _ deriv) = ppr deriv ppr (DerivD _ deriv) = ppr deriv
ppr (ForD _ fd) = ppr fd ppr (ForD _ fd) = ppr fd
ppr (SigD _ sd) = ppr sd ppr (SigD _ sd) = ppr sd
ppr (KindSigD _ ksd) = ppr ksd
ppr (RuleD _ rd) = ppr rd ppr (RuleD _ rd) = ppr rd
ppr (WarningD _ wd) = ppr wd ppr (WarningD _ wd) = ppr wd
ppr (AnnD _ ad) = ppr ad ppr (AnnD _ ad) = ppr ad
...@@ -304,6 +309,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsGroup p) where ...@@ -304,6 +309,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsGroup p) where
then Nothing then Nothing
else Just (ppr val_decls), else Just (ppr val_decls),
ppr_ds (tyClGroupRoleDecls tycl_decls), ppr_ds (tyClGroupRoleDecls tycl_decls),
ppr_ds (tyClGroupKindSigs tycl_decls),
ppr_ds (tyClGroupTyClDecls tycl_decls), ppr_ds (tyClGroupTyClDecls tycl_decls),
ppr_ds (tyClGroupInstDecls tycl_decls), ppr_ds (tyClGroupInstDecls tycl_decls),
ppr_ds deriv_decls, ppr_ds deriv_decls,
...@@ -658,7 +664,7 @@ tyClDeclLName :: TyClDecl pass -> Located (IdP pass) ...@@ -658,7 +664,7 @@ tyClDeclLName :: TyClDecl pass -> Located (IdP pass)
tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln
tyClDeclLName decl = tcdLName decl tyClDeclLName decl = tcdLName decl
tcdName :: TyClDecl pass -> (IdP pass) tcdName :: TyClDecl pass -> IdP pass
tcdName = unLoc . tyClDeclLName tcdName = unLoc . tyClDeclLName
tyClDeclTyVars :: TyClDecl pass -> LHsQTyVars pass tyClDeclTyVars :: TyClDecl pass -> LHsQTyVars pass
...@@ -682,25 +688,21 @@ countTyClDecls decls ...@@ -682,25 +688,21 @@ countTyClDecls decls
-- | Does this declaration have a complete, user-supplied kind signature? -- | Does this declaration have a complete, user-supplied kind signature?
-- See Note [CUSKs: complete user-supplied kind signatures] -- See Note [CUSKs: complete user-supplied kind signatures]
hsDeclHasCusk hsDeclHasCusk :: TyClDecl GhcRn -> Bool
:: Bool -- True <=> the -XCUSKs extension is enabled hsDeclHasCusk (FamDecl { tcdFam =
-> TyClDecl GhcRn FamilyDecl { fdInfo = fam_info
-> Bool , fdTyVars = tyvars
hsDeclHasCusk _cusks_enabled@False _ = False , fdResultSig = L _ resultSig } }) =
hsDeclHasCusk cusks_enabled (FamDecl { tcdFam = fam_decl }) case fam_info of
= famDeclHasCusk cusks_enabled False fam_decl ClosedTypeFamily {} -> hsTvbAllKinded tyvars
-- False: this is not: an associated type of a class with no cusk && isJust (famResultKindSignature resultSig)
hsDeclHasCusk _cusks_enabled@True (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs }) _ -> True -- Un-associated open type/data families have CUSKs
-- NB: Keep this synchronized with 'getInitialKind' hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
= hsTvbAllKinded tyvars && rhs_annotated rhs = hsTvbAllKinded tyvars && isJust (hsTyKindSig rhs)
where hsDeclHasCusk (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk
rhs_annotated (L _ ty) = case ty of hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
HsParTy _ lty -> rhs_annotated lty hsDeclHasCusk (FamDecl { tcdFam = XFamilyDecl nec }) = noExtCon nec
HsKindSig {} -> True hsDeclHasCusk (XTyClDecl nec) = noExtCon nec
_ -> False
hsDeclHasCusk _cusks_enabled@True (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk
hsDeclHasCusk _cusks_enabled@True (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
hsDeclHasCusk _ (XTyClDecl nec) = noExtCon nec
-- Pretty-printing TyClDecl -- Pretty-printing TyClDecl
-- ~~~~~~~~~~~~~~~~~~~~~~~~ -- ~~~~~~~~~~~~~~~~~~~~~~~~
...@@ -742,10 +744,13 @@ instance (p ~ GhcPass pass, OutputableBndrId p) ...@@ -742,10 +744,13 @@ instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (TyClGroup p) where => Outputable (TyClGroup p) where
ppr (TyClGroup { group_tyclds = tyclds ppr (TyClGroup { group_tyclds = tyclds
, group_roles = roles , group_roles = roles
, group_kisigs = kisigs
, group_instds = instds , group_instds = instds
} }
) )
= ppr tyclds $$ = hang (text "TyClGroup") 2 $
ppr kisigs $$
ppr tyclds $$
ppr roles $$ ppr roles $$
ppr instds ppr instds
ppr (XTyClGroup x) = ppr x ppr (XTyClGroup x) = ppr x
...@@ -777,8 +782,8 @@ pprTyClDeclFlavour (ClassDecl {}) = text "class" ...@@ -777,8 +782,8 @@ pprTyClDeclFlavour (ClassDecl {}) = text "class"
pprTyClDeclFlavour (SynDecl {}) = text "type" pprTyClDeclFlavour (SynDecl {}) = text "type"
pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})
= pprFlavour info <+> text "family" = pprFlavour info <+> text "family"
pprTyClDeclFlavour (FamDecl { tcdFam = XFamilyDecl x}) pprTyClDeclFlavour (FamDecl { tcdFam = XFamilyDecl nec })
= ppr x = noExtCon nec
pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } }) pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } })
= ppr nd = ppr nd
pprTyClDeclFlavour (DataDecl { tcdDataDefn = XHsDataDefn x }) pprTyClDeclFlavour (DataDecl { tcdDataDefn = XHsDataDefn x })
...@@ -910,6 +915,7 @@ data TyClGroup pass -- See Note [TyClGroups and dependency analysis] ...@@ -910,6 +915,7 @@ data TyClGroup pass -- See Note [TyClGroups and dependency analysis]
= TyClGroup { group_ext :: XCTyClGroup pass = TyClGroup { group_ext :: XCTyClGroup pass
, group_tyclds :: [LTyClDecl pass] , group_tyclds :: [LTyClDecl pass]
, group_roles :: [LRoleAnnotDecl pass] , group_roles :: [LRoleAnnotDecl pass]
, group_kisigs :: [LStandaloneKindSig pass]
, group_instds :: [LInstDecl pass] } , group_instds :: [LInstDecl pass] }
| XTyClGroup (XXTyClGroup pass) | XTyClGroup (XXTyClGroup pass)
...@@ -926,6 +932,8 @@ tyClGroupInstDecls = concatMap group_instds ...@@ -926,6 +932,8 @@ tyClGroupInstDecls = concatMap group_instds
tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass] tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass]
tyClGroupRoleDecls = concatMap group_roles tyClGroupRoleDecls = concatMap group_roles
tyClGroupKindSigs :: [TyClGroup pass] -> [LStandaloneKindSig pass]
tyClGroupKindSigs = concatMap group_kisigs
{- ********************************************************************* {- *********************************************************************
...@@ -1024,6 +1032,7 @@ data FamilyResultSig pass = -- see Note [FamilyResultSig] ...@@ -1024,6 +1032,7 @@ data FamilyResultSig pass = -- see Note [FamilyResultSig]
type instance XNoSig (GhcPass _) = NoExtField type instance XNoSig (GhcPass _) = NoExtField
type instance XCKindSig (GhcPass _) = NoExtField type instance XCKindSig (GhcPass _) = NoExtField
type instance XTyVarSig (GhcPass _) = NoExtField type instance XTyVarSig (GhcPass _) = NoExtField
type instance XXFamilyResultSig (GhcPass _) = NoExtCon type instance XXFamilyResultSig (GhcPass _) = NoExtCon
...@@ -1081,32 +1090,15 @@ data FamilyInfo pass ...@@ -1081,32 +1090,15 @@ data FamilyInfo pass
-- said "type family Foo x where .." -- said "type family Foo x where .."
| ClosedTypeFamily (Maybe [LTyFamInstEqn pass]) | ClosedTypeFamily (Maybe [LTyFamInstEqn pass])
-- | Does this family declaration have a complete, user-supplied kind signature? famResultKindSignature :: FamilyResultSig (GhcPass p) -> Maybe (LHsKind (GhcPass p))
-- See Note [CUSKs: complete user-supplied kind signatures] famResultKindSignature (NoSig _) = Nothing
famDeclHasCusk :: Bool -- ^ True <=> the -XCUSKs extension is enabled famResultKindSignature (KindSig _ ki) = Just ki
-> Bool -- ^ True <=> this is an associated type family, famResultKindSignature (TyVarSig _ bndr) =
-- and the parent class has /no/ CUSK case unLoc bndr of
-> FamilyDecl (GhcPass pass) UserTyVar _ _ -> Nothing
-> Bool KindedTyVar _ _ ki -> Just ki
famDeclHasCusk _cusks_enabled@False _ _ = False XTyVarBndr nec -> noExtCon nec
famDeclHasCusk _cusks_enabled@True assoc_with_no_cusk famResultKindSignature (XFamilyResultSig nec) = noExtCon nec
(FamilyDecl { fdInfo = fam_info
, fdTyVars = tyvars
, fdResultSig = L _ resultSig })
= case fam_info of
ClosedTypeFamily {} -> hsTvbAllKinded tyvars
&& hasReturnKindSignature resultSig
_ -> not assoc_with_no_cusk
-- Un-associated open type/data families have CUSKs
-- Associated type families have CUSKs iff the parent class does
famDeclHasCusk _ _ (XFamilyDecl nec) = noExtCon nec
-- | Does this family declaration have user-supplied return kind signature?
hasReturnKindSignature :: FamilyResultSig a -> Bool
hasReturnKindSignature (NoSig _) = False
hasReturnKindSignature (TyVarSig _ (L _ (UserTyVar{}))) = False
hasReturnKindSignature _ = True
-- | Maybe return name of the result type variable -- | Maybe return name of the result type variable
resultVariableName :: FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a)) resultVariableName :: FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))
...@@ -1137,7 +1129,7 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon ...@@ -1137,7 +1129,7 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
NoSig _ -> empty NoSig _ -> empty
KindSig _ kind -> dcolon <+> ppr kind KindSig _ kind -> dcolon <+> ppr kind
TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr
XFamilyResultSig x -> ppr x XFamilyResultSig nec -> noExtCon nec
pp_inj = case mb_inj of pp_inj = case mb_inj of
Just (L _ (InjectivityAnn lhs rhs)) -> Just (L _ (InjectivityAnn lhs rhs)) ->
hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ] hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ]
...@@ -1149,7 +1141,7 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon ...@@ -1149,7 +1141,7 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
Nothing -> text ".." Nothing -> text ".."
Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns ) Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns )
_ -> (empty, empty) _ -> (empty, empty)
pprFamilyDecl _ (XFamilyDecl x) = ppr x pprFamilyDecl _ (XFamilyDecl nec) = noExtCon nec
pprFlavour :: FamilyInfo pass -> SDoc pprFlavour :: FamilyInfo pass -> SDoc
pprFlavour DataFamily = text "data" pprFlavour DataFamily = text "data"
...@@ -1203,6 +1195,7 @@ data HsDataDefn pass -- The payload of a data type defn ...@@ -1203,6 +1195,7 @@ data HsDataDefn pass -- The payload of a data type defn
| XHsDataDefn (XXHsDataDefn pass) | XHsDataDefn (XXHsDataDefn pass)
type instance XCHsDataDefn (GhcPass _) = NoExtField type instance XCHsDataDefn (GhcPass _) = NoExtField
type instance XXHsDataDefn (GhcPass _) = NoExtCon type instance XXHsDataDefn (GhcPass _) = NoExtCon
-- | Haskell Deriving clause -- | Haskell Deriving clause
...@@ -1269,6 +1262,37 @@ instance (p ~ GhcPass pass, OutputableBndrId p) ...@@ -1269,6 +1262,37 @@ instance (p ~ GhcPass pass, OutputableBndrId p)
_ -> (ppDerivStrategy dcs, empty) _ -> (ppDerivStrategy dcs, empty)
ppr (XHsDerivingClause x) = ppr x ppr (XHsDerivingClause x) = ppr x
-- | Located Standalone Kind Signature
type LStandaloneKindSig pass = Located (StandaloneKindSig pass)
data StandaloneKindSig pass
= StandaloneKindSig (XStandaloneKindSig pass)
(Located (IdP pass)) -- Why a single binder? See #16754
(LHsSigType pass) -- Why not LHsSigWcType? See Note [Wildcards in standalone kind signatures]
| XStandaloneKindSig (XXStandaloneKindSig pass)
type instance XStandaloneKindSig (GhcPass p) = NoExtField
type instance XXStandaloneKindSig (GhcPass p) = NoExtCon
standaloneKindSigName :: StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)
standaloneKindSigName (StandaloneKindSig _ lname _) = unLoc lname
standaloneKindSigName (XStandaloneKindSig nec) = noExtCon nec
{- Note [Wildcards in standalone kind signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Standalone kind signatures enable polymorphic recursion, and it is unclear how
to reconcile this with partial type signatures, so we disallow wildcards in
them.
We reject wildcards in 'rnStandaloneKindSignature' by returning False for
'StandaloneKindSigCtx' in 'wildCardsAllowed'.
The alternative design is to have special treatment for partial standalone kind
signatures, much like we have special treatment for partial type signatures in
terms. However, partial standalone kind signatures are not a proper replacement
for CUSKs, so this would be a separate feature.
-}
data NewOrData data NewOrData
= NewType -- ^ @newtype Blah ...@ = NewType -- ^ @newtype Blah ...@
| DataType -- ^ @data Blah ...@ | DataType -- ^ @data Blah ...@
...@@ -1279,6 +1303,7 @@ newOrDataToFlavour :: NewOrData -> TyConFlavour ...@@ -1279,6 +1303,7 @@ newOrDataToFlavour :: NewOrData -> TyConFlavour
newOrDataToFlavour NewType = NewtypeFlavour newOrDataToFlavour NewType = NewtypeFlavour
newOrDataToFlavour DataType = DataTypeFlavour newOrDataToFlavour DataType = DataTypeFlavour
-- | Located data Constructor Declaration -- | Located data Constructor Declaration
type LConDecl pass = Located (ConDecl pass) type LConDecl pass = Located (ConDecl pass)
-- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when
...@@ -1443,6 +1468,11 @@ instance (p ~ GhcPass pass, OutputableBndrId p) ...@@ -1443,6 +1468,11 @@ instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsDataDefn p) where => Outputable (HsDataDefn p) where
ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (StandaloneKindSig p) where
ppr (StandaloneKindSig _ v ki) = text "type" <+> ppr v <+> text "::" <+> ppr ki
ppr (XStandaloneKindSig nec) = noExtCon nec
instance Outputable NewOrData where instance Outputable NewOrData where
ppr NewType = text "newtype" ppr NewType = text "newtype"
ppr DataType = text "data" ppr DataType = text "data"
......
...@@ -280,6 +280,10 @@ type ForallXFixitySig (c :: * -> Constraint) (x :: *) = ...@@ -280,6 +280,10 @@ type ForallXFixitySig (c :: * -> Constraint) (x :: *) =
, c (XXFixitySig x) , c (XXFixitySig x)
) )
-- StandaloneKindSig type families
type family XStandaloneKindSig x
type family XXStandaloneKindSig x
-- ===================================================================== -- =====================================================================
-- Type families for the HsDecls extension points -- Type families for the HsDecls extension points
...@@ -289,6 +293,7 @@ type family XInstD x ...@@ -289,6 +293,7 @@ type family XInstD x
type family XDerivD x type family XDerivD x
type family XValD x type family XValD x
type family XSigD x type family XSigD x
type family XKindSigD x
type family XDefD x type family XDefD x
type family XForD x type family XForD x
type family XWarningD x type family XWarningD x
...@@ -305,6 +310,7 @@ type ForallXHsDecl (c :: * -> Constraint) (x :: *) = ...@@ -305,6 +310,7 @@ type ForallXHsDecl (c :: * -> Constraint) (x :: *) =
, c (XDerivD x) , c (XDerivD x)
, c (XValD x) , c (XValD x)
, c (XSigD x) , c (XSigD x)
, c (XKindSigD x)
, c (XDefD x) , c (XDefD x)
, c (XForD x) , c (XForD x)
, c (XWarningD x) , c (XWarningD x)
......
...@@ -86,6 +86,11 @@ deriving instance Data (FixitySig GhcPs) ...@@ -86,6 +86,11 @@ deriving instance Data (FixitySig GhcPs)
deriving instance Data (FixitySig GhcRn) deriving instance Data (FixitySig GhcRn)
deriving instance Data (FixitySig GhcTc) deriving instance Data (FixitySig GhcTc)
-- deriving instance (DataId p) => Data (StandaloneKindSig p)
deriving instance Data (StandaloneKindSig GhcPs)
deriving instance Data (StandaloneKindSig GhcRn)
deriving instance Data (StandaloneKindSig GhcTc)
-- deriving instance (DataIdLR p p) => Data (HsPatSynDir p) -- deriving instance (DataIdLR p p) => Data (HsPatSynDir p)
deriving instance Data (HsPatSynDir GhcPs) deriving instance Data (HsPatSynDir GhcPs)
deriving instance Data (HsPatSynDir GhcRn) deriving instance Data (HsPatSynDir GhcRn)
......
...@@ -62,6 +62,7 @@ module GHC.Hs.Types ( ...@@ -62,6 +62,7 @@ module GHC.Hs.Types (
mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy, mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy,
ignoreParens, hsSigType, hsSigWcType, ignoreParens, hsSigType, hsSigWcType,
hsLTyVarBndrToType, hsLTyVarBndrsToTypes, hsLTyVarBndrToType, hsLTyVarBndrsToTypes,
hsTyKindSig,
hsConDetailsArgs, hsConDetailsArgs,
-- Printing -- Printing
...@@ -79,7 +80,7 @@ import {-# SOURCE #-} GHC.Hs.Expr ( HsSplice, pprSplice ) ...@@ -79,7 +80,7 @@ import {-# SOURCE #-} GHC.Hs.Expr ( HsSplice, pprSplice )
import GHC.Hs.Extension import GHC.Hs.Extension
import Id ( Id ) import Id ( Id )
import Name( Name ) import Name( Name, NamedThing(getName) )
import RdrName ( RdrName ) import RdrName ( RdrName )
import DataCon( HsSrcBang(..), HsImplBang(..), import DataCon( HsSrcBang(..), HsImplBang(..),
SrcStrictness(..), SrcUnpackedness(..) ) SrcStrictness(..), SrcUnpackedness(..) )
...@@ -505,6 +506,7 @@ data HsTyVarBndr pass ...@@ -505,6 +506,7 @@ data HsTyVarBndr pass
type instance XUserTyVar (GhcPass _) = NoExtField type instance XUserTyVar (GhcPass _) = NoExtField
type instance XKindedTyVar (GhcPass _) = NoExtField type instance XKindedTyVar (GhcPass _) = NoExtField
type instance XXTyVarBndr (GhcPass _) = NoExtCon type instance XXTyVarBndr (GhcPass _) = NoExtCon
-- | Does this 'HsTyVarBndr' come with an explicit kind annotation? -- | Does this 'HsTyVarBndr' come with an explicit kind annotation?
...@@ -517,6 +519,11 @@ isHsKindedTyVar (XTyVarBndr {}) = False ...@@ -517,6 +519,11 @@ isHsKindedTyVar (XTyVarBndr {}) = False
hsTvbAllKinded :: LHsQTyVars pass -> Bool hsTvbAllKinded :: LHsQTyVars pass -> Bool
hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit
instance NamedThing (HsTyVarBndr GhcRn) where
getName (UserTyVar _ v) = unLoc v
getName (KindedTyVar _ v _) = unLoc v
getName (XTyVarBndr nec) = noExtCon nec
-- | Haskell Type -- | Haskell Type
data HsType pass data HsType pass
= HsForAllTy -- See Note [HsType binders] = HsForAllTy -- See Note [HsType binders]
...@@ -1076,6 +1083,24 @@ hsLTyVarBndrsToTypes :: LHsQTyVars (GhcPass p) -> [LHsType (GhcPass p)] ...@@ -1076,6 +1083,24 @@ hsLTyVarBndrsToTypes :: LHsQTyVars (GhcPass p) -> [LHsType (GhcPass p)]
hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs
hsLTyVarBndrsToTypes (XLHsQTyVars nec) = noExtCon nec hsLTyVarBndrsToTypes (XLHsQTyVars nec) = noExtCon nec
-- | Get the kind signature of a type, ignoring parentheses:
--
-- hsTyKindSig `Maybe ` = Nothing
-- hsTyKindSig `Maybe :: Type -> Type ` = Just `Type -> Type`
-- hsTyKindSig `Maybe :: ((Type -> Type))` = Just `Type -> Type`
--
-- This is used to extract the result kind of type synonyms with a CUSK:
--
-- type S = (F :: res_kind)
-- ^^^^^^^^
--
hsTyKindSig :: LHsType pass -> Maybe (LHsKind pass)
hsTyKindSig lty =
case unLoc lty of
HsParTy _ lty' -> hsTyKindSig lty'
HsKindSig _ _ k -> Just k
_ -> Nothing
--------------------- ---------------------
ignoreParens :: LHsType pass -> LHsType pass ignoreParens :: LHsType pass -> LHsType pass
ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty
...@@ -1449,7 +1474,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) ...@@ -1449,7 +1474,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsTyVarBndr p) where => Outputable (HsTyVarBndr p) where
ppr (UserTyVar _ n) = ppr n ppr (UserTyVar _ n) = ppr n
ppr (KindedTyVar _ n k) = parens $ hsep [ppr n, dcolon, ppr k] ppr (KindedTyVar _ n k) = parens $ hsep [ppr n, dcolon, ppr k]
ppr (XTyVarBndr n) = ppr n ppr (XTyVarBndr nec) = noExtCon nec
instance (p ~ GhcPass pass,Outputable thing) instance (p ~ GhcPass pass,Outputable thing)
=> Outputable (HsImplicitBndrs p thing) where => Outputable (HsImplicitBndrs p thing) where
......
...@@ -180,6 +180,12 @@ cvtDec (TH.SigD nm typ) ...@@ -180,6 +180,12 @@ cvtDec (TH.SigD nm typ)
; returnJustL $ Hs.SigD noExtField ; returnJustL $ Hs.SigD noExtField
(TypeSig noExtField [nm'] (mkLHsSigWcType ty')) } (TypeSig noExtField [nm'] (mkLHsSigWcType ty')) }
cvtDec (TH.KiSigD nm ki)
= do { nm' <- tconNameL nm
; ki' <- cvtType ki
; let sig' = StandaloneKindSig noExtField nm' (mkLHsSigType ki')
; returnJustL $ Hs.KindSigD noExtField sig' }
cvtDec (TH.InfixD fx nm) cvtDec (TH.InfixD fx nm)
-- Fixity signatures are allowed for variables, constructors, and types -- Fixity signatures are allowed for variables, constructors, and types
-- the renamer automatically looks for types during renaming, even when -- the renamer automatically looks for types during renaming, even when
......
...@@ -11,7 +11,7 @@ module NameEnv ( ...@@ -11,7 +11,7 @@ module NameEnv (
NameEnv, NameEnv,
-- ** Manipulating these environments -- ** Manipulating these environments
mkNameEnv, mkNameEnv, mkNameEnvWith,
emptyNameEnv, isEmptyNameEnv, emptyNameEnv, isEmptyNameEnv,
unitNameEnv, nameEnvElts, unitNameEnv, nameEnvElts,
extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, extendNameEnv_C, extendNameEnv_Acc, extendNameEnv,
...@@ -92,6 +92,7 @@ type NameEnv a = UniqFM a -- Domain is Name ...@@ -92,6 +92,7 @@ type NameEnv a = UniqFM a -- Domain is Name
emptyNameEnv :: NameEnv a emptyNameEnv :: NameEnv a
isEmptyNameEnv :: NameEnv a -> Bool isEmptyNameEnv :: NameEnv a -> Bool
mkNameEnv :: [(Name,a)] -> NameEnv a mkNameEnv :: [(Name,a)] -> NameEnv a
mkNameEnvWith :: (a -> Name) -> [a] -> NameEnv a
nameEnvElts :: NameEnv a -> [a] nameEnvElts :: NameEnv a -> [a]
alterNameEnv :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a alterNameEnv :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a
extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a
...@@ -121,6 +122,7 @@ extendNameEnvList x l = addListToUFM x l ...@@ -121,6 +122,7 @@ extendNameEnvList x l = addListToUFM x l
lookupNameEnv x y = lookupUFM x y lookupNameEnv x y = lookupUFM x y
alterNameEnv = alterUFM alterNameEnv = alterUFM
mkNameEnv l = listToUFM l mkNameEnv l = listToUFM l
mkNameEnvWith f = mkNameEnv . map (\a -> (f a, a))
elemNameEnv x y = elemUFM x y elemNameEnv x y = elemUFM x y
plusNameEnv x y = plusUFM x y plusNameEnv x y = plusUFM x y
plusNameEnv_C f x y = plusUFM_C f x y plusNameEnv_C f x y = plusUFM_C f x y
......
...@@ -140,6 +140,7 @@ repTopDs group@(HsGroup { hs_valds = valds ...@@ -140,6 +140,7 @@ repTopDs group@(HsGroup { hs_valds = valds
; _ <- mapM no_splice splcds ; _ <- mapM no_splice splcds
; tycl_ds <- mapM repTyClD (tyClGroupTyClDecls tyclds) ; tycl_ds <- mapM repTyClD (tyClGroupTyClDecls tyclds)