    {-# LANGUAGE MultiWayIf #-}

    module GHC.HsToCore.Foreign.Utils
      ( Binding
      , getPrimTyOf
      , primTyDescChar
      , ppPrimTyConStgType
      )
    where

    import GHC.Prelude

    import GHC.Platform

    import GHC.Tc.Utils.TcType

    import GHC.Core (CoreExpr)
    import GHC.Core.DataCon
    import GHC.Core.TyCon
    import GHC.Core.TyCo.Rep

    import GHC.Types.Id
    import GHC.Types.RepType

    import GHC.Builtin.Types
    import GHC.Builtin.Types.Prim

    import GHC.Utils.Outputable
    import GHC.Utils.Panic

    type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
                                  -- the occurrence analyser will sort it all out

    -- This function returns the primitive type associated with the boxed
    -- type argument to a foreign export (eg. Int ==> Int#).
    getPrimTyOf :: Type -> UnaryType
    getPrimTyOf :: Type -> Type
    getPrimTyOf Type
    ty
      | Type -> Bool
    isBoolTy Type
    rep_ty = Type
    intPrimTy
      -- Except for Bool, the types we are interested in have a single constructor
      -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
      | Bool
    otherwise =
      case Type -> Maybe (TyCon, [Type], DataCon, [Scaled Type])
    splitDataProductType_maybe Type
    rep_ty of
         Just (TyCon
    _, [Type]
    _, DataCon
    data_con, [Scaled Type
    _ Type
    prim_ty]) ->
            Bool -> Type -> Type
    forall a. HasCallStack => Bool -> a -> a
    assert (DataCon -> Arity
    dataConSourceArity DataCon
    data_con Arity -> Arity -> Bool
    forall a. Eq a => a -> a -> Bool
    == Arity
    1) (Type -> Type) -> Type -> Type
    forall a b. (a -> b) -> a -> b
    $
            Bool -> SDoc -> Type -> Type
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr (HasDebugCallStack => Type -> Bool
    Type -> Bool
    isUnliftedType Type
    prim_ty) (Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    prim_ty)
              -- NB: it's OK to call isUnliftedType here, as we don't allow
              -- representation-polymorphic types in foreign import/export declarations
            Type
    prim_ty
         Maybe (TyCon, [Type], DataCon, [Scaled Type])
    _other -> String -> SDoc -> Type
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "getPrimTyOf" (Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    ty)
      where
            rep_ty :: Type
    rep_ty = Type -> Type
    unwrapType Type
    ty

    -- represent a primitive type as a Char, for building a string that
    -- described the foreign function type.  The types are size-dependent,
    -- e.g. 'W' is a signed 32-bit integer.
    primTyDescChar :: Platform -> Type -> Char
    primTyDescChar :: Platform -> Type -> Char
    primTyDescChar !Platform
    platform Type
    ty
     | Type
    ty HasCallStack => Type -> Type -> Bool
    Type -> Type -> Bool
    `eqType` Type
    unitTy = Char
    'v'
     | Bool
    otherwise
     = case HasDebugCallStack => Type -> PrimRep
    Type -> PrimRep
    typePrimRepU (Type -> Type
    getPrimTyOf Type
    ty) of
         PrimRep
    IntRep      -> Char
    signed_word
         PrimRep
    WordRep     -> Char
    unsigned_word
         PrimRep
    Int8Rep     -> Char
    'B'
         PrimRep
    Word8Rep    -> Char
    'b'
         PrimRep
    Int16Rep    -> Char
    'S'
         PrimRep
    Word16Rep   -> Char
    's'
         PrimRep
    Int32Rep    -> Char
    'W'
         PrimRep
    Word32Rep   -> Char
    'w'
         PrimRep
    Int64Rep    -> Char
    'L'
         PrimRep
    Word64Rep   -> Char
    'l'
         PrimRep
    AddrRep     -> Char
    'p'
         PrimRep
    FloatRep    -> Char
    'f'
         PrimRep
    DoubleRep   -> Char
    'd'
         PrimRep
    _           -> String -> SDoc -> Char
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "primTyDescChar" (Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    ty)
      where
        (Char
    signed_word, Char
    unsigned_word) = case Platform -> PlatformWordSize
    platformWordSize Platform
    platform of
          PlatformWordSize
    PW4 -> (Char
    'W',Char
    'w')
          PlatformWordSize
    PW8 -> (Char
    'L',Char
    'l')

    -- | Printed C Type to be used with CAPI calling convention
    ppPrimTyConStgType :: TyCon -> Maybe String
    ppPrimTyConStgType :: TyCon -> Maybe String
    ppPrimTyConStgType TyCon
    tc =
      if | TyCon
    tc TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    charPrimTyCon -> String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "StgChar"
         | TyCon
    tc TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    intPrimTyCon -> String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "StgInt"
         | TyCon
    tc TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    int8PrimTyCon -> String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "StgInt8"
         | TyCon
    tc TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    int16PrimTyCon -> String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "StgInt16"
         | TyCon
    tc TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    int32PrimTyCon -> String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "StgInt32"
         | TyCon
    tc TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    int64PrimTyCon -> String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "StgInt64"
         | TyCon
    tc TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    wordPrimTyCon -> String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "StgWord"
         | TyCon
    tc TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    word8PrimTyCon -> String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "StgWord8"
         | TyCon
    tc TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    word16PrimTyCon -> String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "StgWord16"
         | TyCon
    tc TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    word32PrimTyCon -> String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "StgWord32"
         | TyCon
    tc TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    word64PrimTyCon -> String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "StgWord64"
         | TyCon
    tc TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    floatPrimTyCon -> String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "StgFloat"
         | TyCon
    tc TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    doublePrimTyCon -> String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "StgDouble"
         | TyCon
    tc TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    addrPrimTyCon -> String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "StgAddr"
         | TyCon
    tc TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    stablePtrPrimTyCon -> String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "StgStablePtr"
         | TyCon
    tc TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    arrayPrimTyCon -> String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "const StgAddr"
         | TyCon
    tc TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    mutableArrayPrimTyCon -> String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "StgAddr"
         | TyCon
    tc TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    byteArrayPrimTyCon -> String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "const StgAddr"
         | TyCon
    tc TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    mutableByteArrayPrimTyCon -> String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "StgAddr"
         | TyCon
    tc TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    smallArrayPrimTyCon -> String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "const StgAddr"
         | TyCon
    tc TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    smallMutableArrayPrimTyCon -> String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "StgAddr"
         | Bool
    otherwise -> Maybe String
    forall a. Maybe a
    Nothing