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

  Builtin Type and Kind definitions
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskellQuotes #-}

module Clash.Core.TysPrim
  ( liftedTypeKind
  , typeNatKind
  , typeSymbolKind
  , intPrimTy
  , integerPrimTy
  , charPrimTy
  , stringPrimTy
#if !MIN_VERSION_ghc(9,2,0)
  , voidPrimTy
#endif
  , wordPrimTy
  , int64PrimTy
  , word64PrimTy
  , int8PrimTy
  , int16PrimTy
  , int32PrimTy
  , word8PrimTy
  , word16PrimTy
  , word32PrimTy
  , floatPrimTy
  , doublePrimTy
  , naturalPrimTy
  , byteArrayPrimTy
  , eqPrimTy
  , tysPrimMap
  )
where


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

import           GHC.Base hiding (Type, TyCon)
import           Data.Text.Extra (showt)

#if MIN_VERSION_base(4,17,0)
import           Clash.Core.DataCon (DataCon(..), DcStrictness(..))
import           GHC.Num.Integer (Integer(..))
import           GHC.Num.Natural (Natural(..))
#endif

import           Clash.Core.Name
import           Clash.Core.TyCon
import           Clash.Core.Type
import           Clash.Core.Var (mkTyVar)
import           Clash.Unique (fromGhcUnique)
import qualified Clash.Data.UniqMap as UniqMap

-- | Builtin Name
liftedTypeKindTyConName, typeNatKindTyConName, typeSymbolKindTyConName :: TyConName
liftedTypeKindTyConName :: TyConName
liftedTypeKindTyConName   = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"Type"
                              (Unique -> Unique
fromGhcUnique Unique
liftedTypeKindTyConKey)
#if MIN_VERSION_ghc(9,2,0)
typeNatKindTyConName      = naturalPrimTyConName
#else
typeNatKindTyConName :: TyConName
typeNatKindTyConName      = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"Nat"
                              (Unique -> Unique
fromGhcUnique Unique
typeNatKindConNameKey)
#endif
typeSymbolKindTyConName :: TyConName
typeSymbolKindTyConName   = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"Symbol"
                              (Unique -> Unique
fromGhcUnique 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,
  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
fromGhcUnique Unique
intPrimTyConKey)
#if MIN_VERSION_base(4,15,0)
integerPrimTyConName = mkUnsafeSystemName "GHC.Num.Integer.Integer"
                                (fromGhcUnique integerTyConKey)
#else
integerPrimTyConName :: TyConName
integerPrimTyConName = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"GHC.Integer.Type.Integer"
                                (Unique -> Unique
fromGhcUnique Unique
integerTyConKey)
#endif
stringPrimTyConName :: TyConName
stringPrimTyConName  = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"GHC.Prim.Addr#"
                        (Unique -> Unique
fromGhcUnique Unique
addrPrimTyConKey)
charPrimTyConName :: TyConName
charPrimTyConName    = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"GHC.Prim.Char#"
                                (Unique -> Unique
fromGhcUnique Unique
charPrimTyConKey)
wordPrimTyConName :: TyConName
wordPrimTyConName    = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"GHC.Prim.Word#"
                                (Unique -> Unique
fromGhcUnique Unique
wordPrimTyConKey)
int64PrimTyConName :: TyConName
int64PrimTyConName   = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"GHC.Prim.Int64#"
                                (Unique -> Unique
fromGhcUnique Unique
int64PrimTyConKey)
word64PrimTyConName :: TyConName
word64PrimTyConName  = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"GHC.Prim.Word64#"
                                (Unique -> Unique
fromGhcUnique Unique
word64PrimTyConKey)
floatPrimTyConName :: TyConName
floatPrimTyConName   = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"GHC.Prim.Float#"
                                (Unique -> Unique
fromGhcUnique Unique
floatPrimTyConKey)
doublePrimTyConName :: TyConName
doublePrimTyConName  = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"GHC.Prim.Double#"
                                (Unique -> Unique
fromGhcUnique Unique
doublePrimTyConKey)
#if MIN_VERSION_base(4,15,0)
naturalPrimTyConName = mkUnsafeSystemName "GHC.Num.Natural.Natural"
                                (fromGhcUnique naturalTyConKey)
#else
naturalPrimTyConName :: TyConName
naturalPrimTyConName = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"GHC.Natural.Natural"
                                (Unique -> Unique
fromGhcUnique Unique
naturalTyConKey)
#endif
byteArrayPrimTyConName :: TyConName
byteArrayPrimTyConName = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"GHC.Prim.ByteArray#"
                          (Unique -> Unique
fromGhcUnique Unique
byteArrayPrimTyConKey)

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

#if !MIN_VERSION_ghc(9,2,0)
voidPrimTyConName :: TyConName
voidPrimTyConName :: TyConName
voidPrimTyConName    = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"Void#" (Unique -> Unique
fromGhcUnique Unique
voidPrimTyConKey)
#endif

int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, word8PrimTyConName,
  word16PrimTyConName, word32PrimTyConName :: TyConName
