{-# 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.Types.Unique ( isValidKnownKeyUnique )
import GHC.Core.ConLike ( ConLike(..) )
import GHC.Builtin.Names.TH ( templateHaskellNames )
import GHC.Builtin.Names
import GHC.Core.Opt.ConstantFold
import GHC.Types.Avail
import GHC.Builtin.PrimOps
import GHC.Core.DataCon
import GHC.Types.Basic
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Id.Make
import GHC.Utils.Outputable
import GHC.Builtin.Types.Prim
import GHC.Builtin.Types
import GHC.Driver.Types
import GHC.Core.Class
import GHC.Core.TyCon
import GHC.Types.Unique.FM
import GHC.Utils.Misc as Utils
import GHC.Builtin.Types.Literals ( typeNatTyCons )
import GHC.Hs.Doc
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]
wired_tycon_kk_names TyCon
funTyCon
, (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
funTyCon TyCon -> [TyCon] -> [TyCon]
forall a. a -> [a] -> [a]
: [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
funTyCon TyCon -> [TyCon] -> [TyCon]
forall a. a -> [a] -> [a]
: [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"