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
Pipeline #10628 failed with stages
in 427 minutes and 21 seconds
This diff is collapsed.
......@@ -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 ->
......
This diff is collapsed.
......@@ -24,6 +24,7 @@ module IfaceType (
IfaceForAllBndr, ArgFlag(..), AnonArgFlag(..),
ForallVisFlag(..), ShowForAllFlag(..),
mkIfaceForAllTvBndr,
mkIfaceTyConKind,
ifForAllBndrVar, ifForAllBndrName, ifaceBndrName,
ifTyConBinderVar, ifTyConBinderName,
......@@ -35,6 +36,8 @@ module IfaceType (
appArgsIfaceTypes, appArgsIfaceTypesArgFlags,
-- Printing
SuppressBndrSig(..),
UseBndrParens(..),
pprIfaceType, pprParendIfaceType, pprPrecIfaceType,
pprIfaceContext, pprIfaceContextArr,
pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders,
......@@ -44,6 +47,7 @@ module IfaceType (
pprIfaceCoercion, pprParendIfaceCoercion,
splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll,
pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp,
isIfaceTauType,
suppressIfaceInvisibles,
stripIfaceInvisVars,
......@@ -106,6 +110,10 @@ ifaceBndrName :: IfaceBndr -> IfLclName
ifaceBndrName (IfaceTvBndr bndr) = ifaceTvBndrName bndr
ifaceBndrName (IfaceIdBndr bndr) = ifaceIdBndrName bndr
ifaceBndrType :: IfaceBndr -> IfaceType
ifaceBndrType (IfaceIdBndr (_, t)) = t
ifaceBndrType (IfaceTvBndr (_, t)) = t
type IfaceLamBndr = (IfaceBndr, IfaceOneShot)
data IfaceOneShot -- See Note [Preserve OneShotInfo] in CoreTicy
......@@ -164,6 +172,15 @@ type IfaceForAllBndr = VarBndr IfaceBndr ArgFlag
mkIfaceForAllTvBndr :: ArgFlag -> IfaceTvBndr -> IfaceForAllBndr
mkIfaceForAllTvBndr vis var = Bndr (IfaceTvBndr var) vis
-- | Build the 'tyConKind' from the binders and the result kind.
-- Keep in sync with 'mkTyConKind' in types/TyCon.
mkIfaceTyConKind :: [IfaceTyConBinder] -> IfaceKind -> IfaceKind
mkIfaceTyConKind bndrs res_kind = foldr mk res_kind bndrs
where
mk :: IfaceTyConBinder -> IfaceKind -> IfaceKind
mk (Bndr tv (AnonTCB af)) k = IfaceFunTy af (ifaceBndrType tv) k
mk (Bndr tv (NamedTCB vis)) k = IfaceForAllTy (Bndr tv vis) k
-- | Stores the arguments in a type application as a list.
-- See @Note [Suppressing invisible arguments]@.
data IfaceAppArgs
......@@ -686,11 +703,17 @@ pprIfacePrefixApp ctxt_prec pp_fun pp_tys
| otherwise = maybeParen ctxt_prec appPrec $
hang pp_fun 2 (sep pp_tys)
isIfaceTauType :: IfaceType -> Bool
isIfaceTauType (IfaceForAllTy _ _) = False
isIfaceTauType (IfaceFunTy InvisArg _ _) = False
isIfaceTauType _ = True
-- ----------------------------- Printing binders ------------------------------------
instance Outputable IfaceBndr where
ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr
ppr (IfaceTvBndr bndr) = char '@' <+> pprIfaceTvBndr False bndr
ppr (IfaceTvBndr bndr) = char '@' <+> pprIfaceTvBndr bndr (SuppressBndrSig False)
(UseBndrParens False)
pprIfaceBndrs :: [IfaceBndr] -> SDoc
pprIfaceBndrs bs = sep (map ppr bs)
......@@ -702,31 +725,60 @@ pprIfaceLamBndr (b, IfaceOneShot) = ppr b <> text "[OneShot]"
pprIfaceIdBndr :: IfaceIdBndr -> SDoc
pprIfaceIdBndr (name, ty) = parens (ppr name <+> dcolon <+> ppr ty)
pprIfaceTvBndr :: Bool -> IfaceTvBndr -> SDoc
pprIfaceTvBndr use_parens (tv, ki)
{- Note [Suppressing binder signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When printing the binders in a 'forall', we want to keep the kind annotations:
forall (a :: k). blah
^^^^
good
On the other hand, when we print the binders of a data declaration in :info,
the kind information would be redundant due to the standalone kind signature:
type F :: Symbol -> Type
type F (s :: Symbol) = blah
^^^^^^^^^
redundant
Here we'd like to omit the kind annotation:
type F :: Symbol -> Type
type F s = blah
-}
-- | Do we want to suppress kind annotations on binders?
-- See Note [Suppressing binder signatures]
newtype SuppressBndrSig = SuppressBndrSig Bool
newtype UseBndrParens = UseBndrParens Bool
pprIfaceTvBndr :: IfaceTvBndr -> SuppressBndrSig -> UseBndrParens -> SDoc
pprIfaceTvBndr (tv, ki) (SuppressBndrSig suppress_sig) (UseBndrParens use_parens)
| suppress_sig = ppr tv
| isIfaceLiftedTypeKind ki = ppr tv
| otherwise = maybe_parens (ppr tv <+> dcolon <+> ppr ki)
where
maybe_parens | use_parens = parens
| otherwise = id
pprIfaceTyConBinders :: [IfaceTyConBinder] -> SDoc
pprIfaceTyConBinders = sep . map go
pprIfaceTyConBinders :: SuppressBndrSig -> [IfaceTyConBinder] -> SDoc
pprIfaceTyConBinders suppress_sig = sep . map go
where
go :: IfaceTyConBinder -> SDoc
go (Bndr (IfaceIdBndr bndr) _) = pprIfaceIdBndr bndr
go (Bndr (IfaceTvBndr bndr) vis) =
-- See Note [Pretty-printing invisible arguments]
case vis of
AnonTCB VisArg -> ppr_bndr True
AnonTCB InvisArg -> char '@' <> braces (ppr_bndr False)
AnonTCB VisArg -> ppr_bndr (UseBndrParens True)
AnonTCB InvisArg -> char '@' <> braces (ppr_bndr (UseBndrParens False))
-- The above case is rare. (See Note [AnonTCB InvisArg] in TyCon.)
-- Should we print these differently?
NamedTCB Required -> ppr_bndr True
NamedTCB Specified -> char '@' <> ppr_bndr True
NamedTCB Inferred -> char '@' <> braces (ppr_bndr False)
NamedTCB Required -> ppr_bndr (UseBndrParens True)
NamedTCB Specified -> char '@' <> ppr_bndr (UseBndrParens True)
NamedTCB Inferred -> char '@' <> braces (ppr_bndr (UseBndrParens False))
where
ppr_bndr use_parens = pprIfaceTvBndr use_parens bndr
ppr_bndr = pprIfaceTvBndr bndr suppress_sig
instance Binary IfaceBndr where
put_ bh (IfaceIdBndr aa) = do
......@@ -1045,13 +1097,19 @@ pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc
pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs
pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc
pprIfaceForAllBndr (Bndr (IfaceTvBndr tv) Inferred)
= sdocWithDynFlags $ \dflags ->
if gopt Opt_PrintExplicitForalls dflags
then braces $ pprIfaceTvBndr False tv
else pprIfaceTvBndr True tv
pprIfaceForAllBndr (Bndr (IfaceTvBndr tv) _) = pprIfaceTvBndr True tv
pprIfaceForAllBndr (Bndr (IfaceIdBndr idv) _) = pprIfaceIdBndr idv
pprIfaceForAllBndr bndr =
case bndr of
Bndr (IfaceTvBndr tv) Inferred ->
sdocWithDynFlags $ \dflags ->
if gopt Opt_PrintExplicitForalls dflags
then braces $ pprIfaceTvBndr tv suppress_sig (UseBndrParens False)
else pprIfaceTvBndr tv suppress_sig (UseBndrParens True)
Bndr (IfaceTvBndr tv) _ ->
pprIfaceTvBndr tv suppress_sig (UseBndrParens True)
Bndr (IfaceIdBndr idv) _ -> pprIfaceIdBndr idv
where
-- See Note [Suppressing binder signatures] in IfaceType
suppress_sig = SuppressBndrSig False
pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc
pprIfaceForAllCoBndr (tv, kind_co)
......
......@@ -4526,6 +4526,7 @@ xFlagsDeps = [
flagSpec' "TemplateHaskell" LangExt.TemplateHaskell
checkTemplateHaskellOk,
flagSpec "TemplateHaskellQuotes" LangExt.TemplateHaskellQuotes,
flagSpec "StandaloneKindSignatures" LangExt.StandaloneKindSignatures,
flagSpec "TraditionalRecordSyntax" LangExt.TraditionalRecordSyntax,
flagSpec "TransformListComp" LangExt.TransformListComp,
flagSpec "TupleSections" LangExt.TupleSections,
......@@ -4653,6 +4654,9 @@ impliedXFlags
, (LangExt.TypeInType, turnOn, LangExt.PolyKinds)
, (LangExt.TypeInType, turnOn, LangExt.KindSignatures)
-- Standalone kind signatures are a replacement for CUSKs.
, (LangExt.StandaloneKindSignatures, turnOff, LangExt.CUSKs)
-- AutoDeriveTypeable is not very useful without DeriveDataTypeable
, (LangExt.AutoDeriveTypeable, turnOn, LangExt.DeriveDataTypeable)
......
......@@ -1049,6 +1049,7 @@ topdecls_semi :: { OrdList (LHsDecl GhcPs) }
topdecl :: { LHsDecl GhcPs }
: cl_decl { sL1 $1 (TyClD noExtField (unLoc $1)) }
| ty_decl { sL1 $1 (TyClD noExtField (unLoc $1)) }
| standalone_kind_sig { sL1 $1 (KindSigD noExtField (unLoc $1)) }
| inst_decl { sL1 $1 (InstD noExtField (unLoc $1)) }
| stand_alone_deriving { sLL $1 $> (DerivD noExtField (unLoc $1)) }
| role_annot { sL1 $1 (RoleAnnotD noExtField (unLoc $1)) }
......@@ -1131,6 +1132,19 @@ ty_decl :: { LTyClDecl GhcPs }
(snd $ unLoc $4) Nothing)
(mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) }
-- standalone kind signature
standalone_kind_sig :: { LStandaloneKindSig GhcPs }
: 'type' sks_vars '::' ktypedoc
{% amms (mkStandaloneKindSig (comb2 $1 $4) $2 $4)
[mj AnnType $1,mu AnnDcolon $3] }
-- See also: sig_vars
sks_vars :: { Located [Located RdrName] } -- Returned in reverse order
: sks_vars ',' oqtycon
{% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>
return (sLL $1 $> ($3 : unLoc $1)) }
| oqtycon { sL1 $1 [$1] }
inst_decl :: { LInstDecl GhcPs }
: 'instance' overlap_pragma inst_type where_inst
{% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4)
......
......@@ -23,6 +23,7 @@ module RdrHsSyn (
mkClassDecl,
mkTyData, mkDataFamInst,
mkTySynonym, mkTyFamInstEqn,
mkStandaloneKindSig,
mkTyFamInst,
mkFamDecl, mkLHsSigType,
mkInlinePragma,
......@@ -239,6 +240,30 @@ mkTySynonym loc lhs rhs
, tcdFixity = fixity
, tcdRhs = rhs })) }
mkStandaloneKindSig
:: SrcSpan
-> Located [Located RdrName] -- LHS
-> LHsKind GhcPs -- RHS
-> P (LStandaloneKindSig GhcPs)
mkStandaloneKindSig loc lhs rhs =
do { vs <- mapM check_lhs_name (unLoc lhs)
; v <- check_singular_lhs (reverse vs)
; return $ cL loc $ StandaloneKindSig noExtField v (mkLHsSigType rhs) }
where
check_lhs_name v@(unLoc->name) =
if isUnqual name && isTcOcc (rdrNameOcc name)
then return v
else addFatalError (getLoc v) $
hang (text "Expected an unqualified type constructor:") 2 (ppr v)
check_singular_lhs vs =
case vs of
[] -> panic "mkStandaloneKindSig: empty left-hand side"
[v] -> return v
_ -> addFatalError (getLoc lhs) $
vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:")
2 (pprWithCommas ppr vs)
, text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." ]
mkTyFamInstEqn :: Maybe [LHsTyVarBndr GhcPs]
-> LHsType GhcPs
-> LHsType GhcPs
......
......@@ -68,7 +68,7 @@ templateHaskellNames = [
-- Dec
funDName, valDName, dataDName, newtypeDName, tySynDName,
classDName, instanceWithOverlapDName,
standaloneDerivWithStrategyDName, sigDName, forImpDName,
standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,
pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName,
dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
......@@ -341,7 +341,7 @@ recSName = libFun (fsLit "recS") recSIdKey
-- data Dec = ...
funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
instanceWithOverlapDName, sigDName, forImpDName, pragInlDName,
instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName,
pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,
pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName,
dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,
......@@ -357,6 +357,7 @@ classDName = libFun (fsLit "classD")
instanceWithOverlapDName = libFun (fsLit "instanceWithOverlapD") instanceWithOverlapDIdKey
standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey
sigDName = libFun (fsLit "sigD") sigDIdKey
kiSigDName = libFun (fsLit "kiSigD") kiSigDIdKey
defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey
forImpDName = libFun (fsLit "forImpD") forImpDIdKey
pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey
......@@ -868,7 +869,8 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,
newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,
infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,
patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey :: Unique
patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey,
kiSigDIdKey :: Unique
funDIdKey = mkPreludeMiscIdUnique 320
valDIdKey = mkPreludeMiscIdUnique 321
dataDIdKey = mkPreludeMiscIdUnique 322
......@@ -901,6 +903,7 @@ patSynDIdKey = mkPreludeMiscIdUnique 348
patSynSigDIdKey = mkPreludeMiscIdUnique 349
pragCompleteDIdKey = mkPreludeMiscIdUnique 350
implicitParamBindDIdKey = mkPreludeMiscIdUnique 351
kiSigDIdKey = mkPreludeMiscIdUnique 352
-- type Cxt = ...
cxtIdKey :: Unique
......
......@@ -93,7 +93,7 @@ module TysWiredIn (
-- * Kinds
typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind,
isLiftedTypeKindTyConName, liftedTypeKind, constraintKind,
liftedTypeKindTyCon, constraintKindTyCon,
liftedTypeKindTyCon, constraintKindTyCon, constraintKindTyConName,
liftedTypeKindTyConName,
-- * Equality predicates
......@@ -406,7 +406,7 @@ makeRecoveryTyCon :: TyCon -> TyCon
makeRecoveryTyCon tc
= mkTcTyCon (tyConName tc)
bndrs res_kind
[] -- No scoped vars
noTcTyConScopedTyVars
True -- Fully generalised
flavour -- Keep old flavour
where
......
......@@ -973,7 +973,7 @@ renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)
; when (is_deflt && not defaultSigs_on) $
addErr (defaultSigErr sig)
; new_v <- mapM (lookupSigOccRn ctxt sig) vs
; (new_ty, fvs) <- rnHsSigType ty_ctxt ty
; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty
; return (ClassOpSig noExtField is_deflt new_v new_ty, fvs) }
where
(v1:_) = vs
......@@ -981,7 +981,7 @@ renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)
<+> quotes (ppr v1))
renameSig _ (SpecInstSig _ src ty)
= do { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx ty
= do { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx TypeLevel ty
; return (SpecInstSig noExtField src new_ty,fvs) }
-- {-# SPECIALISE #-} pragmas can refer to imported Ids
......@@ -998,7 +998,7 @@ renameSig ctxt sig@(SpecSig _ v tys inl)
ty_ctxt = GenericCtx (text "a SPECIALISE signature for"
<+> quotes (ppr v))
do_one (tys,fvs) ty
= do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt ty
= do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel ty
; return ( new_ty:tys, fvs_ty `plusFV` fvs) }
renameSig ctxt sig@(InlineSig _ v s)
......@@ -1015,7 +1015,7 @@ renameSig ctxt sig@(MinimalSig _ s (L l bf))
renameSig ctxt sig@(PatSynSig _ vs ty)
= do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
; (ty', fvs) <- rnHsSigType ty_ctxt ty
; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty
; return (PatSynSig noExtField new_vs ty', fvs) }
where
ty_ctxt = GenericCtx (text "a pattern synonym signature for"
......
This diff is collapsed.
......@@ -242,6 +242,7 @@ extraConstraintWildCardsAllowed env
TypeSigCtx {} -> True
ExprWithTySigCtx {} -> True
DerivDeclCtx {} -> True
StandaloneKindSigCtx {} -> False -- See Note [Wildcards in standalone kind signatures] in GHC/Hs/Decls
_ -> False
-- | Finds free type and kind variables in a type,
......@@ -295,19 +296,22 @@ of the HsWildCardBndrs structure, and we are done.
* *
****************************************************** -}