[Git][ghc/ghc][wip/sand-witch/dep-anal] Progress: ghc panics with out-of-scope sigs
Vladislav Zavialov (@int-index)
gitlab at gitlab.haskell.org
Tue Jun 27 20:36:44 UTC 2023
Vladislav Zavialov pushed to branch wip/sand-witch/dep-anal at Glasgow Haskell Compiler / GHC
Commits:
b492edf0 by Vladislav Zavialov at 2023-06-27T22:36:35+02:00
Progress: ghc panics with out-of-scope sigs
- - - - -
4 changed files:
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/TyCl.hs
Changes:
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -132,6 +132,7 @@ import GHC.Data.Bag
import GHC.Data.Maybe
import Data.Data (Data)
import Data.Foldable (toList)
+import Data.Void
{-
************************************************************************
@@ -671,7 +672,7 @@ type LDeclHeaderRn = LocatedA DeclHeaderRn
--
data DeclHeaderRn
= DeclHeaderRn
- { decl_header_flav :: TyConFlavour GhcRn,
+ { decl_header_flav :: TyConFlavour Void,
decl_header_name :: Name,
decl_header_cusk :: Bool,
decl_header_bndrs :: LHsQTyVars GhcRn,
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -62,7 +62,7 @@ import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Driver.Env ( HscEnv(..), hsc_home_unit)
import GHC.Data.List.SetOps ( findDupsEq, removeDupsOn, equivClasses )
-import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..)
+import GHC.Data.Graph.Directed ( SCC, flattenSCC, Node(..)
, stronglyConnCompFromEdgedVerticesUniq, stronglyConnCompFromEdgedVerticesOrd )
import GHC.Types.Unique.Set
import GHC.Data.OrdList
@@ -1414,13 +1414,11 @@ rnTyClDecls :: [TyClGroup GhcPs]
rnTyClDecls tycl_ds
= do { -- Rename the type/class, instance, and role declarations
; tycls_w_fvs' <- mapM (wrapLocFstMA rnTyClDecl) (tyClGroupTyClDecls tycl_ds)
- ; let
- tycls_w_fvs = map (\(L l (t, fv1), fv2) -> (L l t, fv1 `plusFV` fv2)) tycls_w_fvs'
- tycls_w_fvs_new = map (\(L l (t, fv1), fv2) -> ((L l t, fv1), fv2)) tycls_w_fvs'
- ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs)
- ; let decl_headers = mkNameEnv (map mk_pair tycls_w_fvs_new)
+ ; let tycls_w_fvs = map (\(L l (t, fv1), fv2) -> ((L l t, fv1), fv2)) tycls_w_fvs'
+ ; let tc_names = mkNameSet (map (tcdName . unLoc . fst . fst) tycls_w_fvs)
+ ; let decl_headers = mkNameEnv (map mk_pair tycls_w_fvs)
where
- mk_pair = \((L l t, _fv1), fv2)->
+ mk_pair ((L l t, _fv1), fv2) =
let hdr = mkDeclHeaderRn t
in (decl_header_name hdr, (L l hdr, fv2))
; traceRn "rnTyClDecls" $
@@ -1428,67 +1426,21 @@ rnTyClDecls tycl_ds
, text "tc_names:" <+> ppr tc_names ]
; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names decl_headers (tyClGroupKindSigs tycl_ds)
; instds_w_fvs <- mapM (wrapLocFstMA rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)
- ; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)
+ -- ; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)
-- Do SCC analysis on the type/class decls
; rdr_env <- getGlobalRdrEnv
; traceRn "rnTyClDecls SCC analysis" $
vcat [ text "rdr_env:" <+> ppr rdr_env ]
- ; 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
-
- first_group
- | null init_inst_ds = []
- | otherwise = [TyClGroup { group_ext = noExtField
- , group_tyclds = []
- , group_kisigs = []
- , group_roles = []
- , group_instds = init_inst_ds }]
-
- (final_inst_ds, groups)
- = mapAccumL (mk_group role_annot_env kisig_env) rest_inst_ds tycl_sccs
-
- all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs `plusFV`
+ ; let 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
+ ; let all_groups = doDepAnal kisigs_w_fvs instds_w_fvs tycls_w_fvs rdr_env
- all_groups = first_group ++ groups
-
- ; massertPpr (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)
-
- ; traceRn "rnTyClDecls NEW SCC anal could have made groups" $
- (ppr (doDepAnal kisigs_w_fvs instds_w_fvs tycls_w_fvs_new rdr_env))
+ ; traceRn "rnTyClDecls made groups" $
+ (ppr all_groups)
; return (all_groups, all_fvs) }
- where
- mk_group :: RoleAnnotEnv
- -> KindSigEnv
- -> InstDeclFreeVarsMap
- -> SCC (LTyClDecl GhcRn)
- -> (InstDeclFreeVarsMap, TyClGroup GhcRn)
- mk_group role_env kisig_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
- (inst_ds, inst_map') = getInsts bndrs inst_map
- group = TyClGroup { group_ext = noExtField
- , group_tyclds = tycl_ds
- , group_kisigs = kisigs
- , group_roles = roles
- , group_instds = inst_ds }
-- | Free variables of standalone kind signatures.
newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars)
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -580,14 +580,16 @@ top level of a signature.
-}
-- Does validity checking and zonking.
-tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind)
+tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, SAKS_or_CUSK)
tcStandaloneKindSig (L _ (StandaloneKindSig _ (L _ name) ksig))
= addSigCtxt ctxt ksig $
do { kind <- tc_top_lhs_type KindLevel ctxt ksig
; checkValidType ctxt kind
- ; return (name, kind) }
+ ; return (name, SAKS kind) }
where
ctxt = StandaloneKindSigCtxt name
+tcStandaloneKindSig (L _ (XStandaloneKindSig hdr)) =
+ return (decl_header_name (unLoc hdr), CUSK)
tcTopLHsType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcTopLHsType ctxt lsig_ty
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -115,6 +115,7 @@ import Data.List ( partition)
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
import Data.Tuple( swap )
+import Data.Void
{-
************************************************************************
@@ -201,8 +202,29 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds))
; (tyclss, data_deriv_info, kindless) <-
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) $
+ mapM tcDeclSig kisigs
+ -- FIXME: false positives because there might be signatures/cusks
+ -- in previous declaration groups
+ ; let is_kinded_decl name = any (\tctc -> tyConName tctc == name) checked_tcs
+ ; tcExtendKindEnvWithTyCons checked_tcs $
+ tcTyClDecls tyclds is_kinded_decl 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)
@@ -238,20 +260,83 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
; return (gbl_env'', inst_info, deriv_info,
th_bndrs' `plusNameEnv` th_bndrs) }
--- Gives the kind for every TyCon that has a standalone kind signature
-type KindSigEnv = NameEnv Kind
+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 =
+ unitNameEnv (decl_header_name hdr)
+ (case decl_header_flav hdr of
+ ClassFlavour -> APromotionErr ClassPE
+ _ -> APromotionErr TyConPE)
+ where
+ (L _ hdr) = case sig of
+ StandaloneKindSig hdr _ _ -> hdr
+ XStandaloneKindSig hdr -> hdr
+
+tcDeclSig :: LStandaloneKindSig GhcRn -> TcM TcTyCon
+tcDeclSig kisig = do
+ (_, ki) <- tcStandaloneKindSig kisig
+ tc <- check_decl_sig ki hdr
+ return tc
+ where
+ (L _ hdr) = case unLoc kisig of
+ StandaloneKindSig hdr _ _ -> hdr
+ XStandaloneKindSig hdr -> hdr
+
+check_decl_sig :: SAKS_or_CUSK -> DeclHeaderRn -> TcM TcTyCon
+check_decl_sig msig hdr =
+ kcDeclHeader strategy 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 strategy DataType
+
+ | flav == NewtypeFlavour
+ -> case res_sig of
+ Just ksig -> TheKind <$> tcLHsKindSig (DataKindCtxt name) ksig
+ Nothing -> return $ dataDeclDefaultResultKind strategy 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 = fmap absurd (decl_header_flav hdr)
+ res_sig = decl_header_res_sig hdr
+ strategy = InitialKindCheck msig
+
+is_fam_flav :: TyConFlavour tc -> Bool
+is_fam_flav OpenFamilyFlavour{} = 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], NameSet)
-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, kindless) <- checkNoErrs $
- kcTyClGroup kisig_env tyclds
+ kcTyClGroup is_kinded_decl tyclds
-- checkNoErrs: If the TyCons are ill-kinded, stop now. Else we
-- can get follow-on errors. Example: #23252, where the TyCon
-- had an ill-scoped kind forall (d::k) k (a::k). blah
@@ -857,7 +942,7 @@ been generalized.
-}
-kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM ([PolyTcTyCon], NameSet)
+kcTyClGroup :: (Name -> Bool) -> [LTyClDecl GhcRn] -> TcM ([PolyTcTyCon], NameSet)
-- 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
@@ -865,7 +950,7 @@ kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM ([PolyTcTyCon], NameSet)
-- and Note [Inferring kinds for type declarations]
--
-- The NameSet returned contains kindless tycon names, without CUSK or SAKS.
-kcTyClGroup kisig_env decls
+kcTyClGroup is_kinded_decl decls
= do { mod <- getModule
; traceTc "---- kcTyClGroup ---- {"
(text "module" <+> ppr mod $$ vcat (map ppr decls))
@@ -876,31 +961,36 @@ 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
- kindless_names = mkNameSet $ map get_name kindless_decls
+ -- ; cusks_enabled <- xoptM LangExt.CUSKs <&&> xoptM LangExt.PolyKinds
+ -- -- See Note [CUSKs and PolyKinds]
+ -- ; let (kindless_decls, kinded_decls) = partitionWith get_kind decls
+ -- kindless_names = mkNameSet $ map get_name kindless_decls
- get_name d = tcdName (unLoc d)
+ -- get_name d = tcdName (unLoc d)
- get_kind d
- | Just ki <- lookupNameEnv kisig_env (get_name d)
- = Right (d, SAKS ki)
+ -- get_kind d
+ -- | Just ki <- lookupNameEnv kisig_env (get_name d)
+ -- = Right (d, SAKS ki)
- | cusks_enabled && hsDeclHasCusk (unLoc d)
- = Right (d, CUSK)
+ -- | cusks_enabled && hsDeclHasCusk (unLoc d)
+ -- = Right (d, CUSK)
- | otherwise = Left d
+ -- | otherwise = Left d
+ ; let (kinded_decls, kindless_decls) = partition (is_kinded_decl . tcdName . unLoc) decls
+ kindless_names = mkNameSet $ map get_name kindless_decls
+ get_name d = tcdName (unLoc d)
+ ; (checked_tcs, concat -> checked_assoc_tcs) <-
+ mapAndUnzipM checkKindedDecl kinded_decls
- ; checked_tcs <- checkNoErrs $
- checkInitialKinds kinded_decls
- -- checkNoErrs because we are about to extend
- -- the envt with these tycons, and we get
- -- knock-on errors if we have tycons with
- -- malformed kinds
+ -- ; checked_tcs <- checkNoErrs $
+ -- checkInitialKinds kinded_decls
+ -- -- checkNoErrs because we are about to extend
+ -- -- the envt with these tycons, and we get
+ -- -- knock-on errors if we have tycons with
+ -- -- malformed kinds
; inferred_tcs
- <- tcExtendKindEnvWithTyCons checked_tcs $
+ <- tcExtendKindEnvWithTyCons checked_assoc_tcs $
pushLevelAndSolveEqualities unkSkolAnon [] $
-- We are going to kind-generalise, so unification
-- variables in here must be one level in
@@ -929,13 +1019,25 @@ 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, kindless_names) }
where
ppr_tc_kinds tcs = vcat (map pp_tc tcs)
pp_tc tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc)
+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 (addLocMA (check_initial_kind_assoc_fam cls)) ats
+ ; return (cls, inner_tcs) }
+checkKindedDecl (L _ d)
+ = do { tc <- tcLookupTcTyCon (tcdName d)
+ ; return (tc, []) }
+
type ScopedPairs = [(Name, TcTyVar)]
-- The ScopedPairs for a TcTyCon are precisely
-- specified-tvs ++ required-tvs
@@ -1510,17 +1612,17 @@ inferInitialKinds decls
where
infer_initial_kind = addLocMA (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 [PolyTcTyCon]
-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) =
- addLocMA (getInitialKind (InitialKindCheck msig)) ldecl
+-- -- Check type/class declarations against their standalone kind signatures or
+-- -- CUSKs, producing a generalized TcTyCon for each.
+-- checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [PolyTcTyCon]
+-- 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) =
+-- addLocMA (getInitialKind (InitialKindCheck msig)) ldecl
-- | Get the initial kind of a TyClDecl, either generalized or non-generalized,
-- depending on the 'InitialKindStrategy'.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b492edf08f2e4047ee9cd6b7b101c3f7a47f21bc
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b492edf08f2e4047ee9cd6b7b101c3f7a47f21bc
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/20230627/f15ecdeb/attachment-0001.html>
More information about the ghc-commits
mailing list