[Git][ghc/ghc][wip/sand-witch/dep-anal] Put DeclHeaderRn in StandaloneKindSig
Vladislav Zavialov (@int-index)
gitlab at gitlab.haskell.org
Tue Jun 27 19:09:31 UTC 2023
Vladislav Zavialov pushed to branch wip/sand-witch/dep-anal at Glasgow Haskell Compiler / GHC
Commits:
1ff06bcc by Vladislav Zavialov at 2023-06-27T21:09:16+02:00
Put DeclHeaderRn in StandaloneKindSig
- - - - -
3 changed files:
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Rename/Module.hs
Changes:
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -26,6 +26,7 @@ module GHC.Hs.Decls (
HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys,
NewOrData, newOrDataToFlavour, anyLConIsGadt,
StandaloneKindSig(..), LStandaloneKindSig, standaloneKindSigName,
+ DeclHeaderRn(..), LDeclHeaderRn,
-- ** Class or type declarations
TyClDecl(..), LTyClDecl, DataDeclRn(..),
@@ -652,14 +653,52 @@ instance OutputableBndrId p => Outputable (DerivClauseTys (GhcPass p)) where
ppr (DctSingle _ ty) = ppr ty
ppr (DctMulti _ tys) = parens (interpp'SP tys)
+type LDeclHeaderRn = LocatedA 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 GhcRn,
+ decl_header_name :: Name,
+ decl_header_cusk :: Bool,
+ decl_header_bndrs :: LHsQTyVars GhcRn,
+ decl_header_res_sig :: Maybe (LHsType GhcRn)
+ }
+
+instance Outputable DeclHeaderRn where
+ ppr (DeclHeaderRn flav name cusk bndrs res_sig) =
+ ppr flav <+>
+ ppr name <+>
+ ppr bndrs <+>
+ maybe empty ((text "::" <+>) . ppr) res_sig <+>
+ if cusk then text "{- CUSK -}" else empty
+
type instance XStandaloneKindSig GhcPs = EpAnn [AddEpAnn]
-type instance XStandaloneKindSig GhcRn = NoExtField
+type instance XStandaloneKindSig GhcRn = LDeclHeaderRn
type instance XStandaloneKindSig GhcTc = NoExtField
-type instance XXStandaloneKindSig (GhcPass p) = DataConCantHappen
+type instance XXStandaloneKindSig GhcPs = DataConCantHappen
+type instance XXStandaloneKindSig GhcRn = LDeclHeaderRn -- CUSK
+type instance XXStandaloneKindSig GhcTc = DataConCantHappen
-standaloneKindSigName :: StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)
+standaloneKindSigName :: forall p. IsPass p => StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)
standaloneKindSigName (StandaloneKindSig _ lname _) = unLoc lname
+standaloneKindSigName (XStandaloneKindSig x) =
+ case ghcPass @p of
+ GhcRn -> decl_header_name (unLoc x)
type instance XConDeclGADT (GhcPass _) = EpAnn [AddEpAnn]
type instance XConDeclH98 (GhcPass _) = EpAnn [AddEpAnn]
@@ -732,6 +771,10 @@ instance OutputableBndrId p
=> Outputable (StandaloneKindSig (GhcPass p)) where
ppr (StandaloneKindSig _ v ki)
= text "type" <+> pprPrefixOcc (unLoc v) <+> text "::" <+> ppr ki
+ ppr (XStandaloneKindSig x) =
+ case ghcPass @p of
+ GhcRn -> whenPprDebug $
+ text "CUSK:" <+> ppr (decl_header_name (unLoc x))
pp_condecls :: forall p. OutputableBndrId p => [LConDecl (GhcPass p)] -> SDoc
pp_condecls cs
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -98,6 +98,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)
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -1418,10 +1418,15 @@ rnTyClDecls tycl_ds
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)
+ where
+ mk_pair = \((L l t, _fv1), fv2)->
+ let hdr = mkDeclHeaderRn t
+ in (decl_header_name hdr, (L l hdr, fv2))
; traceRn "rnTyClDecls" $
vcat [ text "tyClGroupTyClDecls:" <+> ppr tycls_w_fvs
, text "tc_names:" <+> ppr tc_names ]
- ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names (tyClGroupKindSigs tycl_ds)
+ ; 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)
@@ -1508,26 +1513,31 @@ getKindSigs bndrs kisig_env = mapMaybe (lookupNameEnv kisig_env) bndrs
rnStandaloneKindSignatures
:: NameSet -- names of types and classes in the current TyClGroup
+ -> NameEnv (LDeclHeaderRn, FreeVars) -- 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) = removeDupsOn get_name kisigs
get_name = standaloneKindSigName . unLoc
; mapM_ dupKindSig_Err dup_kisigs
- ; mapM (wrapLocFstMA (rnStandaloneKindSignature tc_names)) no_dups
+ ; mapM (wrapLocFstMA (rnStandaloneKindSignature tc_names decl_headers)) no_dups
}
rnStandaloneKindSignature
:: NameSet -- names of types and classes in the current TyClGroup
+ -> NameEnv (LDeclHeaderRn, FreeVars) -- 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 TcRnUnexpectedStandaloneKindSig
; 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, hdr_fvs) = case lookupNameEnv decl_headers (unLoc new_v) of
+ Nothing -> panic "SPANK SPANK SPANK!\nTHE KIND SIGNATURE HAS NO ASSOCIATED DECLARATION"
+ Just a -> a
+ ; return (StandaloneKindSig hdr new_v new_ki, fvs `plusFV` hdr_fvs)
}
depAnalTyClDecls :: GlobalRdrEnv
@@ -2718,40 +2728,6 @@ add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs)
add_sig _ (XValBindsLR {}) = panic "GHC.Rename.Module.add_sig"
-
-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 GhcRn,
- decl_header_name :: Name,
- decl_header_cusk :: Bool,
- decl_header_bndrs :: LHsQTyVars GhcRn,
- decl_header_res_sig :: Maybe (LHsType GhcRn)
- }
-
-instance Outputable DeclHeaderRn where
- ppr (DeclHeaderRn flav name cusk bndrs res_sig) =
- ppr flav <+>
- ppr name <+>
- ppr bndrs <+>
- maybe empty ((text "::" <+>) . ppr) res_sig <+>
- if cusk then text "{- CUSK -}" else empty
-
data DAKey = DAInst Name | DASig Name | DADef Name
deriving (Eq, Ord)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1ff06bcc4e40e1d90fcd2c2bac0e35e9f388facc
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1ff06bcc4e40e1d90fcd2c2bac0e35e9f388facc
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/71153129/attachment-0001.html>
More information about the ghc-commits
mailing list