{-# LANGUAGE CPP #-}
module PrelInfo (
isKnownKeyName,
lookupKnownKeyName,
lookupKnownNameInfo,
knownKeyNames,
wiredInIds, ghcPrimIds,
primOpRules, builtinRules,
ghcPrimExports,
primOpId,
maybeCharLikeCon, maybeIntLikeCon,
isNumericClass, isStandardClass
) where
#include "HsVersions.h"
import GhcPrelude
import KnownUniques
import Unique ( isValidKnownKeyUnique )
import ConLike ( ConLike(..) )
import THNames ( templateHaskellNames )
import PrelNames
import PrelRules
import Avail
import PrimOp
import DataCon
import Id
import Name
import NameEnv
import MkId
import Outputable
import TysPrim
import TysWiredIn
import HscTypes
import Class
import TyCon
import UniqFM
import Util
import TcTypeNats ( typeNatTyCons )
import Control.Applicative ((<|>))
import Data.List ( intercalate )
import Data.Array
import Data.Maybe
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 =
[[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]
singleton NameEnv [Name]
m Name
n Name
n)
NameEnv [Name]
forall elt. UniqFM 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 elt. UniqFM 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 -> Unique -> Maybe Name
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM 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 -> Bool
forall key elt. Uniquable key => key -> UniqFM elt -> Bool
elemUFM Name
n UniqFM Name
knownKeysMap
knownKeysMap :: UniqFM Name
knownKeysMap :: UniqFM Name
knownKeysMap = [(Unique, Name)] -> UniqFM Name
forall key elt. Uniquable key => [(key, elt)] -> UniqFM elt
listToUFM [ (Name -> Unique
nameUnique Name
n, Name
n) | Name
n <- [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 ]
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 :: a -> [a] -> Bool
is_elem = String -> a -> [a] -> Bool
forall a. Eq a => String -> a -> [a] -> Bool
isIn String
"is_X_Class"