summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorVladislav Zavialov <vlad.z.4096@gmail.com>2020-03-30 17:31:10 +0300
committerVladislav Zavialov <vlad.z.4096@gmail.com>2020-04-02 14:04:53 +0300
commitd4fb13dfb25151bd1c763d867ee197b891f19852 (patch)
treeacd670d7db4b8214668f4dbc7e45c96d5495dbc6
parent3c09f636a459f50119bfbb5bf798b9a9e19eb464 (diff)
downloadhaskell-wip/tycl-group.tar.gz
Handle sigs in separate TyClGroupswip/tycl-group
Fixing #12088 implies that we put declarations and definitions in separate TyClGroups. Consider this example: {-# LANGUAGE StandaloneKindSignatures #-} import Data.Kind (Type) type X :: Type data X If the renamer puts type X :: Type and data X into separate TyClGroups, then the type checker must be prepared to handle it. Before this patch, the type checker always assumed that signatures were put into the same TyClGroup as the definition. After this patch, no such assumption is made.
-rw-r--r--compiler/GHC/Core/TyCon.hs3
-rw-r--r--compiler/GHC/Hs/Decls.hs101
-rw-r--r--compiler/GHC/Hs/Instances.hs2
-rw-r--r--compiler/GHC/HsToCore/Quote.hs8
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs2
-rw-r--r--compiler/GHC/Rename/Source.hs127
-rw-r--r--compiler/typecheck/TcEnv.hs2
-rw-r--r--compiler/typecheck/TcHsType.hs9
-rw-r--r--compiler/typecheck/TcTyClsDecls.hs264
-rw-r--r--testsuite/tests/parser/should_compile/DumpRenamedAst.stderr128
10 files changed, 484 insertions, 162 deletions
diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs
index e3044095bc..1c4a9ed292 100644
--- a/compiler/GHC/Core/TyCon.hs
+++ b/compiler/GHC/Core/TyCon.hs
@@ -8,6 +8,7 @@ The @TyCon@ datatype
{-# LANGUAGE CPP, FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE DeriveDataTypeable #-}
module GHC.Core.TyCon(
-- * Main TyCon data types
@@ -2586,7 +2587,7 @@ data TyConFlavour
| TypeSynonymFlavour
| BuiltInTypeFlavour -- ^ e.g., the @(->)@ 'TyCon'.
| PromotedDataConFlavour
- deriving Eq
+ deriving (Eq, Data.Data)
instance Outputable TyConFlavour where
ppr = text . go
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index 07cdb82a91..6de4bed626 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -3,6 +3,7 @@
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable,
DeriveTraversable #-}
{-# LANGUAGE StandaloneDeriving #-}
@@ -29,16 +30,18 @@ module GHC.Hs.Decls (
-- ** Class or type declarations
TyClDecl(..), LTyClDecl, DataDeclRn(..),
+ LDeclHeaderRn, DeclHeaderRn(..),
TyClGroup(..),
tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,
tyClGroupKindSigs,
isClassDecl, isDataDecl, isSynDecl, tcdName,
isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,
isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,
+ getFamFlav,
tyFamInstDeclName, tyFamInstDeclLName,
countTyClDecls, pprTyClDeclFlavour,
tyClDeclLName, tyClDeclTyVars,
- hsDeclHasCusk, famResultKindSignature,
+ famResultKindSignature,
FamilyDecl(..), LFamilyDecl,
-- ** Instance declarations
@@ -93,6 +96,8 @@ module GHC.Hs.Decls (
) where
+#include "HsVersions.h"
+
-- friends:
import GhcPrelude
@@ -108,6 +113,7 @@ import GHC.Types.Basic
import GHC.Core.Coercion
import GHC.Types.ForeignCall
import GHC.Hs.Extension
+import GHC.Types.Name
import GHC.Types.Name.Set
-- others:
@@ -120,6 +126,7 @@ import GHC.Core.Type
import Bag
import Maybes
import Data.Data hiding (TyCon,Fixity, Infix)
+import Data.Void
{-
************************************************************************
@@ -741,24 +748,6 @@ countTyClDecls decls
isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True
isNewTy _ = False
--- | Does this declaration have a complete, user-supplied kind signature?
--- See Note [CUSKs: complete user-supplied kind signatures]
-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
-- ~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1145,6 +1134,27 @@ data FamilyInfo pass
-- said "type family Foo x where .."
| ClosedTypeFamily (Maybe [LTyFamInstEqn pass])
+getFamFlav
+ :: Maybe TyCon -- ^ Just cls <=> this is an associated family of class cls
+ -> FamilyInfo pass
+ -> TyConFlavour
+getFamFlav mb_parent_tycon info =
+ case info of
+ DataFamily -> DataFamilyFlavour mb_parent_tycon
+ OpenTypeFamily -> OpenTypeFamilyFlavour mb_parent_tycon
+ ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon ) -- See Note [Closed type family mb_parent_tycon]
+ ClosedTypeFamilyFlavour
+
+{- Note [Closed type family mb_parent_tycon]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There's no way to write a closed type family inside a class declaration:
+
+ class C a where
+ type family F a where -- error: parse error on input ‘where’
+
+In fact, it is not clear what the meaning of such a declaration would be.
+Therefore, 'mb_parent_tycon' of any closed type family has to be Nothing.
+-}
------------- Functions over FamilyDecls -----------
@@ -1329,6 +1339,31 @@ instance OutputableBndrId p
_ -> (ppDerivStrategy dcs, empty)
ppr (XHsDerivingClause x) = ppr x
+type LDeclHeaderRn = Located DeclHeaderRn
+
+-- | Renamed declaration header (left-hand side of a declaration):
+--
+-- 1. data T a b = MkT (a -> b)
+-- ^^^^^^^^^^
+--
+-- 2. class C a where
+-- ^^^^^^^^^
+--
+-- 3. type family F a b :: r where
+-- ^^^^^^^^^^^^^^^^^^^^^^
+--
+-- Supplies arity and flavor information not covered by a standalone kind
+-- signature.
+--
+data DeclHeaderRn
+ = DeclHeaderRn
+ { decl_header_flav :: TyConFlavour,
+ decl_header_name :: Name,
+ decl_header_cusk :: Bool,
+ decl_header_bndrs :: LHsQTyVars GhcRn,
+ decl_header_res_sig :: Maybe (LHsType GhcRn)
+ }
+
-- | Located Standalone Kind Signature
type LStandaloneKindSig pass = Located (StandaloneKindSig pass)
@@ -1338,12 +1373,23 @@ data StandaloneKindSig pass
(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
+type instance XStandaloneKindSig GhcPs = NoExtField
+type instance XStandaloneKindSig GhcRn = Maybe LDeclHeaderRn
+ -- Just hdr for signatures with an accompanying binding.
+ -- Nothing for signatures without an accompanying binding (error).
+type instance XStandaloneKindSig GhcTc = Void
-standaloneKindSigName :: StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)
+type instance XXStandaloneKindSig GhcPs = NoExtCon
+type instance XXStandaloneKindSig GhcRn = LDeclHeaderRn -- CUSK
+type instance XXStandaloneKindSig GhcTc = NoExtCon
+
+standaloneKindSigName :: forall p. IsPass p => StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)
standaloneKindSigName (StandaloneKindSig _ lname _) = unLoc lname
-standaloneKindSigName (XStandaloneKindSig nec) = noExtCon nec
+standaloneKindSigName (XStandaloneKindSig x) =
+ case ghcPass @p of
+ GhcPs -> noExtCon x
+ GhcRn -> decl_header_name (unLoc x)
+ GhcTc -> noExtCon x
{- Note [Wildcards in standalone kind signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1535,11 +1581,16 @@ instance OutputableBndrId p
=> Outputable (HsDataDefn (GhcPass p)) where
ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d
-instance OutputableBndrId p
+instance (IsPass p, OutputableBndrId p)
=> Outputable (StandaloneKindSig (GhcPass p)) where
ppr (StandaloneKindSig _ v ki)
= text "type" <+> pprPrefixOcc (unLoc v) <+> text "::" <+> ppr ki
- ppr (XStandaloneKindSig nec) = noExtCon nec
+ ppr (XStandaloneKindSig x) =
+ case ghcPass @p of
+ GhcPs -> noExtCon x
+ GhcRn -> whenPprDebug $
+ text "CUSK:" <+> ppr (decl_header_name (unLoc x))
+ GhcTc -> noExtCon x
instance Outputable NewOrData where
ppr NewType = text "newtype"
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index fd723e1408..af96eba2ca 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -86,6 +86,8 @@ deriving instance Data (FixitySig GhcPs)
deriving instance Data (FixitySig GhcRn)
deriving instance Data (FixitySig GhcTc)
+deriving instance Data DeclHeaderRn
+
-- deriving instance (DataId p) => Data (StandaloneKindSig p)
deriving instance Data (StandaloneKindSig GhcPs)
deriving instance Data (StandaloneKindSig GhcRn)
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 4de99748e5..d9b55c1e23 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -284,7 +284,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)
+ ; kisig_ds <- mapMaybeM repKiSigD (concatMap group_kisigs tyclds)
; inst_ds <- mapM repInstD instds
; deriv_ds <- mapM repStandaloneDerivD derivds
; fix_ds <- mapM repLFixD fixds
@@ -493,11 +493,11 @@ repRoleD (L loc (RoleAnnotDecl _ tycon roles))
repRoleD (L _ (XRoleAnnotDecl nec)) = noExtCon nec
-------------------------
-repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
+repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (Maybe (SrcSpan, Core (M TH.Dec)))
repKiSigD (L loc kisig) =
case kisig of
- StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v
- XStandaloneKindSig nec -> noExtCon nec
+ StandaloneKindSig _ v ki -> Just <$> rep_ty_sig kiSigDName loc ki v
+ XStandaloneKindSig _ -> pure Nothing
-------------------------
repDataDefn :: Core TH.Name
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 7d45d8d798..468e4d32d1 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1487,7 +1487,7 @@ instance ToHie (StandaloneKindSig GhcRn) where
[ toHie $ C TyDecl name
, toHie $ TS (ResolvedScopes []) typ
]
- XStandaloneKindSig nec -> noExtCon nec
+ XStandaloneKindSig _ -> []
instance ToHie (SigContext (LSig GhcRn)) where
toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of
diff --git a/compiler/GHC/Rename/Source.hs b/compiler/GHC/Rename/Source.hs
index fabe5b817d..817a9e7d71 100644
--- a/compiler/GHC/Rename/Source.hs
+++ b/compiler/GHC/Rename/Source.hs
@@ -25,6 +25,7 @@ import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr )
import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls )
import GHC.Hs
+import GHC.Core.TyCon ( TyConFlavour(..) )
import GHC.Types.FieldLabel
import GHC.Types.Name.Reader
import GHC.Rename.Types
@@ -59,7 +60,8 @@ import GHC.Types.Basic ( pprRuleName, TypeOrKind(..) )
import FastString
import GHC.Types.SrcLoc as SrcLoc
import GHC.Driver.Session
-import Util ( debugIsOn, filterOut, lengthExceeds, partitionWith )
+import Util ( debugIsOn, filterOut, lengthExceeds,
+ partitionWith, (<&&>) )
import GHC.Driver.Types ( HscEnv, hsc_dflags )
import ListSetOps ( findDupsEq, removeDups, equivClasses )
import Digraph ( SCC, flattenSCC, flattenSCCs, Node(..)
@@ -73,7 +75,7 @@ import Control.Arrow ( first )
import Data.List ( mapAccumL )
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty ( NonEmpty(..) )
-import Data.Maybe ( isNothing, fromMaybe, mapMaybe )
+import Data.Maybe ( isNothing, isJust, fromMaybe, mapMaybe )
import qualified Data.Set as Set ( difference, fromList, toList, null )
import Data.Function ( on )
@@ -1293,7 +1295,23 @@ rnTyClDecls tycl_ds
= do { -- Rename the type/class, instance, and role declaraations
; tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupTyClDecls tycl_ds)
; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs)
- ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names (tyClGroupKindSigs tycl_ds)
+ decl_headers_env = mkNameEnv (map mk_pair decl_headers_list)
+ where mk_pair hdr = (decl_header_name (unLoc hdr), hdr)
+ decl_headers_list = map (mapLoc mkDeclHeaderRn . fst) tycls_w_fvs
+ ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names decl_headers_env (tyClGroupKindSigs tycl_ds)
+
+ ; cusks_enabled <- xoptM LangExt.CUSKs <&&> xoptM LangExt.PolyKinds
+ -- See Note [CUSKs and PolyKinds] in TcTyClsDecls
+ ; let (kisig_env, kisig_fv_env) = mkKindSig_fv_env kisigs_w_fvs
+ cusks_env
+ | cusks_enabled =
+ mapNameEnv (\hdr -> L (getLoc hdr) (XStandaloneKindSig hdr)) $
+ filterNameEnv (decl_header_cusk . unLoc) decl_headers_env
+ | otherwise = emptyNameEnv
+ kisig_cusks_env =
+ plusNameEnv_C (\saks _cusk -> saks) -- See Note [Choose SAKSs over CUSKs]
+ kisig_env cusks_env
+
; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)
; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)
@@ -1301,7 +1319,6 @@ rnTyClDecls tycl_ds
; rdr_env <- getGlobalRdrEnv
; let tycl_sccs = depAnalTyClDecls rdr_env kisig_fv_env tycls_w_fvs
role_annot_env = mkRoleAnnotEnv role_annots
- (kisig_env, kisig_fv_env) = mkKindSig_fv_env kisigs_w_fvs
inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs
(init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map
@@ -1315,7 +1332,7 @@ rnTyClDecls tycl_ds
, group_instds = init_inst_ds }]
(final_inst_ds, groups)
- = mapAccumL (mk_group role_annot_env kisig_env) rest_inst_ds tycl_sccs
+ = mapAccumL (mk_group role_annot_env kisig_cusks_env) rest_inst_ds tycl_sccs
all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs `plusFV`
foldr (plusFV . snd) emptyFVs instds_w_fvs `plusFV`
@@ -1348,6 +1365,89 @@ rnTyClDecls tycl_ds
, group_roles = roles
, group_instds = inst_ds }
+{- Note [Choose SAKSs over CUSKs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Some declarations have both a CUSK and a SAKS:
+
+type T :: Type -> Type
+data T (a :: Type) = MkT
+
+In this case, we will end up with two representations for its signature:
+
+ 1. StandaloneKindSig (data T (a :: Type)) T (Type -> Type) -- representing the SAKS
+ 2. XStandaloneKindSig (data T (a :: Type)) -- representing the CUSK
+
+In the resulting TyClGroups, we want only one. The CUSK node is generated from
+the header and contains no new information, so it is safe to discard it. The
+SAKS node contains the signature explicitly given by the user and should not be
+discarded.
+
+Therefore, the SAKS node takes precedence over the CUSK node.
+-}
+
+
+-- | Extract the declaration header from a type/class definition.
+mkDeclHeaderRn :: TyClDecl GhcRn -> DeclHeaderRn
+
+-- Class
+mkDeclHeaderRn
+ (ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs })
+ = DeclHeaderRn
+ { decl_header_flav = ClassFlavour,
+ decl_header_name = name,
+ decl_header_cusk = hsTvbAllKinded ktvs,
+ decl_header_bndrs = ktvs,
+ decl_header_res_sig = Nothing }
+
+-- Data/Newtype
+mkDeclHeaderRn
+ (DataDecl { tcdLName = L _ name
+ , tcdTyVars = ktvs
+ , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
+ , dd_ND = new_or_data }
+ , tcdDExt = DataDeclRn { tcdDataCusk = has_cusk }})
+ = DeclHeaderRn
+ { decl_header_flav = newOrDataToFlavour new_or_data,
+ decl_header_name = name,
+ decl_header_cusk = has_cusk,
+ decl_header_bndrs = ktvs,
+ decl_header_res_sig = m_sig }
+
+-- Type/data family
+mkDeclHeaderRn
+ (FamDecl { tcdFam =
+ FamilyDecl { fdLName = L _ name
+ , fdTyVars = ktvs
+ , fdResultSig = L _ resultSig
+ , fdInfo = info } })
+ = DeclHeaderRn
+ { decl_header_flav = getFamFlav Nothing info,
+ decl_header_name = name,
+ decl_header_cusk = has_cusk,
+ decl_header_bndrs = ktvs,
+ decl_header_res_sig = famResultKindSignature resultSig }
+ where
+ has_cusk =
+ case info of
+ ClosedTypeFamily {} -> hsTvbAllKinded ktvs
+ && isJust (famResultKindSignature resultSig)
+ _ -> True -- Un-associated open type/data families have CUSKs
+
+-- Type synonym
+mkDeclHeaderRn
+ (SynDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdRhs = rhs })
+ = DeclHeaderRn
+ { decl_header_flav = TypeSynonymFlavour,
+ decl_header_name = name,
+ decl_header_cusk = hsTvbAllKinded ktvs && isJust (hsTyKindSig rhs),
+ decl_header_bndrs = ktvs,
+ decl_header_res_sig = hsTyKindSig rhs }
+
+-- Impossible cases
+mkDeclHeaderRn (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec
+mkDeclHeaderRn (FamDecl {tcdFam = XFamilyDecl nec}) = noExtCon nec
+mkDeclHeaderRn (XTyClDecl nec) = noExtCon nec
+
-- | Free variables of standalone kind signatures.
newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars)
@@ -1370,34 +1470,37 @@ getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn]
getKindSigs bndrs kisig_env = mapMaybe (lookupNameEnv kisig_env) bndrs
rnStandaloneKindSignatures
- :: NameSet -- names of types and classes in the current TyClGroup
+ :: NameSet -- names of types and classes in the current HsGroup
+ -> NameEnv LDeclHeaderRn -- headers of types and classes in the current HsGroup
-> [LStandaloneKindSig GhcPs]
-> RnM [(LStandaloneKindSig GhcRn, FreeVars)]
-rnStandaloneKindSignatures tc_names kisigs
+rnStandaloneKindSignatures tc_names decl_headers kisigs
= do { let (no_dups, dup_kisigs) = removeDups (compare `on` get_name) kisigs
get_name = standaloneKindSigName . unLoc
; mapM_ dupKindSig_Err dup_kisigs
- ; mapM (wrapLocFstM (rnStandaloneKindSignature tc_names)) no_dups
+ ; mapM (wrapLocFstM (rnStandaloneKindSignature tc_names decl_headers)) no_dups
}
rnStandaloneKindSignature
- :: NameSet -- names of types and classes in the current TyClGroup
+ :: NameSet -- names of types and classes in the current HsGroup
+ -> NameEnv LDeclHeaderRn -- headers of types and classes in the current HsGroup
-> StandaloneKindSig GhcPs
-> RnM (StandaloneKindSig GhcRn, FreeVars)
-rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki)
+rnStandaloneKindSignature tc_names decl_headers (StandaloneKindSig _ v ki)
= do { standalone_ki_sig_ok <- xoptM LangExt.StandaloneKindSignatures
; unless standalone_ki_sig_ok $ addErr standaloneKiSigErr
; new_v <- lookupSigCtxtOccRn (TopSigCtxt tc_names) (text "standalone kind signature") v
; let doc = StandaloneKindSigCtx (ppr v)
; (new_ki, fvs) <- rnHsSigType doc KindLevel ki
- ; return (StandaloneKindSig noExtField new_v new_ki, fvs)
+ ; let hdr = lookupNameEnv decl_headers (unLoc new_v)
+ ; return (StandaloneKindSig hdr new_v new_ki, fvs)
}
where
standaloneKiSigErr :: SDoc
standaloneKiSigErr =
hang (text "Illegal standalone kind signature")
2 (text "Did you mean to enable StandaloneKindSignatures?")
-rnStandaloneKindSignature _ (XStandaloneKindSig nec) = noExtCon nec
+rnStandaloneKindSignature _ _ (XStandaloneKindSig nec) = noExtCon nec
depAnalTyClDecls :: GlobalRdrEnv
-> KindSig_FV_Env
diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
index 01bff1db4c..fa3bbb53be 100644
--- a/compiler/typecheck/TcEnv.hs
+++ b/compiler/typecheck/TcEnv.hs
@@ -464,7 +464,7 @@ tcLookupTcTyCon name = do
thing <- tcLookup name
case thing of
ATcTyCon tc -> return tc
- _ -> pprPanic "tcLookupTcTyCon" (ppr name)
+ _ -> pprPanic "tcLookupTcTyCon" (ppr name <+> text ":" <+> ppr thing)
getInLocalScope :: TcM (Name -> Bool)
getInLocalScope = do { lcl_env <- getLclTypeEnv
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index 37bfda6e9f..c725e87474 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -263,15 +263,16 @@ tcHsSigType ctxt sig_ty
skol_info = SigTypeSkol ctxt
-- Does validity checking and zonking.
-tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind)
-tcStandaloneKindSig (L _ kisig) = case kisig of
+tcStandaloneKindSig :: StandaloneKindSig GhcRn -> TcM (Name, SAKS_or_CUSK)
+tcStandaloneKindSig kisig = case kisig of
StandaloneKindSig _ (L _ name) ksig ->
let ctxt = StandaloneKindSigCtxt name in
addSigCtxt ctxt (hsSigType ksig) $
do { kind <- tcTopLHsType kindLevelMode ksig (expectedKindInCtxt ctxt)
; checkValidType ctxt kind
- ; return (name, kind) }
- XStandaloneKindSig nec -> noExtCon nec
+ ; return (name, SAKS kind) }
+ XStandaloneKindSig hdr ->
+ return (decl_header_name (unLoc hdr), CUSK)
tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn
-> ContextKind -> TcM (Bool, TcType)
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index b69a4654f3..a9ff1cf588 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -123,6 +123,26 @@ Thus, we take two passes over the resulting tycons, first checking for general
validity and then checking for valid role annotations.
-}
+-- | TcTyCons generated from SAKS/CUSKs, whose definitions occur in a later TyClGroup.
+newtype InterGroupEnv = InterGroupEnv (NameEnv TcTyCon)
+
+emptyInterGroupEnv :: InterGroupEnv
+emptyInterGroupEnv = InterGroupEnv emptyNameEnv
+
+extendInterGroupEnv :: [TcTyCon] -> InterGroupEnv -> InterGroupEnv
+extendInterGroupEnv tcs (InterGroupEnv env) = InterGroupEnv (extendNameEnvList env named_tcs)
+ where named_tcs = map (\tc -> (tyConName tc, tc)) tcs
+
+purgeInterGroupEnv :: [TcTyCon] -> InterGroupEnv -> InterGroupEnv
+purgeInterGroupEnv tcs (InterGroupEnv env) = InterGroupEnv (delListFromNameEnv env tcs_names)
+ where tcs_names = map tyConName tcs
+
+interGroupEnvTyCons :: InterGroupEnv -> [TcTyCon]
+interGroupEnvTyCons (InterGroupEnv env) = nameEnvElts env
+
+interGroupElem :: InterGroupEnv -> Name -> Bool
+interGroupElem (InterGroupEnv env) name = elemNameEnv name env
+
tcTyAndClassDecls :: [TyClGroup GhcRn] -- Mutually-recursive groups in
-- dependency order
-> TcM ( TcGblEnv -- Input env extended by types and
@@ -136,28 +156,33 @@ tcTyAndClassDecls tyclds_s
-- The code recovers internally, but if anything gave rise to
-- an error we'd better stop now, to avoid a cascade
-- Type check each group in dependency order folding the global env
- = checkNoErrs $ fold_env [] [] tyclds_s
+ = checkNoErrs $ fold_env emptyInterGroupEnv [] [] tyclds_s
where
- fold_env :: [InstInfo GhcRn]
+ fold_env :: InterGroupEnv
+ -> [InstInfo GhcRn]
-> [DerivInfo]
-> [TyClGroup GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
- fold_env inst_info deriv_info []
+ fold_env _ inst_info deriv_info []
= do { gbl_env <- getGblEnv
; return (gbl_env, inst_info, deriv_info) }
- fold_env inst_info deriv_info (tyclds:tyclds_s)
- = do { (tcg_env, inst_info', deriv_info') <- tcTyClGroup tyclds
+ fold_env inter_group_env inst_info deriv_info (tyclds:tyclds_s)
+ = do { (tcg_env, inter_group_env', inst_info', deriv_info') <-
+ tcTyClGroup inter_group_env tyclds
; setGblEnv tcg_env $
-- remaining groups are typechecked in the extended global env.
- fold_env (inst_info' ++ inst_info)
+ fold_env inter_group_env'
+ (inst_info' ++ inst_info)
(deriv_info' ++ deriv_info)
tyclds_s }
-tcTyClGroup :: TyClGroup GhcRn
- -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
+tcTyClGroup :: InterGroupEnv
+ -> TyClGroup GhcRn
+ -> TcM (TcGblEnv, InterGroupEnv, [InstInfo GhcRn], [DerivInfo])
-- Typecheck one strongly-connected component of type, class, and instance decls
-- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls
-tcTyClGroup (TyClGroup { group_tyclds = tyclds
+tcTyClGroup inter_group_env
+ (TyClGroup { group_tyclds = tyclds
, group_roles = roles
, group_kisigs = kisigs
, group_instds = instds })
@@ -166,10 +191,19 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
-- Step 1: Typecheck the standalone kind signatures and type/class declarations
; traceTc "---- tcTyClGroup ---- {" empty
; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds))
- ; (tyclss, data_deriv_info) <-
+ ; (inter_group_env', tyclss, data_deriv_info) <-
tcExtendKindEnv (mkPromotionErrorEnv tyclds) $ -- See Note [Type environment evolution]
- do { kisig_env <- mkNameEnv <$> traverse tcStandaloneKindSig kisigs
- ; tcTyClDecls tyclds kisig_env role_annots }
+ do { checked_tcs <-
+ tcExtendKindEnv (mkSigPromotionErrorEnv kisigs) $
+ mapMaybeM tcDeclSig kisigs
+ ; let extended_inter_group_env = extendInterGroupEnv checked_tcs inter_group_env
+ is_kinded_decl = interGroupElem extended_inter_group_env
+ ; (tyclss, data_deriv_info) <-
+ tcExtendKindEnvWithTyCons (interGroupEnvTyCons extended_inter_group_env) $
+ tcTyClDecls tyclds is_kinded_decl role_annots
+ ; let purged_inter_group_env = purgeInterGroupEnv tyclss extended_inter_group_env
+ ; return (purged_inter_group_env, tyclss, data_deriv_info)
+ }
-- Step 1.5: Make sure we don't have any type synonym cycles
; traceTc "Starting synonym cycle check" (ppr tyclss)
@@ -200,24 +234,75 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
tcInstDecls1 instds
; let deriv_info = datafam_deriv_info ++ data_deriv_info
- ; return (gbl_env', inst_info, deriv_info) }
+ ; return (gbl_env', inter_group_env', inst_info, deriv_info) }
-tcTyClGroup (XTyClGroup nec) = noExtCon nec
+tcTyClGroup _ (XTyClGroup nec) = noExtCon nec
+
+tcDeclSig :: LStandaloneKindSig GhcRn -> TcM (Maybe TcTyCon)
+tcDeclSig (L l_sig kisig) =
+ case m_hdr of
+ Nothing -> return Nothing
+ Just (L l_hdr hdr) -> do
+ (_, ki) <- setSrcSpan l_sig $ tcStandaloneKindSig kisig
+ tc <- setSrcSpan l_hdr $ check_decl_sig ki hdr
+ return (Just tc)
+ where
+ m_hdr = case kisig of
+ StandaloneKindSig m_hdr _ _ -> m_hdr
+ XStandaloneKindSig hdr -> Just hdr
+
+check_decl_sig :: SAKS_or_CUSK -> DeclHeaderRn -> TcM TcTyCon
+check_decl_sig msig hdr =
+ kcDeclHeader (InitialKindCheck msig) name flav (decl_header_bndrs hdr) $
+ if | flav == ClassFlavour
+ -> return (TheKind constraintKind)
+
+ | flav == DataTypeFlavour
+ -> case res_sig of
+ Just ksig -> TheKind <$> tcLHsKindSig (DataKindCtxt name) ksig
+ Nothing -> return $ dataDeclDefaultResultKind DataType
+
+ | flav == NewtypeFlavour
+ -> case res_sig of
+ Just ksig -> TheKind <$> tcLHsKindSig (DataKindCtxt name) ksig
+ Nothing -> return $ dataDeclDefaultResultKind NewType
+
+ | is_fam_flav flav
+ -> case res_sig of
+ Just ksig -> TheKind <$> tcLHsKindSig (TyFamResKindCtxt name) ksig
+ Nothing ->
+ case msig of
+ CUSK -> return (TheKind liftedTypeKind)
+ SAKS _ -> return AnyKind
+
+ | flav == TypeSynonymFlavour
+ -> case res_sig of
+ Just rhs_sig -> TheKind <$> tcLHsKindSig (TySynKindCtxt name) rhs_sig
+ Nothing -> return AnyKind
+
+ | otherwise -> return AnyKind
+ where
+ name = decl_header_name hdr
+ flav = decl_header_flav hdr
+ res_sig = decl_header_res_sig hdr
--- Gives the kind for every TyCon that has a standalone kind signature
-type KindSigEnv = NameEnv Kind
+is_fam_flav :: TyConFlavour -> Bool
+is_fam_flav DataFamilyFlavour{} = True
+is_fam_flav OpenTypeFamilyFlavour{} = True
+is_fam_flav ClosedTypeFamilyFlavour = True
+is_fam_flav _ = False
tcTyClDecls
:: [LTyClDecl GhcRn]
- -> KindSigEnv
+ -> (Name -> Bool) -- Does this declaration have a SAKS or a CUSK?
-> RoleAnnotEnv
-> TcM ([TyCon], [DerivInfo])
-tcTyClDecls tyclds kisig_env role_annots
+tcTyClDecls tyclds is_kinded_decl role_annots
= do { -- Step 1: kind-check this group and returns the final
-- (possibly-polymorphic) kind of each TyCon and Class
-- See Note [Kind checking for type and class decls]
- tc_tycons <- kcTyClGroup kisig_env tyclds
+ tc_tycons <- kcTyClGroup is_kinded_decl tyclds
; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons))
-- Step 2: type-check all groups together, returning
@@ -618,13 +703,13 @@ been generalized.
-}
-kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM [TcTyCon]
+kcTyClGroup :: (Name -> Bool) -> [LTyClDecl GhcRn] -> TcM [TcTyCon]
-- Kind check this group, kind generalize, and return the resulting local env
-- This binds the TyCons and Classes of the group, but not the DataCons
-- See Note [Kind checking for type and class decls]
-- and Note [Inferring kinds for type declarations]
-kcTyClGroup kisig_env decls
+kcTyClGroup is_kinded_decl decls
= do { mod <- getModule
; traceTc "---- kcTyClGroup ---- {"
(text "module" <+> ppr mod $$ vcat (map ppr decls))
@@ -635,22 +720,11 @@ kcTyClGroup kisig_env decls
-- 3. Generalise the inferred kinds
-- See Note [Kind checking for type and class decls]
- ; cusks_enabled <- xoptM LangExt.CUSKs <&&> xoptM LangExt.PolyKinds
- -- See Note [CUSKs and PolyKinds]
- ; let (kindless_decls, kinded_decls) = partitionWith get_kind decls
-
- get_kind d
- | Just ki <- lookupNameEnv kisig_env (tcdName (unLoc d))
- = Right (d, SAKS ki)
-
- | cusks_enabled && hsDeclHasCusk (unLoc d)
- = Right (d, CUSK)
-
- | otherwise = Left d
-
- ; checked_tcs <- checkInitialKinds kinded_decls
+ ; let (kinded_decls, kindless_decls) = partition (is_kinded_decl . tcdName . unLoc) decls
+ ; (checked_tcs, concat -> checked_assoc_tcs) <-
+ mapAndUnzipM checkKindedDecl kinded_decls
; inferred_tcs
- <- tcExtendKindEnvWithTyCons checked_tcs $
+ <- tcExtendKindEnvWithTyCons checked_assoc_tcs $
pushTcLevelM_ $ -- We are going to kind-generalise, so
-- unification variables in here must
-- be one level in
@@ -679,7 +753,7 @@ kcTyClGroup kisig_env decls
; generalized_tcs <- concatMapM (generaliseTyClDecl inferred_tc_env)
kindless_decls
- ; let poly_tcs = checked_tcs ++ generalized_tcs
+ ; let poly_tcs = checked_tcs ++ checked_assoc_tcs ++ generalized_tcs
; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs)
; return poly_tcs }
where
@@ -1254,6 +1328,24 @@ mk_prom_err_env decl
= unitNameEnv (tcdName decl) (APromotionErr TyConPE)
-- Works for family declarations too
+mkSigPromotionErrorEnv :: [LStandaloneKindSig GhcRn] -> TcTypeEnv
+mkSigPromotionErrorEnv =
+ foldr (plusNameEnv . mk_sig_prom_err_env . unLoc) emptyNameEnv
+
+mk_sig_prom_err_env :: StandaloneKindSig GhcRn -> TcTypeEnv
+mk_sig_prom_err_env sig =
+ case m_hdr of
+ Nothing -> emptyNameEnv
+ Just (L _ hdr) ->
+ unitNameEnv (decl_header_name hdr)
+ (case decl_header_flav hdr of
+ ClassFlavour -> APromotionErr ClassPE
+ _ -> APromotionErr TyConPE)
+ where
+ m_hdr = case sig of
+ StandaloneKindSig m_hdr _ _ -> m_hdr
+ XStandaloneKindSig hdr -> Just hdr
+
--------------
inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon]
-- Returns a TcTyCon for each TyCon bound by the decls,
@@ -1261,27 +1353,24 @@ inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon]
inferInitialKinds decls
= do { traceTc "inferInitialKinds {" $ ppr (map (tcdName . unLoc) decls)
- ; tcs <- concatMapM infer_initial_kind decls
+ ; tcs <- concatMapM (addLocM inferInitialKind) decls
; traceTc "inferInitialKinds done }" empty
; return tcs }
- where
- infer_initial_kind = addLocM (getInitialKind InitialKindInfer)
-
--- Check type/class declarations against their standalone kind signatures or
--- CUSKs, producing a generalized TcTyCon for each.
-checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TcTyCon]
-checkInitialKinds decls
- = do { traceTc "checkInitialKinds {" $ ppr (mapFst (tcdName . unLoc) decls)
- ; tcs <- concatMapM check_initial_kind decls
- ; traceTc "checkInitialKinds done }" empty
- ; return tcs }
- where
- check_initial_kind (ldecl, msig) =
- addLocM (getInitialKind (InitialKindCheck msig)) ldecl
--- | Get the initial kind of a TyClDecl, either generalized or non-generalized,
--- depending on the 'InitialKindStrategy'.
-getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon]
+checkKindedDecl :: LTyClDecl GhcRn -> TcM (TcTyCon, [TcTyCon])
+checkKindedDecl (L _ (ClassDecl { tcdLName = L _ name , tcdATs = ats }))
+ = do { cls <- tcLookupTcTyCon name
+ ; let parent_tv_prs = tcTyConScopedTyVars cls
+ ; inner_tcs <-
+ tcExtendNameTyVarEnv parent_tv_prs $
+ mapM (addLocM (check_initial_kind_assoc_fam cls)) ats
+ ; return (cls, inner_tcs) }
+checkKindedDecl (L _ d)
+ = do { tc <- tcLookupTcTyCon (tcdName d)
+ ; return (tc, []) }
+
+-- | Get the initial, non-generalized kind of a TyClDecl.
+inferInitialKind :: TyClDecl GhcRn -> TcM [TcTyCon]
-- Allocate a fresh kind variable for each TyCon and Class
-- For each tycon, return a TcTyCon with kind k
@@ -1296,71 +1385,49 @@ getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon]
-- * The result kinds signature on a TyClDecl
--
-- No family instances are passed to checkInitialKinds/inferInitialKinds
-getInitialKind strategy
+inferInitialKind
(ClassDecl { tcdLName = L _ name
, tcdTyVars = ktvs
, tcdATs = ats })
- = do { cls <- kcDeclHeader strategy name ClassFlavour ktvs $
+ = do { cls <- kcDeclHeader InitialKindInfer name ClassFlavour ktvs $
return (TheKind constraintKind)
; let parent_tv_prs = tcTyConScopedTyVars cls
-- See Note [Don't process associated types in getInitialKind]
; inner_tcs <-
tcExtendNameTyVarEnv parent_tv_prs $
- mapM (addLocM (getAssocFamInitialKind cls)) ats
+ mapM (addLocM (get_fam_decl_initial_kind (Just cls))) ats
; return (cls : inner_tcs) }
- where
- getAssocFamInitialKind cls =
- case strategy of
- InitialKindInfer -> get_fam_decl_initial_kind (Just cls)
- InitialKindCheck _ -> check_initial_kind_assoc_fam cls
-getInitialKind strategy
+inferInitialKind
(DataDecl { tcdLName = L _ name
, tcdTyVars = ktvs
, tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
, dd_ND = new_or_data } })
= do { let flav = newOrDataToFlavour new_or_data
ctxt = DataKindCtxt name
- ; tc <- kcDeclHeader strategy name flav ktvs $
+ ; tc <- kcDeclHeader InitialKindInfer name flav ktvs $
case m_sig of
Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig
Nothing -> return $ dataDeclDefaultResultKind new_or_data
; return [tc] }
-getInitialKind InitialKindInfer (FamDecl { tcdFam = decl })
+inferInitialKind (FamDecl { tcdFam = decl })
= do { tc <- get_fam_decl_initial_kind Nothing decl
; return [tc] }
-getInitialKind (InitialKindCheck msig) (FamDecl { tcdFam =
- FamilyDecl { fdLName = unLoc -> name
- , fdTyVars = ktvs
- , fdResultSig = unLoc -> resultSig
- , fdInfo = info } } )
- = do { let flav = getFamFlav Nothing info
- ctxt = TyFamResKindCtxt name
- ; tc <- kcDeclHeader (InitialKindCheck msig) name flav ktvs $
- case famResultKindSignature resultSig of
- Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig
- Nothing ->
- case msig of
- CUSK -> return (TheKind liftedTypeKind)
- SAKS _ -> return AnyKind
- ; return [tc] }
-
-getInitialKind strategy
+inferInitialKind
(SynDecl { tcdLName = L _ name
, tcdTyVars = ktvs
, tcdRhs = rhs })
= do { let ctxt = TySynKindCtxt name
- ; tc <- kcDeclHeader strategy name TypeSynonymFlavour ktvs $
+ ; tc <- kcDeclHeader InitialKindInfer name TypeSynonymFlavour ktvs $
case hsTyKindSig rhs of
Just rhs_sig -> TheKind <$> tcLHsKindSig ctxt rhs_sig
Nothing -> return AnyKind
; return [tc] }
-getInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec
-getInitialKind _ (FamDecl {tcdFam = XFamilyDecl nec}) = noExtCon nec
-getInitialKind _ (XTyClDecl nec) = noExtCon nec
+inferInitialKind (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec
+inferInitialKind (XTyClDecl nec) = noExtCon nec
get_fam_decl_initial_kind
:: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls
@@ -1473,29 +1540,6 @@ See Note [Implementation of UnliftedNewtypes], STEP 1 and it's sub-note
<Error Messages>.
-}
----------------------------------
-getFamFlav
- :: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls
- -> FamilyInfo pass
- -> TyConFlavour
-getFamFlav mb_parent_tycon info =
- case info of
- DataFamily -> DataFamilyFlavour mb_parent_tycon
- OpenTypeFamily -> OpenTypeFamilyFlavour mb_parent_tycon
- ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon ) -- See Note [Closed type family mb_parent_tycon]
- ClosedTypeFamilyFlavour
-
-{- Note [Closed type family mb_parent_tycon]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There's no way to write a closed type family inside a class declaration:
-
- class C a where
- type family F a where -- error: parse error on input ‘where’
-
-In fact, it is not clear what the meaning of such a declaration would be.
-Therefore, 'mb_parent_tycon' of any closed type family has to be Nothing.
--}
-
------------------------------------------------------------------------
kcLTyClDecl :: LTyClDecl GhcRn -> TcM ()
-- See Note [Kind checking for type and class decls]
diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
index 57da7c2199..db0f6aced4 100644
--- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
@@ -109,7 +109,17 @@
({ <no location info> }
[]))))]
[]
- []
+ [({ DumpRenamedAst.hs:9:1-30 }
+ (XStandaloneKindSig
+ ({ DumpRenamedAst.hs:9:1-30 }
+ (DeclHeaderRn
+ (DataTypeFlavour)
+ {Name: DumpRenamedAst.Peano}
+ (True)
+ (HsQTvs
+ []
+ [])
+ (Nothing)))))]
[])
,(TyClGroup
(NoExtField)
@@ -229,7 +239,36 @@
{Name: DumpRenamedAst.Peano})))))
(Nothing))))]
[]
- []
+ [({ DumpRenamedAst.hs:11:1-39 }
+ (XStandaloneKindSig
+ ({ DumpRenamedAst.hs:11:1-39 }
+ (DeclHeaderRn
+ (ClosedTypeFamilyFlavour)
+ {Name: DumpRenamedAst.Length}
+ (True)
+ (HsQTvs
+ [{Name: k}]
+ [({ DumpRenamedAst.hs:11:21-29 }
+ (KindedTyVar
+ (NoExtField)
+ ({ DumpRenamedAst.hs:11:21-22 }
+ {Name: as})
+ ({ DumpRenamedAst.hs:11:27-29 }
+ (HsListTy
+ (NoExtField)
+ ({ DumpRenamedAst.hs:11:28 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:11:28 }
+ {Name: k})))))))])
+ (Just
+ ({ DumpRenamedAst.hs:11:35-39 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:11:35-39 }
+ {Name: DumpRenamedAst.Peano}))))))))]
[])
,(TyClGroup
(NoExtField)
@@ -274,7 +313,42 @@
{Name: GHC.Types.Type})))))))))
(Nothing))))]
[]
- []
+ [({ DumpRenamedAst.hs:15:1-33 }
+ (XStandaloneKindSig
+ ({ DumpRenamedAst.hs:15:1-33 }
+ (DeclHeaderRn
+ (DataFamilyFlavour
+ (Nothing))
+ {Name: DumpRenamedAst.Nat}
+ (True)
+ (HsQTvs
+ [{Name: k}]
+ [])
+ (Just
+ ({ DumpRenamedAst.hs:15:20-33 }
+ (HsFunTy
+ (NoExtField)
+ ({ DumpRenamedAst.hs:15:20 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:15:20 }
+ {Name: k})))
+ ({ DumpRenamedAst.hs:15:25-33 }
+ (HsFunTy
+ (NoExtField)
+ ({ DumpRenamedAst.hs:15:25 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:15:25 }
+ {Name: k})))
+ ({ DumpRenamedAst.hs:15:30-33 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:15:30-33 }
+ {Name: GHC.Types.Type}))))))))))))]
[({ DumpRenamedAst.hs:(18,1)-(19,45) }
(DataFamInstD
(NoExtField)
@@ -627,7 +701,53 @@
{Name: GHC.Types.Type})))))
(Nothing))))]
[]
- []
+ [({ DumpRenamedAst.hs:23:1-48 }
+ (XStandaloneKindSig
+ ({ DumpRenamedAst.hs:23:1-48 }
+ (DeclHeaderRn
+ (ClosedTypeFamilyFlavour)
+ {Name: DumpRenamedAst.F1}
+ (True)
+ (HsQTvs
+ [{Name: k}]
+ [({ DumpRenamedAst.hs:23:17-22 }
+ (KindedTyVar
+ (NoExtField)
+ ({ DumpRenamedAst.hs:23:17 }
+ {Name: a})
+ ({ DumpRenamedAst.hs:23:22 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:23:22 }
+ {Name: k})))))
+ ,({ DumpRenamedAst.hs:23:26-39 }
+ (KindedTyVar
+ (NoExtField)
+ ({ DumpRenamedAst.hs:23:26 }
+ {Name: f})
+ ({ DumpRenamedAst.hs:23:31-39 }
+ (HsFunTy
+ (NoExtField)
+ ({ DumpRenamedAst.hs:23:31 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:23:31 }
+ {Name: k})))
+ ({ DumpRenamedAst.hs:23:36-39 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:23:36-39 }
+ {Name: GHC.Types.Type})))))))])
+ (Just
+ ({ DumpRenamedAst.hs:23:45-48 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ DumpRenamedAst.hs:23:45-48 }
+ {Name: GHC.Types.Type}))))))))]
[])]
[]
[]