module GHC.Builtin.Utils (
isKnownKeyName,
lookupKnownKeyName,
lookupKnownNameInfo,
knownKeyNames,
wiredInIds, ghcPrimIds,
ghcPrimExports,
ghcPrimDeclDocs,
ghcPrimWarns,
ghcPrimFixities,
maybeCharLikeCon, maybeIntLikeCon,
isNumericClass, isStandardClass
) where
import GHC.Prelude
import GHC.Builtin.Uniques
import GHC.Builtin.PrimOps
import GHC.Builtin.PrimOps.Ids
import GHC.Builtin.Types
import GHC.Builtin.Types.Literals ( typeNatTyCons )
import GHC.Builtin.Types.Prim
import GHC.Builtin.Names.TH ( templateHaskellNames )
import GHC.Builtin.Names
import GHC.Core.ConLike ( ConLike(..) )
import GHC.Core.DataCon
import GHC.Core.Class
import GHC.Core.TyCon
import GHC.Types.Avail
import GHC.Types.Id
import GHC.Types.Fixity
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Id.Make
import GHC.Types.SourceText
import GHC.Types.Unique.FM
import GHC.Types.Unique.Map
import GHC.Types.TyThing
import GHC.Types.Unique ( isValidKnownKeyUnique, pprUniqueAlways )
import GHC.Utils.Outputable
import GHC.Utils.Misc as Utils
import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
import GHC.Parser.Annotation
import GHC.Hs.Doc
import GHC.Unit.Module.ModIface (IfaceExport)
import GHC.Unit.Module.Warnings
import GHC.Data.List.SetOps
import Control.Applicative ((<|>))
import Data.Maybe
knownKeyNames :: [Name]
knownKeyNames :: [Name]
knownKeyNames
| Bool
debugIsOn
, Just SDoc
badNamesDoc <- [Name] -> Maybe SDoc
knownKeyNamesOkay [Name]
all_names
= String -> SDoc -> [Name]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"badAllKnownKeyNames" SDoc
badNamesDoc
| Bool
otherwise
= [Name]
all_names
where
all_names :: [Name]
all_names =
[[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ (TyCon -> [Name]) -> [TyCon] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TyCon -> [Name]
wired_tycon_kk_names [TyCon]
primTyCons
, (TyCon -> [Name]) -> [TyCon] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TyCon -> [Name]
wired_tycon_kk_names [TyCon]
wiredInTyCons
, (TyCon -> [Name]) -> [TyCon] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TyCon -> [Name]
wired_tycon_kk_names [TyCon]
typeNatTyCons
, (Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
idName [Id]
wiredInIds
, (Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
idName [Id]
allThePrimOpIds
, (PrimOp -> Name) -> [PrimOp] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Id -> Name
idName (Id -> Name) -> (PrimOp -> Id) -> PrimOp -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimOp -> Id
primOpWrapperId) [PrimOp]
allThePrimOps
, [Name]
basicKnownKeyNames
, [Name]
templateHaskellNames
]
wired_tycon_kk_names :: TyCon -> [Name]
wired_tycon_kk_names :: TyCon -> [Name]
wired_tycon_kk_names TyCon
tc =
TyCon -> Name
tyConName TyCon
tc Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: (TyCon -> [Name]
rep_names TyCon
tc [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
implicits)
where implicits :: [Name]
implicits = (TyThing -> [Name]) -> [TyThing] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TyThing -> [Name]
thing_kk_names (TyCon -> [TyThing]
implicitTyConThings TyCon
tc)
wired_datacon_kk_names :: DataCon -> [Name]
wired_datacon_kk_names :: DataCon -> [Name]
wired_datacon_kk_names DataCon
dc =
DataCon -> Name
dataConName DataCon
dc Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: TyCon -> [Name]
rep_names (DataCon -> TyCon
promoteDataCon DataCon
dc)
thing_kk_names :: TyThing -> [Name]
thing_kk_names :: TyThing -> [Name]
thing_kk_names (ATyCon TyCon
tc) = TyCon -> [Name]
wired_tycon_kk_names TyCon
tc
thing_kk_names (AConLike (RealDataCon DataCon
dc)) = DataCon -> [Name]
wired_datacon_kk_names DataCon
dc
thing_kk_names TyThing
thing = [TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
thing]
rep_names :: TyCon -> [Name]
rep_names TyCon
tc = case TyCon -> Maybe Name
tyConRepName_maybe TyCon
tc of
Just Name
n -> [Name
n]
Maybe Name
Nothing -> []
knownKeyNamesOkay :: [Name] -> Maybe SDoc
knownKeyNamesOkay :: [Name] -> Maybe SDoc
knownKeyNamesOkay [Name]
all_names
| ns :: [Name]
ns@(Name
_:[Name]
_) <- (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Name -> Bool) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Bool
isValidKnownKeyUnique (Unique -> Bool) -> (Name -> Unique) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Unique
forall a. Uniquable a => a -> Unique
getUnique) [Name]
all_names
= SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" Out-of-range known-key uniques: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets ((Name -> SDoc) -> [Name] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OccName -> SDoc) -> (Name -> OccName) -> Name -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName) [Name]
ns)
| [(Unique, [Name])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Unique, [Name])]
badNamesPairs
= Maybe SDoc
forall a. Maybe a
Nothing
| Bool
otherwise
= SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just SDoc
badNamesDoc
where
namesEnv :: NameEnv [Name]
namesEnv = (NameEnv [Name] -> Name -> NameEnv [Name])
-> NameEnv [Name] -> [Name] -> NameEnv [Name]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\NameEnv [Name]
m Name
n -> (Name -> [Name] -> [Name])
-> (Name -> [Name])
-> NameEnv [Name]
-> Name
-> Name
-> NameEnv [Name]
forall a b.
(a -> b -> b) -> (a -> b) -> NameEnv b -> Name -> a -> NameEnv b
extendNameEnv_Acc (:) Name -> [Name]
forall a. a -> [a]
Utils.singleton NameEnv [Name]
m Name
n Name
n)
NameEnv [Name]
forall {k} (key :: k) elt. UniqFM key elt
emptyUFM [Name]
all_names
badNamesEnv :: NameEnv [Name]
badNamesEnv = ([Name] -> Bool) -> NameEnv [Name] -> NameEnv [Name]
forall elt. (elt -> Bool) -> NameEnv elt -> NameEnv elt
filterNameEnv (\[Name]
ns -> [Name]
ns [Name] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
1) NameEnv [Name]
namesEnv
badNamesPairs :: [(Unique, [Name])]
badNamesPairs = NameEnv [Name] -> [(Unique, [Name])]
forall {k} (key :: k) elt. UniqFM key elt -> [(Unique, elt)]
nonDetUFMToList NameEnv [Name]
badNamesEnv
badNamesDoc :: SDoc
badNamesDoc :: SDoc
badNamesDoc = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ ((Unique, [Name]) -> SDoc) -> [(Unique, [Name])] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Unique, [Name]) -> SDoc
pairToDoc [(Unique, [Name])]
badNamesPairs
pairToDoc :: (Unique, [Name]) -> SDoc
pairToDoc :: (Unique, [Name]) -> SDoc
pairToDoc (Unique
uniq, [Name]
ns) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
Unique -> SDoc
forall doc. IsLine doc => Unique -> doc
pprUniqueAlways Unique
uniq SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
": " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets ((Name -> SDoc) -> [Name] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OccName -> SDoc) -> (Name -> OccName) -> Name -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName) [Name]
ns)
lookupKnownKeyName :: Unique -> Maybe Name
lookupKnownKeyName :: Unique -> Maybe Name
lookupKnownKeyName Unique
u =
Unique -> Maybe Name
knownUniqueName Unique
u Maybe Name -> Maybe Name -> Maybe Name
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> UniqFM Name Name -> Unique -> Maybe Name
forall {k} (key :: k) elt. UniqFM key elt -> Unique -> Maybe elt
lookupUFM_Directly UniqFM Name Name
knownKeysMap Unique
u
isKnownKeyName :: Name -> Bool
isKnownKeyName :: Name -> Bool
isKnownKeyName Name
n =
Maybe Name -> Bool
forall a. Maybe a -> Bool
isJust (Unique -> Maybe Name
knownUniqueName (Unique -> Maybe Name) -> Unique -> Maybe Name
forall a b. (a -> b) -> a -> b
$ Name -> Unique
nameUnique Name
n) Bool -> Bool -> Bool
|| Name -> UniqFM Name Name -> Bool
forall key elt. Uniquable key => key -> UniqFM key elt -> Bool
elemUFM Name
n UniqFM Name Name
knownKeysMap
knownKeysMap :: UniqFM Name Name
knownKeysMap :: UniqFM Name Name
knownKeysMap = [Name] -> UniqFM Name Name
forall key. Uniquable key => [key] -> UniqFM key key
listToIdentityUFM [Name]
knownKeyNames
lookupKnownNameInfo :: Name -> SDoc
lookupKnownNameInfo :: Name -> SDoc
lookupKnownNameInfo Name
name = case NameEnv SDoc -> Name -> Maybe SDoc
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv SDoc
knownNamesInfo Name
name of
Maybe SDoc
Nothing -> SDoc
forall doc. IsOutput doc => doc
empty
Just SDoc
doc -> [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"{-", SDoc
doc, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-}"]
knownNamesInfo :: NameEnv SDoc
knownNamesInfo :: NameEnv SDoc
knownNamesInfo = Name -> SDoc -> NameEnv SDoc
forall a. Name -> a -> NameEnv a
unitNameEnv Name
coercibleTyConName (SDoc -> NameEnv SDoc) -> SDoc -> NameEnv SDoc
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Coercible is a special constraint with custom solving rules."
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"It is not a class."
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Please see section `The Coercible constraint`"
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"of the user's guide for details." ]
ghcPrimExports :: [IfaceExport]
ghcPrimExports :: [IfaceExport]
ghcPrimExports
= (Id -> IfaceExport) -> [Id] -> [IfaceExport]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> IfaceExport
Avail (Name -> IfaceExport) -> (Id -> Name) -> Id -> IfaceExport
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name
idName) [Id]
ghcPrimIds [IfaceExport] -> [IfaceExport] -> [IfaceExport]
forall a. [a] -> [a] -> [a]
++
(Id -> IfaceExport) -> [Id] -> [IfaceExport]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> IfaceExport
Avail (Name -> IfaceExport) -> (Id -> Name) -> Id -> IfaceExport
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name
idName) [Id]
allThePrimOpIds [IfaceExport] -> [IfaceExport] -> [IfaceExport]
forall a. [a] -> [a] -> [a]
++
[ Name -> [Name] -> IfaceExport
AvailTC Name
n [Name
n]
| TyCon
tc <- [TyCon]
exposedPrimTyCons, let n :: Name
n = TyCon -> Name
tyConName TyCon
tc ]
ghcPrimDeclDocs :: Docs
ghcPrimDeclDocs :: Docs
ghcPrimDeclDocs = Docs
emptyDocs { docs_decls = listToUniqMap $ mapMaybe findName primOpDocs }
where
findName :: (FastString, String)
-> Maybe (Name, [WithHsDocIdentifiers HsDocString pass])
findName (FastString
nameStr, String
doc)
| Just Name
name <- FastStringEnv Name -> FastString -> Maybe Name
forall a. FastStringEnv a -> FastString -> Maybe a
lookupFsEnv FastStringEnv Name
ghcPrimNames FastString
nameStr
= (Name, [WithHsDocIdentifiers HsDocString pass])
-> Maybe (Name, [WithHsDocIdentifiers HsDocString pass])
forall a. a -> Maybe a
Just (Name
name, [HsDocString
-> [Located (IdP pass)] -> WithHsDocIdentifiers HsDocString pass
forall a pass.
a -> [Located (IdP pass)] -> WithHsDocIdentifiers a pass
WithHsDocIdentifiers (String -> HsDocString
mkGeneratedHsDocString String
doc) []])
| Bool
otherwise = Maybe (Name, [WithHsDocIdentifiers HsDocString pass])
forall a. Maybe a
Nothing
ghcPrimNames :: FastStringEnv Name
ghcPrimNames :: FastStringEnv Name
ghcPrimNames
= [(FastString, Name)] -> FastStringEnv Name
forall a. [(FastString, a)] -> FastStringEnv a
mkFsEnv
[ (OccName -> FastString
occNameFS (OccName -> FastString) -> OccName -> FastString
forall a b. (a -> b) -> a -> b
$ Name -> OccName
nameOccName Name
name, Name
name)
| Name
name <-
(Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
idName [Id]
ghcPrimIds [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
(Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
idName [Id]
allThePrimOpIds [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
(TyCon -> Name) -> [TyCon] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyCon -> Name
tyConName [TyCon]
exposedPrimTyCons
]
ghcPrimWarns :: Warnings a
ghcPrimWarns :: forall a. Warnings a
ghcPrimWarns = DeclWarnOccNames a -> ExportWarnNames a -> Warnings a
forall pass.
DeclWarnOccNames pass -> ExportWarnNames pass -> Warnings pass
WarnSome
(((OccName, FastString) -> (OccName, WarningTxt a))
-> [(OccName, FastString)] -> DeclWarnOccNames a
forall a b. (a -> b) -> [a] -> [b]
map (OccName, FastString) -> (OccName, WarningTxt a)
forall {a} {pass}. (a, FastString) -> (a, WarningTxt pass)
mk_decl_dep [(OccName, FastString)]
primOpDeprecations)
[]
where
mk_txt :: FastString -> WarningTxt pass
mk_txt FastString
msg =
SourceText
-> [LocatedE (WithHsDocIdentifiers StringLiteral pass)]
-> WarningTxt pass
forall pass.
SourceText
-> [LocatedE (WithHsDocIdentifiers StringLiteral pass)]
-> WarningTxt pass
DeprecatedTxt SourceText
NoSourceText [WithHsDocIdentifiers StringLiteral pass
-> LocatedE (WithHsDocIdentifiers StringLiteral pass)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (WithHsDocIdentifiers StringLiteral pass
-> LocatedE (WithHsDocIdentifiers StringLiteral pass))
-> WithHsDocIdentifiers StringLiteral pass
-> LocatedE (WithHsDocIdentifiers StringLiteral pass)
forall a b. (a -> b) -> a -> b
$ StringLiteral
-> [Located (IdP pass)] -> WithHsDocIdentifiers StringLiteral pass
forall a pass.
a -> [Located (IdP pass)] -> WithHsDocIdentifiers a pass
WithHsDocIdentifiers (SourceText
-> FastString -> Maybe NoCommentsLocation -> StringLiteral
StringLiteral SourceText
NoSourceText FastString
msg Maybe NoCommentsLocation
forall a. Maybe a
Nothing) []]
mk_decl_dep :: (a, FastString) -> (a, WarningTxt pass)
mk_decl_dep (a
occ, FastString
msg) = (a
occ, FastString -> WarningTxt pass
forall {pass}. FastString -> WarningTxt pass
mk_txt FastString
msg)
ghcPrimFixities :: [(OccName,Fixity)]
ghcPrimFixities :: [(OccName, Fixity)]
ghcPrimFixities = [(OccName, Fixity)]
fixities
where
fixities :: [(OccName, Fixity)]
fixities = (Id -> OccName
forall a. NamedThing a => a -> OccName
getOccName Id
seqId, Int -> FixityDirection -> Fixity
Fixity Int
0 FixityDirection
InfixR)
(OccName, Fixity) -> [(OccName, Fixity)] -> [(OccName, Fixity)]
forall a. a -> [a] -> [a]
: (PrimOp -> Maybe (OccName, Fixity))
-> [PrimOp] -> [(OccName, Fixity)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PrimOp -> Maybe (OccName, Fixity)
mkFixity [PrimOp]
allThePrimOps
mkFixity :: PrimOp -> Maybe (OccName, Fixity)
mkFixity PrimOp
op = (,) (PrimOp -> OccName
primOpOcc PrimOp
op) (Fixity -> (OccName, Fixity))
-> Maybe Fixity -> Maybe (OccName, Fixity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrimOp -> Maybe Fixity
primOpFixity PrimOp
op
maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool
maybeCharLikeCon :: DataCon -> Bool
maybeCharLikeCon DataCon
con = DataCon
con DataCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
charDataConKey
maybeIntLikeCon :: DataCon -> Bool
maybeIntLikeCon DataCon
con = DataCon
con DataCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
intDataConKey
isNumericClass, isStandardClass :: Class -> Bool
isNumericClass :: Class -> Bool
isNumericClass Class
clas = Class -> Unique
classKey Class
clas Unique -> [Unique] -> Bool
forall a. Eq a => a -> [a] -> Bool
`is_elem` [Unique]
numericClassKeys
isStandardClass :: Class -> Bool
isStandardClass Class
clas = Class -> Unique
classKey Class
clas Unique -> [Unique] -> Bool
forall a. Eq a => a -> [a] -> Bool
`is_elem` [Unique]
standardClassKeys
is_elem :: Eq a => a -> [a] -> Bool
is_elem :: forall a. Eq a => a -> [a] -> Bool
is_elem = String -> a -> [a] -> Bool
forall a. Eq a => String -> a -> [a] -> Bool
isIn String
"is_X_Class"