summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-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}))))))))]
[])]
[]
[]
View Lorry Controller Status