{-# LANGUAGE CPP #-}
module GHC.Builtin.Utils (
isKnownKeyName,
lookupKnownKeyName,
lookupKnownNameInfo,
knownKeyNames,
wiredInIds, ghcPrimIds,
primOpRules, builtinRules,
ghcPrimExports,
ghcPrimDeclDocs,
primOpId,
maybeCharLikeCon, maybeIntLikeCon,
isNumericClass, isStandardClass
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Builtin.Uniques
import GHC.Builtin.PrimOps
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.Opt.ConstantFold
import GHC.Core.DataCon
import GHC.Core.Class
import GHC.Core.TyCon
import GHC.Types.Avail
import GHC.Types.Basic
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Id.Make
import GHC.Types.Unique.FM
import GHC.Types.TyThing
import GHC.Types.Unique ( isValidKnownKeyUnique )
import GHC.Utils.Outputable
import GHC.Utils.Misc as Utils
import GHC.Utils.Panic
import GHC.Hs.Doc
import GHC.Unit.Module.ModIface (IfaceExport)
import Control.Applicative ((<|>))
import Data.List ( intercalate , find )
import Data.Array
import Data.Maybe
import qualified Data.Map as Map
knownKeyNames :: [Name]
knownKeyNames :: [Name]
knownKeyNames
| Bool
debugIsOn
, Just String
badNamesStr <- [Name] -> Maybe String
knownKeyNamesOkay [Name]
all_names
= String -> [Name]
forall a. String -> a
panic (String
"badAllKnownKeyNames:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
badNamesStr)
| Bool
otherwise
= [Name]
all_names
where
all_names :: [Name]
all_names =
TupleSort -> Int -> Name
tupleTyConName TupleSort
BoxedTuple Int
1 Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: Boxity -> Int -> Name
tupleDataConName Boxity
Boxed Int
1 Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:
[[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
, (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
primOpId) [PrimOp]
allThePrimOps
, (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 String
knownKeyNamesOkay :: [Name] -> Maybe String
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
= String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
" Out-of-range known-key uniques: ["
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Name -> String) -> [Name] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> String
occNameString (OccName -> String) -> (Name -> OccName) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName) [Name]
ns) String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"]"
| [(Unique, [Name])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Unique, [Name])]
badNamesPairs
= Maybe String
forall a. Maybe a
Nothing
| Bool
otherwise
= String -> Maybe String
forall a. a -> Maybe a
Just String
badNamesStr
where
namesEnv :: NameEnv [Name]
namesEnv = (NameEnv [Name] -> Name -> NameEnv [Name])
-> NameEnv [Name] -> [Name] -> NameEnv [Name]
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 key 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 key elt. UniqFM key elt -> [(Unique, elt)]
nonDetUFMToList NameEnv [Name]
badNamesEnv
badNamesStrs :: [String]
badNamesStrs = ((Unique, [Name]) -> String) -> [(Unique, [Name])] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Unique, [Name]) -> String
forall {a}. Show a => (a, [Name]) -> String
pairToStr [(Unique, [Name])]
badNamesPairs
badNamesStr :: String
badNamesStr = [String] -> String
unlines [String]
badNamesStrs
pairToStr :: (a, [Name]) -> String
pairToStr (a
uniq, [Name]
ns) = String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++
a -> String
forall a. Show a => a -> String
show a
uniq String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
": [" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Name -> String) -> [Name] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> String
occNameString (OccName -> String) -> (Name -> OccName) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName) [Name]
ns) String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"]"
lookupKnownKeyName :: Unique -> Maybe Name
lookupKnownKeyName :: Unique -> Maybe Name
lookupKnownKeyName Unique
u =
Unique -> Maybe Name
knownUniqueName Unique
u Maybe Name -> Maybe Name -> Maybe Name
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> UniqFM Name Name -> Unique -> Maybe Name
forall key 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
empty
Just SDoc
doc -> [SDoc] -> SDoc
vcat [String -> SDoc
text String
"{-", SDoc
doc, String -> SDoc
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
vcat [ String -> SDoc
text String
"Coercible is a special constraint with custom solving rules."
, String -> SDoc
text String
"It is not a class."
, String -> SDoc
text String
"Please see section `The Coercible constraint`"
, String -> SDoc
text String
"of the user's guide for details." ]
primOpIds :: Array Int Id
primOpIds :: Array Int Id
primOpIds = (Int, Int) -> [(Int, Id)] -> Array Int Id
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
1,Int
maxPrimOpTag) [ (PrimOp -> Int
primOpTag PrimOp
op, PrimOp -> Id
mkPrimOpId PrimOp
op)
| PrimOp
op <- [PrimOp]
allThePrimOps ]
primOpId :: PrimOp -> Id
primOpId :: PrimOp -> Id
primOpId PrimOp
op = Array Int Id
primOpIds Array Int Id -> Int -> Id
forall i e. Ix i => Array i e -> i -> e
! PrimOp -> Int
primOpTag PrimOp
op
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]
++
(PrimOp -> IfaceExport) -> [PrimOp] -> [IfaceExport]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> IfaceExport
avail (Name -> IfaceExport) -> (PrimOp -> Name) -> PrimOp -> IfaceExport
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name
idName (Id -> Name) -> (PrimOp -> Id) -> PrimOp -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimOp -> Id
primOpId) [PrimOp]
allThePrimOps [IfaceExport] -> [IfaceExport] -> [IfaceExport]
forall a. [a] -> [a] -> [a]
++
[ Name -> [Name] -> [FieldLabel] -> IfaceExport
availTC Name
n [Name
n] []
| TyCon
tc <- [TyCon]
exposedPrimTyCons, let n :: Name
n = TyCon -> Name
tyConName TyCon
tc ]
ghcPrimDeclDocs :: DeclDocMap
ghcPrimDeclDocs :: DeclDocMap
ghcPrimDeclDocs = Map Name HsDocString -> DeclDocMap
DeclDocMap (Map Name HsDocString -> DeclDocMap)
-> Map Name HsDocString -> DeclDocMap
forall a b. (a -> b) -> a -> b
$ [(Name, HsDocString)] -> Map Name HsDocString
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, HsDocString)] -> Map Name HsDocString)
-> [(Name, HsDocString)] -> Map Name HsDocString
forall a b. (a -> b) -> a -> b
$ ((String, String) -> Maybe (Name, HsDocString))
-> [(String, String)] -> [(Name, HsDocString)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String, String) -> Maybe (Name, HsDocString)
findName [(String, String)]
primOpDocs
where
names :: [Name]
names = (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]
++
(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
primOpId) [PrimOp]
allThePrimOps [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
findName :: (String, String) -> Maybe (Name, HsDocString)
findName (String
nameStr, String
doc)
| Just Name
name <- (Name -> Bool) -> [Name] -> Maybe Name
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String
nameStr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool) -> (Name -> String) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. NamedThing a => a -> String
getOccString) [Name]
names
= (Name, HsDocString) -> Maybe (Name, HsDocString)
forall a. a -> Maybe a
Just (Name
name, String -> HsDocString
mkHsDocString String
doc)
| Bool
otherwise = Maybe (Name, HsDocString)
forall a. Maybe a
Nothing
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"