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

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
......@@ -20,18 +20,20 @@ module GHC.Hs.Decls (
-- * Toplevel declarations
HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep,
HsDerivingClause(..), LHsDerivingClause, NewOrData(..), newOrDataToFlavour,
StandaloneKindSig(..), LStandaloneKindSig, standaloneKindSigName,
-- ** Class or type declarations
TyClDecl(..), LTyClDecl, DataDeclRn(..),
TyClGroup(..),
tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,
tyClGroupKindSigs,
isClassDecl, isDataDecl, isSynDecl, tcdName,
isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,
isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,
tyFamInstDeclName, tyFamInstDeclLName,
countTyClDecls, pprTyClDeclFlavour,
tyClDeclLName, tyClDeclTyVars,
hsDeclHasCusk, famDeclHasCusk,
hsDeclHasCusk, famResultKindSignature,
FamilyDecl(..), LFamilyDecl,
-- ** Instance declarations
......@@ -136,6 +138,7 @@ data HsDecl p
| DerivD (XDerivD p) (DerivDecl p) -- ^ Deriving declaration
| ValD (XValD p) (HsBind p) -- ^ Value declaration
| SigD (XSigD p) (Sig p) -- ^ Signature declaration
| KindSigD (XKindSigD p) (StandaloneKindSig p) -- ^ Standalone kind signature
| DefD (XDefD p) (DefaultDecl p) -- ^ 'default' declaration
| ForD (XForD p) (ForeignDecl p) -- ^ Foreign declaration
| WarningD (XWarningD p) (WarnDecls p) -- ^ Warning declaration
......@@ -152,6 +155,7 @@ type instance XInstD (GhcPass _) = NoExtField
type instance XDerivD (GhcPass _) = NoExtField
type instance XValD (GhcPass _) = NoExtField
type instance XSigD (GhcPass _) = NoExtField
type instance XKindSigD (GhcPass _) = NoExtField
type instance XDefD (GhcPass _) = NoExtField
type instance XForD (GhcPass _) = NoExtField
type instance XWarningD (GhcPass _) = NoExtField
......@@ -278,6 +282,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsDecl p) where
ppr (DerivD _ deriv) = ppr deriv
ppr (ForD _ fd) = ppr fd
ppr (SigD _ sd) = ppr sd
ppr (KindSigD _ ksd) = ppr ksd
ppr (RuleD _ rd) = ppr rd
ppr (WarningD _ wd) = ppr wd
ppr (AnnD _ ad) = ppr ad
......@@ -304,6 +309,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsGroup p) where
then Nothing
else Just (ppr val_decls),
ppr_ds (tyClGroupRoleDecls tycl_decls),
ppr_ds (tyClGroupKindSigs tycl_decls),
ppr_ds (tyClGroupTyClDecls tycl_decls),
ppr_ds (tyClGroupInstDecls tycl_decls),
ppr_ds deriv_decls,
......@@ -658,7 +664,7 @@ tyClDeclLName :: TyClDecl pass -> Located (IdP pass)
tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln
tyClDeclLName decl = tcdLName decl
tcdName :: TyClDecl pass -> (IdP pass)
tcdName :: TyClDecl pass -> IdP pass
tcdName = unLoc . tyClDeclLName
tyClDeclTyVars :: TyClDecl pass -> LHsQTyVars pass
......@@ -682,25 +688,21 @@ countTyClDecls decls
-- | Does this declaration have a complete, user-supplied kind signature?
-- See Note [CUSKs: complete user-supplied kind signatures]
hsDeclHasCusk
:: Bool -- True <=> the -XCUSKs extension is enabled
-> TyClDecl GhcRn
-> Bool
hsDeclHasCusk _cusks_enabled@False _ = False
hsDeclHasCusk cusks_enabled (FamDecl { tcdFam = fam_decl })
= famDeclHasCusk cusks_enabled False fam_decl
-- False: this is not: an associated type of a class with no cusk
hsDeclHasCusk _cusks_enabled@True (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
-- NB: Keep this synchronized with 'getInitialKind'
= hsTvbAllKinded tyvars && rhs_annotated rhs
where
rhs_annotated (L _ ty) = case ty of
HsParTy _ lty -> rhs_annotated lty
HsKindSig {} -> True
_ -> 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
hsDeclHasCusk :: TyClDecl GhcRn -> Bool
hsDeclHasCusk (FamDecl { tcdFam =
FamilyDecl { fdInfo = fam_info
, fdTyVars = tyvars
, fdResultSig = L _ resultSig } }) =
case fam_info of
ClosedTypeFamily {} -> hsTvbAllKinded tyvars
&& isJust (famResultKindSignature resultSig)
_ -> True -- Un-associated open type/data families have CUSKs
hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
= hsTvbAllKinded tyvars && isJust (hsTyKindSig rhs)
hsDeclHasCusk (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk
hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
hsDeclHasCusk (FamDecl { tcdFam = XFamilyDecl nec }) = noExtCon nec
hsDeclHasCusk (XTyClDecl nec) = noExtCon nec
-- Pretty-printing TyClDecl
-- ~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -742,10 +744,13 @@ instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (TyClGroup p) where
ppr (TyClGroup { group_tyclds = tyclds
, group_roles = roles
, group_kisigs = kisigs
, group_instds = instds
}
)
= ppr tyclds $$
= hang (text "TyClGroup") 2 $
ppr kisigs $$
ppr tyclds $$
ppr roles $$
ppr instds
ppr (XTyClGroup x) = ppr x
......@@ -777,8 +782,8 @@ pprTyClDeclFlavour (ClassDecl {}) = text "class"
pprTyClDeclFlavour (SynDecl {}) = text "type"
pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})
= pprFlavour info <+> text "family"
pprTyClDeclFlavour (FamDecl { tcdFam = XFamilyDecl x})
= ppr x
pprTyClDeclFlavour (FamDecl { tcdFam = XFamilyDecl nec })
= noExtCon nec
pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } })
= ppr nd
pprTyClDeclFlavour (DataDecl { tcdDataDefn = XHsDataDefn x })
......@@ -910,6 +915,7 @@ data TyClGroup pass -- See Note [TyClGroups and dependency analysis]
= TyClGroup { group_ext :: XCTyClGroup pass
, group_tyclds :: [LTyClDecl pass]
, group_roles :: [LRoleAnnotDecl pass]
, group_kisigs :: [LStandaloneKindSig pass]
, group_instds :: [LInstDecl pass] }
| XTyClGroup (XXTyClGroup pass)
......@@ -926,6 +932,8 @@ tyClGroupInstDecls = concatMap group_instds
tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass]
tyClGroupRoleDecls = concatMap group_roles
tyClGroupKindSigs :: [TyClGroup pass] -> [LStandaloneKindSig pass]
tyClGroupKindSigs = concatMap group_kisigs
{- *********************************************************************
......@@ -1024,6 +1032,7 @@ data FamilyResultSig pass = -- see Note [FamilyResultSig]
type instance XNoSig (GhcPass _) = NoExtField
type instance XCKindSig (GhcPass _) = NoExtField
type instance XTyVarSig (GhcPass _) = NoExtField
type instance XXFamilyResultSig (GhcPass _) = NoExtCon
......@@ -1081,32 +1090,15 @@ data FamilyInfo pass
-- said "type family Foo x where .."
| ClosedTypeFamily (Maybe [LTyFamInstEqn pass])
-- | Does this family declaration have a complete, user-supplied kind signature?
-- See Note [CUSKs: complete user-supplied kind signatures]
famDeclHasCusk :: Bool -- ^ True <=> the -XCUSKs extension is enabled
-> Bool -- ^ True <=> this is an associated type family,
-- and the parent class has /no/ CUSK
-> FamilyDecl (GhcPass pass)
-> Bool
famDeclHasCusk _cusks_enabled@False _ _ = False
famDeclHasCusk _cusks_enabled@True assoc_with_no_cusk
(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
famResultKindSignature :: FamilyResultSig (GhcPass p) -> Maybe (LHsKind (GhcPass p))
famResultKindSignature (NoSig _) = Nothing
famResultKindSignature (KindSig _ ki) = Just ki
famResultKindSignature (TyVarSig _ bndr) =
case unLoc bndr of
UserTyVar _ _ -> Nothing
KindedTyVar _ _ ki -> Just ki
XTyVarBndr nec -> noExtCon nec
famResultKindSignature (XFamilyResultSig nec) = noExtCon nec
-- | Maybe return name of the result type variable
resultVariableName :: FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))
......@@ -1137,7 +1129,7 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
NoSig _ -> empty
KindSig _ kind -> dcolon <+> ppr kind
TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr
XFamilyResultSig x -> ppr x
XFamilyResultSig nec -> noExtCon nec
pp_inj = case mb_inj of
Just (L _ (InjectivityAnn lhs rhs)) ->
hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ]
......@@ -1149,7 +1141,7 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
Nothing -> text ".."
Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns )
_ -> (empty, empty)
pprFamilyDecl _ (XFamilyDecl x) = ppr x
pprFamilyDecl _ (XFamilyDecl nec) = noExtCon nec
pprFlavour :: FamilyInfo pass -> SDoc
pprFlavour DataFamily = text "data"
......@@ -1203,6 +1195,7 @@ data HsDataDefn pass -- The payload of a data type defn
| XHsDataDefn (XXHsDataDefn pass)
type instance XCHsDataDefn (GhcPass _) = NoExtField
type instance XXHsDataDefn (GhcPass _) = NoExtCon
-- | Haskell Deriving clause
......@@ -1269,6 +1262,37 @@ instance (p ~ GhcPass pass, OutputableBndrId p)
_ -> (ppDerivStrategy dcs, empty)
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
= NewType -- ^ @newtype Blah ...@
| DataType -- ^ @data Blah ...@
......@@ -1279,6 +1303,7 @@ newOrDataToFlavour :: NewOrData -> TyConFlavour
newOrDataToFlavour NewType = NewtypeFlavour
newOrDataToFlavour DataType = DataTypeFlavour
-- | Located data Constructor Declaration
type LConDecl pass = Located (ConDecl pass)
-- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when
......@@ -1443,6 +1468,11 @@ instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsDataDefn p) where
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
ppr NewType = text "newtype"
ppr DataType = text "data"
......
......@@ -280,6 +280,10 @@ type ForallXFixitySig (c :: * -> Constraint) (x :: *) =
, c (XXFixitySig x)
)
-- StandaloneKindSig type families
type family XStandaloneKindSig x
type family XXStandaloneKindSig x
-- =====================================================================
-- Type families for the HsDecls extension points
......@@ -289,6 +293,7 @@ type family XInstD x
type family XDerivD x
type family XValD x
type family XSigD x
type family XKindSigD x
type family XDefD x
type family XForD x
type family XWarningD x
......@@ -305,6 +310,7 @@ type ForallXHsDecl (c :: * -> Constraint) (x :: *) =
, c (XDerivD x)
, c (XValD x)
, c (XSigD x)
, c (XKindSigD x)
, c (XDefD x)
, c (XForD x)
, c (XWarningD x)
......
......@@ -86,6 +86,11 @@ deriving instance Data (FixitySig GhcPs)
deriving instance Data (FixitySig GhcRn)
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 Data (HsPatSynDir GhcPs)
deriving instance Data (HsPatSynDir GhcRn)
......
......@@ -62,6 +62,7 @@ module GHC.Hs.Types (
mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy,
ignoreParens, hsSigType, hsSigWcType,
hsLTyVarBndrToType, hsLTyVarBndrsToTypes,
hsTyKindSig,
hsConDetailsArgs,
-- Printing
......@@ -79,7 +80,7 @@ import {-# SOURCE #-} GHC.Hs.Expr ( HsSplice, pprSplice )
import GHC.Hs.Extension
import Id ( Id )
import Name( Name )
import Name( Name, NamedThing(getName) )
import RdrName ( RdrName )
import DataCon( HsSrcBang(..), HsImplBang(..),
SrcStrictness(..), SrcUnpackedness(..) )
......@@ -505,6 +506,7 @@ data HsTyVarBndr pass
type instance XUserTyVar (GhcPass _) = NoExtField
type instance XKindedTyVar (GhcPass _) = NoExtField
type instance XXTyVarBndr (GhcPass _) = NoExtCon
-- | Does this 'HsTyVarBndr' come with an explicit kind annotation?
......@@ -517,6 +519,11 @@ isHsKindedTyVar (XTyVarBndr {}) = False
hsTvbAllKinded :: LHsQTyVars pass -> Bool
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
data HsType pass
= HsForAllTy -- See Note [HsType binders]
......@@ -1076,6 +1083,24 @@ hsLTyVarBndrsToTypes :: LHsQTyVars (GhcPass p) -> [LHsType (GhcPass p)]
hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs
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 (L _ (HsParTy _ ty)) = ignoreParens ty
......@@ -1449,7 +1474,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsTyVarBndr p) where
ppr (UserTyVar _ n) = ppr n
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)
=> Outputable (HsImplicitBndrs p thing) where
......
......@@ -180,6 +180,12 @@ cvtDec (TH.SigD nm typ)
; returnJustL $ Hs.SigD noExtField
(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)
-- Fixity signatures are allowed for variables, constructors, and types
-- the renamer automatically looks for types during renaming, even when
......
......@@ -11,7 +11,7 @@ module NameEnv (
NameEnv,
-- ** Manipulating these environments
mkNameEnv,
mkNameEnv, mkNameEnvWith,
emptyNameEnv, isEmptyNameEnv,
unitNameEnv, nameEnvElts,
extendNameEnv_C, extendNameEnv_Acc, extendNameEnv,
......@@ -92,6 +92,7 @@ type NameEnv a = UniqFM a -- Domain is Name
emptyNameEnv :: NameEnv a
isEmptyNameEnv :: NameEnv a -> Bool
mkNameEnv :: [(Name,a)] -> NameEnv a
mkNameEnvWith :: (a -> Name) -> [a] -> NameEnv a
nameEnvElts :: NameEnv a -> [a]
alterNameEnv :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a
extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a
......@@ -121,6 +122,7 @@ extendNameEnvList x l = addListToUFM x l
lookupNameEnv x y = lookupUFM x y
alterNameEnv = alterUFM
mkNameEnv l = listToUFM l
mkNameEnvWith f = mkNameEnv . map (\a -> (f a, a))
elemNameEnv x y = elemUFM x y
plusNameEnv x y = plusUFM x y
plusNameEnv_C f x y = plusUFM_C f x y
......
......@@ -140,6 +140,7 @@ repTopDs group@(HsGroup { hs_valds = valds
; _ <- mapM no_splice splcds
; tycl_ds <- mapM repTyClD (tyClGroupTyClDecls tyclds)
; role_ds <- mapM repRoleD (concatMap group_roles tyclds)
; kisig_ds <- mapM repKiSigD (concatMap group_kisigs tyclds)
; inst_ds <- mapM repInstD instds
; deriv_ds <- mapM repStandaloneDerivD derivds
; fix_ds <- mapM repFixD fixds
......@@ -155,6 +156,7 @@ repTopDs group@(HsGroup { hs_valds = valds
-- more needed
; return (de_loc $ sort_by_loc $
val_ds ++ catMaybes tycl_ds ++ role_ds
++ kisig_ds
++ (concat fix_ds)
++ inst_ds ++ rule_ds ++ for_ds
++ ann_ds ++ deriv_ds) }) ;
......@@ -347,6 +349,13 @@ repRoleD (dL->L loc (RoleAnnotDecl _ tycon roles))
; return (loc, dec) }
repRoleD _ = panic "repRoleD"
-------------------------
repKiSigD :: LStandaloneKindSig GhcRn -> DsM (SrcSpan, Core TH.DecQ)
repKiSigD (dL->L loc kisig) =
case kisig of
StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v
XStandaloneKindSig nec -> noExtCon nec
-------------------------
repDataDefn :: Core TH.Name
-> Either (Core [TH.TyVarBndrQ])
......@@ -870,7 +879,7 @@ rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name
-- and Note [Don't quantify implicit type variables in quotes]
rep_ty_sig mk_sig loc sig_ty nm
| HsIB { hsib_body = hs_ty } <- sig_ty
, (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty
, (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis hs_ty
= do { nm1 <- lookupLOcc nm
; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
; repTyVarBndrWithKind tv name }
......
......@@ -1254,8 +1254,13 @@ instance ( a ~ GhcPass p
XCmd _ -> []
instance ToHie (TyClGroup GhcRn) where
toHie (TyClGroup _ classes roles instances) = concatM
toHie TyClGroup{ group_tyclds = classes
, group_roles = roles
, group_kisigs = sigs
, group_instds = instances } =
concatM
[ toHie classes
, toHie sigs
, toHie roles
, toHie instances
]
......@@ -1466,6 +1471,17 @@ instance ( HasLoc thing
where span = loc a
toHie (TS _ (XHsWildCardBndrs _)) = pure []
instance ToHie (LStandaloneKindSig GhcRn) where
toHie (L sp sig) = concatM [makeNode sig sp, toHie sig]
instance ToHie (StandaloneKindSig GhcRn) where
toHie sig = concatM $ case sig of
StandaloneKindSig _ name typ ->
[ toHie $ C TyDecl name
, toHie $ TS (ResolvedScopes []) typ
]
XStandaloneKindSig _ -> []
instance ToHie (SigContext (LSig GhcRn)) where
toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of
TypeSig _ names typ ->
......
......@@ -69,6 +69,7 @@ import TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag )
import Util( dropList, filterByList, notNull, unzipWith )
import DataCon (SrcStrictness(..), SrcUnpackedness(..))
import Lexeme (isLexSym)
import TysWiredIn ( constraintKindTyConName )
import Control.Monad
import System.IO.Unsafe
......@@ -730,6 +731,14 @@ pprClassRoles ss clas binders roles =
binders
roles
pprClassStandaloneKindSig :: ShowSub -> IfaceTopBndr -> IfaceKind -> SDoc
pprClassStandaloneKindSig ss clas =
pprStandaloneKindSig (pprPrefixIfDeclBndr (ss_how_much ss) (occName clas))
constraintIfaceKind :: IfaceKind
constraintIfaceKind =
IfaceTyConApp (IfaceTyCon constraintKindTyConName (IfaceTyConInfo NotPromoted IfaceNormalTyCon)) IA_Nil
pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc
-- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi
-- See Note [Pretty-printing TyThings] in PprTyThing
......@@ -741,10 +750,12 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
ifBinders = binders })
| gadt = vcat [ pp_roles
, pp_ki_sig
, pp_nd <+> pp_lhs <+> pp_kind <+> pp_where
, nest 2 (vcat pp_cons)
, nest 2 $ ppShowIface ss pp_extra ]
| otherwise = vcat [ pp_roles
, pp_ki_sig
, hang (pp_nd <+> pp_lhs) 2 (add_bars pp_cons)
, nest 2 $ ppShowIface ss pp_extra ]
where
......@@ -759,26 +770,45 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,