[Git][ghc/ghc][wip/26699] Migrating the simplest types required for Trees That Grow progress
recursion-ninja pushed to branch wip/26699 at Glasgow Haskell Compiler / GHC Commits: d970f2bb by Recursion Ninja at 2026-01-22T16:20:00-05:00 Migrating the simplest types required for Trees That Grow progress from GHC.Types.Basic to Language.Haskell.Syntax.Basic. Related function definitions were also moved. Outputable type-class instances are defined in GHC.Utils.Outputable. Binary instance of Boxity was moved to GHC.Utils.Binary. Migrated types: * TopLevelFlag * RuleName * TyConFlavour * TypeOrData * NewOrData - - - - - 18 changed files: - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Errors/Types.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax/Basic.hs - compiler/Language/Haskell/Syntax/Decls.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs Changes: ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -17,7 +17,7 @@ module GHC.Hs.Decls ( -- * Toplevel declarations HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys, - NewOrData, newOrDataToFlavour, anyLConIsGadt, + NewOrData, newOrDataToFlavour, dataDefnConsNewOrData, anyLConIsGadt, StandaloneKindSig(..), LStandaloneKindSig, standaloneKindSigName, -- ** Class or type declarations @@ -1106,6 +1106,11 @@ anyLConIsGadt xs = case toList xs of {-# SPECIALIZE anyLConIsGadt :: [GenLocated l (ConDecl pass)] -> Bool #-} {-# SPECIALIZE anyLConIsGadt :: DataDefnCons (GenLocated l (ConDecl pass)) -> Bool #-} +dataDefnConsNewOrData :: DataDefnCons a -> NewOrData +dataDefnConsNewOrData = \ case + NewTypeCon {} -> NewType + DataTypeCons {} -> DataType + {- ************************************************************************ * * ===================================== compiler/GHC/Hs/Utils.hs ===================================== @@ -53,6 +53,7 @@ module GHC.Hs.Utils( -- * Bindings mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind, mkPatSynBind, + familyInfoTyConFlavour, isInfixFunBind, spanHsLocaLBinds, @@ -148,6 +149,7 @@ import Control.Arrow ( first ) import Data.Foldable ( toList ) import Data.List ( partition ) import Data.List.NonEmpty ( NonEmpty (..), nonEmpty ) +import Data.Maybe ( isNothing ) import qualified Data.List.NonEmpty as NE import Data.IntMap ( IntMap ) @@ -1502,6 +1504,18 @@ hsLTyClDeclBinders (L loc (DataDecl { tcdLName = (L _ name) where flav = newOrDataToFlavour $ dataDefnConsNewOrData $ dd_cons defn +familyInfoTyConFlavour + :: Maybe tc -- ^ Just cls <=> this is an associated family of class cls + -> FamilyInfo pass + -> TyConFlavour tc +familyInfoTyConFlavour mb_parent_tycon info = + case info of + DataFamily -> OpenFamilyFlavour (IAmData DataType) mb_parent_tycon + OpenTypeFamily -> OpenFamilyFlavour IAmType mb_parent_tycon + ClosedTypeFamily _ -> assert (isNothing mb_parent_tycon) + -- See Note [Closed type family mb_parent_tycon] + ClosedTypeFamilyFlavour + ------------------- hsForeignDeclsBinders :: forall p a. (UnXRec (GhcPass p), IsSrcSpanAnn p a) => [LForeignDecl (GhcPass p)] -> [LIdP (GhcPass p)] ===================================== compiler/GHC/HsToCore/Errors/Types.hs ===================================== @@ -4,7 +4,7 @@ module GHC.HsToCore.Errors.Types where import GHC.Prelude -import GHC.Core (CoreRule, CoreExpr, RuleName) +import GHC.Core (CoreRule, CoreExpr) import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.Type ===================================== compiler/GHC/Rename/Env.hs ===================================== @@ -80,7 +80,7 @@ import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Builtin.Names( rOOT_MAIN ) -import GHC.Types.Basic ( TopLevelFlag(..), TupleSort(..), tupleSortBoxity ) +import GHC.Types.Basic ( TupleSort(..), tupleSortBoxity ) import GHC.Types.TyThing ( tyThingGREInfo ) import GHC.Types.SrcLoc as SrcLoc import GHC.Utils.Outputable as Outputable ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -52,7 +52,7 @@ import GHC.Types.ForeignCall ( CCallTarget(..) ) import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env -import GHC.Types.Basic ( VisArity, TyConFlavour(..), TypeOrKind(..), RuleName ) +import GHC.Types.Basic ( VisArity, TyConFlavour(..), TypeOrKind(..) ) import GHC.Types.GREInfo (ConLikeInfo (..), ConInfo, mkConInfo, conInfoFields) import GHC.Types.Hint (SigLike(..)) import GHC.Types.Unique.Set ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -70,7 +70,7 @@ import GHC.Types.FieldLabel import GHC.Types.Hint import GHC.Types.SourceFile import GHC.Types.SrcLoc as SrcLoc -import GHC.Types.Basic ( TopLevelFlag(..), TyConFlavour (..), convImportLevel ) +import GHC.Types.Basic ( TyConFlavour (..), convImportLevel ) import GHC.Types.SourceText import GHC.Types.Id import GHC.Types.PkgQual ===================================== compiler/GHC/Rename/Splice.hs ===================================== @@ -32,7 +32,7 @@ import GHC.Rename.Unbound ( isUnboundName ) import GHC.Rename.Module ( rnSrcDecls, findSplice ) import GHC.Rename.Pat ( rnPat ) import GHC.Types.Error -import GHC.Types.Basic ( TopLevelFlag, isTopLevel, maxPrec ) +import GHC.Types.Basic ( maxPrec ) import GHC.Types.SourceText ( SourceText(..) ) import GHC.Types.ThLevelIndex import GHC.Utils.Outputable ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -62,7 +62,6 @@ import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Types.SrcLoc -import GHC.Types.Basic import GHC.Types.Error import GHC.Builtin.Names ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -119,7 +119,6 @@ import GHC.Data.List.SetOps import GHC.Data.Maybe( MaybeErr(..), orElse, maybeToList, fromMaybe ) import GHC.Types.SrcLoc -import GHC.Types.Basic hiding( SuccessFlag(..) ) import GHC.Types.TypeEnv import GHC.Types.SourceFile import GHC.Types.Name ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -239,7 +239,7 @@ import GHC.Types.Unique.DFM import GHC.Types.Unique.Supply import GHC.Types.Unique (uniqueTag) import GHC.Types.Annotations -import GHC.Types.Basic( TopLevelFlag(..), TypeOrKind(..) ) +import GHC.Types.Basic( TypeOrKind(..) ) import GHC.Types.CostCentre.State import GHC.Types.SourceFile ===================================== compiler/GHC/Types/Basic.hs ===================================== @@ -103,7 +103,6 @@ module GHC.Types.Basic ( import GHC.Prelude import GHC.ForeignSrcLang -import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Binary @@ -111,15 +110,16 @@ import GHC.Types.Arity import GHC.Types.SourceText import qualified GHC.LanguageExtensions as LangExt import {-# SOURCE #-} Language.Haskell.Syntax.Type (PromotionFlag(..), isPromoted) -import Language.Haskell.Syntax.Basic (Boxity(..), isBoxed, ConTag) import {-# SOURCE #-} Language.Haskell.Syntax.Expr (HsDoFlavour) + +import Language.Haskell.Syntax.Basic +import Language.Haskell.Syntax.ImpExp + import Control.DeepSeq ( NFData(..) ) import Data.Data import Data.Maybe import qualified Data.Semigroup as Semi -import Language.Haskell.Syntax.ImpExp - {- ************************************************************************ * * @@ -420,55 +420,10 @@ instance NFData FunctionOrData where ************************************************************************ -} -type RuleName = FastString - pprRuleName :: RuleName -> SDoc pprRuleName rn = doubleQuotes (ftext rn) -{- -************************************************************************ -* * -\subsection[Top-level/local]{Top-level/not-top level flag} -* * -************************************************************************ --} - -data TopLevelFlag - = TopLevel - | NotTopLevel - deriving Data - -isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool - -isNotTopLevel NotTopLevel = True -isNotTopLevel TopLevel = False - -isTopLevel TopLevel = True -isTopLevel NotTopLevel = False - -instance Outputable TopLevelFlag where - ppr TopLevel = text "<TopLevel>" - ppr NotTopLevel = text "<NotTopLevel>" - -{- -************************************************************************ -* * - Boxity flag -* * -************************************************************************ --} - -instance Outputable Boxity where - ppr Boxed = text "Boxed" - ppr Unboxed = text "Unboxed" - -instance Binary Boxity where -- implemented via isBoxed-isomorphism to Bool - put_ bh = put_ bh . isBoxed - get bh = do - b <- get bh - pure $ if b then Boxed else Unboxed - {- ************************************************************************ * * @@ -1524,11 +1479,13 @@ instance NFData TypeOrConstraint where TypeLike -> () ConstraintLike -> () -{- ********************************************************************* +{- +************************************************************************ * * - TyConFlavour +TyConFlavour * * -********************************************************************* -} +************************************************************************ +-} -- | Paints a picture of what a 'TyCon' represents, in broad strokes. -- This is used towards more informative error messages. @@ -1571,7 +1528,6 @@ instance Outputable (TyConFlavour tc) where go BuiltInTypeFlavour = "built-in type" go PromotedDataConFlavour = "promoted data constructor" - -- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour tyConFlavourAssoc_maybe :: TyConFlavour tc -> Maybe tc tyConFlavourAssoc_maybe (OpenFamilyFlavour _ mb_parent) = mb_parent @@ -1584,22 +1540,10 @@ data TypeOrData | IAmType deriving (Eq, Data) --- | When we only care whether a data-type declaration is `data` or `newtype`, --- but not what constructors it has. -data NewOrData - = NewType -- ^ @newtype Blah ...@ - | DataType -- ^ @data Blah ...@ - deriving ( Eq, Data ) -- Needed because Demand derives Eq - instance Outputable TypeOrData where ppr (IAmData newOrData) = ppr newOrData ppr IAmType = text "type" -instance Outputable NewOrData where - ppr = \case - NewType -> text "newtype" - DataType -> text "data" - {- ********************************************************************* * * Defaulting options ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -117,6 +117,7 @@ module GHC.Utils.Binary import GHC.Prelude +import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Binds.InlinePragma import Language.Haskell.Syntax.Module.Name (ModuleName(..)) import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..)) @@ -2011,6 +2012,12 @@ instance NFData a => NFData (FingerprintWithValue a) where rnf (FingerprintWithValue fp mflags) = rnf fp `seq` rnf mflags `seq` () +instance Binary Boxity where -- implemented via isBoxed-isomorphism to Bool + put_ bh = put_ bh . isBoxed + get bh = do + b <- get bh + pure $ if b then Boxed else Unboxed + instance Binary ConInfoTable where get bh = Binary.decode <$> get bh ===================================== compiler/GHC/Utils/Outputable.hs ===================================== @@ -112,6 +112,7 @@ module GHC.Utils.Outputable ( import {-# SOURCE #-} GHC.Unit.Types ( Unit, Module, moduleName ) import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName ) +import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Binds.InlinePragma import Language.Haskell.Syntax.Module.Name ( ModuleName(..) ) @@ -2001,19 +2002,32 @@ instance IsDoc HDoc where {-# INLINE CONLIKE dualDoc #-} instance Outputable (ActivationX p) where - ppr AlwaysActive = empty - ppr NeverActive = brackets (text "~") - ppr (ActiveBefore n) = brackets (char '~' <> int n) - ppr (ActiveAfter n) = brackets (int n) - ppr (XActivation _) = text "[final]" + ppr AlwaysActive = empty + ppr NeverActive = brackets (text "~") + ppr (ActiveBefore n) = brackets (char '~' <> int n) + ppr (ActiveAfter n) = brackets (int n) + ppr (XActivation _) = text "[final]" instance Outputable InlineSpec where - ppr Inline = text "INLINE" - ppr NoInline = text "NOINLINE" - ppr Inlinable = text "INLINABLE" - ppr Opaque = text "OPAQUE" - ppr NoUserInlinePrag = empty + ppr Inline = text "INLINE" + ppr NoInline = text "NOINLINE" + ppr Inlinable = text "INLINABLE" + ppr Opaque = text "OPAQUE" + ppr NoUserInlinePrag = empty + +instance Outputable Boxity where + ppr Boxed = text "Boxed" + ppr Unboxed = text "Unboxed" instance Outputable RuleMatchInfo where - ppr ConLike = text "CONLIKE" - ppr FunLike = text "FUNLIKE" + ppr ConLike = text "CONLIKE" + ppr FunLike = text "FUNLIKE" + +instance Outputable NewOrData where + ppr = \case + NewType -> text "newtype" + DataType -> text "data" + +instance Outputable TopLevelFlag where + ppr TopLevel = text "<TopLevel>" + ppr NotTopLevel = text "<NotTopLevel>" ===================================== compiler/Language/Haskell/Syntax/Basic.hs ===================================== @@ -10,6 +10,37 @@ import Prelude import GHC.Data.FastString (FastString) import Control.DeepSeq +{- +************************************************************************ +* * +Rules +* * +************************************************************************ +-} + +type RuleName = FastString + +{- +************************************************************************ +* * +\subsection[Top-level/local]{Top-level/not-top level flag} +* * +************************************************************************ +-} + +data TopLevelFlag + = TopLevel + | NotTopLevel + deriving Data + +isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool + +isNotTopLevel NotTopLevel = True +isNotTopLevel TopLevel = False + +isTopLevel TopLevel = True +isTopLevel NotTopLevel = False + {- ************************************************************************ * * @@ -125,3 +156,10 @@ data Fixity = Fixity Int FixityDirection instance NFData Fixity where rnf (Fixity i d) = rnf i `seq` rnf d `seq` () + +-- | When we only care whether a data-type declaration is `data` or `newtype`, +-- but not what constructors it has. +data NewOrData + = NewType -- ^ @newtype Blah ...@ + | DataType -- ^ @data Blah ...@ + deriving ( Eq, Data ) -- Needed because Demand derives Eq ===================================== compiler/Language/Haskell/Syntax/Decls.hs ===================================== @@ -18,7 +18,7 @@ module Language.Haskell.Syntax.Decls ( -- * Toplevel declarations HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, FunDep(..), HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys, - NewOrData(..), DataDefnCons(..), dataDefnConsNewOrData, + NewOrData(..), DataDefnCons(..), isTypeDataDefnCons, firstDataDefnCon, StandaloneKindSig(..), LStandaloneKindSig, @@ -31,7 +31,7 @@ module Language.Haskell.Syntax.Decls ( FamilyDecl(..), LFamilyDecl, -- ** Instance declarations - InstDecl(..), LInstDecl, FamilyInfo(..), familyInfoTyConFlavour, + InstDecl(..), LInstDecl, FamilyInfo(..), TyFamInstDecl(..), LTyFamInstDecl, TyFamDefltDecl, LTyFamDefltDecl, DataFamInstDecl(..), LDataFamInstDecl, @@ -91,6 +91,7 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsExpr, HsUntypedSplice ) -- Because Expr imports Decls via HsBracket +import Language.Haskell.Syntax.Basic (TopLevelFlag, RuleName, NewOrData(..)) import Language.Haskell.Syntax.Binds import Language.Haskell.Syntax.Binds.InlinePragma (Activation) import Language.Haskell.Syntax.Extension @@ -98,8 +99,7 @@ import Language.Haskell.Syntax.Type import Language.Haskell.Syntax.Basic (Role, LexicalFixity) import Language.Haskell.Syntax.Specificity (Specificity) -import GHC.Types.Basic (TopLevelFlag, OverlapMode, RuleName - ,TyConFlavour(..), TypeOrData(..), NewOrData(..)) +import GHC.Types.Basic (OverlapMode) import GHC.Types.ForeignCall (CType, CCallConv, Safety, Header, CLabelString, CCallTarget, CExportSpec) import GHC.Data.FastString (FastString) @@ -108,7 +108,6 @@ import GHC.Hs.Doc (WithHsDocIdentifiers) import GHC.Types.SourceText (StringLiteral) import Control.DeepSeq -import Control.Exception (assert) import Control.Monad import Data.Data hiding (TyCon, Fixity, Infix) import Data.Maybe @@ -779,18 +778,6 @@ data FamilyInfo pass -- said "type family Foo x where .." | ClosedTypeFamily (Maybe [LTyFamInstEqn pass]) -familyInfoTyConFlavour - :: Maybe tc -- ^ Just cls <=> this is an associated family of class cls - -> FamilyInfo pass - -> TyConFlavour tc -familyInfoTyConFlavour mb_parent_tycon info = - case info of - DataFamily -> OpenFamilyFlavour (IAmData DataType) mb_parent_tycon - OpenTypeFamily -> OpenFamilyFlavour IAmType 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: @@ -932,11 +919,6 @@ data DataDefnCons a [a] -- The (possibly empty) list of data constructors deriving ( Eq, Data, Foldable, Functor, Traversable ) -- Needed because Demand derives Eq -dataDefnConsNewOrData :: DataDefnCons a -> NewOrData -dataDefnConsNewOrData = \ case - NewTypeCon {} -> NewType - DataTypeCons {} -> DataType - -- | Are the constructors within a @type data@ declaration? -- See Note [Type data declarations] in GHC.Rename.Module. isTypeDataDefnCons :: DataDefnCons a -> Bool ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs ===================================== @@ -33,7 +33,6 @@ import GHC import GHC.Core.InstEnv import qualified GHC.Driver.DynFlags as DynFlags import GHC.Driver.Ppr -import GHC.Plugins (TopLevelFlag (..)) import GHC.Types.SourceText import GHC.Unit.State import GHC.Utils.Outputable as Outputable ===================================== utils/haddock/haddock-api/src/Haddock/Convert.hs ===================================== @@ -59,7 +59,7 @@ import GHC.Core.TyCo.Rep import GHC.Core.TyCon import GHC.Core.Type import GHC.Hs -import GHC.Types.Basic (DefMethSpec (..), TopLevelFlag (..), TupleSort (..)) +import GHC.Types.Basic (DefMethSpec (..), TupleSort (..)) import GHC.Types.Id (idType, setIdType) import GHC.Types.Name import GHC.Types.Name.Reader (mkVarUnqual) ===================================== utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs ===================================== @@ -37,7 +37,7 @@ import GHC hiding (NoLink, HsTypeGhcPsExt (..)) import GHC.Builtin.Types (eqTyCon_RDR, tupleDataConName, tupleTyConName) import GHC.Core.TyCon (tyConResKind) import GHC.Driver.DynFlags (getDynFlags) -import GHC.Types.Basic (TopLevelFlag (..), TupleSort (..)) +import GHC.Types.Basic (TupleSort (..)) import GHC.Types.Name import GHC.Types.Name.Reader (RdrName (Exact)) import Language.Haskell.Syntax.BooleanFormula(BooleanFormula(..)) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d970f2bb8e0c5d173becef1c1aa8f1e2... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d970f2bb8e0c5d173becef1c1aa8f1e2... You're receiving this email because of your account on gitlab.haskell.org.
participants (1)
-
recursion-ninja (＠recursion-ninja)