int8PrimTyConName :: TyConName
int8PrimTyConName   = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName (Name -> Text
forall a. Show a => a -> Text
showt ''Int8#)
                        (Unique -> Unique
fromGhcUnique Unique
int8PrimTyConKey)
int16PrimTyConName :: TyConName
int16PrimTyConName  = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName (Name -> Text
forall a. Show a => a -> Text
showt ''Int16#)
                        (Unique -> Unique
fromGhcUnique Unique
int16PrimTyConKey)
int32PrimTyConName :: TyConName
int32PrimTyConName  = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName (Name -> Text
forall a. Show a => a -> Text
showt ''Int32#)
                        (Unique -> Unique
fromGhcUnique Unique
int32PrimTyConKey)
word8PrimTyConName :: TyConName
word8PrimTyConName  = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName (Name -> Text
forall a. Show a => a -> Text
showt ''Word8#)
                        (Unique -> Unique
fromGhcUnique Unique
word8PrimTyConKey)
word16PrimTyConName :: TyConName
word16PrimTyConName = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName (Name -> Text
forall a. Show a => a -> Text
showt ''Word16#)
                        (Unique -> Unique
fromGhcUnique Unique
word16PrimTyConKey)
word32PrimTyConName :: TyConName
word32PrimTyConName = Text -> Unique -> TyConName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName (Name -> Text
forall a. Show a => a -> Text
showt ''Word32#)
                        (Unique -> Unique
fromGhcUnique Unique
word32PrimTyConKey)

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, wordPrimTc,
  int64PrimTc, word64PrimTc, floatPrimTc, doublePrimTc, naturalPrimTc,
  byteArrayPrimTc :: TyCon
intPrimTc :: TyCon
intPrimTc     = TyConName -> TyCon
liftedPrimTC TyConName
intPrimTyConName
#if MIN_VERSION_base(4,17,0)
-- While GHC might have dropped Integer and Natural literals, in Clash it is
-- still nice to have them around. However, Integer and Natural are also no
-- longer primitive types in GHC, but we still want to give the Integer and
-- Natural type to our Integer and Natural literals.
--
-- So instead of recording the primitive types, we record the algebraic types,
-- i.e. the complete data type for Integer and Natural, data constructors and all.

integerPrimTc =
  let
    name = integerPrimTyConName
    uniq = nameUniq name
    isDcNm = mkUnsafeSystemName (showt 'IS) (fromGhcUnique integerISDataConKey)
    isDc = MkData
      { dcName = isDcNm
      , dcUniq = nameUniq isDcNm
      , dcTag  = 1
      , dcType = mkPolyFunTy integerPrimTy [Right intPrimTy]
      , dcUnivTyVars = []
      , dcExtTyVars = []
      , dcArgTys = [intPrimTy]
      , dcArgStrict = [Strict]
      , dcFieldLabels = []
      }
    ipDcNm = mkUnsafeSystemName (showt 'IP) (fromGhcUnique integerIPDataConKey)
    ipDc = MkData
      { dcName = ipDcNm
      , dcUniq = nameUniq ipDcNm
      , dcTag  = 2
      , dcType = mkPolyFunTy integerPrimTy [Right byteArrayPrimTy]
      , dcUnivTyVars = []
      , dcExtTyVars = []
      , dcArgTys = [byteArrayPrimTy]
      , dcArgStrict = [Strict]
      , dcFieldLabels = []
      }
    inDcNm = mkUnsafeSystemName (showt 'IN) (fromGhcUnique integerINDataConKey)
    inDc = MkData
      { dcName = inDcNm
      , dcUniq = nameUniq inDcNm
      , dcTag  = 3
      , dcType = mkPolyFunTy integerPrimTy [Right byteArrayPrimTy]
      , dcUnivTyVars = []
      , dcExtTyVars = []
      , dcArgTys = [byteArrayPrimTy]
      , dcArgStrict = [Strict]
      , dcFieldLabels = []
      }
    rhs = DataTyCon [isDc,ipDc,inDc]
  in
    AlgTyCon uniq name liftedTypeKind 0 rhs False

naturalPrimTc =
  let
    name = naturalPrimTyConName
    uniq = nameUniq name
    nsDcNm = mkUnsafeSystemName (showt 'NS) (fromGhcUnique naturalNSDataConKey)
    nsDc = MkData
      { dcName = nsDcNm
      , dcUniq = nameUniq nsDcNm
      , dcTag  = 1
      , dcType = mkPolyFunTy naturalPrimTy [Right wordPrimTy]
      , dcUnivTyVars = []
      , dcExtTyVars = []
      , dcArgTys = [wordPrimTy]
      , dcArgStrict = [Strict]
      , dcFieldLabels = []
      }
    nbDcNm = mkUnsafeSystemName (showt 'NB) (fromGhcUnique naturalNBDataConKey)
    nbDc = MkData
      { dcName = nbDcNm
      , dcUniq = nameUniq nbDcNm
      , dcTag  = 2
      , dcType = mkPolyFunTy naturalPrimTy [Right byteArrayPrimTy]
      , dcUnivTyVars = []
      , dcExtTyVars = []
      , dcArgTys = [byteArrayPrimTy]
      , dcArgStrict = [Strict]
      , dcFieldLabels = []
      }
    rhs = DataTyCon [nsDc,nbDc]
   in
    AlgTyCon uniq name liftedTypeKind 0 rhs False
#else
integerPrimTc :: TyCon
integerPrimTc = TyConName -> TyCon
liftedPrimTC TyConName
integerPrimTyConName
naturalPrimTc :: TyCon
naturalPrimTc = TyConName -> TyCon
liftedPrimTC TyConName
naturalPrimTyConName
#endif
charPrimTc :: TyCon
charPrimTc    = TyConName -> TyCon
liftedPrimTC TyConName
charPrimTyConName
stringPrimTc :: TyCon
stringPrimTc  = TyConName -> TyCon
liftedPrimTC TyConName
stringPrimTyConName
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
byteArrayPrimTc :: TyCon
byteArrayPrimTc = TyConName -> TyCon
liftedPrimTC  TyConName
byteArrayPrimTyConName

#if !MIN_VERSION_ghc(9,2,0)
voidPrimTc :: TyCon
voidPrimTc :: TyCon
voidPrimTc    = TyConName -> TyCon
liftedPrimTC TyConName
voidPrimTyConName
#endif

int8PrimTc, int16PrimTc, int32PrimTc, word8PrimTc, word16PrimTc,
  word32PrimTc :: TyCon
int8PrimTc :: TyCon
int8PrimTc    = TyConName -> TyCon
liftedPrimTC TyConName
int8PrimTyConName
int16PrimTc :: TyCon
int16PrimTc   = TyConName -> TyCon
liftedPrimTC TyConName
int16PrimTyConName
int32PrimTc :: TyCon
int32PrimTc   = TyConName -> TyCon
liftedPrimTC TyConName
int32PrimTyConName
word8PrimTc :: TyCon
word8PrimTc   = TyConName -> TyCon
liftedPrimTC TyConName
word8PrimTyConName
word16PrimTc :: TyCon
word16PrimTc  = TyConName -> TyCon
liftedPrimTC TyConName
word16PrimTyConName
word32PrimTc :: TyCon
word32PrimTc  = TyConName -> TyCon
liftedPrimTC TyConName
word32PrimTyConName

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, 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
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

#if !MIN_VERSION_ghc(9,2,0)
voidPrimTy :: Type
voidPrimTy :: Kind
voidPrimTy    = TyConName -> Kind
mkTyConTy TyConName
voidPrimTyConName
#endif

int8PrimTy, int16PrimTy, int32PrimTy, word8PrimTy, word16PrimTy,
  word32PrimTy :: Type
int8PrimTy :: Kind
int8PrimTy    = TyConName -> Kind
mkTyConTy TyConName
int8PrimTyConName
int16PrimTy :: Kind
int16PrimTy   = TyConName -> Kind
mkTyConTy TyConName
int16PrimTyConName
int32PrimTy :: Kind
int32PrimTy   = TyConName -> Kind
mkTyConTy TyConName
int32PrimTyConName
word8PrimTy :: Kind
word8PrimTy   = TyConName -> Kind
mkTyConTy TyConName
word8PrimTyConName
word16PrimTy :: Kind
word16PrimTy  = TyConName -> Kind
mkTyConTy TyConName
word16PrimTyConName
word32PrimTy :: Kind
word32PrimTy  = TyConName -> Kind
mkTyConTy TyConName
word32PrimTyConName

tysPrimMap :: TyConMap
tysPrimMap :: TyConMap
tysPrimMap = [(TyConName, TyCon)] -> TyConMap
forall a b. Uniquable a => [(a, b)] -> UniqMap b
UniqMap.fromList
  [  (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)
#if !MIN_VERSION_ghc(9,2,0)
  ,  (TyConName
voidPrimTyConName , TyCon
voidPrimTc)
#endif
  ,  (TyConName
wordPrimTyConName , TyCon
wordPrimTc)
  ,  (TyConName
int64PrimTyConName , TyCon
int64PrimTc)
  ,  (TyConName
word64PrimTyConName , TyCon
word64PrimTc)
  ,  (TyConName
int8PrimTyConName , TyCon
int8PrimTc)
  ,  (TyConName
int16PrimTyConName , TyCon
int16PrimTc)
  ,  (TyConName
int32PrimTyConName , TyCon
int32PrimTc)
  ,  (TyConName
word8PrimTyConName , TyCon
word8PrimTc)
  ,  (TyConName
word16PrimTyConName , TyCon
word16PrimTc)
  ,  (TyConName
word32PrimTyConName , TyCon
word32PrimTc)
  ,  (TyConName
floatPrimTyConName , TyCon
floatPrimTc)
  ,  (TyConName
doublePrimTyConName , TyCon
doublePrimTc)
  ,  (TyConName
naturalPrimTyConName , TyCon
naturalPrimTc)
  ,  (TyConName
byteArrayPrimTyConName , TyCon
byteArrayPrimTc)
  ,  (TyConName
eqPrimTyConName , TyCon
eqPrimTc)
  ]