[Git][ghc/ghc][wip/tycl-group] 2 commits: tcLookupTcTyCon for kinded decls
Vladislav Zavialov
gitlab at gitlab.haskell.org
Wed Mar 18 17:12:17 UTC 2020
Vladislav Zavialov pushed to branch wip/tycl-group at Glasgow Haskell Compiler / GHC
Commits:
f6ef692e by Vladislav Zavialov at 2020-03-18T17:11:56Z
tcLookupTcTyCon for kinded decls
- - - - -
117800fe by Vladislav Zavialov at 2020-03-18T17:11:56Z
split_group test
- - - - -
11 changed files:
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Driver/Plugins.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Extension.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Rename/Source.hs
- compiler/typecheck/TcEnv.hs
- compiler/typecheck/TcHsType.hs
- compiler/typecheck/TcRnDriver.hs
- compiler/typecheck/TcTyClsDecls.hs
Changes:
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -7,6 +7,7 @@ The @TyCon@ datatype
-}
{-# LANGUAGE CPP, FlexibleInstances #-}
+{-# LANGUAGE DeriveDataTypeable #-}
module GHC.Core.TyCon(
-- * Main TyCon data types
@@ -2583,7 +2584,7 @@ data TyConFlavour
| TypeSynonymFlavour
| BuiltInTypeFlavour -- ^ e.g., the @(->)@ 'TyCon'.
| PromotedDataConFlavour
- deriving Eq
+ deriving (Eq, Data.Data)
instance Outputable TyConFlavour where
ppr = text . go
=====================================
compiler/GHC/Driver/Plugins.hs
=====================================
@@ -229,7 +229,7 @@ keepRenamedSource _ gbl_env group =
update_exports Nothing = Just []
update_exports m = m
- update Nothing = Just emptyRnGroup
+ update Nothing = Just (emptyRnGroup :: HsGroup GhcRn)
update m = m
=====================================
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 #-}
@@ -30,6 +31,7 @@ module GHC.Hs.Decls (
-- ** Class or type declarations
TyClDecl(..), LTyClDecl, DataDeclRn(..),
+ DeclHeaderRn(..), DeclSigRn(..),
TyClGroup(..),
tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,
tyClGroupKindSigs,
@@ -43,7 +45,7 @@ module GHC.Hs.Decls (
FamilyDecl(..), LFamilyDecl,
-- ** Instance declarations
- InstDecl(..), LInstDecl, FamilyInfo(..),
+ InstDecl(..), LInstDecl, FamilyInfo(..), getFamFlav,
TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
TyFamDefltDecl, LTyFamDefltDecl,
DataFamInstDecl(..), LDataFamInstDecl,
@@ -89,11 +91,14 @@ module GHC.Hs.Decls (
resultVariableName, familyDeclLName, familyDeclName,
-- * Grouping
+ KindedDecls(..), isKindedDecl,
HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups,
hsGroupTopLevelFixitySigs,
) where
+#include "HsVersions.h"
+
-- friends:
import GhcPrelude
@@ -122,6 +127,7 @@ import Bag
import Maybes
import Data.Data hiding (TyCon,Fixity, Infix)
import Data.Void
+import qualified Data.Semigroup
{-
************************************************************************
@@ -252,15 +258,28 @@ data HsGroup p
}
| XHsGroup (XXHsGroup p)
-type instance XCHsGroup (GhcPass _) = NoExtField
+type instance XCHsGroup GhcPs = NoExtField
+type instance XCHsGroup GhcRn = KindedDecls
+type instance XCHsGroup GhcTc = KindedDecls
type instance XXHsGroup (GhcPass _) = NoExtCon
+-- | Names of declarations that either have a CUSK or a SAKS.
+newtype KindedDecls = KindedDecls NameSet
+
+instance Semigroup KindedDecls where
+ KindedDecls a <> KindedDecls b = KindedDecls (unionNameSet a b)
+
+instance Monoid KindedDecls where
+ mempty = KindedDecls emptyNameSet
-emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass p)
+isKindedDecl :: KindedDecls -> TyClDecl GhcRn -> Bool
+isKindedDecl (KindedDecls nameSet) d = elemNameSet (tcdName d) nameSet
+
+emptyGroup, emptyRdrGroup, emptyRnGroup :: Monoid (XCHsGroup (GhcPass p)) => HsGroup (GhcPass p)
emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut }
-emptyGroup = HsGroup { hs_ext = noExtField,
+emptyGroup = HsGroup { hs_ext = mempty,
hs_tyclds = [],
hs_derivds = [],
hs_fixds = [], hs_defds = [], hs_annds = [],
@@ -282,10 +301,12 @@ hsGroupTopLevelFixitySigs (HsGroup{ hs_fixds = fixds, hs_tyclds = tyclds }) =
]
hsGroupTopLevelFixitySigs (XHsGroup nec) = noExtCon nec
-appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p)
+appendGroups :: Semigroup (XCHsGroup (GhcPass p))
+ => HsGroup (GhcPass p) -> HsGroup (GhcPass p)
-> HsGroup (GhcPass p)
appendGroups
HsGroup {
+ hs_ext = ext1,
hs_valds = val_groups1,
hs_splcds = spliceds1,
hs_tyclds = tyclds1,
@@ -298,6 +319,7 @@ appendGroups
hs_ruleds = rulds1,
hs_docs = docs1 }
HsGroup {
+ hs_ext = ext2,
hs_valds = val_groups2,
hs_splcds = spliceds2,
hs_tyclds = tyclds2,
@@ -311,7 +333,7 @@ appendGroups
hs_docs = docs2 }
=
HsGroup {
- hs_ext = noExtField,
+ hs_ext = ext1 Data.Semigroup.<> ext2,
hs_valds = val_groups1 `plusHsValBinds` val_groups2,
hs_splcds = spliceds1 ++ spliceds2,
hs_tyclds = tyclds1 ++ tyclds2,
@@ -972,6 +994,28 @@ See Note [Dependency analysis of type, class, and instance decls]
in GHC.Rename.Source for more info.
-}
+-- | 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 :: Located (IdP GhcRn),
+ decl_header_bndrs :: LHsQTyVars GhcRn,
+ decl_header_res_sig :: Maybe (LHsType GhcRn)
+ }
+
-- | Type or Class Group
data family TyClGroup pass
@@ -981,11 +1025,23 @@ data instance TyClGroup GhcPs
| TcgPsKiSig (LStandaloneKindSig GhcPs)
| TcgPsInst (LInstDecl GhcPs)
+-- | Declaration signature (CUSK or SAKS).
+data DeclSigRn
+ = DeclSigRnCUSK
+ (Located DeclHeaderRn) -- Complete user-specified kind (CUSK)
+ | DeclSigRnSAKS
+ (Located DeclHeaderRn) -- Not necessarily a CUSK
+ (LStandaloneKindSig GhcRn) -- Standalone kind signature (SAKS)
+
+instance Outputable DeclSigRn where
+ ppr (DeclSigRnCUSK hdr) = text "CUSK:" <+> ppr (decl_header_name (unLoc hdr))
+ ppr (DeclSigRnSAKS _ sig) = ppr sig
+
-- See Note [TyClGroups and dependency analysis]
data instance TyClGroup GhcRn =
TcgRn { tcg_rn_tyclds :: [LTyClDecl GhcRn]
, tcg_rn_roles :: [LRoleAnnotDecl GhcRn]
- , tcg_rn_kisigs :: [LStandaloneKindSig GhcRn]
+ , tcg_rn_kisigs :: [DeclSigRn]
, tcg_rn_instds :: [LInstDecl GhcRn] }
newtype instance TyClGroup GhcTc = TcgTc Void
@@ -1018,7 +1074,7 @@ tyClGroupKindSigs :: forall p. IsPass p => TyClGroup (GhcPass p) -> [LStandalone
tyClGroupKindSigs tcg =
case ghcPass @p of
GhcPs -> [a | TcgPsKiSig a <- [tcg] ]
- GhcRn -> tcg_rn_kisigs tcg
+ GhcRn -> [a | DeclSigRnSAKS _ a <- tcg_rn_kisigs tcg ]
GhcTc -> tcg_tc_absurd tcg
{- *********************************************************************
@@ -1175,6 +1231,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 -----------
=====================================
compiler/GHC/Hs/Extension.hs
=====================================
@@ -28,6 +28,7 @@ module GHC.Hs.Extension where
import GhcPrelude
import Data.Data hiding ( Fixity )
+import Data.Semigroup
import Name
import RdrName
import Var
@@ -143,6 +144,12 @@ data NoExtField = NoExtField
instance Outputable NoExtField where
ppr _ = text "NoExtField"
+instance Semigroup NoExtField where
+ _ <> _ = NoExtField
+
+instance Monoid NoExtField where
+ mempty = NoExtField
+
-- | Used when constructing a term with an unused extension point.
noExtField :: NoExtField
noExtField = NoExtField
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -104,6 +104,8 @@ deriving instance Data (HsDecl GhcPs)
deriving instance Data (HsDecl GhcRn)
deriving instance Data (HsDecl GhcTc)
+deriving instance Data KindedDecls
+
-- deriving instance (DataIdLR p p) => Data (HsGroup p)
deriving instance Data (HsGroup GhcPs)
deriving instance Data (HsGroup GhcRn)
@@ -119,6 +121,9 @@ deriving instance Data (TyClDecl GhcPs)
deriving instance Data (TyClDecl GhcRn)
deriving instance Data (TyClDecl GhcTc)
+deriving instance Data DeclHeaderRn
+deriving instance Data DeclSigRn
+
-- deriving instance (DataIdLR p p) => Data (TyClGroup p)
deriving instance Data (TyClGroup GhcPs)
deriving instance Data (TyClGroup GhcRn)
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1267,7 +1267,7 @@ instance ToHie (TyClGroup GhcRn) where
, tcg_rn_instds = instances } =
concatM
[ toHie classes
- , toHie sigs
+ , toHie [a | DeclSigRnSAKS _ a <- sigs ]
, toHie roles
, toHie instances
]
=====================================
compiler/GHC/Rename/Source.hs
=====================================
@@ -52,6 +52,7 @@ import PrelNames ( applicativeClassName, pureAName, thenAName
import Name
import NameSet
import NameEnv
+import GHC.Core.TyCon ( TyConFlavour(..) )
import Avail
import Outputable
import Bag
@@ -59,7 +60,8 @@ import BasicTypes ( pprRuleName, TypeOrKind(..) )
import FastString
import 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(..)
@@ -160,7 +162,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
-- means we'll only report a declaration as unused if it isn't
-- mentioned at all. Ah well.
traceRn "Start rnTyClDecls" (ppr tycl_decls) ;
- (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
+ (rn_tycl_decls, kinded_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
-- (F) Rename Value declarations right-hand sides
traceRn "Start rnmono" empty ;
@@ -202,7 +204,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
last_tcg_env <- getGblEnv ;
-- (I) Compute the results and return
- let {rn_group = HsGroup { hs_ext = noExtField,
+ let {rn_group = HsGroup { hs_ext = kinded_decls,
hs_valds = rn_val_decls,
hs_splcds = rn_splice_decls,
hs_tyclds = rn_tycl_decls,
@@ -1287,7 +1289,7 @@ constructors] in TcEnv
rnTyClDecls :: [TyClGroup GhcPs]
- -> RnM ([TyClGroup GhcRn], FreeVars)
+ -> RnM ([TyClGroup GhcRn], KindedDecls, FreeVars)
-- Rename the declarations and do dependency analysis on them
rnTyClDecls tycl_ds
= do { -- Rename the type/class, instance, and role declaraations
@@ -1297,11 +1299,19 @@ rnTyClDecls tycl_ds
; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (concatMap tyClGroupInstDecls tycl_ds)
; role_annots <- rnRoleAnnots tc_names (concatMap tyClGroupRoleDecls 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
+ decl_sig_list =
+ mapMaybe (mkDeclSigRn cusks_enabled kisig_env . fst) $
+ tycls_w_fvs
+ decl_sig_env = mkNameEnv decl_sig_list
+ kinded_decls = KindedDecls (mkNameSet (map fst decl_sig_list))
+
-- Do SCC analysis on the type/class decls
; 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
@@ -1314,38 +1324,105 @@ rnTyClDecls tycl_ds
, tcg_rn_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 decl_sig_env) rest_inst_ds tycl_sccs
all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs `plusFV`
foldr (plusFV . snd) emptyFVs instds_w_fvs `plusFV`
foldr (plusFV . snd) emptyFVs kisigs_w_fvs
- all_groups = first_group ++ groups
+ all_groups = concatMap split_group (first_group ++ groups)
; MASSERT2( null final_inst_ds, ppr instds_w_fvs $$ ppr inst_ds_map
$$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds )
; traceRn "rnTycl dependency analysis made groups" (ppr all_groups)
- ; return (all_groups, all_fvs) }
+ ; return (all_groups, kinded_decls, all_fvs) }
where
mk_group :: RoleAnnotEnv
- -> KindSigEnv
+ -> NameEnv DeclSigRn
-> InstDeclFreeVarsMap
-> SCC (LTyClDecl GhcRn)
-> (InstDeclFreeVarsMap, TyClGroup GhcRn)
- mk_group role_env kisig_env inst_map scc
+ mk_group role_env decl_sig_env inst_map scc
= (inst_map', group)
where
tycl_ds = flattenSCC scc
bndrs = map (tcdName . unLoc) tycl_ds
roles = getRoleAnnots bndrs role_env
- kisigs = getKindSigs bndrs kisig_env
+ decl_sigs = getDeclSigs bndrs decl_sig_env
(inst_ds, inst_map') = getInsts bndrs inst_map
group = TcgRn { tcg_rn_tyclds = tycl_ds
- , tcg_rn_kisigs = kisigs
+ , tcg_rn_kisigs = decl_sigs
, tcg_rn_roles = roles
, tcg_rn_instds = inst_ds }
+ split_group :: TyClGroup GhcRn -> [TyClGroup GhcRn]
+ split_group (TcgRn tyclds [] kisigs []) =
+ [TcgRn [] [] kisigs [], TcgRn tyclds [] [] []]
+ split_group g = [g]
+
+mkDeclSigRn
+ :: Bool -- ^ CUSKs enabled
+ -> KindSigEnv
+ -> LTyClDecl GhcRn
+ -> Maybe (Name, DeclSigRn)
+mkDeclSigRn cusks_enabled kisig_env tcd
+ -- Stanadlone kind signature
+ | Just ki <- lookupNameEnv kisig_env name
+ = Just (name, DeclSigRnSAKS decl_header ki)
+ -- Complete user-supplied kind
+ | cusks_enabled && has_cusk
+ = Just (name, DeclSigRnCUSK decl_header)
+ -- No signature: needs inference
+ | otherwise
+ = Nothing
+ where
+ has_cusk = hsDeclHasCusk (unLoc tcd)
+ name = tcdName (unLoc tcd)
+ decl_header = mapLoc mkDeclHeaderRn tcd
+
+mkDeclHeaderRn :: TyClDecl GhcRn -> DeclHeaderRn
+mkDeclHeaderRn tcd = case tcd of
+ -- Class
+ ClassDecl { tcdLName = name, tcdTyVars = ktvs }
+ -> DeclHeaderRn
+ { decl_header_flav = ClassFlavour,
+ decl_header_name = name,
+ decl_header_bndrs = ktvs,
+ decl_header_res_sig = Nothing }
+ -- Data/Newtype
+ DataDecl { tcdLName = name
+ , tcdTyVars = ktvs
+ , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
+ , dd_ND = new_or_data } }
+ -> DeclHeaderRn
+ { decl_header_flav = newOrDataToFlavour new_or_data,
+ decl_header_name = name,
+ decl_header_bndrs = ktvs,
+ decl_header_res_sig = m_sig }
+ -- Type/data family
+ FamDecl { tcdFam =
+ FamilyDecl { fdLName = name
+ , fdTyVars = ktvs
+ , fdResultSig = L _ resultSig
+ , fdInfo = info } }
+ -> DeclHeaderRn
+ { decl_header_flav = getFamFlav Nothing info,
+ decl_header_name = name,
+ decl_header_bndrs = ktvs,
+ decl_header_res_sig = famResultKindSignature resultSig }
+ -- Type synonym
+ SynDecl { tcdLName = name, tcdTyVars = ktvs, tcdRhs = rhs }
+ -> DeclHeaderRn
+ { decl_header_flav = TypeSynonymFlavour,
+ decl_header_name = name,
+ decl_header_bndrs = ktvs,
+ decl_header_res_sig = hsTyKindSig rhs }
+ -- Impossible cases
+ DataDecl _ _ _ _ (XHsDataDefn nec) -> noExtCon nec
+ FamDecl {tcdFam = XFamilyDecl nec} -> noExtCon nec
+ XTyClDecl nec -> noExtCon nec
+
-- | Free variables of standalone kind signatures.
newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars)
@@ -1364,8 +1441,8 @@ mkKindSig_fv_env kisigs_w_fvs = (kisig_env, kisig_fv_env)
compound_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars)
= mkNameEnvWith (standaloneKindSigName . unLoc . fst) kisigs_w_fvs
-getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn]
-getKindSigs bndrs kisig_env = mapMaybe (lookupNameEnv kisig_env) bndrs
+getDeclSigs :: [Name] -> NameEnv DeclSigRn -> [DeclSigRn]
+getDeclSigs bndrs decl_sig_env = mapMaybe (lookupNameEnv decl_sig_env) bndrs
rnStandaloneKindSignatures
:: NameSet -- names of types and classes in the current TyClGroup
=====================================
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 thing)
getInLocalScope :: TcM (Name -> Bool)
getInLocalScope = do { lcl_env <- getLclTypeEnv
=====================================
compiler/typecheck/TcHsType.hs
=====================================
@@ -251,8 +251,8 @@ 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, Kind)
+tcStandaloneKindSig kisig = case kisig of
StandaloneKindSig _ (L _ name) ksig ->
let ctxt = StandaloneKindSigCtxt name in
addSigCtxt ctxt (hsSigType ksig) $
=====================================
compiler/typecheck/TcRnDriver.hs
=====================================
@@ -625,7 +625,8 @@ tcRnHsBootDecls hsc_src decls
= do { (first_group, group_tail) <- findSplice decls
-- Rename the declarations
- ; (tcg_env, HsGroup { hs_tyclds = tycl_decls
+ ; (tcg_env, HsGroup { hs_ext = kinded_decls
+ , hs_tyclds = tycl_decls
, hs_derivds = deriv_decls
, hs_fords = for_decls
, hs_defds = def_decls
@@ -653,7 +654,7 @@ tcRnHsBootDecls hsc_src decls
-- Typecheck type/class/instance decls
; traceTc "Tc2 (boot)" empty
; (tcg_env, inst_infos, _deriv_binds)
- <- tcTyClsInstDecls tycl_decls deriv_decls val_binds
+ <- tcTyClsInstDecls kinded_decls tycl_decls deriv_decls val_binds
; setGblEnv tcg_env $ do {
-- Emit Typeable bindings
@@ -1396,7 +1397,8 @@ rnTopSrcDecls group
}
tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv)
-tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
+tcTopSrcDecls (HsGroup { hs_ext = kinded_decls,
+ hs_tyclds = tycl_decls,
hs_derivds = deriv_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
@@ -1412,7 +1414,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
-- and import the supporting declarations
traceTc "Tc3" empty ;
(tcg_env, inst_infos, XValBindsLR (NValBinds deriv_binds deriv_sigs))
- <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ;
+ <- tcTyClsInstDecls kinded_decls tycl_decls deriv_decls val_binds ;
setGblEnv tcg_env $ do {
@@ -1681,7 +1683,8 @@ tcMissingParentClassWarn warnFlag isName shouldName
---------------------------
-tcTyClsInstDecls :: [TyClGroup GhcRn]
+tcTyClsInstDecls :: KindedDecls
+ -> [TyClGroup GhcRn]
-> [LDerivDecl GhcRn]
-> [(RecFlag, LHsBinds GhcRn)]
-> TcM (TcGblEnv, -- The full inst env
@@ -1691,11 +1694,11 @@ tcTyClsInstDecls :: [TyClGroup GhcRn]
HsValBinds GhcRn) -- Supporting bindings for derived
-- instances
-tcTyClsInstDecls tycl_decls deriv_decls binds
+tcTyClsInstDecls kinded_decls tycl_decls deriv_decls binds
= tcAddDataFamConPlaceholders (tycl_decls >>= tyClGroupInstDecls) $
tcAddPatSynPlaceholders (getPatSynBinds binds) $
do { (tcg_env, inst_info, deriv_info)
- <- tcTyAndClassDecls tycl_decls ;
+ <- tcTyAndClassDecls kinded_decls tycl_decls ;
; setGblEnv tcg_env $ do {
-- With the @TyClDecl at s and @InstDecl at s checked we're ready to
-- process the deriving clauses, including data family deriving
=====================================
compiler/typecheck/TcTyClsDecls.hs
=====================================
@@ -123,7 +123,25 @@ Thus, we take two passes over the resulting tycons, first checking for general
validity and then checking for valid role annotations.
-}
-tcTyAndClassDecls :: [TyClGroup GhcRn] -- Mutually-recursive groups in
+-- | 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
+
+tcTyAndClassDecls :: KindedDecls
+ -> [TyClGroup GhcRn] -- Mutually-recursive groups in
-- dependency order
-> TcM ( TcGblEnv -- Input env extended by types and
-- classes
@@ -132,32 +150,38 @@ tcTyAndClassDecls :: [TyClGroup GhcRn] -- Mutually-recursive groups in
, [DerivInfo] -- Deriving info
)
-- Fails if there are any errors
-tcTyAndClassDecls tyclds_s
+tcTyAndClassDecls kinded_decls 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 kinded_decls 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 :: KindedDecls
+ -> 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 (TcgRn { tcg_rn_tyclds = tyclds
+tcTyClGroup kinded_decls inter_group_env
+ (TcgRn { tcg_rn_tyclds = tyclds
, tcg_rn_roles = roles
, tcg_rn_kisigs = kisigs
, tcg_rn_instds = instds })
@@ -166,10 +190,18 @@ tcTyClGroup (TcgRn { tcg_rn_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) $
+ traverse tcDeclSig kisigs
+ ; let extended_inter_group_env = extendInterGroupEnv checked_tcs inter_group_env
+ ; (tyclss, data_deriv_info) <-
+ tcExtendKindEnvWithTyCons (interGroupEnvTyCons extended_inter_group_env) $
+ tcTyClDecls tyclds kinded_decls 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,21 +232,66 @@ tcTyClGroup (TcgRn { tcg_rn_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) }
+
+tcDeclSig :: DeclSigRn -> TcM TcTyCon
+tcDeclSig (DeclSigRnCUSK (L l hdr)) =
+ setSrcSpan l $ check_decl_sig CUSK hdr
+tcDeclSig (DeclSigRnSAKS (L l_hdr hdr) (L l_sig kisig)) = do
+ (_, ki) <- setSrcSpan l_sig $ tcStandaloneKindSig kisig
+ setSrcSpan l_hdr $ check_decl_sig (SAKS ki) 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
+ L _ 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
+ -> KindedDecls
-> RoleAnnotEnv
-> TcM ([TyCon], [DerivInfo])
-tcTyClDecls tyclds kisig_env role_annots
+tcTyClDecls tyclds kinded_decls 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 kinded_decls tyclds
; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons))
-- Step 2: type-check all groups together, returning
@@ -615,13 +692,13 @@ been generalized.
-}
-kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM [TcTyCon]
+kcTyClGroup :: KindedDecls -> [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 kd_set decls
= do { mod <- getModule
; traceTc "---- kcTyClGroup ---- {"
(text "module" <+> ppr mod $$ vcat (map ppr decls))
@@ -632,22 +709,16 @@ 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)
+ get_kind (L l d)
+ | isKindedDecl kd_set d = Right d
+ | otherwise = Left (L l d)
- | otherwise = Left d
-
- ; checked_tcs <- checkInitialKinds kinded_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
@@ -676,7 +747,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
@@ -1251,6 +1322,21 @@ mk_prom_err_env decl
= unitNameEnv (tcdName decl) (APromotionErr TyConPE)
-- Works for family declarations too
+mkSigPromotionErrorEnv :: [DeclSigRn] -> TcTypeEnv
+mkSigPromotionErrorEnv =
+ foldr (plusNameEnv . mk_sig_prom_err_env) emptyNameEnv
+
+mk_sig_prom_err_env :: DeclSigRn -> TcTypeEnv
+mk_sig_prom_err_env sig =
+ unitNameEnv (unLoc (decl_header_name hdr))
+ (case decl_header_flav hdr of
+ ClassFlavour -> APromotionErr ClassPE
+ _ -> APromotionErr TyConPE)
+ where
+ hdr = case sig of
+ DeclSigRnCUSK (L _ h) -> h
+ DeclSigRnSAKS (L _ h) _ -> h
+
--------------
inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon]
-- Returns a TcTyCon for each TyCon bound by the decls,
@@ -1258,27 +1344,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 :: TyClDecl GhcRn -> TcM (TcTyCon, [TcTyCon])
+checkKindedDecl (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 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
@@ -1293,71 +1376,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
@@ -1470,29 +1531,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]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/75b41923593348964d40ccbcf27b864240fa0658...117800fe7631e454ac7e7db9976c2548bc79f349
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/75b41923593348964d40ccbcf27b864240fa0658...117800fe7631e454ac7e7db9976c2548bc79f349
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200318/8695a0b6/attachment-0001.html>
More information about the ghc-commits
mailing list