module TysWiredIn (
wiredInTyCons, isBuiltInOcc_maybe,
boolTy, boolTyCon, boolTyCon_RDR, boolTyConName,
trueDataCon, trueDataConId, true_RDR,
falseDataCon, falseDataConId, false_RDR,
promotedBoolTyCon, promotedFalseDataCon, promotedTrueDataCon,
ltDataCon, ltDataConId,
eqDataCon, eqDataConId,
gtDataCon, gtDataConId,
promotedOrderingTyCon,
promotedLTDataCon, promotedEQDataCon, promotedGTDataCon,
charTyCon, charDataCon, charTyCon_RDR,
charTy, stringTy, charTyConName,
doubleTyCon, doubleDataCon, doubleTy, doubleTyConName,
floatTyCon, floatDataCon, floatTy, floatTyConName,
intTyCon, intDataCon, intTyCon_RDR, intDataCon_RDR, intTyConName,
intTy,
wordTyCon, wordDataCon, wordTyConName, wordTy,
listTyCon, nilDataCon, nilDataConName, consDataCon, consDataConName,
listTyCon_RDR, consDataCon_RDR, listTyConName,
mkListTy, mkPromotedListTy,
mkTupleTy, mkBoxedTupleTy,
tupleTyCon, tupleCon,
promotedTupleTyCon, promotedTupleDataCon,
unitTyCon, unitDataCon, unitDataConId, pairTyCon,
unboxedUnitTyCon, unboxedUnitDataCon,
unboxedSingletonTyCon, unboxedSingletonDataCon,
unboxedPairTyCon, unboxedPairDataCon,
unitTy,
typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind,
mkPArrTy,
parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon,
parrTyCon_RDR, parrTyConName,
eqTyCon_RDR, eqTyCon, eqTyConName, eqBoxDataCon,
coercibleTyCon, coercibleDataCon, coercibleClass,
mkWiredInTyConName
) where
#include "HsVersions.h"
import MkId( mkDataConWorkId )
import PrelNames
import TysPrim
import Constants ( mAX_TUPLE_SIZE )
import Module ( Module )
import Type ( mkTyConApp )
import DataCon
import ConLike
import Var
import TyCon
import Class ( Class, mkClass )
import TypeRep
import RdrName
import Name
import BasicTypes ( TupleSort(..), tupleSortBoxity,
Arity, RecFlag(..), Boxity(..) )
import ForeignCall
import Unique ( incrUnique, mkTupleTyConUnique,
mkTupleDataConUnique, mkPArrDataConUnique )
import Data.Array
import FastString
import Outputable
import Util
import BooleanFormula ( mkAnd )
alpha_tyvar :: [TyVar]
alpha_tyvar = [alphaTyVar]
alpha_ty :: [Type]
alpha_ty = [alphaTy]
wiredInTyCons :: [TyCon]
wiredInTyCons = [ unitTyCon
, boolTyCon
, charTyCon
, doubleTyCon
, floatTyCon
, intTyCon
, wordTyCon
, listTyCon
, parrTyCon
, eqTyCon
, coercibleTyCon
, typeNatKindCon
, typeSymbolKindCon
]
mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name
mkWiredInTyConName built_in modu fs unique tycon
= mkWiredInName modu (mkTcOccFS fs) unique
(ATyCon tycon)
built_in
mkWiredInDataConName :: BuiltInSyntax -> Module -> FastString -> Unique -> DataCon -> Name
mkWiredInDataConName built_in modu fs unique datacon
= mkWiredInName modu (mkDataOccFS fs) unique
(AConLike (RealDataCon datacon))
built_in
eqTyConName, eqBoxDataConName :: Name
eqTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "~") eqTyConKey eqTyCon
eqBoxDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqBoxDataConKey eqBoxDataCon
coercibleTyConName, coercibleDataConName :: Name
coercibleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Coercible") coercibleTyConKey coercibleTyCon
coercibleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "MkCoercible") coercibleDataConKey coercibleDataCon
charTyConName, charDataConName, intTyConName, intDataConName :: Name
charTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Char") charTyConKey charTyCon
charDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "C#") charDataConKey charDataCon
intTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Int") intTyConKey intTyCon
intDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "I#") intDataConKey intDataCon
boolTyConName, falseDataConName, trueDataConName :: Name
boolTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Bool") boolTyConKey boolTyCon
falseDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "False") falseDataConKey falseDataCon
trueDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "True") trueDataConKey trueDataCon
listTyConName, nilDataConName, consDataConName :: Name
listTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "[]") listTyConKey listTyCon
nilDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon
consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon
wordTyConName, wordDataConName, floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name
wordTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Word") wordTyConKey wordTyCon
wordDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "W#") wordDataConKey wordDataCon
floatTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Float") floatTyConKey floatTyCon
floatDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "F#") floatDataConKey floatDataCon
doubleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Double") doubleTyConKey doubleTyCon
doubleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#") doubleDataConKey doubleDataCon
typeNatKindConName, typeSymbolKindConName :: Name
typeNatKindConName = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "Nat") typeNatKindConNameKey typeNatKindCon
typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon
parrTyConName, parrDataConName :: Name
parrTyConName = mkWiredInTyConName BuiltInSyntax
gHC_PARR' (fsLit "[::]") parrTyConKey parrTyCon
parrDataConName = mkWiredInDataConName UserSyntax
gHC_PARR' (fsLit "PArr") parrDataConKey parrDataCon
boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR,
intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR, eqTyCon_RDR :: RdrName
boolTyCon_RDR = nameRdrName boolTyConName
false_RDR = nameRdrName falseDataConName
true_RDR = nameRdrName trueDataConName
intTyCon_RDR = nameRdrName intTyConName
charTyCon_RDR = nameRdrName charTyConName
intDataCon_RDR = nameRdrName intDataConName
listTyCon_RDR = nameRdrName listTyConName
consDataCon_RDR = nameRdrName consDataConName
parrTyCon_RDR = nameRdrName parrTyConName
eqTyCon_RDR = nameRdrName eqTyConName
pcNonRecDataTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
pcNonRecDataTyCon = pcTyCon False NonRecursive False
pcTyCon :: Bool -> RecFlag -> Bool -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
pcTyCon is_enum is_rec is_prom name cType tyvars cons
= buildAlgTyCon name
tyvars
(map (const Representational) tyvars)
cType
[]
(DataTyCon cons is_enum)
is_rec
is_prom
False
NoParentTyCon
pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
pcDataCon = pcDataConWithFixity False
pcDataConWithFixity :: Bool -> Name -> [TyVar] -> [Type] -> TyCon -> DataCon
pcDataConWithFixity infx n = pcDataConWithFixity' infx n (incrUnique (nameUnique n))
pcDataConWithFixity' :: Bool -> Name -> Unique -> [TyVar] -> [Type] -> TyCon -> DataCon
pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon
= data_con
where
data_con = mkDataCon dc_name declared_infix
(map (const HsNoBang) arg_tys)
[]
tyvars
[]
[]
[]
arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))
tycon
[]
(mkDataConWorkId wrk_name data_con)
NoDataConRep
modu = ASSERT( isExternalName dc_name )
nameModule dc_name
wrk_occ = mkDataConWorkerOcc (nameOccName dc_name)
wrk_name = mkWiredInName modu wrk_occ wrk_key
(AnId (dataConWorkId data_con)) UserSyntax
typeNatKindCon, typeSymbolKindCon :: TyCon
typeNatKindCon = pcTyCon False NonRecursive True typeNatKindConName Nothing [] []
typeSymbolKindCon = pcTyCon False NonRecursive True typeSymbolKindConName Nothing [] []
typeNatKind, typeSymbolKind :: Kind
typeNatKind = TyConApp (promoteTyCon typeNatKindCon) []
typeSymbolKind = TyConApp (promoteTyCon typeSymbolKindCon) []
isBuiltInOcc_maybe :: OccName -> Maybe Name
isBuiltInOcc_maybe occ
= case occNameString occ of
"[]" -> choose_ns listTyCon nilDataCon
":" -> Just consDataConName
"[::]" -> Just parrTyConName
"(##)" -> choose_ns unboxedUnitTyCon unboxedUnitDataCon
"()" -> choose_ns unitTyCon unitDataCon
'(':'#':',':rest -> parse_tuple UnboxedTuple 2 rest
'(':',':rest -> parse_tuple BoxedTuple 2 rest
_other -> Nothing
where
ns = occNameSpace occ
parse_tuple sort n rest
| (',' : rest2) <- rest = parse_tuple sort (n+1) rest2
| tail_matches sort rest = choose_ns (tupleTyCon sort n)
(tupleCon sort n)
| otherwise = Nothing
tail_matches BoxedTuple ")" = True
tail_matches UnboxedTuple "#)" = True
tail_matches _ _ = False
choose_ns tc dc
| isTcClsNameSpace ns = Just (getName tc)
| isDataConNameSpace ns = Just (getName dc)
| otherwise = Just (getName (dataConWorkId dc))
mkTupleOcc :: NameSpace -> TupleSort -> Arity -> OccName
mkTupleOcc ns sort ar = mkOccName ns str
where
str = case sort of
UnboxedTuple -> '(' : '#' : commas ++ "#)"
BoxedTuple -> '(' : commas ++ ")"
ConstraintTuple -> '(' : commas ++ ")"
commas = take (ar1) (repeat ',')
tupleTyCon :: TupleSort -> Arity -> TyCon
tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i)
tupleTyCon BoxedTuple i = fst (boxedTupleArr ! i)
tupleTyCon UnboxedTuple i = fst (unboxedTupleArr ! i)
tupleTyCon ConstraintTuple i = fst (factTupleArr ! i)
promotedTupleTyCon :: TupleSort -> Arity -> TyCon
promotedTupleTyCon sort i = promoteTyCon (tupleTyCon sort i)
promotedTupleDataCon :: TupleSort -> Arity -> TyCon
promotedTupleDataCon sort i = promoteDataCon (tupleCon sort i)
tupleCon :: TupleSort -> Arity -> DataCon
tupleCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i)
tupleCon BoxedTuple i = snd (boxedTupleArr ! i)
tupleCon UnboxedTuple i = snd (unboxedTupleArr ! i)
tupleCon ConstraintTuple i = snd (factTupleArr ! i)
boxedTupleArr, unboxedTupleArr, factTupleArr :: Array Int (TyCon,DataCon)
boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple BoxedTuple i | i <- [0..mAX_TUPLE_SIZE]]
unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple UnboxedTuple i | i <- [0..mAX_TUPLE_SIZE]]
factTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple ConstraintTuple i | i <- [0..mAX_TUPLE_SIZE]]
mk_tuple :: TupleSort -> Int -> (TyCon,DataCon)
mk_tuple sort arity = (tycon, tuple_con)
where
tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con sort prom_tc
prom_tc = case sort of
BoxedTuple -> Just (mkPromotedTyCon tycon (promoteKind tc_kind))
UnboxedTuple -> Nothing
ConstraintTuple -> Nothing
modu = mkTupleModule sort
tc_name = mkWiredInName modu (mkTupleOcc tcName sort arity) tc_uniq
(ATyCon tycon) BuiltInSyntax
tc_kind = mkArrowKinds (map tyVarKind tyvars) res_kind
res_kind = case sort of
BoxedTuple -> liftedTypeKind
UnboxedTuple -> unliftedTypeKind
ConstraintTuple -> constraintKind
tyvars = take arity $ case sort of
BoxedTuple -> alphaTyVars
UnboxedTuple -> openAlphaTyVars
ConstraintTuple -> tyVarList constraintKind
tuple_con = pcDataCon dc_name tyvars tyvar_tys tycon
tyvar_tys = mkTyVarTys tyvars
dc_name = mkWiredInName modu (mkTupleOcc dataName sort arity) dc_uniq
(AConLike (RealDataCon tuple_con)) BuiltInSyntax
tc_uniq = mkTupleTyConUnique sort arity
dc_uniq = mkTupleDataConUnique sort arity
unitTyCon :: TyCon
unitTyCon = tupleTyCon BoxedTuple 0
unitDataCon :: DataCon
unitDataCon = head (tyConDataCons unitTyCon)
unitDataConId :: Id
unitDataConId = dataConWorkId unitDataCon
pairTyCon :: TyCon
pairTyCon = tupleTyCon BoxedTuple 2
unboxedUnitTyCon :: TyCon
unboxedUnitTyCon = tupleTyCon UnboxedTuple 0
unboxedUnitDataCon :: DataCon
unboxedUnitDataCon = tupleCon UnboxedTuple 0
unboxedSingletonTyCon :: TyCon
unboxedSingletonTyCon = tupleTyCon UnboxedTuple 1
unboxedSingletonDataCon :: DataCon
unboxedSingletonDataCon = tupleCon UnboxedTuple 1
unboxedPairTyCon :: TyCon
unboxedPairTyCon = tupleTyCon UnboxedTuple 2
unboxedPairDataCon :: DataCon
unboxedPairDataCon = tupleCon UnboxedTuple 2
eqTyCon :: TyCon
eqTyCon = mkAlgTyCon eqTyConName
(ForAllTy kv $ mkArrowKinds [k, k] constraintKind)
[kv, a, b]
[Nominal, Nominal, Nominal]
Nothing
[]
(DataTyCon [eqBoxDataCon] False)
NoParentTyCon
NonRecursive
False
Nothing
where
kv = kKiVar
k = mkTyVarTy kv
a:b:_ = tyVarList k
eqBoxDataCon :: DataCon
eqBoxDataCon = pcDataCon eqBoxDataConName args [TyConApp eqPrimTyCon (map mkTyVarTy args)] eqTyCon
where
kv = kKiVar
k = mkTyVarTy kv
a:b:_ = tyVarList k
args = [kv, a, b]
coercibleTyCon :: TyCon
coercibleTyCon = mkClassTyCon
coercibleTyConName kind tvs [Nominal, Representational, Representational]
rhs coercibleClass NonRecursive
where kind = (ForAllTy kv $ mkArrowKinds [k, k] constraintKind)
kv = kKiVar
k = mkTyVarTy kv
a:b:_ = tyVarList k
tvs = [kv, a, b]
rhs = DataTyCon [coercibleDataCon] False
coercibleDataCon :: DataCon
coercibleDataCon = pcDataCon coercibleDataConName args [TyConApp eqReprPrimTyCon (map mkTyVarTy args)] coercibleTyCon
where
kv = kKiVar
k = mkTyVarTy kv
a:b:_ = tyVarList k
args = [kv, a, b]
coercibleClass :: Class
coercibleClass = mkClass (tyConTyVars coercibleTyCon) [] [] [] [] [] (mkAnd []) coercibleTyCon
charTy :: Type
charTy = mkTyConTy charTyCon
charTyCon :: TyCon
charTyCon = pcNonRecDataTyCon charTyConName
(Just (CType Nothing (fsLit "HsChar")))
[] [charDataCon]
charDataCon :: DataCon
charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon
stringTy :: Type
stringTy = mkListTy charTy
intTy :: Type
intTy = mkTyConTy intTyCon
intTyCon :: TyCon
intTyCon = pcNonRecDataTyCon intTyConName (Just (CType Nothing (fsLit "HsInt"))) [] [intDataCon]
intDataCon :: DataCon
intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon
wordTy :: Type
wordTy = mkTyConTy wordTyCon
wordTyCon :: TyCon
wordTyCon = pcNonRecDataTyCon wordTyConName (Just (CType Nothing (fsLit "HsWord"))) [] [wordDataCon]
wordDataCon :: DataCon
wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon
floatTy :: Type
floatTy = mkTyConTy floatTyCon
floatTyCon :: TyCon
floatTyCon = pcNonRecDataTyCon floatTyConName (Just (CType Nothing (fsLit "HsFloat"))) [] [floatDataCon]
floatDataCon :: DataCon
floatDataCon = pcDataCon floatDataConName [] [floatPrimTy] floatTyCon
doubleTy :: Type
doubleTy = mkTyConTy doubleTyCon
doubleTyCon :: TyCon
doubleTyCon = pcNonRecDataTyCon doubleTyConName (Just (CType Nothing (fsLit "HsDouble"))) [] [doubleDataCon]
doubleDataCon :: DataCon
doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon
boolTy :: Type
boolTy = mkTyConTy boolTyCon
boolTyCon :: TyCon
boolTyCon = pcTyCon True NonRecursive True boolTyConName
(Just (CType Nothing (fsLit "HsBool")))
[] [falseDataCon, trueDataCon]
falseDataCon, trueDataCon :: DataCon
falseDataCon = pcDataCon falseDataConName [] [] boolTyCon
trueDataCon = pcDataCon trueDataConName [] [] boolTyCon
falseDataConId, trueDataConId :: Id
falseDataConId = dataConWorkId falseDataCon
trueDataConId = dataConWorkId trueDataCon
orderingTyCon :: TyCon
orderingTyCon = pcTyCon True NonRecursive True orderingTyConName Nothing
[] [ltDataCon, eqDataCon, gtDataCon]
ltDataCon, eqDataCon, gtDataCon :: DataCon
ltDataCon = pcDataCon ltDataConName [] [] orderingTyCon
eqDataCon = pcDataCon eqDataConName [] [] orderingTyCon
gtDataCon = pcDataCon gtDataConName [] [] orderingTyCon
ltDataConId, eqDataConId, gtDataConId :: Id
ltDataConId = dataConWorkId ltDataCon
eqDataConId = dataConWorkId eqDataCon
gtDataConId = dataConWorkId gtDataCon
mkListTy :: Type -> Type
mkListTy ty = mkTyConApp listTyCon [ty]
listTyCon :: TyCon
listTyCon = pcTyCon False Recursive True
listTyConName Nothing alpha_tyvar [nilDataCon, consDataCon]
mkPromotedListTy :: Type -> Type
mkPromotedListTy ty = mkTyConApp promotedListTyCon [ty]
promotedListTyCon :: TyCon
promotedListTyCon = promoteTyCon listTyCon
nilDataCon :: DataCon
nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon
consDataCon :: DataCon
consDataCon = pcDataConWithFixity True
consDataConName
alpha_tyvar [alphaTy, mkTyConApp listTyCon alpha_ty] listTyCon
mkTupleTy :: TupleSort -> [Type] -> Type
mkTupleTy sort [ty] | Boxed <- tupleSortBoxity sort = ty
mkTupleTy sort tys = mkTyConApp (tupleTyCon sort (length tys)) tys
mkBoxedTupleTy :: [Type] -> Type
mkBoxedTupleTy tys = mkTupleTy BoxedTuple tys
unitTy :: Type
unitTy = mkTupleTy BoxedTuple []
mkPArrTy :: Type -> Type
mkPArrTy ty = mkTyConApp parrTyCon [ty]
parrTyCon :: TyCon
parrTyCon = pcNonRecDataTyCon parrTyConName Nothing alpha_tyvar [parrDataCon]
parrDataCon :: DataCon
parrDataCon = pcDataCon
parrDataConName
alpha_tyvar
[intTy,
mkTyConApp
arrayPrimTyCon
alpha_ty]
parrTyCon
isPArrTyCon :: TyCon -> Bool
isPArrTyCon tc = tyConName tc == parrTyConName
parrFakeCon :: Arity -> DataCon
parrFakeCon i | i > mAX_TUPLE_SIZE = mkPArrFakeCon i
parrFakeCon i = parrFakeConArr!i
parrFakeConArr :: Array Int DataCon
parrFakeConArr = array (0, mAX_TUPLE_SIZE) [(i, mkPArrFakeCon i)
| i <- [0..mAX_TUPLE_SIZE]]
mkPArrFakeCon :: Int -> DataCon
mkPArrFakeCon arity = data_con
where
data_con = pcDataCon name [tyvar] tyvarTys parrTyCon
tyvar = head alphaTyVars
tyvarTys = replicate arity $ mkTyVarTy tyvar
nameStr = mkFastString ("MkPArr" ++ show arity)
name = mkWiredInName gHC_PARR' (mkDataOccFS nameStr) unique
(AConLike (RealDataCon data_con)) UserSyntax
unique = mkPArrDataConUnique arity
isPArrFakeCon :: DataCon -> Bool
isPArrFakeCon dcon = dcon == parrFakeCon (dataConSourceArity dcon)
promotedBoolTyCon, promotedFalseDataCon, promotedTrueDataCon :: TyCon
promotedBoolTyCon = promoteTyCon boolTyCon
promotedTrueDataCon = promoteDataCon trueDataCon
promotedFalseDataCon = promoteDataCon falseDataCon
promotedOrderingTyCon
, promotedLTDataCon
, promotedEQDataCon
, promotedGTDataCon
:: TyCon
promotedOrderingTyCon = promoteTyCon orderingTyCon
promotedLTDataCon = promoteDataCon ltDataCon
promotedEQDataCon = promoteDataCon eqDataCon
promotedGTDataCon = promoteDataCon gtDataCon