{-# 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.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
= forall a. String -> a
panic (String
"badAllKnownKeyNames:\n" forall a. [a] -> [a] -> [a]
++ String
badNamesStr)
| Bool
otherwise
= [Name]
all_names
where
all_names :: [Name]
all_names =
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TyCon -> [Name]
wired_tycon_kk_names [TyCon]
primTyCons
, forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TyCon -> [Name]
wired_tycon_kk_names [TyCon]
wiredInTyCons
, forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TyCon -> [Name]
wired_tycon_kk_names [TyCon]
typeNatTyCons
, forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
idName [Id]
wiredInIds
, forall a b. (a -> b) -> [a] -> [b]
map (Id -> Name
idName forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimOp -> Id
primOpId) [PrimOp]
allThePrimOps
, forall a b. (a -> b) -> [a] -> [b]
map (Id -> Name
idName 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 forall a. a -> [a] -> [a]
: (TyCon -> [Name]
rep_names TyCon
tc forall a. [a] -> [a] -> [a]
++ [Name]
implicits)
where implicits :: [Name]
implicits = 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 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 = [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]
_) <- forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Bool
isValidKnownKeyUnique forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Uniquable a => a -> Unique
getUnique) [Name]
all_names
= forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
" Out-of-range known-key uniques: ["
forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map (OccName -> String
occNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName) [Name]
ns) forall a. [a] -> [a] -> [a]
++
String
"]"
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Unique, [Name])]
badNamesPairs
= forall a. Maybe a
Nothing
| Bool
otherwise
= forall a. a -> Maybe a
Just String
badNamesStr
where
namesEnv :: NameEnv [Name]
namesEnv = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\NameEnv [Name]
m Name
n -> forall a b.
(a -> b -> b) -> (a -> b) -> NameEnv b -> Name -> a -> NameEnv b
extendNameEnv_Acc (:) forall a. a -> [a]
Utils.singleton NameEnv [Name]
m Name
n Name
n)
forall key elt. UniqFM key elt
emptyUFM [Name]
all_names
badNamesEnv :: NameEnv [Name]
badNamesEnv = forall elt. (elt -> Bool) -> NameEnv elt -> NameEnv elt
filterNameEnv (\[Name]
ns -> [Name]
ns forall a. [a] -> Int -> Bool
`lengthExceeds` Int
1) NameEnv [Name]
namesEnv
badNamesPairs :: [(Unique, [Name])]
badNamesPairs = forall key elt. UniqFM key elt -> [(Unique, elt)]
nonDetUFMToList NameEnv [Name]
badNamesEnv
badNamesStrs :: [String]
badNamesStrs = forall a b. (a -> b) -> [a] -> [b]
map 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
" " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> String
show a
uniq forall a. [a] -> [a] -> [a]
++
String
": [" forall a. [a] -> [a] -> [a]
++
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map (OccName -> String
occNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName) [Name]
ns) forall a. [a] -> [a] -> [a]
++
String
"]"
lookupKnownKeyName :: Unique -> Maybe Name
lookupKnownKeyName :: Unique -> Maybe Name
lookupKnownKeyName Unique
u =
Unique -> Maybe Name
knownUniqueName Unique
u forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> 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 =
forall a. Maybe a -> Bool
isJust (Unique -> Maybe Name
knownUniqueName forall a b. (a -> b) -> a -> b
$ Name -> Unique
nameUnique Name
n) Bool -> Bool -> 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 = forall key. Uniquable key => [key] -> UniqFM key key
listToIdentityUFM [Name]
knownKeyNames
lookupKnownNameInfo :: Name -> SDoc
lookupKnownNameInfo :: Name -> SDoc
lookupKnownNameInfo Name
name = case 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 = forall a. Name -> a -> NameEnv a
unitNameEnv Name
coercibleTyConName 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 = 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 forall i e. Ix i => Array i e -> i -> e
! PrimOp -> Int
primOpTag PrimOp
op
ghcPrimExports :: [IfaceExport]
ghcPrimExports :: [IfaceExport]
ghcPrimExports
= forall a b. (a -> b) -> [a] -> [b]
map (Name -> IfaceExport
avail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name
idName) [Id]
ghcPrimIds forall a. [a] -> [a] -> [a]
++
forall a b. (a -> b) -> [a] -> [b]
map (Name -> IfaceExport
avail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name
idName forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimOp -> Id
primOpId) [PrimOp]
allThePrimOps 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 forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String, String) -> Maybe (Name, HsDocString)
findName [(String, String)]
primOpDocs
where
names :: [Name]
names = forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
idName [Id]
ghcPrimIds forall a. [a] -> [a] -> [a]
++
forall a b. (a -> b) -> [a] -> [b]
map (Id -> Name
idName forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimOp -> Id
primOpId) [PrimOp]
allThePrimOps forall a. [a] -> [a] -> [a]
++
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 <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String
nameStr forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NamedThing a => a -> String
getOccString) [Name]
names
= forall a. a -> Maybe a
Just (Name
name, String -> HsDocString
mkHsDocString String
doc)
| Bool
otherwise = forall a. Maybe a
Nothing
maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool
maybeCharLikeCon :: DataCon -> Bool
maybeCharLikeCon DataCon
con = DataCon
con forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
charDataConKey
maybeIntLikeCon :: DataCon -> Bool
maybeIntLikeCon DataCon
con = DataCon
con 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 forall a. Eq a => a -> [a] -> Bool
`is_elem` [Unique]
numericClassKeys
isStandardClass :: Class -> Bool
isStandardClass Class
clas = Class -> Unique
classKey Class
clas 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 = forall a. Eq a => String -> a -> [a] -> Bool
isIn String
"is_X_Class"