module GHC.Builtin.Types (
mkWiredInTyConName,
mkWiredInIdName,
wiredInTyCons, isBuiltInOcc_maybe,
boolTy, boolTyCon, boolTyCon_RDR, boolTyConName,
trueDataCon, trueDataConId, true_RDR,
falseDataCon, falseDataConId, false_RDR,
promotedFalseDataCon, promotedTrueDataCon,
orderingTyCon,
ordLTDataCon, ordLTDataConId,
ordEQDataCon, ordEQDataConId,
ordGTDataCon, ordGTDataConId,
promotedLTDataCon, promotedEQDataCon, promotedGTDataCon,
boxingDataCon_maybe,
charTyCon, charDataCon, charTyCon_RDR,
charTy, stringTy, charTyConName, stringTyCon_RDR,
doubleTyCon, doubleDataCon, doubleTy, doubleTyConName,
floatTyCon, floatDataCon, floatTy, floatTyConName,
intTyCon, intDataCon, intTyCon_RDR, intDataCon_RDR, intTyConName,
intTy,
wordTyCon, wordDataCon, wordTyConName, wordTy,
word8TyCon, word8DataCon, word8Ty,
listTyCon, listTyCon_RDR, listTyConName, listTyConKey,
nilDataCon, nilDataConName, nilDataConKey,
consDataCon_RDR, consDataCon, consDataConName,
promotedNilDataCon, promotedConsDataCon,
mkListTy, mkPromotedListTy,
maybeTyCon, maybeTyConName,
nothingDataCon, nothingDataConName, promotedNothingDataCon,
justDataCon, justDataConName, promotedJustDataCon,
mkPromotedMaybeTy, mkMaybeTy, isPromotedMaybeTy,
mkTupleTy, mkTupleTy1, mkBoxedTupleTy, mkTupleStr,
tupleTyCon, tupleDataCon, tupleTyConName, tupleDataConName,
promotedTupleDataCon,
unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey,
pairTyCon, mkPromotedPairTy, isPromotedPairType,
unboxedUnitTy,
unboxedUnitTyCon, unboxedUnitDataCon,
unboxedTupleKind, unboxedSumKind,
filterCTuple,
cTupleTyCon, cTupleTyConName, cTupleTyConNames, isCTupleTyConName,
cTupleTyConNameArity_maybe,
cTupleDataCon, cTupleDataConName, cTupleDataConNames,
cTupleSelId, cTupleSelIdName,
anyTyCon, anyTy, anyTypeOfKind,
makeRecoveryTyCon,
mkSumTy, sumTyCon, sumDataCon,
typeSymbolKindCon, typeSymbolKind,
isLiftedTypeKindTyConName,
typeToTypeKind,
liftedRepTyCon, unliftedRepTyCon,
constraintKind, liftedTypeKind, unliftedTypeKind,
constraintKindTyCon, liftedTypeKindTyCon, unliftedTypeKindTyCon,
constraintKindTyConName, liftedTypeKindTyConName, unliftedTypeKindTyConName,
liftedRepTyConName, unliftedRepTyConName,
heqTyCon, heqTyConName, heqClass, heqDataCon,
eqTyCon, eqTyConName, eqClass, eqDataCon, eqTyCon_RDR,
coercibleTyCon, coercibleTyConName, coercibleDataCon, coercibleClass,
runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon,
boxedRepDataConTyCon,
runtimeRepTy, liftedRepTy, unliftedRepTy,
vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon,
liftedDataConTyCon, unliftedDataConTyCon,
liftedDataConTy, unliftedDataConTy,
intRepDataConTy,
int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,
wordRepDataConTy,
word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,
addrRepDataConTy,
floatRepDataConTy, doubleRepDataConTy,
vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,
vec64DataConTy,
int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,
int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,
word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,
doubleElemRepDataConTy,
multiplicityTyConName, oneDataConName, manyDataConName, multiplicityTy,
multiplicityTyCon, oneDataCon, manyDataCon, oneDataConTy, manyDataConTy,
oneDataConTyCon, manyDataConTyCon,
multMulTyCon,
unrestrictedFunTyCon, unrestrictedFunTyConName,
integerTy, integerTyCon, integerTyConName,
integerISDataCon, integerISDataConName,
integerIPDataCon, integerIPDataConName,
integerINDataCon, integerINDataConName,
naturalTy, naturalTyCon, naturalTyConName,
naturalNSDataCon, naturalNSDataConName,
naturalNBDataCon, naturalNBDataConName
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Types.Id.Make ( mkDataConWorkId, mkDictSelId )
import GHC.Builtin.Names
import GHC.Builtin.Types.Prim
import GHC.Builtin.Uniques
import GHC.Core.Coercion.Axiom
import GHC.Types.Id
import GHC.Types.TyThing
import GHC.Types.SourceText
import GHC.Types.Var (VarBndr (Bndr))
import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE )
import GHC.Unit.Module ( Module )
import GHC.Core.Type
import qualified GHC.Core.TyCo.Rep as TyCoRep (Type(TyConApp))
import GHC.Types.RepType
import GHC.Core.DataCon
import GHC.Core.ConLike
import GHC.Core.TyCon
import GHC.Core.Class ( Class, mkClass )
import GHC.Types.Name.Reader
import GHC.Types.Name as Name
import GHC.Types.Name.Env ( NameEnv, mkNameEnv, lookupNameEnv, lookupNameEnv_NF )
import GHC.Types.Basic
import GHC.Types.ForeignCall
import GHC.Types.Unique.Set
import Data.Array
import GHC.Data.FastString
import GHC.Data.BooleanFormula ( mkAnd )
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
import qualified Data.ByteString.Char8 as BS
import Data.List ( elemIndex )
alpha_tyvar :: [TyVar]
alpha_tyvar = [alphaTyVar]
alpha_ty :: [Type]
alpha_ty = [alphaTy]
wiredInTyCons :: [TyCon]
wiredInTyCons = [
unitTyCon
, unboxedUnitTyCon
, anyTyCon
, boolTyCon
, charTyCon
, stringTyCon
, doubleTyCon
, floatTyCon
, intTyCon
, wordTyCon
, listTyCon
, orderingTyCon
, maybeTyCon
, heqTyCon
, eqTyCon
, coercibleTyCon
, typeSymbolKindCon
, runtimeRepTyCon
, levityTyCon
, vecCountTyCon
, vecElemTyCon
, constraintKindTyCon
, liftedTypeKindTyCon
, unliftedTypeKindTyCon
, multiplicityTyCon
, naturalTyCon
, integerTyCon
, liftedRepTyCon
, unliftedRepTyCon
]
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
mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name
mkWiredInIdName mod fs uniq id
= mkWiredInName mod (mkOccNameFS Name.varName fs) uniq (AnId id) UserSyntax
eqTyConName, eqDataConName, eqSCSelIdName :: Name
eqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~") eqTyConKey eqTyCon
eqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqDataConKey eqDataCon
eqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "eq_sel") eqSCSelIdKey eqSCSelId
eqTyCon_RDR :: RdrName
eqTyCon_RDR = nameRdrName eqTyConName
heqTyConName, heqDataConName, heqSCSelIdName :: Name
heqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~~") heqTyConKey heqTyCon
heqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "HEq#") heqDataConKey heqDataCon
heqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "heq_sel") heqSCSelIdKey heqSCSelId
coercibleTyConName, coercibleDataConName, coercibleSCSelIdName :: Name
coercibleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Coercible") coercibleTyConKey coercibleTyCon
coercibleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "MkCoercible") coercibleDataConKey coercibleDataCon
coercibleSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "coercible_sel") coercibleSCSelIdKey coercibleSCSelId
charTyConName, charDataConName, intTyConName, intDataConName, stringTyConName :: Name
charTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Char") charTyConKey charTyCon
charDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "C#") charDataConKey charDataCon
stringTyConName = mkWiredInTyConName UserSyntax gHC_BASE (fsLit "String") stringTyConKey stringTyCon
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
maybeTyConName, nothingDataConName, justDataConName :: Name
maybeTyConName = mkWiredInTyConName UserSyntax gHC_MAYBE (fsLit "Maybe")
maybeTyConKey maybeTyCon
nothingDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Nothing")
nothingDataConKey nothingDataCon
justDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Just")
justDataConKey justDataCon
wordTyConName, wordDataConName, word8DataConName :: Name
wordTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Word") wordTyConKey wordTyCon
wordDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "W#") wordDataConKey wordDataCon
word8DataConName = mkWiredInDataConName UserSyntax gHC_WORD (fsLit "W8#") word8DataConKey word8DataCon
floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name
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
anyTyConName :: Name
anyTyConName =
mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Any") anyTyConKey anyTyCon
anyTyCon :: TyCon
anyTyCon = mkFamilyTyCon anyTyConName binders res_kind Nothing
(ClosedSynFamilyTyCon Nothing)
Nothing
NotInjective
where
binders@[kv] = mkTemplateKindTyConBinders [liftedTypeKind]
res_kind = mkTyVarTy (binderVar kv)
anyTy :: Type
anyTy = mkTyConTy anyTyCon
anyTypeOfKind :: Kind -> Type
anyTypeOfKind kind = mkTyConApp anyTyCon [kind]
makeRecoveryTyCon :: TyCon -> TyCon
makeRecoveryTyCon tc
= mkTcTyCon (tyConName tc)
bndrs res_kind
noTcTyConScopedTyVars
True
flavour
where
flavour = tyConFlavour tc
[kv] = mkTemplateKindVars [liftedTypeKind]
(bndrs, res_kind)
= case flavour of
PromotedDataConFlavour -> ([mkNamedTyConBinder Inferred kv], mkTyVarTy kv)
_ -> (tyConBinders tc, tyConResKind tc)
typeSymbolKindConName :: Name
typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon
constraintKindTyConName :: Name
constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint") constraintKindTyConKey constraintKindTyCon
liftedTypeKindTyConName, unliftedTypeKindTyConName :: Name
liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") liftedTypeKindTyConKey liftedTypeKindTyCon
unliftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedType") unliftedTypeKindTyConKey unliftedTypeKindTyCon
liftedRepTyConName, unliftedRepTyConName :: Name
liftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "LiftedRep") liftedRepTyConKey liftedRepTyCon
unliftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedRep") unliftedRepTyConKey unliftedRepTyCon
multiplicityTyConName :: Name
multiplicityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Multiplicity")
multiplicityTyConKey multiplicityTyCon
oneDataConName, manyDataConName :: Name
oneDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "One") oneDataConKey oneDataCon
manyDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "Many") manyDataConKey manyDataCon
runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName, boxedRepDataConName :: Name
runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon
vecRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "VecRep") vecRepDataConKey vecRepDataCon
tupleRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon
sumRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "SumRep") sumRepDataConKey sumRepDataCon
boxedRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "BoxedRep") boxedRepDataConKey boxedRepDataCon
levityTyConName, liftedDataConName, unliftedDataConName :: Name
levityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Levity") levityTyConKey levityTyCon
liftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Lifted") liftedDataConKey liftedDataCon
unliftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Unlifted") unliftedDataConKey unliftedDataCon
runtimeRepSimpleDataConNames :: [Name]
runtimeRepSimpleDataConNames
= zipWith3Lazy mk_special_dc_name
[ fsLit "IntRep"
, fsLit "Int8Rep", fsLit "Int16Rep", fsLit "Int32Rep", fsLit "Int64Rep"
, fsLit "WordRep"
, fsLit "Word8Rep", fsLit "Word16Rep", fsLit "Word32Rep", fsLit "Word64Rep"
, fsLit "AddrRep"
, fsLit "FloatRep", fsLit "DoubleRep"
]
runtimeRepSimpleDataConKeys
runtimeRepSimpleDataCons
vecCountTyConName :: Name
vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon
vecCountDataConNames :: [Name]
vecCountDataConNames = zipWith3Lazy mk_special_dc_name
[ fsLit "Vec2", fsLit "Vec4", fsLit "Vec8"
, fsLit "Vec16", fsLit "Vec32", fsLit "Vec64" ]
vecCountDataConKeys
vecCountDataCons
vecElemTyConName :: Name
vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon
vecElemDataConNames :: [Name]
vecElemDataConNames = zipWith3Lazy mk_special_dc_name
[ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep"
, fsLit "Int64ElemRep", fsLit "Word8ElemRep", fsLit "Word16ElemRep"
, fsLit "Word32ElemRep", fsLit "Word64ElemRep"
, fsLit "FloatElemRep", fsLit "DoubleElemRep" ]
vecElemDataConKeys
vecElemDataCons
mk_special_dc_name :: FastString -> Unique -> DataCon -> Name
mk_special_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc
boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, stringTyCon_RDR,
intDataCon_RDR, listTyCon_RDR, consDataCon_RDR :: RdrName
boolTyCon_RDR = nameRdrName boolTyConName
false_RDR = nameRdrName falseDataConName
true_RDR = nameRdrName trueDataConName
intTyCon_RDR = nameRdrName intTyConName
charTyCon_RDR = nameRdrName charTyConName
stringTyCon_RDR = nameRdrName stringTyConName
intDataCon_RDR = nameRdrName intDataConName
listTyCon_RDR = nameRdrName listTyConName
consDataCon_RDR = nameRdrName consDataConName
pcTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
pcTyCon name cType tyvars cons
= mkAlgTyCon name
(mkAnonTyConBinders VisArg tyvars)
liftedTypeKind
(map (const Representational) tyvars)
cType
[]
(mkDataTyConRhs cons)
(VanillaAlgTyCon (mkPrelTyConRepName name))
False
pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
pcDataCon n univs tys = pcDataConW n univs (map linear tys)
pcDataConW :: Name -> [TyVar] -> [Scaled Type] -> TyCon -> DataCon
pcDataConW n univs tys = pcDataConWithFixity False n univs
[]
univs
tys
pcDataConWithFixity :: Bool
-> Name
-> [TyVar]
-> [TyCoVar]
-> [TyCoVar]
-> [Scaled Type]
-> TyCon
-> DataCon
pcDataConWithFixity infx n = pcDataConWithFixity' infx n (dataConWorkerUnique (nameUnique n))
NoRRI
pcDataConWithFixity' :: Bool -> Name -> Unique -> RuntimeRepInfo
-> [TyVar] -> [TyCoVar] -> [TyCoVar]
-> [Scaled Type] -> TyCon -> DataCon
pcDataConWithFixity' declared_infix dc_name wrk_key rri
tyvars ex_tyvars user_tyvars arg_tys tycon
= data_con
where
tag_map = mkTyConTagMap tycon
data_con = mkDataCon dc_name declared_infix prom_info
(map (const no_bang) arg_tys)
[]
tyvars ex_tyvars
(mkTyVarBinders SpecifiedSpec user_tyvars)
[]
[]
arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))
rri
tycon
(lookupNameEnv_NF tag_map dc_name)
[]
(mkDataConWorkId wrk_name data_con)
NoDataConRep
no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict
wrk_name = mkDataConWorkerName data_con wrk_key
prom_info = mkPrelTyConRepName dc_name
mkDataConWorkerName :: DataCon -> Unique -> Name
mkDataConWorkerName data_con wrk_key =
mkWiredInName modu wrk_occ wrk_key
(AnId (dataConWorkId data_con)) UserSyntax
where
modu = ASSERT( isExternalName dc_name )
nameModule dc_name
dc_name = dataConName data_con
dc_occ = nameOccName dc_name
wrk_occ = mkDataConWorkerOcc dc_occ
pcSpecialDataCon :: Name -> [Type] -> TyCon -> RuntimeRepInfo -> DataCon
pcSpecialDataCon dc_name arg_tys tycon rri
= pcDataConWithFixity' False dc_name (dataConWorkerUnique (nameUnique dc_name)) rri
[] [] [] (map linear arg_tys) tycon
typeSymbolKindCon :: TyCon
typeSymbolKindCon = pcTyCon typeSymbolKindConName Nothing [] []
typeSymbolKind :: Kind
typeSymbolKind = mkTyConTy typeSymbolKindCon
constraintKindTyCon :: TyCon
constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] []
liftedTypeKind, unliftedTypeKind, typeToTypeKind, constraintKind :: Kind
liftedTypeKind = mkTyConTy liftedTypeKindTyCon
unliftedTypeKind = mkTyConTy unliftedTypeKindTyCon
typeToTypeKind = liftedTypeKind `mkVisFunTyMany` liftedTypeKind
constraintKind = mkTyConTy constraintKindTyCon
isBuiltInOcc_maybe :: OccName -> Maybe Name
isBuiltInOcc_maybe occ =
case name of
"[]" -> Just $ choose_ns listTyConName nilDataConName
":" -> Just consDataConName
"~" -> Just eqTyConName
"FUN" -> Just funTyConName
"->" -> Just unrestrictedFunTyConName
"()" -> Just $ tup_name Boxed 0
_ | Just rest <- "(" `BS.stripPrefix` name
, (commas, rest') <- BS.span (==',') rest
, ")" <- rest'
-> Just $ tup_name Boxed (1+BS.length commas)
"(##)" -> Just $ tup_name Unboxed 0
"Solo#" -> Just $ tup_name Unboxed 1
_ | Just rest <- "(#" `BS.stripPrefix` name
, (commas, rest') <- BS.span (==',') rest
, "#)" <- rest'
-> Just $ tup_name Unboxed (1+BS.length commas)
_ | Just rest <- "(#" `BS.stripPrefix` name
, (pipes, rest') <- BS.span (=='|') rest
, "#)" <- rest'
-> Just $ tyConName $ sumTyCon (1+BS.length pipes)
_ | Just rest <- "(#" `BS.stripPrefix` name
, (pipes1, rest') <- BS.span (=='|') rest
, Just rest'' <- "_" `BS.stripPrefix` rest'
, (pipes2, rest''') <- BS.span (=='|') rest''
, "#)" <- rest'''
-> let arity = BS.length pipes1 + BS.length pipes2 + 1
alt = BS.length pipes1 + 1
in Just $ dataConName $ sumDataCon alt arity
_ -> Nothing
where
name = bytesFS $ occNameFS occ
choose_ns :: Name -> Name -> Name
choose_ns tc dc
| isTcClsNameSpace ns = tc
| isDataConNameSpace ns = dc
| otherwise = pprPanic "tup_name" (ppr occ)
where ns = occNameSpace occ
tup_name boxity arity
= choose_ns (getName (tupleTyCon boxity arity))
(getName (tupleDataCon boxity arity))
mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName
mkTupleOcc ns Boxed ar = mkOccName ns (mkBoxedTupleStr ar)
mkTupleOcc ns Unboxed ar = mkOccName ns (mkUnboxedTupleStr ar)
mkCTupleOcc :: NameSpace -> Arity -> OccName
mkCTupleOcc ns ar = mkOccName ns (mkConstraintTupleStr ar)
mkTupleStr :: Boxity -> Arity -> String
mkTupleStr Boxed = mkBoxedTupleStr
mkTupleStr Unboxed = mkUnboxedTupleStr
mkBoxedTupleStr :: Arity -> String
mkBoxedTupleStr 0 = "()"
mkBoxedTupleStr 1 = "Solo"
mkBoxedTupleStr ar = '(' : commas ar ++ ")"
mkUnboxedTupleStr :: Arity -> String
mkUnboxedTupleStr 0 = "(##)"
mkUnboxedTupleStr 1 = "Solo#"
mkUnboxedTupleStr ar = "(#" ++ commas ar ++ "#)"
mkConstraintTupleStr :: Arity -> String
mkConstraintTupleStr 0 = "(%%)"
mkConstraintTupleStr 1 = "Solo%"
mkConstraintTupleStr ar = "(%" ++ commas ar ++ "%)"
commas :: Arity -> String
commas ar = take (ar1) (repeat ',')
cTupleTyCon :: Arity -> TyCon
cTupleTyCon i
| i > mAX_CTUPLE_SIZE = fstOf3 (mk_ctuple i)
| otherwise = fstOf3 (cTupleArr ! i)
cTupleTyConName :: Arity -> Name
cTupleTyConName a = tyConName (cTupleTyCon a)
cTupleTyConNames :: [Name]
cTupleTyConNames = map cTupleTyConName (0 : [2..mAX_CTUPLE_SIZE])
cTupleTyConKeys :: UniqSet Unique
cTupleTyConKeys = mkUniqSet $ map getUnique cTupleTyConNames
isCTupleTyConName :: Name -> Bool
isCTupleTyConName n
= ASSERT2( isExternalName n, ppr n )
getUnique n `elementOfUniqSet` cTupleTyConKeys
cTupleTyConNameArity_maybe :: Name -> Maybe Arity
cTupleTyConNameArity_maybe n
| not (isCTupleTyConName n) = Nothing
| otherwise = fmap adjustArity (n `elemIndex` cTupleTyConNames)
where
adjustArity a = if a > 0 then a + 1 else a
cTupleDataCon :: Arity -> DataCon
cTupleDataCon i
| i > mAX_CTUPLE_SIZE = sndOf3 (mk_ctuple i)
| otherwise = sndOf3 (cTupleArr ! i)
cTupleDataConName :: Arity -> Name
cTupleDataConName i = dataConName (cTupleDataCon i)
cTupleDataConNames :: [Name]
cTupleDataConNames = map cTupleDataConName (0 : [2..mAX_CTUPLE_SIZE])
cTupleSelId :: ConTag
-> Arity
-> Id
cTupleSelId sc_pos arity
| sc_pos > arity
= panic ("cTupleSelId: index out of bounds: superclass position: "
++ show sc_pos ++ " > arity " ++ show arity)
| sc_pos <= 0
= panic ("cTupleSelId: Superclass positions start from 1. "
++ "(superclass position: " ++ show sc_pos
++ ", arity: " ++ show arity ++ ")")
| arity < 2
= panic ("cTupleSelId: Arity starts from 2. "
++ "(superclass position: " ++ show sc_pos
++ ", arity: " ++ show arity ++ ")")
| arity > mAX_CTUPLE_SIZE
= thdOf3 (mk_ctuple arity) ! (sc_pos 1)
| otherwise
= thdOf3 (cTupleArr ! arity) ! (sc_pos 1)
cTupleSelIdName :: ConTag
-> Arity
-> Name
cTupleSelIdName sc_pos arity = idName (cTupleSelId sc_pos arity)
tupleTyCon :: Boxity -> Arity -> TyCon
tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i)
tupleTyCon Boxed i = fst (boxedTupleArr ! i)
tupleTyCon Unboxed i = fst (unboxedTupleArr ! i)
tupleTyConName :: TupleSort -> Arity -> Name
tupleTyConName ConstraintTuple a = cTupleTyConName a
tupleTyConName BoxedTuple a = tyConName (tupleTyCon Boxed a)
tupleTyConName UnboxedTuple a = tyConName (tupleTyCon Unboxed a)
promotedTupleDataCon :: Boxity -> Arity -> TyCon
promotedTupleDataCon boxity i = promoteDataCon (tupleDataCon boxity i)
tupleDataCon :: Boxity -> Arity -> DataCon
tupleDataCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i)
tupleDataCon Boxed i = snd (boxedTupleArr ! i)
tupleDataCon Unboxed i = snd (unboxedTupleArr ! i)
tupleDataConName :: Boxity -> Arity -> Name
tupleDataConName sort i = dataConName (tupleDataCon sort i)
mkPromotedPairTy :: Kind -> Kind -> Type -> Type -> Type
mkPromotedPairTy k1 k2 t1 t2 = mkTyConApp (promotedTupleDataCon Boxed 2) [k1,k2,t1,t2]
isPromotedPairType :: Type -> Maybe (Type, Type)
isPromotedPairType t
| Just (tc, [_,_,x,y]) <- splitTyConApp_maybe t
, tc == promotedTupleDataCon Boxed 2
= Just (x, y)
| otherwise = Nothing
boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon)
boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed i | i <- [0..mAX_TUPLE_SIZE]]
unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]]
cTupleArr :: Array Int (TyCon, DataCon, Array Int Id)
cTupleArr = listArray (0,mAX_CTUPLE_SIZE) [mk_ctuple i | i <- [0..mAX_CTUPLE_SIZE]]
unboxedTupleSumKind :: TyCon -> [Type] -> Kind
unboxedTupleSumKind tc rr_tys
= tYPE (mkTyConApp tc [mkPromotedListTy runtimeRepTy rr_tys])
unboxedTupleKind :: [Type] -> Kind
unboxedTupleKind = unboxedTupleSumKind tupleRepDataConTyCon
mk_tuple :: Boxity -> Int -> (TyCon,DataCon)
mk_tuple Boxed arity = (tycon, tuple_con)
where
tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con
BoxedTuple flavour
tc_binders = mkTemplateAnonTyConBinders (replicate arity liftedTypeKind)
tc_res_kind = liftedTypeKind
tc_arity = arity
flavour = VanillaAlgTyCon (mkPrelTyConRepName tc_name)
dc_tvs = binderVars tc_binders
dc_arg_tys = mkTyVarTys dc_tvs
tuple_con = pcDataCon dc_name dc_tvs dc_arg_tys tycon
boxity = Boxed
modu = gHC_TUPLE
tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq
(ATyCon tycon) BuiltInSyntax
dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq
(AConLike (RealDataCon tuple_con)) BuiltInSyntax
tc_uniq = mkTupleTyConUnique boxity arity
dc_uniq = mkTupleDataConUnique boxity arity
mk_tuple Unboxed arity = (tycon, tuple_con)
where
tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con
UnboxedTuple flavour
tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy)
(\ks -> map tYPE ks)
tc_res_kind = unboxedTupleKind rr_tys
tc_arity = arity * 2
flavour = UnboxedAlgTyCon $ Just (mkPrelTyConRepName tc_name)
dc_tvs = binderVars tc_binders
(rr_tys, dc_arg_tys) = splitAt arity (mkTyVarTys dc_tvs)
tuple_con = pcDataCon dc_name dc_tvs dc_arg_tys tycon
boxity = Unboxed
modu = gHC_PRIM
tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq
(ATyCon tycon) BuiltInSyntax
dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq
(AConLike (RealDataCon tuple_con)) BuiltInSyntax
tc_uniq = mkTupleTyConUnique boxity arity
dc_uniq = mkTupleDataConUnique boxity arity
mk_ctuple :: Arity -> (TyCon, DataCon, Array ConTagZ Id)
mk_ctuple arity = (tycon, tuple_con, sc_sel_ids_arr)
where
tycon = mkClassTyCon tc_name binders roles
rhs klass
(mkPrelTyConRepName tc_name)
klass = mk_ctuple_class tycon sc_theta sc_sel_ids
tuple_con = pcDataConW dc_name tvs (map unrestricted sc_theta) tycon
binders = mkTemplateAnonTyConBinders (replicate arity constraintKind)
roles = replicate arity Nominal
rhs = TupleTyCon{data_con = tuple_con, tup_sort = ConstraintTuple}
modu = gHC_CLASSES
tc_name = mkWiredInName modu (mkCTupleOcc tcName arity) tc_uniq
(ATyCon tycon) BuiltInSyntax
dc_name = mkWiredInName modu (mkCTupleOcc dataName arity) dc_uniq
(AConLike (RealDataCon tuple_con)) BuiltInSyntax
tc_uniq = mkCTupleTyConUnique arity
dc_uniq = mkCTupleDataConUnique arity
tvs = binderVars binders
sc_theta = map mkTyVarTy tvs
sc_sel_ids = [mk_sc_sel_id sc_pos | sc_pos <- [0..arity1]]
sc_sel_ids_arr = listArray (0,arity1) sc_sel_ids
mk_sc_sel_id sc_pos =
let sc_sel_id_uniq = mkCTupleSelIdUnique sc_pos arity
sc_sel_id_occ = mkCTupleOcc tcName arity
sc_sel_id_name = mkWiredInIdName
gHC_CLASSES
(occNameFS (mkSuperDictSelOcc sc_pos sc_sel_id_occ))
sc_sel_id_uniq
sc_sel_id
sc_sel_id = mkDictSelId sc_sel_id_name klass
in sc_sel_id
unitTyCon :: TyCon
unitTyCon = tupleTyCon Boxed 0
unitTyConKey :: Unique
unitTyConKey = getUnique unitTyCon
unitDataCon :: DataCon
unitDataCon = head (tyConDataCons unitTyCon)
unitDataConId :: Id
unitDataConId = dataConWorkId unitDataCon
pairTyCon :: TyCon
pairTyCon = tupleTyCon Boxed 2
unboxedUnitTy :: Type
unboxedUnitTy = mkTyConApp unboxedUnitTyCon []
unboxedUnitTyCon :: TyCon
unboxedUnitTyCon = tupleTyCon Unboxed 0
unboxedUnitDataCon :: DataCon
unboxedUnitDataCon = tupleDataCon Unboxed 0
mkSumTyConOcc :: Arity -> OccName
mkSumTyConOcc n = mkOccName tcName str
where
str = '(' : '#' : bars ++ "#)"
bars = replicate (n1) '|'
mkSumDataConOcc :: ConTag -> Arity -> OccName
mkSumDataConOcc alt n = mkOccName dataName str
where
str = '(' : '#' : bars alt ++ '_' : bars (n alt 1) ++ "#)"
bars i = replicate i '|'
sumTyCon :: Arity -> TyCon
sumTyCon arity
| arity > mAX_SUM_SIZE
= fst (mk_sum arity)
| arity < 2
= panic ("sumTyCon: Arity starts from 2. (arity: " ++ show arity ++ ")")
| otherwise
= fst (unboxedSumArr ! arity)
sumDataCon :: ConTag
-> Arity
-> DataCon
sumDataCon alt arity
| alt > arity
= panic ("sumDataCon: index out of bounds: alt: "
++ show alt ++ " > arity " ++ show arity)
| alt <= 0
= panic ("sumDataCon: Alts start from 1. (alt: " ++ show alt
++ ", arity: " ++ show arity ++ ")")
| arity < 2
= panic ("sumDataCon: Arity starts from 2. (alt: " ++ show alt
++ ", arity: " ++ show arity ++ ")")
| arity > mAX_SUM_SIZE
= snd (mk_sum arity) ! (alt 1)
| otherwise
= snd (unboxedSumArr ! arity) ! (alt 1)
unboxedSumArr :: Array Int (TyCon, Array Int DataCon)
unboxedSumArr = listArray (2,mAX_SUM_SIZE) [mk_sum i | i <- [2..mAX_SUM_SIZE]]
unboxedSumKind :: [Type] -> Kind
unboxedSumKind = unboxedTupleSumKind sumRepDataConTyCon
mk_sum :: Arity -> (TyCon, Array ConTagZ DataCon)
mk_sum arity = (tycon, sum_cons)
where
tycon = mkSumTyCon tc_name tc_binders tc_res_kind (arity * 2) tyvars (elems sum_cons)
(UnboxedAlgTyCon rep_name)
rep_name = Nothing
tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy)
(\ks -> map tYPE ks)
tyvars = binderVars tc_binders
tc_res_kind = unboxedSumKind rr_tys
(rr_tys, tyvar_tys) = splitAt arity (mkTyVarTys tyvars)
tc_name = mkWiredInName gHC_PRIM (mkSumTyConOcc arity) tc_uniq
(ATyCon tycon) BuiltInSyntax
sum_cons = listArray (0,arity1) [sum_con i | i <- [0..arity1]]
sum_con i = let dc = pcDataCon dc_name
tyvars
[tyvar_tys !! i]
tycon
dc_name = mkWiredInName gHC_PRIM
(mkSumDataConOcc i arity)
(dc_uniq i)
(AConLike (RealDataCon dc))
BuiltInSyntax
in dc
tc_uniq = mkSumTyConUnique arity
dc_uniq i = mkSumDataConUnique i arity
eqTyCon, heqTyCon, coercibleTyCon :: TyCon
eqClass, heqClass, coercibleClass :: Class
eqDataCon, heqDataCon, coercibleDataCon :: DataCon
eqSCSelId, heqSCSelId, coercibleSCSelId :: Id
(eqTyCon, eqClass, eqDataCon, eqSCSelId)
= (tycon, klass, datacon, sc_sel_id)
where
tycon = mkClassTyCon eqTyConName binders roles
rhs klass
(mkPrelTyConRepName eqTyConName)
klass = mk_class tycon sc_pred sc_sel_id
datacon = pcDataConW eqDataConName tvs [unrestricted sc_pred] tycon
binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k])
roles = [Nominal, Nominal, Nominal]
rhs = mkDataTyConRhs [datacon]
tvs@[k,a,b] = binderVars binders
sc_pred = mkTyConApp eqPrimTyCon (mkTyVarTys [k,k,a,b])
sc_sel_id = mkDictSelId eqSCSelIdName klass
(heqTyCon, heqClass, heqDataCon, heqSCSelId)
= (tycon, klass, datacon, sc_sel_id)
where
tycon = mkClassTyCon heqTyConName binders roles
rhs klass
(mkPrelTyConRepName heqTyConName)
klass = mk_class tycon sc_pred sc_sel_id
datacon = pcDataConW heqDataConName tvs [unrestricted sc_pred] tycon
binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id
roles = [Nominal, Nominal, Nominal, Nominal]
rhs = mkDataTyConRhs [datacon]
tvs = binderVars binders
sc_pred = mkTyConApp eqPrimTyCon (mkTyVarTys tvs)
sc_sel_id = mkDictSelId heqSCSelIdName klass
(coercibleTyCon, coercibleClass, coercibleDataCon, coercibleSCSelId)
= (tycon, klass, datacon, sc_sel_id)
where
tycon = mkClassTyCon coercibleTyConName binders roles
rhs klass
(mkPrelTyConRepName coercibleTyConName)
klass = mk_class tycon sc_pred sc_sel_id
datacon = pcDataConW coercibleDataConName tvs [unrestricted sc_pred] tycon
binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k])
roles = [Nominal, Representational, Representational]
rhs = mkDataTyConRhs [datacon]
tvs@[k,a,b] = binderVars binders
sc_pred = mkTyConApp eqReprPrimTyCon (mkTyVarTys [k, k, a, b])
sc_sel_id = mkDictSelId coercibleSCSelIdName klass
mk_class :: TyCon -> PredType -> Id -> Class
mk_class tycon sc_pred sc_sel_id
= mkClass (tyConName tycon) (tyConTyVars tycon) [] [sc_pred] [sc_sel_id]
[] [] (mkAnd []) tycon
mk_ctuple_class :: TyCon -> ThetaType -> [Id] -> Class
mk_ctuple_class tycon sc_theta sc_sel_ids
= mkClass (tyConName tycon) (tyConTyVars tycon) [] sc_theta sc_sel_ids
[] [] (mkAnd []) tycon
multiplicityTy :: Type
multiplicityTy = mkTyConTy multiplicityTyCon
multiplicityTyCon :: TyCon
multiplicityTyCon = pcTyCon multiplicityTyConName Nothing []
[oneDataCon, manyDataCon]
oneDataCon, manyDataCon :: DataCon
oneDataCon = pcDataCon oneDataConName [] [] multiplicityTyCon
manyDataCon = pcDataCon manyDataConName [] [] multiplicityTyCon
oneDataConTy, manyDataConTy :: Type
oneDataConTy = mkTyConTy oneDataConTyCon
manyDataConTy = mkTyConTy manyDataConTyCon
oneDataConTyCon, manyDataConTyCon :: TyCon
oneDataConTyCon = promoteDataCon oneDataCon
manyDataConTyCon = promoteDataCon manyDataCon
multMulTyConName :: Name
multMulTyConName =
mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "MultMul") multMulTyConKey multMulTyCon
multMulTyCon :: TyCon
multMulTyCon = mkFamilyTyCon multMulTyConName binders multiplicityTy Nothing
(BuiltInSynFamTyCon trivialBuiltInFamily)
Nothing
NotInjective
where
binders = mkTemplateAnonTyConBinders [multiplicityTy, multiplicityTy]
unrestrictedFunTy :: Type
unrestrictedFunTy = functionWithMultiplicity manyDataConTy
unrestrictedFunTyCon :: TyCon
unrestrictedFunTyCon = buildSynTyCon unrestrictedFunTyConName [] arrowKind [] unrestrictedFunTy
where arrowKind = mkTyConKind binders liftedTypeKind
binders = [ Bndr runtimeRep1TyVar (NamedTCB Inferred)
, Bndr runtimeRep2TyVar (NamedTCB Inferred)
]
++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty
, tYPE runtimeRep2Ty
]
unrestrictedFunTyConName :: Name
unrestrictedFunTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "->") unrestrictedFunTyConKey unrestrictedFunTyCon
runtimeRepTy :: Type
runtimeRepTy = mkTyConTy runtimeRepTyCon
liftedTypeKindTyCon :: TyCon
liftedTypeKindTyCon =
buildSynTyCon liftedTypeKindTyConName [] liftedTypeKind [] rhs
where rhs = TyCoRep.TyConApp tYPETyCon [mkTyConApp liftedRepTyCon []]
unliftedTypeKindTyCon :: TyCon
unliftedTypeKindTyCon =
buildSynTyCon unliftedTypeKindTyConName [] liftedTypeKind [] rhs
where rhs = TyCoRep.TyConApp tYPETyCon [mkTyConApp unliftedRepTyCon []]
liftedRepTyCon :: TyCon
liftedRepTyCon = buildSynTyCon
liftedRepTyConName [] runtimeRepTy [] liftedRepTy
unliftedRepTyCon :: TyCon
unliftedRepTyCon = buildSynTyCon
unliftedRepTyConName [] runtimeRepTy [] unliftedRepTy
runtimeRepTyCon :: TyCon
runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing []
(vecRepDataCon : tupleRepDataCon :
sumRepDataCon : boxedRepDataCon : runtimeRepSimpleDataCons)
levityTyCon :: TyCon
levityTyCon = pcTyCon levityTyConName Nothing [] [liftedDataCon,unliftedDataCon]
liftedDataCon, unliftedDataCon :: DataCon
liftedDataCon = pcSpecialDataCon liftedDataConName
[] levityTyCon LiftedInfo
unliftedDataCon = pcSpecialDataCon unliftedDataConName
[] levityTyCon UnliftedInfo
boxedRepDataCon :: DataCon
boxedRepDataCon = pcSpecialDataCon boxedRepDataConName
[ mkTyConTy levityTyCon ] runtimeRepTyCon (RuntimeRep prim_rep_fun)
where
prim_rep_fun [lev]
= case tyConRuntimeRepInfo (tyConAppTyCon lev) of
LiftedInfo -> [LiftedRep]
UnliftedInfo -> [UnliftedRep]
_ -> pprPanic "boxedRepDataCon" (ppr lev)
prim_rep_fun args
= pprPanic "boxedRepDataCon" (ppr args)
vecRepDataCon :: DataCon
vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon
, mkTyConTy vecElemTyCon ]
runtimeRepTyCon
(RuntimeRep prim_rep_fun)
where
prim_rep_fun [count, elem]
| VecCount n <- tyConRuntimeRepInfo (tyConAppTyCon count)
, VecElem e <- tyConRuntimeRepInfo (tyConAppTyCon elem)
= [VecRep n e]
prim_rep_fun args
= pprPanic "vecRepDataCon" (ppr args)
vecRepDataConTyCon :: TyCon
vecRepDataConTyCon = promoteDataCon vecRepDataCon
tupleRepDataCon :: DataCon
tupleRepDataCon = pcSpecialDataCon tupleRepDataConName [ mkListTy runtimeRepTy ]
runtimeRepTyCon (RuntimeRep prim_rep_fun)
where
prim_rep_fun [rr_ty_list]
= concatMap (runtimeRepPrimRep doc) rr_tys
where
rr_tys = extractPromotedList rr_ty_list
doc = text "tupleRepDataCon" <+> ppr rr_tys
prim_rep_fun args
= pprPanic "tupleRepDataCon" (ppr args)
tupleRepDataConTyCon :: TyCon
tupleRepDataConTyCon = promoteDataCon tupleRepDataCon
sumRepDataCon :: DataCon
sumRepDataCon = pcSpecialDataCon sumRepDataConName [ mkListTy runtimeRepTy ]
runtimeRepTyCon (RuntimeRep prim_rep_fun)
where
prim_rep_fun [rr_ty_list]
= map slotPrimRep (ubxSumRepType prim_repss)
where
rr_tys = extractPromotedList rr_ty_list
doc = text "sumRepDataCon" <+> ppr rr_tys
prim_repss = map (runtimeRepPrimRep doc) rr_tys
prim_rep_fun args
= pprPanic "sumRepDataCon" (ppr args)
sumRepDataConTyCon :: TyCon
sumRepDataConTyCon = promoteDataCon sumRepDataCon
runtimeRepSimpleDataCons :: [DataCon]
runtimeRepSimpleDataCons
= zipWithLazy mk_runtime_rep_dc
[ IntRep
, Int8Rep, Int16Rep, Int32Rep, Int64Rep
, WordRep
, Word8Rep, Word16Rep, Word32Rep, Word64Rep
, AddrRep
, FloatRep, DoubleRep
]
runtimeRepSimpleDataConNames
where
mk_runtime_rep_dc primrep name
= pcSpecialDataCon name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep]))
intRepDataConTy,
int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,
wordRepDataConTy,
word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,
addrRepDataConTy,
floatRepDataConTy, doubleRepDataConTy :: Type
[intRepDataConTy,
int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,
wordRepDataConTy,
word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,
addrRepDataConTy,
floatRepDataConTy, doubleRepDataConTy
]
= map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons
vecCountTyCon :: TyCon
vecCountTyCon = pcTyCon vecCountTyConName Nothing [] vecCountDataCons
vecCountDataCons :: [DataCon]
vecCountDataCons = zipWithLazy mk_vec_count_dc
[ 2, 4, 8, 16, 32, 64 ]
vecCountDataConNames
where
mk_vec_count_dc n name
= pcSpecialDataCon name [] vecCountTyCon (VecCount n)
vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,
vec64DataConTy :: Type
[vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,
vec64DataConTy] = map (mkTyConTy . promoteDataCon) vecCountDataCons
vecElemTyCon :: TyCon
vecElemTyCon = pcTyCon vecElemTyConName Nothing [] vecElemDataCons
vecElemDataCons :: [DataCon]
vecElemDataCons = zipWithLazy mk_vec_elem_dc
[ Int8ElemRep, Int16ElemRep, Int32ElemRep, Int64ElemRep
, Word8ElemRep, Word16ElemRep, Word32ElemRep, Word64ElemRep
, FloatElemRep, DoubleElemRep ]
vecElemDataConNames
where
mk_vec_elem_dc elem name
= pcSpecialDataCon name [] vecElemTyCon (VecElem elem)
int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,
int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,
word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,
doubleElemRepDataConTy :: Type
[int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,
int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,
word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,
doubleElemRepDataConTy] = map (mkTyConTy . promoteDataCon)
vecElemDataCons
liftedDataConTyCon :: TyCon
liftedDataConTyCon = promoteDataCon liftedDataCon
unliftedDataConTyCon :: TyCon
unliftedDataConTyCon = promoteDataCon unliftedDataCon
liftedDataConTy :: Type
liftedDataConTy = mkTyConTy liftedDataConTyCon
unliftedDataConTy :: Type
unliftedDataConTy = mkTyConTy unliftedDataConTyCon
boxedRepDataConTyCon :: TyCon
boxedRepDataConTyCon = promoteDataCon boxedRepDataCon
liftedRepTy :: Type
liftedRepTy = mkTyConApp boxedRepDataConTyCon [liftedDataConTy]
unliftedRepTy :: Type
unliftedRepTy = mkTyConApp boxedRepDataConTyCon [unliftedDataConTy]
boxingDataCon_maybe :: TyCon -> Maybe DataCon
boxingDataCon_maybe tc
= lookupNameEnv boxing_constr_env (tyConName tc)
boxing_constr_env :: NameEnv DataCon
boxing_constr_env
= mkNameEnv [(charPrimTyConName , charDataCon )
,(intPrimTyConName , intDataCon )
,(wordPrimTyConName , wordDataCon )
,(floatPrimTyConName , floatDataCon )
,(doublePrimTyConName, doubleDataCon) ]
charTy :: Type
charTy = mkTyConTy charTyCon
charTyCon :: TyCon
charTyCon = pcTyCon charTyConName
(Just (CType NoSourceText Nothing
(NoSourceText,fsLit "HsChar")))
[] [charDataCon]
charDataCon :: DataCon
charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon
stringTy :: Type
stringTy = mkTyConApp stringTyCon []
stringTyCon :: TyCon
stringTyCon = buildSynTyCon stringTyConName
[] liftedTypeKind []
(mkListTy charTy)
intTy :: Type
intTy = mkTyConTy intTyCon
intTyCon :: TyCon
intTyCon = pcTyCon intTyConName
(Just (CType NoSourceText Nothing (NoSourceText,fsLit "HsInt")))
[] [intDataCon]
intDataCon :: DataCon
intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon
wordTy :: Type
wordTy = mkTyConTy wordTyCon
wordTyCon :: TyCon
wordTyCon = pcTyCon wordTyConName
(Just (CType NoSourceText Nothing (NoSourceText, fsLit "HsWord")))
[] [wordDataCon]
wordDataCon :: DataCon
wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon
word8Ty :: Type
word8Ty = mkTyConTy word8TyCon
word8TyCon :: TyCon
word8TyCon = pcTyCon word8TyConName
(Just (CType NoSourceText Nothing
(NoSourceText, fsLit "HsWord8"))) []
[word8DataCon]
word8DataCon :: DataCon
word8DataCon = pcDataCon word8DataConName [] [word8PrimTy] word8TyCon
floatTy :: Type
floatTy = mkTyConTy floatTyCon
floatTyCon :: TyCon
floatTyCon = pcTyCon floatTyConName
(Just (CType NoSourceText Nothing
(NoSourceText, fsLit "HsFloat"))) []
[floatDataCon]
floatDataCon :: DataCon
floatDataCon = pcDataCon floatDataConName [] [floatPrimTy] floatTyCon
doubleTy :: Type
doubleTy = mkTyConTy doubleTyCon
doubleTyCon :: TyCon
doubleTyCon = pcTyCon doubleTyConName
(Just (CType NoSourceText Nothing
(NoSourceText,fsLit "HsDouble"))) []
[doubleDataCon]
doubleDataCon :: DataCon
doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon
boolTy :: Type
boolTy = mkTyConTy boolTyCon
boolTyCon :: TyCon
boolTyCon = pcTyCon boolTyConName
(Just (CType NoSourceText Nothing
(NoSourceText, 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 orderingTyConName Nothing
[] [ordLTDataCon, ordEQDataCon, ordGTDataCon]
ordLTDataCon, ordEQDataCon, ordGTDataCon :: DataCon
ordLTDataCon = pcDataCon ordLTDataConName [] [] orderingTyCon
ordEQDataCon = pcDataCon ordEQDataConName [] [] orderingTyCon
ordGTDataCon = pcDataCon ordGTDataConName [] [] orderingTyCon
ordLTDataConId, ordEQDataConId, ordGTDataConId :: Id
ordLTDataConId = dataConWorkId ordLTDataCon
ordEQDataConId = dataConWorkId ordEQDataCon
ordGTDataConId = dataConWorkId ordGTDataCon
mkListTy :: Type -> Type
mkListTy ty = mkTyConApp listTyCon [ty]
listTyCon :: TyCon
listTyCon = pcTyCon listTyConName Nothing [alphaTyVar] [nilDataCon, consDataCon]
nilDataCon :: DataCon
nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon
consDataCon :: DataCon
consDataCon = pcDataConWithFixity True
consDataConName
alpha_tyvar [] alpha_tyvar
(map linear [alphaTy, mkTyConApp listTyCon alpha_ty]) listTyCon
maybeTyCon :: TyCon
maybeTyCon = pcTyCon maybeTyConName Nothing alpha_tyvar
[nothingDataCon, justDataCon]
nothingDataCon :: DataCon
nothingDataCon = pcDataCon nothingDataConName alpha_tyvar [] maybeTyCon
justDataCon :: DataCon
justDataCon = pcDataCon justDataConName alpha_tyvar [alphaTy] maybeTyCon
mkPromotedMaybeTy :: Kind -> Maybe Type -> Type
mkPromotedMaybeTy k (Just x) = mkTyConApp promotedJustDataCon [k,x]
mkPromotedMaybeTy k Nothing = mkTyConApp promotedNothingDataCon [k]
mkMaybeTy :: Type -> Kind
mkMaybeTy t = mkTyConApp maybeTyCon [t]
isPromotedMaybeTy :: Type -> Maybe (Maybe Type)
isPromotedMaybeTy t
| Just (tc,[_,x]) <- splitTyConApp_maybe t, tc == promotedJustDataCon = return $ Just x
| Just (tc,[_]) <- splitTyConApp_maybe t, tc == promotedNothingDataCon = return $ Nothing
| otherwise = Nothing
mkTupleTy :: Boxity -> [Type] -> Type
mkTupleTy Boxed [ty] = ty
mkTupleTy boxity tys = mkTupleTy1 boxity tys
mkTupleTy1 :: Boxity -> [Type] -> Type
mkTupleTy1 Boxed tys = mkTyConApp (tupleTyCon Boxed (length tys)) tys
mkTupleTy1 Unboxed tys = mkTyConApp (tupleTyCon Unboxed (length tys))
(map getRuntimeRep tys ++ tys)
mkBoxedTupleTy :: [Type] -> Type
mkBoxedTupleTy tys = mkTupleTy Boxed tys
unitTy :: Type
unitTy = mkTupleTy Boxed []
mkSumTy :: [Type] -> Type
mkSumTy tys = mkTyConApp (sumTyCon (length tys))
(map getRuntimeRep tys ++ tys)
promotedFalseDataCon, promotedTrueDataCon :: TyCon
promotedTrueDataCon = promoteDataCon trueDataCon
promotedFalseDataCon = promoteDataCon falseDataCon
promotedNothingDataCon, promotedJustDataCon :: TyCon
promotedNothingDataCon = promoteDataCon nothingDataCon
promotedJustDataCon = promoteDataCon justDataCon
promotedLTDataCon
, promotedEQDataCon
, promotedGTDataCon
:: TyCon
promotedLTDataCon = promoteDataCon ordLTDataCon
promotedEQDataCon = promoteDataCon ordEQDataCon
promotedGTDataCon = promoteDataCon ordGTDataCon
promotedConsDataCon, promotedNilDataCon :: TyCon
promotedConsDataCon = promoteDataCon consDataCon
promotedNilDataCon = promoteDataCon nilDataCon
mkPromotedListTy :: Kind
-> [Type]
-> Type
mkPromotedListTy k tys
= foldr cons nil tys
where
cons :: Type
-> Type
-> Type
cons elt list = mkTyConApp promotedConsDataCon [k, elt, list]
nil :: Type
nil = mkTyConApp promotedNilDataCon [k]
extractPromotedList :: Type
-> [Type]
extractPromotedList tys = go tys
where
go list_ty
| Just (tc, [_k, t, ts]) <- splitTyConApp_maybe list_ty
= ASSERT( tc `hasKey` consDataConKey )
t : go ts
| Just (tc, [_k]) <- splitTyConApp_maybe list_ty
= ASSERT( tc `hasKey` nilDataConKey )
[]
| otherwise
= pprPanic "extractPromotedList" (ppr tys)
integerTyConName
, integerISDataConName
, integerIPDataConName
, integerINDataConName
:: Name
integerTyConName
= mkWiredInTyConName
UserSyntax
gHC_NUM_INTEGER
(fsLit "Integer")
integerTyConKey
integerTyCon
integerISDataConName
= mkWiredInDataConName
UserSyntax
gHC_NUM_INTEGER
(fsLit "IS")
integerISDataConKey
integerISDataCon
integerIPDataConName
= mkWiredInDataConName
UserSyntax
gHC_NUM_INTEGER
(fsLit "IP")
integerIPDataConKey
integerIPDataCon
integerINDataConName
= mkWiredInDataConName
UserSyntax
gHC_NUM_INTEGER
(fsLit "IN")
integerINDataConKey
integerINDataCon
integerTy :: Type
integerTy = mkTyConTy integerTyCon
integerTyCon :: TyCon
integerTyCon = pcTyCon integerTyConName Nothing []
[integerISDataCon, integerIPDataCon, integerINDataCon]
integerISDataCon :: DataCon
integerISDataCon = pcDataCon integerISDataConName [] [intPrimTy] integerTyCon
integerIPDataCon :: DataCon
integerIPDataCon = pcDataCon integerIPDataConName [] [byteArrayPrimTy] integerTyCon
integerINDataCon :: DataCon
integerINDataCon = pcDataCon integerINDataConName [] [byteArrayPrimTy] integerTyCon
naturalTyConName
, naturalNSDataConName
, naturalNBDataConName
:: Name
naturalTyConName
= mkWiredInTyConName
UserSyntax
gHC_NUM_NATURAL
(fsLit "Natural")
naturalTyConKey
naturalTyCon
naturalNSDataConName
= mkWiredInDataConName
UserSyntax
gHC_NUM_NATURAL
(fsLit "NS")
naturalNSDataConKey
naturalNSDataCon
naturalNBDataConName
= mkWiredInDataConName
UserSyntax
gHC_NUM_NATURAL
(fsLit "NB")
naturalNBDataConKey
naturalNBDataCon
naturalTy :: Type
naturalTy = mkTyConTy naturalTyCon
naturalTyCon :: TyCon
naturalTyCon = pcTyCon naturalTyConName Nothing []
[naturalNSDataCon, naturalNBDataCon]
naturalNSDataCon :: DataCon
naturalNSDataCon = pcDataCon naturalNSDataConName [] [wordPrimTy] naturalTyCon
naturalNBDataCon :: DataCon
naturalNBDataCon = pcDataCon naturalNBDataConName [] [byteArrayPrimTy] naturalTyCon
filterCTuple :: RdrName -> RdrName
filterCTuple (Exact n)
| Just arity <- cTupleTyConNameArity_maybe n
= Exact $ tupleTyConName BoxedTuple arity
filterCTuple rdr = rdr