{-|
  Copyright   :  (C) 2012-2016, University of Twente,
                     2016     , Myrtle Software Ltd,
                     2021     , QBayLogic B.V.
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>

  Builtin Type and Kind definitions
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

module Clash.Core.TysPrim
  ( liftedTypeKind
  , typeNatKind
  , typeSymbolKind
  , intPrimTy
  , integerPrimTy
  , charPrimTy
  , stringPrimTy
  , voidPrimTy
  , wordPrimTy
  , int64PrimTy
  , word64PrimTy
  , floatPrimTy
  , doublePrimTy
  , naturalPrimTy
  , byteArrayPrimTy
  , eqPrimTy
  , tysPrimMap
  )
where

import qualified Data.List            as List

#if MIN_VERSION_ghc(9,0,0)
import           GHC.Builtin.Names
import           GHC.Types.Unique     (getKey)
#else
import           PrelNames
import           Unique               (getKey)
#endif

import           Clash.Core.Name
import           Clash.Core.TyCon
import           Clash.Core.Type
import           Clash.Core.Var (mkTyVar)
import           Clash.Unique

-- | Builtin Name
liftedTypeKindTyConName, typeNatKindTyConName, typeSymbolKindTyConName :: TyConName
liftedTypeKindTyConName :: TyConName
liftedTypeKindTyConName   = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"Type" (Unique -> Unique
getKey Unique
liftedTypeKindTyConKey)
typeNatKindTyConName :: TyConName
typeNatKindTyConName      = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"Nat" (Unique -> Unique
getKey Unique
typeNatKindConNameKey)
typeSymbolKindTyConName :: TyConName
typeSymbolKindTyConName   = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"Symbol" (Unique -> Unique
getKey Unique
typeSymbolKindConNameKey)

-- | Builtin Kind
liftedTypeKindTc, typeNatKindTc, typeSymbolKindTc :: TyCon
liftedTypeKindTc :: TyCon
liftedTypeKindTc = TyConName -> Kind -> TyCon
mkKindTyCon TyConName
liftedTypeKindTyConName Kind
liftedTypeKind
typeNatKindTc :: TyCon
typeNatKindTc    = TyConName -> Kind -> TyCon
mkKindTyCon TyConName
typeNatKindTyConName Kind
liftedTypeKind
typeSymbolKindTc :: TyCon
typeSymbolKindTc = TyConName -> Kind -> TyCon
mkKindTyCon TyConName
typeSymbolKindTyConName Kind
liftedTypeKind

liftedTypeKind, typeNatKind, typeSymbolKind :: Type
liftedTypeKind :: Kind
liftedTypeKind = TyConName -> Kind
mkTyConTy TyConName
liftedTypeKindTyConName
typeNatKind :: Kind
typeNatKind    = TyConName -> Kind
mkTyConTy TyConName
typeNatKindTyConName
typeSymbolKind :: Kind
typeSymbolKind = TyConName -> Kind
mkTyConTy TyConName
typeSymbolKindTyConName

intPrimTyConName, integerPrimTyConName, charPrimTyConName, stringPrimTyConName,
  voidPrimTyConName, wordPrimTyConName, int64PrimTyConName,
  word64PrimTyConName, floatPrimTyConName, doublePrimTyConName,
  naturalPrimTyConName, byteArrayPrimTyConName, eqPrimTyConName :: TyConName
intPrimTyConName :: TyConName
intPrimTyConName     = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"GHC.Prim.Int#"
                                (Unique -> Unique
getKey Unique
intPrimTyConKey)
#if MIN_VERSION_base(4,15,0)
integerPrimTyConName = mkUnsafeSystemName "GHC.Num.Integer.Integer"
                                (getKey integerTyConKey)
#else
integerPrimTyConName :: TyConName
integerPrimTyConName = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"GHC.Integer.Type.Integer"
                                (Unique -> Unique
getKey Unique
integerTyConKey)
#endif
stringPrimTyConName :: TyConName
stringPrimTyConName  = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"GHC.Prim.Addr#" (Unique -> Unique
getKey Unique
addrPrimTyConKey)
charPrimTyConName :: TyConName
charPrimTyConName    = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"GHC.Prim.Char#"
                                (Unique -> Unique
getKey Unique
charPrimTyConKey)
voidPrimTyConName :: TyConName
voidPrimTyConName    = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"Void#" (Unique -> Unique
getKey Unique
voidPrimTyConKey)
wordPrimTyConName :: TyConName
wordPrimTyConName    = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"GHC.Prim.Word#"
                                (Unique -> Unique
getKey Unique
wordPrimTyConKey)
int64PrimTyConName :: TyConName
int64PrimTyConName   = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"GHC.Prim.Int64#"
                                (Unique -> Unique
getKey Unique
int64PrimTyConKey)
word64PrimTyConName :: TyConName
word64PrimTyConName  = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"GHC.Prim.Word64#"
                                (Unique -> Unique
getKey Unique
word64PrimTyConKey)
floatPrimTyConName :: TyConName
floatPrimTyConName   = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"GHC.Prim.Float#"
                                (Unique -> Unique
getKey Unique
floatPrimTyConKey)
doublePrimTyConName :: TyConName
doublePrimTyConName  = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"GHC.Prim.Double#"
                                (Unique -> Unique
getKey Unique
doublePrimTyConKey)
#if MIN_VERSION_base(4,15,0)
naturalPrimTyConName = mkUnsafeSystemName "GHC.Num.Natural.Natural"
                                (getKey naturalTyConKey)
#else
naturalPrimTyConName :: TyConName
naturalPrimTyConName = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"GHC.Natural.Natural"
                                (Unique -> Unique
getKey Unique
naturalTyConKey)
#endif
byteArrayPrimTyConName :: TyConName
byteArrayPrimTyConName = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"GHC.Prim.ByteArray#"
                          (Unique -> Unique
getKey Unique
byteArrayPrimTyConKey)

eqPrimTyConName :: TyConName
eqPrimTyConName = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"GHC.Prim.~#" (Unique -> Unique
getKey Unique
eqPrimTyConKey)

liftedPrimTC :: TyConName
             -> TyCon
liftedPrimTC :: TyConName -> TyCon
liftedPrimTC TyConName
name = Unique -> TyConName -> Kind -> Unique -> TyCon
PrimTyCon (TyConName -> Unique
forall a. Name a -> Unique
nameUniq TyConName
name) TyConName
name Kind
liftedTypeKind Unique
0

-- | Builtin Type
intPrimTc, integerPrimTc, charPrimTc, stringPrimTc, voidPrimTc, wordPrimTc,
  int64PrimTc, word64PrimTc, floatPrimTc, doublePrimTc, naturalPrimTc,
  byteArrayPrimTc :: TyCon
intPrimTc :: TyCon
intPrimTc     = TyConName -> TyCon
liftedPrimTC TyConName
intPrimTyConName
integerPrimTc :: TyCon
integerPrimTc = TyConName -> TyCon
liftedPrimTC TyConName
integerPrimTyConName
charPrimTc :: TyCon
charPrimTc    = TyConName -> TyCon
liftedPrimTC TyConName
charPrimTyConName
stringPrimTc :: TyCon
stringPrimTc  = TyConName -> TyCon
liftedPrimTC TyConName
stringPrimTyConName
voidPrimTc :: TyCon
voidPrimTc    = TyConName -> TyCon
liftedPrimTC TyConName
voidPrimTyConName
wordPrimTc :: TyCon
wordPrimTc    = TyConName -> TyCon
liftedPrimTC TyConName
wordPrimTyConName
int64PrimTc :: TyCon
int64PrimTc   = TyConName -> TyCon
liftedPrimTC TyConName
int64PrimTyConName
word64PrimTc :: TyCon
word64PrimTc  = TyConName -> TyCon
liftedPrimTC TyConName
word64PrimTyConName
floatPrimTc :: TyCon
floatPrimTc   = TyConName -> TyCon
liftedPrimTC TyConName
floatPrimTyConName
doublePrimTc :: TyCon
doublePrimTc  = TyConName -> TyCon
liftedPrimTC TyConName
doublePrimTyConName
naturalPrimTc :: TyCon
naturalPrimTc = TyConName -> TyCon
liftedPrimTC TyConName
naturalPrimTyConName
byteArrayPrimTc :: TyCon
byteArrayPrimTc = TyConName -> TyCon
liftedPrimTC  TyConName
byteArrayPrimTyConName

eqPrimTc :: TyCon
eqPrimTc :: TyCon
eqPrimTc = Unique -> TyConName -> Kind -> Unique -> TyCon
PrimTyCon (TyConName -> Unique
forall a. Name a -> Unique
nameUniq TyConName
eqPrimTyConName) TyConName
eqPrimTyConName Kind
ty Unique
4
 where
  -- forall (a :: Type). forall (b :: Type). a -> b -> Type
  --
  -- The "real" type for this in GHC has a codomain of `TYPE ('TupleRep '[])`
  -- instead of the `TYPE 'LiftedRep` used here.
  ty :: Kind
ty  = Kind -> [Either TyVar Kind] -> Kind
mkPolyFunTy Kind
liftedTypeKind
    [TyVar -> Either TyVar Kind
forall a b. a -> Either a b
Left TyVar
aTv, TyVar -> Either TyVar Kind
forall a b. a -> Either a b
Left TyVar
bTv, Kind -> Either TyVar Kind
forall a b. b -> Either a b
Right (TyVar -> Kind
VarTy TyVar
aTv), Kind -> Either TyVar Kind
forall a b. b -> Either a b
Right (TyVar -> Kind
VarTy TyVar
bTv)]

  aTv :: TyVar
aTv = Kind -> TyName -> TyVar
mkTyVar Kind
liftedTypeKind (Text -> Unique -> TyName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"a" Unique
0)
  bTv :: TyVar
bTv = Kind -> TyName -> TyVar
mkTyVar Kind
liftedTypeKind (Text -> Unique -> TyName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"b" Unique
1)

intPrimTy, integerPrimTy, charPrimTy, stringPrimTy, voidPrimTy, wordPrimTy,
  int64PrimTy, word64PrimTy, floatPrimTy, doublePrimTy, naturalPrimTy,
  byteArrayPrimTy, eqPrimTy :: Type
intPrimTy :: Kind
intPrimTy     = TyConName -> Kind
mkTyConTy TyConName
intPrimTyConName
integerPrimTy :: Kind
integerPrimTy = TyConName -> Kind
mkTyConTy TyConName
integerPrimTyConName
charPrimTy :: Kind
charPrimTy    = TyConName -> Kind
mkTyConTy TyConName
charPrimTyConName
stringPrimTy :: Kind
stringPrimTy  = TyConName -> Kind
mkTyConTy TyConName
stringPrimTyConName
voidPrimTy :: Kind
voidPrimTy    = TyConName -> Kind
mkTyConTy TyConName
voidPrimTyConName
wordPrimTy :: Kind
wordPrimTy    = TyConName -> Kind
mkTyConTy TyConName
wordPrimTyConName
int64PrimTy :: Kind
int64PrimTy   = TyConName -> Kind
mkTyConTy TyConName
int64PrimTyConName
word64PrimTy :: Kind
word64PrimTy  = TyConName -> Kind
mkTyConTy TyConName
word64PrimTyConName
floatPrimTy :: Kind
floatPrimTy   = TyConName -> Kind
mkTyConTy TyConName
floatPrimTyConName
doublePrimTy :: Kind
doublePrimTy  = TyConName -> Kind
mkTyConTy TyConName
doublePrimTyConName
naturalPrimTy :: Kind
naturalPrimTy = TyConName -> Kind
mkTyConTy TyConName
naturalPrimTyConName
byteArrayPrimTy :: Kind
byteArrayPrimTy = TyConName -> Kind
mkTyConTy TyConName
byteArrayPrimTyConName
eqPrimTy :: Kind
eqPrimTy = TyConName -> Kind
mkTyConTy TyConName
eqPrimTyConName

tysPrimMap :: TyConMap
tysPrimMap :: TyConMap
tysPrimMap = (TyConMap -> (TyConName, TyCon) -> TyConMap)
-> TyConMap -> [(TyConName, TyCon)] -> TyConMap
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\TyConMap
s (TyConName
k,TyCon
x) -> TyConName -> TyCon -> TyConMap -> TyConMap
forall a b. Uniquable a => a -> b -> UniqMap b -> UniqMap b
extendUniqMap TyConName
k TyCon
x TyConMap
s) TyConMap
forall a. UniqMap a
emptyUniqMap
  [  (TyConName
liftedTypeKindTyConName , TyCon
liftedTypeKindTc)
  ,  (TyConName
typeNatKindTyConName , TyCon
typeNatKindTc)
  ,  (TyConName
typeSymbolKindTyConName , TyCon
typeSymbolKindTc)
  ,  (TyConName
intPrimTyConName , TyCon
intPrimTc)
  ,  (TyConName
integerPrimTyConName , TyCon
integerPrimTc)
  ,  (TyConName
charPrimTyConName , TyCon
charPrimTc)
  ,  (TyConName
stringPrimTyConName , TyCon
stringPrimTc)
  ,  (TyConName
voidPrimTyConName , TyCon
voidPrimTc)
  ,  (TyConName
wordPrimTyConName , TyCon
wordPrimTc)
  ,  (TyConName
int64PrimTyConName , TyCon
int64PrimTc)
  ,  (TyConName
word64PrimTyConName , TyCon
word64PrimTc)
  ,  (TyConName
floatPrimTyConName , TyCon
floatPrimTc)
  ,  (TyConName
doublePrimTyConName , TyCon
doublePrimTc)
  ,  (TyConName
naturalPrimTyConName , TyCon
naturalPrimTc)
  ,  (TyConName
byteArrayPrimTyConName , TyCon
byteArrayPrimTc)
  ,  (TyConName
eqPrimTyConName , TyCon
eqPrimTc)
  ]