recursion-ninja pushed to branch wip/26699 at Glasgow Haskell Compiler / GHC Commits: 631825ab by Recursion Ninja at 2026-01-26T19:24:37-05:00 Refactoring after adding TTG extension - - - - - 22 changed files: - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Extension.hs - − compiler/GHC/Hs/Extension.hs-boot - compiler/GHC/Hs/Instances.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Parser.y - compiler/GHC/ThToHs.hs - compiler/GHC/Types/ImportLevel.hs - − compiler/GHC/Types/Name/RdrName.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/OverlapFlag.hs - compiler/GHC/Types/OverlapMode.hs - compiler/GHC/Types/SourceText.hs - compiler/GHC/Unit/Types.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax/Basic.hs - compiler/Language/Haskell/Syntax/Decls.hs - + compiler/Language/Haskell/Syntax/Decls/Overlap.hs - ghc/GHCi/UI.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs Changes: ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -101,6 +101,7 @@ module GHC.Hs.Decls ( import GHC.Prelude import Language.Haskell.Syntax.Decls +import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..)) import Language.Haskell.Syntax.Extension import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprUntypedSplice ) ===================================== compiler/GHC/Hs/Extension.hs ===================================== @@ -16,10 +16,11 @@ import GHC.Prelude import Data.Data hiding ( Fixity ) import Language.Haskell.Syntax.Extension import GHC.Types.Name -import GHC.Types.Name.RdrName +import GHC.Types.Name.Reader import GHC.Types.Var import GHC.Utils.Outputable hiding ((<>)) import GHC.Types.SrcLoc (GenLocated(..), unLoc) +import GHC.Utils.Panic import GHC.Parser.Annotation {- @@ -152,9 +153,9 @@ data GhcPass (c :: Pass) where -- This really should never be entered, but the data-deriving machinery -- needs the instance to exist. instance Typeable p => Data (GhcPass p) where - gunfold _ _ _ = error "instance Data GhcPass" - toConstr _ = error "instance Data GhcPass" - dataTypeOf _ = error "instance Data GhcPass" + gunfold _ _ _ = panic "instance Data GhcPass" + toConstr _ = panic "instance Data GhcPass" + dataTypeOf _ = panic "instance Data GhcPass" data Pass = Parsed | Renamed | Typechecked deriving (Data) ===================================== compiler/GHC/Hs/Extension.hs-boot deleted ===================================== @@ -1,34 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableSuperClasses #-} -- for IsPass; see Note [NoGhcTc] - -module GHC.Hs.Extension where - -import Data.Type.Equality (type (~)) - --- | Used as a data type index for the hsSyn AST; also serves --- as a singleton type for Pass -data GhcPass (c :: Pass) where - GhcPs :: GhcPass 'Parsed - GhcRn :: GhcPass 'Renamed - GhcTc :: GhcPass 'Typechecked - -data Pass = Parsed | Renamed | Typechecked - --- Type synonyms as a shorthand for tagging -type GhcPs = GhcPass 'Parsed -- Output of parser -type GhcRn = GhcPass 'Renamed -- Output of renamer -type GhcTc = GhcPass 'Typechecked -- Output of typechecker - -type family NoGhcTcPass (p :: Pass) :: Pass where - NoGhcTcPass 'Typechecked = 'Renamed - NoGhcTcPass other = other - -class ( NoGhcTcPass (NoGhcTcPass p) ~ NoGhcTcPass p - , IsPass (NoGhcTcPass p) - ) => IsPass p where - ghcPass :: GhcPass p ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -32,8 +32,8 @@ import GHC.Parser.Annotation import GHC.Types.Name.Reader (WithUserRdr(..)) import GHC.Types.InlinePragma (ActivationGhc) import GHC.Data.BooleanFormula (BooleanFormula(..)) -import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Decls +import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..)) import Language.Haskell.Syntax.Extension (Anno) import Language.Haskell.Syntax.Binds.InlinePragma (ActivationX(..), InlinePragma(..)) ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -72,6 +72,7 @@ import GHC.Types.ForeignCall import GHC.Types.Var import GHC.Types.Id import GHC.Types.InlinePragma +import GHC.Types.OverlapMode import GHC.Types.SourceText import GHC.Types.TyThing import GHC.Types.Name hiding( varName, tcName ) ===================================== compiler/GHC/Parser.y ===================================== @@ -70,6 +70,7 @@ import GHC.Types.Error ( GhcHint(..) ) import GHC.Types.Fixity import GHC.Types.ForeignCall import GHC.Types.InlinePragma +import GHC.Types.OverlapMode import GHC.Types.SourceFile import GHC.Types.SourceText import GHC.Types.PkgQual ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -39,10 +39,11 @@ import qualified GHC.Core.Coercion as Coercion ( Role(..) ) import GHC.Builtin.Types import GHC.Builtin.Types.Prim( fUNTyCon ) import GHC.Types.Basic as Hs -import GHC.Types.InlinePragma as Hs import GHC.Types.ForeignCall -import GHC.Types.Unique +import GHC.Types.InlinePragma as Hs +import GHC.Types.OverlapMode as Hs import GHC.Types.SourceText +import GHC.Types.Unique import GHC.Utils.Lexeme import GHC.Utils.Misc import GHC.Data.FastString ===================================== compiler/GHC/Types/ImportLevel.hs ===================================== @@ -1,7 +1,14 @@ {-# LANGUAGE DerivingVia #-} module GHC.Types.ImportLevel ( - ImportLevel(..), convImportLevel, convImportLevelSpec, allImportLevels, + -- * ImportLevel + -- ** Data-type + ImportLevel(..), + -- ** Enumeration + allImportLevels, + -- ** Conversion + convImportLevel, + convImportLevelSpec ) where import GHC.Prelude ===================================== compiler/GHC/Types/Name/RdrName.hs deleted ===================================== @@ -1,202 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE PatternSynonyms #-} - --- | --- Export /only/ the 'RdrName' data-type. --- --- Since 'RdrName' is an integral data-type found in many places throughout --- the compiler, importing a module which exposes 'RdrName' can cause module --- import cycles. By having a dedicated module which exports the bare minimum --- necessary to expose the data-type definition, these module import cycles --- can easily be avoided! -module GHC.Types.Name.RdrName ( - -- * The main type - RdrName(..), - WithUserRdr(..), - isExact_maybe, - rdrNameOcc, - ) where - -import GHC.Prelude - -import GHC.Types.Name -import GHC.Unit.Module -import GHC.Utils.Outputable - -import Data.Data -import qualified Data.Semigroup as S - -{- -************************************************************************ -* * -\subsection{The main data type} -* * -************************************************************************ --} - --- | Reader Name --- --- Do not use the data constructors of RdrName directly: prefer the family --- of functions that creates them, such as 'mkRdrUnqual' --- --- - Note: A Located RdrName will only have API Annotations if it is a --- compound one, --- e.g. --- --- > `bar` --- > ( ~ ) --- -data RdrName - = Unqual OccName - -- ^ Unqualified name - -- - -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. - -- Create such a 'RdrName' with 'mkRdrUnqual' - - | Qual ModuleName OccName - -- ^ Qualified name - -- - -- A qualified name written by the user in - -- /source/ code. The module isn't necessarily - -- the module where the thing is defined; - -- just the one from which it is imported. - -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. - -- Create such a 'RdrName' with 'mkRdrQual' - - | Orig Module OccName - -- ^ Original name - -- - -- An original name; the module is the /defining/ module. - -- This is used when GHC generates code that will be fed - -- into the renamer (e.g. from deriving clauses), but where - -- we want to say \"Use Prelude.map dammit\". One of these - -- can be created with 'mkOrig' - - | Exact Name - -- ^ Exact name - -- - -- We know exactly the 'Name'. This is used: - -- - -- (1) When the parser parses built-in syntax like @[]@ - -- and @(,)@, but wants a 'RdrName' from it - -- - -- (2) By Template Haskell, when TH has generated a unique name - -- - -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' - deriving Data - -{- -************************************************************************ -* * -\subsection{Instances} -* * -************************************************************************ --} - -instance Eq RdrName where - (Exact n1) == (Exact n2) = n1==n2 - -- Convert exact to orig - (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 - r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 - - (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 - (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 - (Unqual o1) == (Unqual o2) = o1==o2 - _ == _ = False - -instance HasOccName RdrName where - occName = rdrNameOcc - -instance Ord RdrName where - a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } - a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } - a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - - -- Exact < Unqual < Qual < Orig - -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig - -- before comparing so that Prelude.map == the exact Prelude.map, but - -- that meant that we reported duplicates when renaming bindings - -- generated by Template Haskell; e.g - -- do { n1 <- newName "foo"; n2 <- newName "foo"; - -- <decl involving n1,n2> } - -- I think we can do without this conversion - compare (Exact n1) (Exact n2) = n1 `compare` n2 - compare (Exact _) _ = LT - - compare (Unqual _) (Exact _) = GT - compare (Unqual o1) (Unqual o2) = o1 `compare` o2 - compare (Unqual _) _ = LT - - compare (Qual _ _) (Exact _) = GT - compare (Qual _ _) (Unqual _) = GT - compare (Qual m1 o1) (Qual m2 o2) = compare o1 o2 S.<> compare m1 m2 - compare (Qual _ _) (Orig _ _) = LT - - compare (Orig m1 o1) (Orig m2 o2) = compare o1 o2 S.<> compare m1 m2 - compare (Orig _ _) _ = GT - -instance Outputable RdrName where - ppr (Exact name) = ppr name - ppr (Unqual occ) = ppr occ - ppr (Qual mod occ) = ppr mod <> dot <> ppr occ - ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod Nothing occ <> ppr occ) - -instance OutputableBndr RdrName where - pprBndr _ n - | isTvOcc (rdrNameOcc n) = char '@' <> ppr n - | otherwise = ppr n - - pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) - pprPrefixOcc rdr - | Just name <- isExact_maybe rdr = pprPrefixName name - -- pprPrefixName has some special cases, so - -- we delegate to them rather than reproduce them - | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) - -isExact_maybe :: RdrName -> Maybe Name -isExact_maybe (Exact n) = Just n -isExact_maybe _ = Nothing - -nukeExact :: Name -> RdrName -nukeExact n - | isExternalName n = Orig (nameModule n) (nameOccName n) - | otherwise = Unqual (nameOccName n) - -rdrNameOcc :: RdrName -> OccName -rdrNameOcc (Qual _ occ) = occ -rdrNameOcc (Unqual occ) = occ -rdrNameOcc (Orig _ occ) = occ -rdrNameOcc (Exact name) = nameOccName name - -rdrQual_maybe :: RdrName -> Maybe ModuleName -rdrQual_maybe = \case - Qual q _ -> Just q - _ -> Nothing - --------------------------------------------------------------------------------- --- Preserving user-written qualification - --- | 'WithUserRdr' allows us to keep track of the original user-written --- 'RdrName', and in particular, any user-written module qualification. --- --- See Note [IdOcc] in Language.Haskell.Syntax.Extension. -data WithUserRdr a = WithUserRdr RdrName a - deriving stock (Functor, Foldable, Traversable) - -instance NamedThing a => NamedThing (WithUserRdr a) where - getName (WithUserRdr _rdr a) = getName a -instance Outputable (WithUserRdr Name) where - ppr (WithUserRdr rdr name) = - pprName_userQual (rdrQual_maybe rdr) name -instance OutputableBndr (WithUserRdr Name) where - pprBndr _ (WithUserRdr rdr name) = - pprName_userQual (rdrQual_maybe rdr) name - pprInfixOcc :: WithUserRdr Name -> SDoc - pprInfixOcc = pprInfixName - pprPrefixOcc = pprPrefixName ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -117,13 +117,12 @@ import GHC.Data.FastString import GHC.Data.Maybe import GHC.Types.Avail -import GHC.Types.Basic +import GHC.Types.Basic ( TyConFlavour(..), tyConFlavourAssoc_maybe ) import GHC.Types.FieldLabel import GHC.Types.GREInfo import GHC.Types.ImportLevel import GHC.Types.Name import GHC.Types.Name.Env -import GHC.Types.Name.RdrName import GHC.Types.Name.Set import GHC.Types.PkgQual import GHC.Types.SrcLoc as SrcLoc @@ -152,6 +151,65 @@ import qualified Data.Map.Strict as Map import qualified Data.Semigroup as S import System.IO.Unsafe ( unsafePerformIO ) +{- +************************************************************************ +* * +\subsection{The main data type} +* * +************************************************************************ +-} + +-- | Reader Name +-- +-- Do not use the data constructors of RdrName directly: prefer the family +-- of functions that creates them, such as 'mkRdrUnqual' +-- +-- - Note: A Located RdrName will only have API Annotations if it is a +-- compound one, +-- e.g. +-- +-- > `bar` +-- > ( ~ ) +-- +data RdrName + = Unqual OccName + -- ^ Unqualified name + -- + -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. + -- Create such a 'RdrName' with 'mkRdrUnqual' + + | Qual ModuleName OccName + -- ^ Qualified name + -- + -- A qualified name written by the user in + -- /source/ code. The module isn't necessarily + -- the module where the thing is defined; + -- just the one from which it is imported. + -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. + -- Create such a 'RdrName' with 'mkRdrQual' + + | Orig Module OccName + -- ^ Original name + -- + -- An original name; the module is the /defining/ module. + -- This is used when GHC generates code that will be fed + -- into the renamer (e.g. from deriving clauses), but where + -- we want to say \"Use Prelude.map dammit\". One of these + -- can be created with 'mkOrig' + + | Exact Name + -- ^ Exact name + -- + -- We know exactly the 'Name'. This is used: + -- + -- (1) When the parser parses built-in syntax like @[]@ + -- and @(,)@, but wants a 'RdrName' from it + -- + -- (2) By Template Haskell, when TH has generated a unique name + -- + -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' + deriving Data + {- ************************************************************************ * * @@ -160,6 +218,15 @@ import System.IO.Unsafe ( unsafePerformIO ) ************************************************************************ -} +instance HasOccName RdrName where + occName = rdrNameOcc + +rdrNameOcc :: RdrName -> OccName +rdrNameOcc (Qual _ occ) = occ +rdrNameOcc (Unqual occ) = occ +rdrNameOcc (Orig _ occ) = occ +rdrNameOcc (Exact name) = nameOccName name + rdrNameSpace :: RdrName -> NameSpace rdrNameSpace = occNameSpace . rdrNameOcc @@ -226,6 +293,11 @@ nameRdrName name = Exact name -- unique is still there for debug printing, particularly -- of Types (which are converted to IfaceTypes before printing) +nukeExact :: Name -> RdrName +nukeExact n + | isExternalName n = Orig (nameModule n) (nameOccName n) + | otherwise = Unqual (nameOccName n) + isRdrDataCon :: RdrName -> Bool isRdrTyVar :: RdrName -> Bool isRdrTc :: RdrName -> Bool @@ -263,6 +335,76 @@ isExact :: RdrName -> Bool isExact (Exact _) = True isExact _ = False +isExact_maybe :: RdrName -> Maybe Name +isExact_maybe (Exact n) = Just n +isExact_maybe _ = Nothing + +{- +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Outputable RdrName where + ppr (Exact name) = ppr name + ppr (Unqual occ) = ppr occ + ppr (Qual mod occ) = ppr mod <> dot <> ppr occ + ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod Nothing occ <> ppr occ) + +instance OutputableBndr RdrName where + pprBndr _ n + | isTvOcc (rdrNameOcc n) = char '@' <> ppr n + | otherwise = ppr n + + pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + pprPrefixOcc rdr + | Just name <- isExact_maybe rdr = pprPrefixName name + -- pprPrefixName has some special cases, so + -- we delegate to them rather than reproduce them + | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + +instance Eq RdrName where + (Exact n1) == (Exact n2) = n1==n2 + -- Convert exact to orig + (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 + r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 + + (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 + (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 + (Unqual o1) == (Unqual o2) = o1==o2 + _ == _ = False + +instance Ord RdrName where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + + -- Exact < Unqual < Qual < Orig + -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig + -- before comparing so that Prelude.map == the exact Prelude.map, but + -- that meant that we reported duplicates when renaming bindings + -- generated by Template Haskell; e.g + -- do { n1 <- newName "foo"; n2 <- newName "foo"; + -- <decl involving n1,n2> } + -- I think we can do without this conversion + compare (Exact n1) (Exact n2) = n1 `compare` n2 + compare (Exact _) _ = LT + + compare (Unqual _) (Exact _) = GT + compare (Unqual o1) (Unqual o2) = o1 `compare` o2 + compare (Unqual _) _ = LT + + compare (Qual _ _) (Exact _) = GT + compare (Qual _ _) (Unqual _) = GT + compare (Qual m1 o1) (Qual m2 o2) = compare o1 o2 S.<> compare m1 m2 + compare (Qual _ _) (Orig _ _) = LT + + compare (Orig m1 o1) (Orig m2 o2) = compare o1 o2 S.<> compare m1 m2 + compare (Orig _ _) _ = GT + {- ************************************************************************ * * @@ -2076,6 +2218,29 @@ pprLoc (UnhelpfulSpan {}) = empty opIsAt :: RdrName -> Bool opIsAt e = e == mkUnqual varName (fsLit "@") + +-------------------------------------------------------------------------------- +-- Preserving user-written qualification + +-- | 'WithUserRdr' allows us to keep track of the original user-written +-- 'RdrName', and in particular, any user-written module qualification. +-- +-- See Note [IdOcc] in Language.Haskell.Syntax.Extension. +data WithUserRdr a = WithUserRdr RdrName a + deriving stock (Functor, Foldable, Traversable) + +instance NamedThing a => NamedThing (WithUserRdr a) where + getName (WithUserRdr _rdr a) = getName a +instance Outputable (WithUserRdr Name) where + ppr (WithUserRdr rdr name) = + pprName_userQual (rdrQual_maybe rdr) name +instance OutputableBndr (WithUserRdr Name) where + pprBndr _ (WithUserRdr rdr name) = + pprName_userQual (rdrQual_maybe rdr) name + pprInfixOcc :: WithUserRdr Name -> SDoc + pprInfixOcc = pprInfixName + pprPrefixOcc = pprPrefixName + unLocWithUserRdr :: GenLocated l (WithUserRdr a) -> a unLocWithUserRdr (L _ (WithUserRdr _ a)) = a @@ -2084,3 +2249,10 @@ noUserRdr n = WithUserRdr (nameRdrName n) n userRdrName :: WithUserRdr Name -> RdrName userRdrName (WithUserRdr rdr _) = rdr + +rdrQual_maybe :: RdrName -> Maybe ModuleName +rdrQual_maybe = \case + Qual q _ -> Just q + _ -> Nothing + +-------------------------------------------------------------------------------- ===================================== compiler/GHC/Types/OverlapFlag.hs ===================================== @@ -41,7 +41,7 @@ import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Types.OverlapMode (changeOverlapModePass) -import Language.Haskell.Syntax.Basic (OverlapMode(..)) +import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..)) import Control.DeepSeq (NFData(..)) ===================================== compiler/GHC/Types/OverlapMode.hs ===================================== @@ -5,6 +5,13 @@ {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- + * (type class): Binary OverlapMode + * (type family): XOverlapMode (GhcPass p) + * (type family): XXOverlapMode (GhcPass p) +-} + module GHC.Types.OverlapMode ( -- * OverlapMode -- ** Data-type @@ -21,15 +28,13 @@ module GHC.Types.OverlapMode ( import GHC.Prelude -import {-# SOURCE #-} GHC.Hs.Extension (GhcPass) - +import GHC.Hs.Extension (GhcPass) import GHC.Types.SourceText +import GHC.Utils.Binary -import Language.Haskell.Syntax.Basic (OverlapMode(..)) +import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..)) import Language.Haskell.Syntax.Extension -import Control.DeepSeq ( NFData(..) ) - type instance XOverlapMode (GhcPass _) = SourceText type instance XXOverlapMode (GhcPass _) = DataConCantHappen @@ -77,3 +82,21 @@ hasNonCanonicalFlag :: OverlapMode (GhcPass p) -> Bool hasNonCanonicalFlag = \case NonCanonical{} -> True _ -> False + +instance Binary (OverlapMode (GhcPass p)) where + put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s + put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s + put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s + put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s + put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s + put_ bh (NonCanonical s) = putByte bh 5 >> put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> (get bh) >>= \s -> return $ NoOverlap s + 1 -> (get bh) >>= \s -> return $ Overlaps s + 2 -> (get bh) >>= \s -> return $ Incoherent s + 3 -> (get bh) >>= \s -> return $ Overlapping s + 4 -> (get bh) >>= \s -> return $ Overlappable s + _ -> (get bh) >>= \s -> return $ NonCanonical s ===================================== compiler/GHC/Types/SourceText.hs ===================================== @@ -32,6 +32,7 @@ import GHC.Prelude import GHC.Data.FastString import GHC.Utils.Outputable +import GHC.Utils.Binary import GHC.Utils.Panic import Data.Function (on) @@ -112,6 +113,21 @@ instance NFData SourceText where SourceText s -> rnf s NoSourceText -> () +instance Binary SourceText where + put_ bh NoSourceText = putByte bh 0 + put_ bh (SourceText s) = do + putByte bh 1 + put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> return NoSourceText + 1 -> do + s <- get bh + return (SourceText s) + _ -> panic $ "Binary SourceText:" ++ show h + -- | Special combinator for showing string literals. pprWithSourceText :: SourceText -> SDoc -> SDoc pprWithSourceText NoSourceText d = d ===================================== compiler/GHC/Unit/Types.hs ===================================== @@ -82,6 +82,7 @@ import GHC.Prelude import GHC.Types.Unique import GHC.Types.Unique.DSet +import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Utils.Encoding @@ -135,6 +136,11 @@ mkModule = Module instance Uniquable Module where getUnique (Module p n) = getUnique (unitFS p `appendFS` moduleNameFS n) +instance Binary a => Binary (GenModule a) where + put_ bh (Module p n) = put_ bh p >> put_ bh n + -- Module has strict fields, so use $! in order not to allocate a thunk + get bh = do p <- get bh; n <- get bh; return $! Module p n + instance NFData (GenModule a) where rnf (Module unit name) = unit `seq` name `seq` () @@ -293,6 +299,23 @@ instance Eq (GenInstantiatedUnit unit) where instance Ord (GenInstantiatedUnit unit) where u1 `compare` u2 = instUnitFS u1 `lexicalCompareFS` instUnitFS u2 +instance Binary InstantiatedUnit where + put_ bh indef = do + put_ bh (instUnitInstanceOf indef) + put_ bh (instUnitInsts indef) + get bh = do + cid <- get bh + insts <- get bh + let fs = mkInstantiatedUnitHash cid insts + -- InstantiatedUnit has strict fields, so use $! in order not to allocate a thunk + return $! InstantiatedUnit { + instUnitInstanceOf = cid, + instUnitInsts = insts, + instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), + instUnitFS = fs, + instUnitKey = getUnique fs + } + instance IsUnitId u => Eq (GenUnit u) where uid1 == uid2 = unitUnique uid1 == unitUnique uid2 @@ -326,6 +349,24 @@ pprUnit HoleUnit = ftext holeFS instance Show Unit where show = unitString +-- Performance: would prefer to have a NameCache like thing +instance Binary Unit where + put_ bh (RealUnit def_uid) = do + putByte bh 0 + put_ bh def_uid + put_ bh (VirtUnit indef_uid) = do + putByte bh 1 + put_ bh indef_uid + put_ bh HoleUnit = + putByte bh 2 + get bh = do b <- getByte bh + u <- case b of + 0 -> fmap RealUnit (get bh) + 1 -> fmap VirtUnit (get bh) + _ -> pure HoleUnit + -- Unit has strict fields that need forcing; otherwise we allocate a thunk. + pure $! u + -- | Retrieve the set of free module holes of a 'Unit'. unitFreeModuleHoles :: GenUnit u -> UniqDSet ModuleName unitFreeModuleHoles (VirtUnit x) = instUnitHoles x @@ -468,6 +509,10 @@ newtype UnitId = UnitId instance NFData UnitId where rnf (UnitId fs) = rnf fs `seq` () +instance Binary UnitId where + put_ bh (UnitId fs) = put_ bh fs + get bh = do fs <- get bh; return (UnitId fs) + instance Eq UnitId where uid1 == uid2 = getUnique uid1 == getUnique uid2 @@ -503,7 +548,7 @@ stringToUnitId = UnitId . mkFastString -- | A definite unit (i.e. without any free module hole) newtype Definite unit = Definite { unDefinite :: unit } deriving (Functor) - deriving newtype (Eq, Ord, Outputable, Uniquable, IsUnitId) + deriving newtype (Eq, Ord, Outputable, Binary, Uniquable, IsUnitId) --------------------------------------------------------------------- -- WIRED-IN UNITS @@ -651,6 +696,15 @@ type ModuleNameWithIsBoot = GenWithIsBoot ModuleName type ModuleWithIsBoot = GenWithIsBoot Module +instance Binary a => Binary (GenWithIsBoot a) where + put_ bh (GWIB { gwib_mod, gwib_isBoot }) = do + put_ bh gwib_mod + put_ bh gwib_isBoot + get bh = do + gwib_mod <- get bh + gwib_isBoot <- get bh + pure $ GWIB { gwib_mod, gwib_isBoot } + instance Outputable a => Outputable (GenWithIsBoot a) where ppr (GWIB { gwib_mod, gwib_isBoot }) = hsep $ ppr gwib_mod : case gwib_isBoot of IsBoot -> [ text "{-# SOURCE #-}" ] ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -120,8 +120,8 @@ 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(..)) -import {-# SOURCE #-} GHC.Hs.Extension (GhcPass) import {-# SOURCE #-} GHC.Types.Name (Name) import GHC.Data.FastString import GHC.Data.TrieMap @@ -130,19 +130,14 @@ import GHC.Utils.Panic.Plain import GHC.Types.Unique.FM import GHC.Data.FastMutInt import GHC.Utils.Fingerprint -import GHC.Types.OverlapMode -import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Types.Unique -import GHC.Unit.Types import qualified GHC.Data.Strict as Strict import GHC.Utils.Outputable( JoinPointHood(..) ) import GHCi.FFI import GHCi.Message -import GHC.Types.Unique.DSet ( unionManyUniqDSets ) - -import Control.DeepSeq ( NFData(..) ) +import Control.DeepSeq import Control.Monad ( when, (<$!>), unless, forM_, void ) import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void) import Data.Array @@ -2017,85 +2012,6 @@ instance NFData a => NFData (FingerprintWithValue a) where rnf (FingerprintWithValue fp mflags) = rnf fp `seq` rnf mflags `seq` () -instance Binary SourceText where - put_ bh NoSourceText = putByte bh 0 - put_ bh (SourceText s) = do - putByte bh 1 - put_ bh s - - get bh = do - h <- getByte bh - case h of - 0 -> return NoSourceText - 1 -> do - s <- get bh - return (SourceText s) - _ -> panic $ "Binary SourceText:" ++ show h - --------------------------------------------------------------------------------- --- Instances for the GHC.Unit.Types module --------------------------------------------------------------------------------- - -instance Binary a => Binary (GenModule a) where - put_ bh (Module p n) = put_ bh p >> put_ bh n - -- Module has strict fields, so use $! in order not to allocate a thunk - get bh = do p <- get bh; n <- get bh; return $! Module p n - -instance Binary InstantiatedUnit where - put_ bh indef = do - put_ bh (instUnitInstanceOf indef) - put_ bh (instUnitInsts indef) - get bh = do - cid <- get bh - insts <- get bh - let fs = mkInstantiatedUnitHash cid insts - -- InstantiatedUnit has strict fields, so use $! in order not to allocate a t\ -hunk - return $! InstantiatedUnit { - instUnitInstanceOf = cid, - instUnitInsts = insts, - instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) ins\ -ts), - instUnitFS = fs, - instUnitKey = getUnique fs - } - --- Performance: would prefer to have a NameCache like thing -instance Binary Unit where - put_ bh (RealUnit def_uid) = do - putByte bh 0 - put_ bh def_uid - put_ bh (VirtUnit indef_uid) = do - putByte bh 1 - put_ bh indef_uid - put_ bh HoleUnit = - putByte bh 2 - get bh = do b <- getByte bh - u <- case b of - 0 -> fmap RealUnit (get bh) - 1 -> fmap VirtUnit (get bh) - _ -> pure HoleUnit - -- Unit has strict fields that need forcing; otherwise we allocate \ -a thunk. - pure $! u - -instance Binary UnitId where - put_ bh (UnitId fs) = put_ bh fs - get bh = do fs <- get bh; return (UnitId fs) - -instance Binary a => Binary (GenWithIsBoot a) where - put_ bh (GWIB { gwib_mod, gwib_isBoot }) = do - put_ bh gwib_mod - put_ bh gwib_isBoot - get bh = do - gwib_mod <- get bh - gwib_isBoot <- get bh - pure $ GWIB { gwib_mod, gwib_isBoot } - -deriving newtype instance Binary x => Binary (Definite x) - --------------------------------------------------------------------------------- - instance Binary Boxity where -- implemented via isBoxed-isomorphism to Bool put_ bh = put_ bh . isBoxed get bh = do @@ -2164,21 +2080,3 @@ instance Binary RuleMatchInfo where h <- getByte bh if h == 1 then pure ConLike else pure FunLike - -instance Binary (OverlapMode (GhcPass p)) where - put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s - put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s - put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s - put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s - put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s - put_ bh (NonCanonical s) = putByte bh 5 >> put_ bh s - - get bh = do - h <- getByte bh - case h of - 0 -> (get bh) >>= \s -> return $ NoOverlap s - 1 -> (get bh) >>= \s -> return $ Overlaps s - 2 -> (get bh) >>= \s -> return $ Incoherent s - 3 -> (get bh) >>= \s -> return $ Overlapping s - 4 -> (get bh) >>= \s -> return $ Overlappable s - _ -> (get bh) >>= \s -> return $ NonCanonical s ===================================== compiler/GHC/Utils/Outputable.hs ===================================== @@ -114,6 +114,7 @@ import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName ) import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Binds.InlinePragma +import Language.Haskell.Syntax.Decls.Overlap ( OverlapMode(..) ) import Language.Haskell.Syntax.Module.Name ( ModuleName(..) ) import GHC.Prelude.Basic ===================================== compiler/Language/Haskell/Syntax/Basic.hs ===================================== @@ -3,8 +3,11 @@ {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Eq XOverlapMode, NFData OverlapMode +-- | Data-type defintions of the Abstrast Sytntax Tree +-- which *do not* have any /Trees That Grow/ extension points. module Language.Haskell.Syntax.Basic where +import Control.DeepSeq import Data.Data (Data) import Data.Eq import Data.Ord @@ -12,8 +15,6 @@ import Data.Bool import Prelude import GHC.Data.FastString (FastString) -import Language.Haskell.Syntax.Extension -import Control.DeepSeq {- ************************************************************************ @@ -161,81 +162,3 @@ data Fixity = Fixity Int FixityDirection instance NFData Fixity where rnf (Fixity i d) = rnf i `seq` rnf d `seq` () - -data OverlapMode pass -- See Note [Rules for instance lookup] in GHC.Core.InstEnv - = NoOverlap (XOverlapMode pass) - -- See Note [Pragma source text] - -- ^ This instance must not overlap another `NoOverlap` instance. - -- However, it may be overlapped by `Overlapping` instances, - -- and it may overlap `Overlappable` instances. - - - | Overlappable (XOverlapMode pass) - -- See Note [Pragma source text] - -- ^ Silently ignore this instance if you find a - -- more specific one that matches the constraint - -- you are trying to resolve - -- - -- Example: constraint (Foo [Int]) - -- instance Foo [Int] - -- instance {-# OVERLAPPABLE #-} Foo [a] - -- - -- Since the second instance has the Overlappable flag, - -- the first instance will be chosen (otherwise - -- its ambiguous which to choose) - - | Overlapping (XOverlapMode pass) - -- See Note [Pragma source text] - -- ^ Silently ignore any more general instances that may be - -- used to solve the constraint. - -- - -- Example: constraint (Foo [Int]) - -- instance {-# OVERLAPPING #-} Foo [Int] - -- instance Foo [a] - -- - -- Since the first instance has the Overlapping flag, - -- the second---more general---instance will be ignored (otherwise - -- it is ambiguous which to choose) - - | Overlaps (XOverlapMode pass) - -- See Note [Pragma source text] - -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. - - | Incoherent (XOverlapMode pass) - -- See Note [Pragma source text] - -- ^ Behave like Overlappable and Overlapping, and in addition pick - -- an arbitrary one if there are multiple matching candidates, and - -- don't worry about later instantiation - -- - -- Example: constraint (Foo [b]) - -- instance {-# INCOHERENT -} Foo [Int] - -- instance Foo [a] - -- Without the Incoherent flag, we'd complain that - -- instantiating 'b' would change which instance - -- was chosen. See also Note [Incoherent instances] in "GHC.Core.InstEnv" - - | NonCanonical (XOverlapMode pass) - -- ^ Behave like Incoherent, but the instance choice is observable - -- by the program behaviour. See Note [Coherence and specialisation: overview]. - -- - -- We don't have surface syntax for the distinction between - -- Incoherent and NonCanonical instances; instead, the flag - -- `-f{no-}specialise-incoherents` (on by default) controls - -- whether `INCOHERENT` instances are regarded as Incoherent or - -- NonCanonical. - - | XOverlapMode !(XXOverlapMode pass) - -- ^ The /Trees That Grow/ extension point constructor. - -deriving instance ( Eq (XOverlapMode pass) - , Eq (XXOverlapMode pass)) => Eq (OverlapMode pass) - -instance ( NFData (XOverlapMode pass) - , XXOverlapMode pass ~ DataConCantHappen) => NFData (OverlapMode pass) where - rnf = \case - NoOverlap s -> rnf s - Overlappable s -> rnf s - Overlapping s -> rnf s - Overlaps s -> rnf s - Incoherent s -> rnf s - NonCanonical s -> rnf s ===================================== compiler/Language/Haskell/Syntax/Decls.hs ===================================== @@ -88,16 +88,17 @@ module Language.Haskell.Syntax.Decls ( -- friends: import {-# SOURCE #-} Language.Haskell.Syntax.Expr - ( HsExpr, HsUntypedSplice ) + (HsExpr, HsUntypedSplice) -- Because Expr imports Decls via HsBracket -import Language.Haskell.Syntax.Basic (OverlapMode, RuleName, TopLevelFlag) +import Language.Haskell.Syntax.Basic + (LexicalFixity, Role, RuleName, TopLevelFlag) import Language.Haskell.Syntax.Binds import Language.Haskell.Syntax.Binds.InlinePragma (Activation) +import Language.Haskell.Syntax.Decls.Overlap (OverlapMode) import Language.Haskell.Syntax.Extension -import Language.Haskell.Syntax.Type -import Language.Haskell.Syntax.Basic (Role, LexicalFixity) import Language.Haskell.Syntax.Specificity (Specificity) +import Language.Haskell.Syntax.Type import GHC.Types.ForeignCall (CType, CCallConv, Safety, Header, CLabelString, CCallTarget, CExportSpec) @@ -118,7 +119,7 @@ import Prelude (Show) import Data.Foldable import Data.Traversable import Data.List.NonEmpty (NonEmpty (..)) -import GHC.Generics ( Generic ) +import GHC.Generics (Generic) {- ===================================== compiler/Language/Haskell/Syntax/Decls/Overlap.hs ===================================== @@ -0,0 +1,96 @@ +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- Eq XOverlapMode, NFData OverlapMode + +{- | +Data-type describing the state of "overlapping instances" for a type. +-} +module Language.Haskell.Syntax.Decls.Overlap where + +import Control.DeepSeq +import Data.Eq +import Prelude + +import Language.Haskell.Syntax.Extension + +-- | The status of overlapping instances /(including no overlap)/ for a type. +data OverlapMode pass -- See Note [Rules for instance lookup] in GHC.Core.InstEnv + = NoOverlap (XOverlapMode pass) + -- See Note [Pragma source text] + -- ^ This instance must not overlap another `NoOverlap` instance. + -- However, it may be overlapped by `Overlapping` instances, + -- and it may overlap `Overlappable` instances. + + + | Overlappable (XOverlapMode pass) + -- See Note [Pragma source text] + -- ^ Silently ignore this instance if you find a + -- more specific one that matches the constraint + -- you are trying to resolve + -- + -- Example: constraint (Foo [Int]) + -- instance Foo [Int] + -- instance {-# OVERLAPPABLE #-} Foo [a] + -- + -- Since the second instance has the Overlappable flag, + -- the first instance will be chosen (otherwise + -- its ambiguous which to choose) + + | Overlapping (XOverlapMode pass) + -- See Note [Pragma source text] + -- ^ Silently ignore any more general instances that may be + -- used to solve the constraint. + -- + -- Example: constraint (Foo [Int]) + -- instance {-# OVERLAPPING #-} Foo [Int] + -- instance Foo [a] + -- + -- Since the first instance has the Overlapping flag, + -- the second---more general---instance will be ignored (otherwise + -- it is ambiguous which to choose) + + | Overlaps (XOverlapMode pass) + -- See Note [Pragma source text] + -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. + + | Incoherent (XOverlapMode pass) + -- See Note [Pragma source text] + -- ^ Behave like Overlappable and Overlapping, and in addition pick + -- an arbitrary one if there are multiple matching candidates, and + -- don't worry about later instantiation + -- + -- Example: constraint (Foo [b]) + -- instance {-# INCOHERENT -} Foo [Int] + -- instance Foo [a] + -- Without the Incoherent flag, we'd complain that + -- instantiating 'b' would change which instance + -- was chosen. See also Note [Incoherent instances] in "GHC.Core.InstEnv" + + | NonCanonical (XOverlapMode pass) + -- ^ Behave like Incoherent, but the instance choice is observable + -- by the program behaviour. See Note [Coherence and specialisation: overview]. + -- + -- We don't have surface syntax for the distinction between + -- Incoherent and NonCanonical instances; instead, the flag + -- `-f{no-}specialise-incoherents` (on by default) controls + -- whether `INCOHERENT` instances are regarded as Incoherent or + -- NonCanonical. + + | XOverlapMode !(XXOverlapMode pass) + -- ^ The /Trees That Grow/ extension point constructor. + +deriving instance ( Eq (XOverlapMode pass) + , Eq (XXOverlapMode pass) + ) => Eq (OverlapMode pass) + +instance ( NFData (XOverlapMode pass) + , XXOverlapMode pass ~ DataConCantHappen + ) => NFData (OverlapMode pass) where + rnf = \case + NoOverlap s -> rnf s + Overlappable s -> rnf s + Overlapping s -> rnf s + Overlaps s -> rnf s + Incoherent s -> rnf s + NonCanonical s -> rnf s ===================================== ghc/GHCi/UI.hs ===================================== @@ -75,6 +75,7 @@ import GHC.Core.TyCo.Ppr import GHC.Types.SafeHaskell ( getSafeMode ) import GHC.Types.SourceError ( SourceError, initSourceErrorContext ) import GHC.Types.Name +import GHC.Types.ImportLevel ( convImportLevel ) import GHC.Types.Var ( varType ) import GHC.Iface.Syntax ( showToHeader ) import GHC.Builtin.Names ===================================== utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs ===================================== @@ -40,7 +40,7 @@ import GHC.Driver.DynFlags (getDynFlags) import GHC.Types.Basic (TupleSort (..)) import GHC.Types.Name import GHC.Types.Name.Reader (RdrName (Exact)) -import GHC.Types.OverlapMode (changeOverlapModeType) +import GHC.Types.OverlapMode (OverlapMode, changeOverlapModeType) import Language.Haskell.Syntax.BooleanFormula(BooleanFormula(..)) import Haddock.Backends.Hoogle (ppExportD) ===================================== utils/haddock/haddock-api/src/Haddock/Types.hs ===================================== @@ -59,6 +59,7 @@ import GHC.Core.InstEnv (is_dfun_name) import GHC.Types.Name (stableNameCmp) import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader (RdrName (..)) +import GHC.Types.OverlapMode (OverlapMode) import GHC.Types.SrcLoc (srcSpanToRealSrcSpan) import GHC.Types.Var (Specificity) import GHC.Utils.Outputable View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/631825abd5f66565616eaa5e314f1eaf... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/631825abd5f66565616eaa5e314f1eaf... You're receiving this email because of your account on gitlab.haskell.org.
participants (1)
-
recursion-ninja (＠recursion-ninja)