[Git][ghc/ghc][wip/int-index/tok-where] WIP: LHsToken for newtype/data and where in DataDecl
Andrei Borzenkov (@sand-witch)
gitlab at gitlab.haskell.org
Mon May 29 11:49:08 UTC 2023
Andrei Borzenkov pushed to branch wip/int-index/tok-where at Glasgow Haskell Compiler / GHC
Commits:
4915acc0 by Andrei Borzenkov at 2023-01-16T17:00:35+04:00
WIP: LHsToken for newtype/data and where in DataDecl
- - - - -
17 changed files:
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/ThToHs.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/T14189.stderr
- testsuite/tests/parser/should_compile/T15323.stderr
- testsuite/tests/parser/should_compile/T20452.stderr
- testsuite/tests/printer/T18791.stderr
- utils/check-exact/ExactPrint.hs
- utils/haddock
Changes:
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -24,7 +24,7 @@ module GHC.Hs.Decls (
-- * Toplevel declarations
HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep,
HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys,
- NewOrData, newOrDataToFlavour, anyLConIsGadt,
+ NewOrData, NewOrDataToken(..), newOrDataToFlavour, anyLConIsGadt,
StandaloneKindSig(..), LStandaloneKindSig, standaloneKindSigName,
-- ** Class or type declarations
@@ -132,6 +132,7 @@ import GHC.Data.Maybe
import Data.Data (Data)
import Data.Foldable (toList)
import qualified GHC.Data.Strict as Strict
+import Data.Functor (($>))
{-
************************************************************************
@@ -440,9 +441,9 @@ instance (OutputableBndrId p) => Outputable (TyClDecl (GhcPass p)) where
pp_vanilla_decl_head ltycon tyvars fixity Nothing <+> equals)
4 (ppr rhs)
- ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity
+ ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity, tcdTkWhere = tkWhere
, tcdDataDefn = defn })
- = pp_data_defn (pp_vanilla_decl_head ltycon tyvars fixity) defn
+ = pp_data_defn (pp_vanilla_decl_head ltycon tyvars fixity) defn (tkWhere $> ())
ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
tcdFixity = fixity,
@@ -715,12 +716,15 @@ ppDataDefnHeader pp_hdr HsDataDefn
pp_data_defn :: (OutputableBndrId p)
=> (Maybe (LHsContext (GhcPass p)) -> SDoc) -- Printing the header
-> HsDataDefn (GhcPass p)
+ -> Strict.Maybe ()
-> SDoc
pp_data_defn pp_hdr defn at HsDataDefn
{ dd_cons = condecls
, dd_derivs = derivings }
+ tkWhere
| null condecls
- = ppDataDefnHeader pp_hdr defn <+> pp_derivings derivings
+ , let tkWhere' = case tkWhere of Strict.Nothing -> empty; _ -> text "where"
+ = ppDataDefnHeader pp_hdr defn <+> tkWhere' <+> pp_derivings derivings
| otherwise
= hang (ppDataDefnHeader pp_hdr defn) 2 (pp_condecls (toList condecls) $$ pp_derivings derivings)
@@ -729,7 +733,7 @@ pp_data_defn pp_hdr defn at HsDataDefn
instance OutputableBndrId p
=> Outputable (HsDataDefn (GhcPass p)) where
- ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d
+ ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d Strict.Nothing
instance OutputableBndrId p
=> Outputable (StandaloneKindSig (GhcPass p)) where
@@ -856,7 +860,7 @@ pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn =
, feqn_pats = pats
, feqn_fixity = fixity
, feqn_rhs = defn })})
- = pp_data_defn pp_hdr defn
+ = pp_data_defn pp_hdr defn Strict.Nothing
where
pp_hdr mctxt = ppr_instance_keyword top_lvl
<+> pprHsFamInstLHS tycon bndrs pats fixity mctxt
@@ -945,6 +949,9 @@ instance Outputable NewOrData where
ppr NewType = text "newtype"
ppr DataType = text "data"
+instance Outputable (NewOrDataToken a) where
+ ppr = ppr . tokenNewOrData
+
-- At the moment we only call this with @f = '[]'@ and @f = 'DataDefnCons'@.
anyLConIsGadt :: Foldable f => f (GenLocated l (ConDecl pass)) -> Bool
anyLConIsGadt xs = case toList xs of
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -131,6 +131,11 @@ deriving instance Data (TyClDecl GhcPs)
deriving instance Data (TyClDecl GhcRn)
deriving instance Data (TyClDecl GhcTc)
+-- deriving instance (DataIdLR p p) => Data (NewOrDataToken p)
+deriving instance Data (NewOrDataToken GhcPs)
+deriving instance Data (NewOrDataToken GhcRn)
+deriving instance Data (NewOrDataToken GhcTc)
+
-- deriving instance (DataIdLR p p) => Data (FunDep p)
deriving instance Data (FunDep GhcPs)
deriving instance Data (FunDep GhcRn)
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1283,7 +1283,7 @@ ty_decl :: { LTyClDecl GhcPs }
-- ordinary data type or newtype declaration
| type_data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings
{% mkTyData (comb4 $1 $3 $4 $5) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3
- Nothing (reverse (snd $ unLoc $4))
+ Nothing (snd $ unLoc $4)
(fmap reverse $5)
((fstOf3 $ unLoc $1):(fst $ unLoc $4)) }
-- We need the location on tycl_hdr in case
@@ -1345,7 +1345,7 @@ inst_decl :: { LInstDecl GhcPs }
| data_or_newtype 'instance' capi_ctype datafam_inst_hdr constrs
maybe_derivings
{% mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (unLoc $4)
- Nothing (reverse (snd $ unLoc $5))
+ Nothing (snd $ unLoc $5)
(fmap reverse $6)
((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)) }
@@ -1507,7 +1507,7 @@ at_decl_inst :: { LInstDecl GhcPs }
-- data/newtype instance declaration, with optional 'instance' keyword
| data_or_newtype opt_instance capi_ctype datafam_inst_hdr constrs maybe_derivings
{% mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (unLoc $4)
- Nothing (reverse (snd $ unLoc $5))
+ Nothing (snd $ unLoc $5)
(fmap reverse $6)
((fst $ unLoc $1):$2++(fst $ unLoc $5)) }
@@ -1520,14 +1520,14 @@ at_decl_inst :: { LInstDecl GhcPs }
(fmap reverse $7)
((fst $ unLoc $1):$2++(fst $ unLoc $5)++(fst $ unLoc $6)) }
-type_data_or_newtype :: { Located (AddEpAnn, Bool, NewOrData) }
- : 'data' { sL1 $1 (mj AnnData $1,False,DataType) }
- | 'newtype' { sL1 $1 (mj AnnNewtype $1,False,NewType) }
- | 'type' 'data' { sL1 $1 (mj AnnData $1,True ,DataType) }
+type_data_or_newtype :: { Located (AddEpAnn, Bool, NewOrDataToken GhcPs) }
+ : 'data' { sL1 $1 (mj AnnData $1,False,DataTypeToken (hsTok $1)) }
+ | 'newtype' { sL1 $1 (mj AnnNewtype $1,False,NewTypeToken (hsTok $1)) }
+ | 'type' 'data' { sL1 $1 (mj AnnData $1,True ,DataTypeToken (hsTok $2)) }
-data_or_newtype :: { Located (AddEpAnn, NewOrData) }
- : 'data' { sL1 $1 (mj AnnData $1,DataType) }
- | 'newtype' { sL1 $1 (mj AnnNewtype $1,NewType) }
+data_or_newtype :: { Located (AddEpAnn, NewOrDataToken GhcPs) }
+ : 'data' { sL1 $1 (mj AnnData $1,DataTypeToken (hsTok $1)) }
+ | 'newtype' { sL1 $1 (mj AnnNewtype $1,NewTypeToken (hsTok $1)) }
-- Family result/return kind signatures
@@ -2364,19 +2364,23 @@ And both become a HsTyVar ("Zero", DataName) after the renamer.
-- Datatype declarations
gadt_constrlist :: { Located ([AddEpAnn]
- ,[LConDecl GhcPs]) } -- Returned in order
+ , PsDataWhereClause) }
: 'where' '{' gadt_constrs '}' {% checkEmptyGADTs $
L (comb2 $1 $3)
([mj AnnWhere $1
,moc $2
,mcc $4]
- , unLoc $3) }
+ , PsDataWhereClause
+ (Strict.Just (hsTok $1))
+ (unLoc $3)) }
| 'where' vocurly gadt_constrs close {% checkEmptyGADTs $
L (comb2 $1 $3)
([mj AnnWhere $1]
- , unLoc $3) }
- | {- empty -} { noLoc ([],[]) }
+ , PsDataWhereClause
+ (Strict.Just (hsTok $1))
+ (unLoc $3)) }
+ | {- empty -} { noLoc ([],PsDataWhereClause Strict.Nothing []) }
gadt_constrs :: { Located [LConDecl GhcPs] }
: gadt_constr ';' gadt_constrs
@@ -2410,8 +2414,8 @@ consequence, GADT constructor names are restricted (names like '(*)' are
allowed in usual data constructors, but not in GADTs).
-}
-constrs :: { Located ([AddEpAnn],[LConDecl GhcPs]) }
- : '=' constrs1 { sLL $1 $2 ([mj AnnEqual $1],unLoc $2)}
+constrs :: { Located ([AddEpAnn],PsDataWhereClause) }
+ : '=' constrs1 { sLL $1 $2 ([mj AnnEqual $1],PsDataWhereClause Strict.Nothing (reverse $ unLoc $2))}
constrs1 :: { Located [LConDecl GhcPs] }
: constrs1 '|' constr
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -23,7 +23,7 @@ module GHC.Parser.PostProcess (
mkHsDo, mkSpliceDecl,
mkRoleAnnotDecl,
PsClassWhereClause(..), mkClassDecl,
- mkTyData, mkDataFamInst,
+ PsDataWhereClause(..), mkTyData, mkDataFamInst,
mkTySynonym, mkTyFamInstEqn,
mkStandaloneKindSig,
mkTyFamInst,
@@ -228,18 +228,24 @@ mkClassDecl loc' tkClass (L _ (mcxt, tycl_hdr)) fds pcwc annsIn
, tcdATs = ats, tcdATDefs = at_defs
, tcdDocs = docs })) }
+data PsDataWhereClause =
+ PsDataWhereClause {
+ pdwcTkWhere :: !(Strict.Maybe (LHsToken "where" GhcPs)),
+ pdkwDecls :: ![LConDecl GhcPs] -- Returned in order
+ }
+
mkTyData :: SrcSpan
-> Bool
- -> NewOrData
+ -> NewOrDataToken GhcPs
-> Maybe (LocatedP CType)
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
- -> [LConDecl GhcPs]
+ -> PsDataWhereClause
-> Located (HsDeriving GhcPs)
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr))
- ksig data_cons (L _ maybe_deriv) annsIn
+ ksig (PsDataWhereClause tkWhere data_cons) (L _ maybe_deriv) annsIn
= do { let loc = noAnnSrcSpan loc'
; (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams
@@ -248,8 +254,10 @@ mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr))
; data_cons <- checkNewOrData (locA loc) (unLoc tc) is_type_data new_or_data data_cons
; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv
; return (L loc (DataDecl { tcdDExt = anns',
+ tcdTkNewOrData = new_or_data,
tcdLName = tc, tcdTyVars = tyvars,
tcdFixity = fixity,
+ tcdTkWhere = tkWhere,
tcdDataDefn = defn })) }
mkDataDefn :: Maybe (LocatedP CType)
@@ -327,17 +335,17 @@ mkTyFamInstEqn loc bndrs lhs rhs anns
, feqn_rhs = rhs })}
mkDataFamInst :: SrcSpan
- -> NewOrData
+ -> NewOrDataToken GhcPs
-> Maybe (LocatedP CType)
-> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs
, LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
- -> [LConDecl GhcPs]
+ -> PsDataWhereClause
-> Located (HsDeriving GhcPs)
-> [AddEpAnn]
-> P (LInstDecl GhcPs)
mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
- ksig data_cons (L _ maybe_deriv) anns
+ ksig (PsDataWhereClause _ data_cons) (L _ maybe_deriv) anns
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan
; let fam_eqn_ans = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments
@@ -992,9 +1000,9 @@ checkRecordSyntax lr@(L loc r)
-- | Check if the gadt_constrlist is empty. Only raise parse error for
-- `data T where` to avoid affecting existing error message, see #8258.
-checkEmptyGADTs :: Located ([AddEpAnn], [LConDecl GhcPs])
- -> P (Located ([AddEpAnn], [LConDecl GhcPs]))
-checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration.
+checkEmptyGADTs :: Located ([AddEpAnn], PsDataWhereClause)
+ -> P (Located ([AddEpAnn], PsDataWhereClause))
+checkEmptyGADTs gadts@(L span (_, PsDataWhereClause _ [])) -- Empty GADT declaration.
= do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax
unless gadtSyntax $ addError $ mkPlainErrorMsgEnvelope span $
PsErrIllegalWhereInDataDecl
@@ -2633,12 +2641,12 @@ mkOpaquePragma src
, inl_rule = FunLike
}
-checkNewOrData :: SrcSpan -> RdrName -> Bool -> NewOrData -> [LConDecl GhcPs]
+checkNewOrData :: SrcSpan -> RdrName -> Bool -> NewOrDataToken GhcPs -> [LConDecl GhcPs]
-> P (DataDefnCons (LConDecl GhcPs))
checkNewOrData span name is_type_data = curry $ \ case
- (NewType, [a]) -> pure $ NewTypeCon a
- (DataType, as) -> pure $ DataTypeCons is_type_data (handle_type_data as)
- (NewType, as) -> addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrMultipleConForNewtype name (length as)
+ (NewTypeToken{}, [a]) -> pure $ NewTypeCon a
+ (DataTypeToken{}, as) -> pure $ DataTypeCons is_type_data (handle_type_data as)
+ (NewTypeToken{}, as) -> addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrMultipleConForNewtype name (length as)
where
-- In a "type data" declaration, the constructors are in the type/class
-- namespace rather than the data constructor namespace.
=====================================
compiler/GHC/Parser/PostProcess/Haddock.hs
=====================================
@@ -479,14 +479,15 @@ instance HasHaddock (HsDecl GhcPs) where
-- deriving newtype (Ord {- ^ Comment on Ord N -})
--
addHaddock (TyClD x decl)
- | DataDecl { tcdDExt, tcdLName, tcdTyVars, tcdFixity, tcdDataDefn = defn } <- decl
+ | DataDecl { tcdDExt, tcdTkNewOrData, tcdLName, tcdTyVars, tcdFixity, tcdTkWhere, tcdDataDefn = defn } <- decl
= do
registerHdkA tcdLName
defn' <- addHaddock defn
pure $
TyClD x (DataDecl {
tcdDExt,
- tcdLName, tcdTyVars, tcdFixity,
+ tcdTkNewOrData,
+ tcdLName, tcdTyVars, tcdFixity, tcdTkWhere,
tcdDataDefn = defn' })
-- Class declarations:
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -1819,13 +1819,16 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,
-- "data", "newtype" declarations
rnTyClDecl (DataDecl
- { tcdLName = tycon, tcdTyVars = tyvars,
+ { tcdTkNewOrData = tkNewOrData,
+ tcdLName = tycon, tcdTyVars = tyvars,
tcdFixity = fixity,
+ tcdTkWhere = tkWhere,
tcdDataDefn = defn at HsDataDefn{ dd_cons = cons, dd_kindSig = kind_sig} })
= do { tycon' <- lookupLocatedTopConstructorRnN tycon
; let kvs = extractDataDefnKindVars defn
doc = TyDataCtx tycon
new_or_data = dataDefnConsNewOrData cons
+ tkNewOrData' = rnNewOrDataToken tkNewOrData
; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)
; bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' no_rhs_kvs ->
do { (defn', fvs) <- rnDataDefn doc defn
@@ -1833,11 +1836,13 @@ rnTyClDecl (DataDecl
; let rn_info = DataDeclRn { tcdDataCusk = cusk
, tcdFVs = fvs }
; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs)
- ; return (DataDecl { tcdLName = tycon'
- , tcdTyVars = tyvars'
- , tcdFixity = fixity
- , tcdDataDefn = defn'
- , tcdDExt = rn_info }, fvs) } }
+ ; return (DataDecl { tcdTkNewOrData = (tkNewOrData' :: NewOrDataToken GhcRn)
+ , tcdLName = tycon'
+ , tcdTyVars = tyvars'
+ , tcdFixity = fixity
+ , tcdTkWhere = tkWhere
+ , tcdDataDefn = defn'
+ , tcdDExt = rn_info }, fvs) } }
rnTyClDecl (ClassDecl { tcdLayout = layout,
tcdTkClass = tkClass,
@@ -1915,6 +1920,10 @@ rnLayoutInfo (ExplicitBraces ob cb) = ExplicitBraces ob cb
rnLayoutInfo (VirtualBraces n) = VirtualBraces n
rnLayoutInfo NoLayoutInfo = NoLayoutInfo
+rnNewOrDataToken :: NewOrDataToken GhcPs -> NewOrDataToken GhcRn
+rnNewOrDataToken (NewTypeToken a) = NewTypeToken a
+rnNewOrDataToken (DataTypeToken a) = DataTypeToken a
+
-- Does the data type declaration include a CUSK?
data_decl_has_cusk :: LHsQTyVars (GhcPass p) -> NewOrData -> Bool -> Maybe (LHsKind (GhcPass p')) -> RnM Bool
data_decl_has_cusk tyvars new_or_data no_rhs_kvs kind_sig = do
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -286,8 +286,10 @@ cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
, dd_derivs = derivs' }
; returnJustLA $ TyClD noExtField $
DataDecl { tcdDExt = noAnn
+ , tcdTkNewOrData = NewTypeToken noHsTok
, tcdLName = tc', tcdTyVars = tvs'
, tcdFixity = Prefix
+ , tcdTkWhere = Strict.Nothing
, tcdDataDefn = defn } }
cvtDec (TypeDataD tc tvs ksig constrs)
@@ -516,8 +518,10 @@ cvtGenDataDec type_data ctxt tc tvs ksig constrs derivs
, dd_derivs = derivs' }
; returnJustLA $ TyClD noExtField $
DataDecl { tcdDExt = noAnn
+ , tcdTkNewOrData = DataTypeToken noHsTok
, tcdLName = tc', tcdTyVars = tvs'
, tcdFixity = Prefix
+ , tcdTkWhere = Strict.Nothing
, tcdDataDefn = defn } }
----------------
=====================================
compiler/Language/Haskell/Syntax/Decls.hs
=====================================
@@ -29,6 +29,7 @@ module Language.Haskell.Syntax.Decls (
-- * Toplevel declarations
HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, FunDep(..),
HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys,
+ NewOrDataToken(..), tokenNewOrData,
NewOrData(..), DataDefnCons(..), dataDefnConsNewOrData,
isTypeDataDefnCons,
StandaloneKindSig(..), LStandaloneKindSig,
@@ -441,12 +442,14 @@ data TyClDecl pass
-- 'GHC.Parser.Annotation.AnnWhere',
-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
- DataDecl { tcdDExt :: XDataDecl pass -- ^ Post renamer, CUSK flag, FVs
- , tcdLName :: LIdP pass -- ^ Type constructor
- , tcdTyVars :: LHsQTyVars pass -- ^ Type variables
- -- See Note [TyVar binders for associated decls]
- , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration
- , tcdDataDefn :: HsDataDefn pass }
+ DataDecl { tcdDExt :: XDataDecl pass -- ^ Post renamer, CUSK flag, FVs
+ , tcdTkNewOrData :: !(NewOrDataToken pass) -- ^ "newtype" or "data" token
+ , tcdLName :: LIdP pass -- ^ Type constructor
+ , tcdTyVars :: LHsQTyVars pass -- ^ Type variables
+ -- See Note [TyVar binders for associated decls]
+ , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration
+ , tcdTkWhere :: !(Strict.Maybe (LHsToken "where" pass)) -- ^ The "where" token
+ , tcdDataDefn :: HsDataDefn pass }
-- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnClass',
-- 'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen',
@@ -995,6 +998,16 @@ data NewOrData
| DataType -- ^ @data Blah ...@
deriving ( Eq, Data ) -- Needed because Demand derives Eq
+-- type role NewOrDataToken representational
+-- | Same as `NewOrData`, but with additional location info
+data NewOrDataToken pass
+ = NewTypeToken !(LHsToken "newtype" pass) -- ^ @newtype Blah ...@
+ | DataTypeToken !(LHsToken "data" pass) -- ^ @data Blah ...@
+
+tokenNewOrData :: NewOrDataToken pass -> NewOrData
+tokenNewOrData NewTypeToken{} = NewType
+tokenNewOrData DataTypeToken{} = DataType
+
-- | Whether a data-type declaration is @data@ or @newtype@, and its constructors.
data DataDefnCons a
= NewTypeCon -- @newtype N x = MkN blah@
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
=====================================
@@ -78,6 +78,11 @@
,(AddEpAnn AnnWhere (EpaSpan { T17544_kw.hs:16:3-7 }))]
(EpaComments
[]))
+ (DataTypeToken
+ (L
+ (TokenLoc
+ (EpaSpan { T17544_kw.hs:15:1-4 }))
+ (HsTok)))
(L
(SrcSpanAnn (EpAnnNotUsed) { T17544_kw.hs:15:6-8 })
(Unqual
@@ -86,6 +91,11 @@
(NoExtField)
[])
(Prefix)
+ (Just
+ (L
+ (TokenLoc
+ (EpaSpan { T17544_kw.hs:16:3-7 }))
+ (HsTok)))
(HsDataDefn
(NoExtField)
(Nothing)
@@ -169,6 +179,11 @@
,(AddEpAnn AnnWhere (EpaSpan { T17544_kw.hs:19:3-7 }))]
(EpaComments
[]))
+ (NewTypeToken
+ (L
+ (TokenLoc
+ (EpaSpan { T17544_kw.hs:18:1-7 }))
+ (HsTok)))
(L
(SrcSpanAnn (EpAnnNotUsed) { T17544_kw.hs:18:9-11 })
(Unqual
@@ -177,6 +192,11 @@
(NoExtField)
[])
(Prefix)
+ (Just
+ (L
+ (TokenLoc
+ (EpaSpan { T17544_kw.hs:19:3-7 }))
+ (HsTok)))
(HsDataDefn
(NoExtField)
(Nothing)
=====================================
testsuite/tests/parser/should_compile/DumpParsedAst.stderr
=====================================
@@ -93,6 +93,11 @@
,(AddEpAnn AnnEqual (EpaSpan { DumpParsedAst.hs:8:12 }))]
(EpaComments
[]))
+ (DataTypeToken
+ (L
+ (TokenLoc
+ (EpaSpan { DumpParsedAst.hs:8:1-4 }))
+ (HsTok)))
(L
(SrcSpanAnn (EpAnnNotUsed) { DumpParsedAst.hs:8:6-10 })
(Unqual
@@ -101,6 +106,7 @@
(NoExtField)
[])
(Prefix)
+ (Nothing)
(HsDataDefn
(NoExtField)
(Nothing)
@@ -486,6 +492,11 @@
,(AddEpAnn AnnEqual (EpaSpan { DumpParsedAst.hs:15:19 }))]
(EpaComments
[]))
+ (DataTypeToken
+ (L
+ (TokenLoc
+ (EpaSpan { DumpParsedAst.hs:15:1-4 }))
+ (HsTok)))
(L
(SrcSpanAnn (EpAnnNotUsed) { DumpParsedAst.hs:15:6 })
(Unqual
@@ -540,6 +551,7 @@
(Unqual
{OccName: k}))))))])
(Prefix)
+ (Nothing)
(HsDataDefn
(NoExtField)
(Nothing)
=====================================
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
=====================================
@@ -100,6 +100,11 @@
(True)
{NameSet:
[{Name: DumpRenamedAst.Peano}]})
+ (DataTypeToken
+ (L
+ (TokenLoc
+ (EpaSpan { DumpRenamedAst.hs:10:1-4 }))
+ (HsTok)))
(L
(SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:10:6-10 })
{Name: DumpRenamedAst.Peano})
@@ -107,6 +112,7 @@
[]
[])
(Prefix)
+ (Nothing)
(HsDataDefn
(NoExtField)
(Nothing)
@@ -739,6 +745,11 @@
{NameSet:
[{Name: a}
,{Name: f}]})
+ (DataTypeToken
+ (L
+ (TokenLoc
+ (EpaSpan { DumpRenamedAst.hs:22:1-4 }))
+ (HsTok)))
(L
(SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:22:6 })
{Name: DumpRenamedAst.T})
@@ -783,6 +794,7 @@
(SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:22:16 })
{Name: k})))))])
(Prefix)
+ (Nothing)
(HsDataDefn
(NoExtField)
(Nothing)
@@ -1385,5 +1397,3 @@
{Name: GHC.Types.Type})))))])))))]
(Nothing)
(Nothing)))
-
-
=====================================
testsuite/tests/parser/should_compile/T14189.stderr
=====================================
@@ -26,6 +26,11 @@
(True)
{NameSet:
[{Name: GHC.Types.Int}]})
+ (DataTypeToken
+ (L
+ (TokenLoc
+ (EpaSpan { T14189.hs:6:1-4 }))
+ (HsTok)))
(L
(SrcSpanAnn (EpAnnNotUsed) { T14189.hs:6:6-11 })
{Name: T14189.MyType})
@@ -33,6 +38,7 @@
[]
[])
(Prefix)
+ (Nothing)
(HsDataDefn
(NoExtField)
(Nothing)
@@ -223,5 +229,3 @@
(FieldSelectors)
{Name: T14189.f}))])])])
(Nothing)))
-
-
=====================================
testsuite/tests/parser/should_compile/T15323.stderr
=====================================
@@ -66,6 +66,11 @@
,(AddEpAnn AnnWhere (EpaSpan { T15323.hs:5:21-25 }))]
(EpaComments
[]))
+ (DataTypeToken
+ (L
+ (TokenLoc
+ (EpaSpan { T15323.hs:5:1-4 }))
+ (HsTok)))
(L
(SrcSpanAnn (EpAnnNotUsed) { T15323.hs:5:6-17 })
(Unqual
@@ -88,6 +93,11 @@
(Unqual
{OccName: v}))))])
(Prefix)
+ (Just
+ (L
+ (TokenLoc
+ (EpaSpan { T15323.hs:5:21-25 }))
+ (HsTok)))
(HsDataDefn
(NoExtField)
(Nothing)
=====================================
testsuite/tests/parser/should_compile/T20452.stderr
=====================================
@@ -66,6 +66,11 @@
,(AddEpAnn AnnEqual (EpaSpan { T20452.hs:5:24 }))]
(EpaComments
[]))
+ (DataTypeToken
+ (L
+ (TokenLoc
+ (EpaSpan { T20452.hs:5:1-4 }))
+ (HsTok)))
(L
(SrcSpanAnn (EpAnnNotUsed) { T20452.hs:5:6-11 })
(Unqual
@@ -105,6 +110,7 @@
(Unqual
{OccName: k}))))))])
(Prefix)
+ (Nothing)
(HsDataDefn
(NoExtField)
(Nothing)
@@ -154,6 +160,11 @@
,(AddEpAnn AnnEqual (EpaSpan { T20452.hs:6:24 }))]
(EpaComments
[]))
+ (DataTypeToken
+ (L
+ (TokenLoc
+ (EpaSpan { T20452.hs:6:1-4 }))
+ (HsTok)))
(L
(SrcSpanAnn (EpAnnNotUsed) { T20452.hs:6:6-11 })
(Unqual
@@ -195,6 +206,7 @@
(Unqual
{OccName: k}))))))])
(Prefix)
+ (Nothing)
(HsDataDefn
(NoExtField)
(Nothing)
=====================================
testsuite/tests/printer/T18791.stderr
=====================================
@@ -66,6 +66,11 @@
,(AddEpAnn AnnWhere (EpaSpan { T18791.hs:4:8-12 }))]
(EpaComments
[]))
+ (DataTypeToken
+ (L
+ (TokenLoc
+ (EpaSpan { T18791.hs:4:1-4 }))
+ (HsTok)))
(L
(SrcSpanAnn (EpAnnNotUsed) { T18791.hs:4:6 })
(Unqual
@@ -74,6 +79,11 @@
(NoExtField)
[])
(Prefix)
+ (Just
+ (L
+ (TokenLoc
+ (EpaSpan { T18791.hs:4:8-12 }))
+ (HsTok)))
(HsDataDefn
(NoExtField)
(Nothing)
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -3450,12 +3450,12 @@ instance ExactPrint (TyClDecl GhcPs) where
, tcdRhs = rhs' })
-- TODO: add a workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/20452
- exact (DataDecl { tcdDExt = an, tcdLName = ltycon, tcdTyVars = tyvars
- , tcdFixity = fixity, tcdDataDefn = defn }) = do
+ exact (DataDecl { tcdDExt = an, tcdTkNewOrData = tknd, tcdLName = ltycon, tcdTyVars = tyvars
+ , tcdFixity = fixity, tcdTkWhere = tkWhere, tcdDataDefn = defn }) = do
(_, an', ltycon', tyvars', _, _mctxt', defn') <-
exactDataDefn an (exactVanillaDeclHead ltycon tyvars fixity) defn
- return (DataDecl { tcdDExt = an', tcdLName = ltycon', tcdTyVars = tyvars'
- , tcdFixity = fixity, tcdDataDefn = defn' })
+ return (DataDecl { tcdDExt = an', tcdTkNewOrData = tknd, tcdLName = ltycon', tcdTyVars = tyvars'
+ , tcdFixity = fixity, tcdTkWhere = tkWhere, tcdDataDefn = defn' })
-- -----------------------------------
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 0fa7dc86dccd751e06845c7ac3908230df2add7f
+Subproject commit 9e9ba4e432194c2b98ce3becaa7f736c2e6ec962
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4915acc018b083bd0c612fb25438ee4e6b0de4f7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4915acc018b083bd0c612fb25438ee4e6b0de4f7
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/20230529/23a02d8d/attachment-0001.html>
More information about the ghc-commits
mailing list