    {-# LANGUAGE Rank2Types #-}
    {- | This module defines the basic libffi machinery.
        You will need this to create support for new ffi types. -}
    module Foreign.LibFFI.Base where

    import Control.Monad
    import Control.Exception
    import Foreign.Ptr
    import Foreign.Storable
    import Foreign.Marshal

    import Foreign.LibFFI.Internal
    import Foreign.LibFFI.FFITypes

    newtype Arg = Arg { Arg -> forall a. (Ptr CType -> Ptr CValue -> IO a) -> IO a
    unArg :: forall a. (Ptr CType -> Ptr CValue -> IO a) -> IO a }

    customPointerArg :: (a -> IO (Ptr b)) -> (Ptr b -> IO ()) -> a -> Arg
    customPointerArg :: forall a b. (a -> IO (Ptr b)) -> (Ptr b -> IO ()) -> a -> Arg
    customPointerArg a -> IO (Ptr b)
    newA Ptr b -> IO ()
    freeA a
    a = (forall a. (Ptr CType -> Ptr CValue -> IO a) -> IO a) -> Arg
    Arg ((forall a. (Ptr CType -> Ptr CValue -> IO a) -> IO a) -> Arg)
    -> (forall a. (Ptr CType -> Ptr CValue -> IO a) -> IO a) -> Arg
    forall a b. (a -> b) -> a -> b
    $ \Ptr CType -> Ptr CValue -> IO a
    withArg ->
        IO (Ptr b) -> (Ptr b -> IO ()) -> (Ptr b -> IO a) -> IO a
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
    bracket (a -> IO (Ptr b)
    newA a
    a) Ptr b -> IO ()
    freeA ((Ptr b -> IO a) -> IO a) -> (Ptr b -> IO a) -> IO a
    forall a b. (a -> b) -> a -> b
    $ \Ptr b
    p ->
            Ptr b -> (Ptr (Ptr b) -> IO a) -> IO a
    forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
    with Ptr b
    p ((Ptr (Ptr b) -> IO a) -> IO a) -> (Ptr (Ptr b) -> IO a) -> IO a
    forall a b. (a -> b) -> a -> b
    $ \Ptr (Ptr b)
    pp ->
                Ptr CType -> Ptr CValue -> IO a
    withArg Ptr CType
    ffi_type_pointer (Ptr (Ptr b) -> Ptr CValue
    forall a b. Ptr a -> Ptr b
    castPtr Ptr (Ptr b)
    pp)

    mkStorableArg :: Storable a => Ptr CType -> a -> Arg
    mkStorableArg :: forall a. Storable a => Ptr CType -> a -> Arg
    mkStorableArg Ptr CType
    cType a
    a = (forall a. (Ptr CType -> Ptr CValue -> IO a) -> IO a) -> Arg
    Arg ((forall a. (Ptr CType -> Ptr CValue -> IO a) -> IO a) -> Arg)
    -> (forall a. (Ptr CType -> Ptr CValue -> IO a) -> IO a) -> Arg
    forall a b. (a -> b) -> a -> b
    $ \Ptr CType -> Ptr CValue -> IO a
    withArg ->
        a -> (Ptr a -> IO a) -> IO a
    forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
    with a
    a ((Ptr a -> IO a) -> IO a) -> (Ptr a -> IO a) -> IO a
    forall a b. (a -> b) -> a -> b
    $ \Ptr a
    p ->
            Ptr CType -> Ptr CValue -> IO a
    withArg Ptr CType
    cType (Ptr a -> Ptr CValue
    forall a b. Ptr a -> Ptr b
    castPtr Ptr a
    p)

    newtype RetType a = RetType { forall a. RetType a -> (Ptr CType -> Ptr CValue -> IO ()) -> IO a
    unRetType :: (Ptr CType -> Ptr CValue -> IO ()) -> IO a }

    instance Functor RetType where
        fmap :: forall a b. (a -> b) -> RetType a -> RetType b
    fmap a -> b
    f  = (a -> IO b) -> RetType a -> RetType b
    forall a b. (a -> IO b) -> RetType a -> RetType b
    withRetType (b -> IO b
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (b -> IO b) -> (a -> b) -> a -> IO b
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> b
    f)

    withRetType :: (a -> IO b) -> RetType a -> RetType b
    withRetType :: forall a b. (a -> IO b) -> RetType a -> RetType b
    withRetType a -> IO b
    f (RetType (Ptr CType -> Ptr CValue -> IO ()) -> IO a
    withPoke) = ((Ptr CType -> Ptr CValue -> IO ()) -> IO b) -> RetType b
    forall a. ((Ptr CType -> Ptr CValue -> IO ()) -> IO a) -> RetType a
    RetType (((Ptr CType -> Ptr CValue -> IO ()) -> IO b) -> RetType b)
    -> ((Ptr CType -> Ptr CValue -> IO ()) -> IO b) -> RetType b
    forall a b. (a -> b) -> a -> b
    $ (Ptr CType -> Ptr CValue -> IO ()) -> IO a
    withPoke ((Ptr CType -> Ptr CValue -> IO ()) -> IO a)
    -> (a -> IO b) -> (Ptr CType -> Ptr CValue -> IO ()) -> IO b
    forall (m :: * -> *) a b c.
    Monad m =>
    (a -> m b) -> (b -> m c) -> a -> m c
    >=> a -> IO b
    f

    mkStorableRetType :: Storable a => Ptr CType -> RetType a
    mkStorableRetType :: forall a. Storable a => Ptr CType -> RetType a
    mkStorableRetType Ptr CType
    cType
        = ((Ptr CType -> Ptr CValue -> IO ()) -> IO a) -> RetType a
    forall a. ((Ptr CType -> Ptr CValue -> IO ()) -> IO a) -> RetType a
    RetType (((Ptr CType -> Ptr CValue -> IO ()) -> IO a) -> RetType a)
    -> ((Ptr CType -> Ptr CValue -> IO ()) -> IO a) -> RetType a
    forall a b. (a -> b) -> a -> b
    $ \Ptr CType -> Ptr CValue -> IO ()
    write -> (Ptr a -> IO a) -> IO a
    forall a b. Storable a => (Ptr a -> IO b) -> IO b
    alloca ((Ptr a -> IO a) -> IO a) -> (Ptr a -> IO a) -> IO a
    forall a b. (a -> b) -> a -> b
    $ \Ptr a
    cValue -> Ptr CType -> Ptr CValue -> IO ()
    write Ptr CType
    cType (Ptr a -> Ptr CValue
    forall a b. Ptr a -> Ptr b
    castPtr Ptr a
    cValue) IO () -> IO a -> IO a
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Ptr a -> IO a
    forall a. Storable a => Ptr a -> IO a
    peek Ptr a
    cValue

    newStorableStructArgRet :: Storable a => [Ptr CType] -> IO (a -> Arg, RetType a, IO ())
    newStorableStructArgRet :: forall a.
    Storable a =>
    [Ptr CType] -> IO (a -> Arg, RetType a, IO ())
    newStorableStructArgRet [Ptr CType]
    cTypes = do
        (Ptr CType
    cType, IO ()
    freeit) <- [Ptr CType] -> IO (Ptr CType, IO ())
    newStructCType [Ptr CType]
    cTypes
        (a -> Arg, RetType a, IO ()) -> IO (a -> Arg, RetType a, IO ())
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Ptr CType -> a -> Arg
    forall a. Storable a => Ptr CType -> a -> Arg
    mkStorableArg Ptr CType
    cType, Ptr CType -> RetType a
    forall a. Storable a => Ptr CType -> RetType a
    mkStorableRetType Ptr CType
    cType, IO ()
    freeit)

    newStructCType  :: [Ptr CType] -> IO (Ptr CType, IO ())
    newStructCType :: [Ptr CType] -> IO (Ptr CType, IO ())
    newStructCType [Ptr CType]
    cTypes = do
        Ptr CType
    ffi_type <- Int -> IO (Ptr CType)
    forall a. Int -> IO (Ptr a)
    mallocBytes Int
    sizeOf_ffi_type
        Ptr (Ptr CType)
    elements <- Ptr CType -> [Ptr CType] -> IO (Ptr (Ptr CType))
    forall a. Storable a => a -> [a] -> IO (Ptr a)
    newArray0 Ptr CType
    forall a. Ptr a
    nullPtr [Ptr CType]
    cTypes
        Ptr CType -> Ptr (Ptr CType) -> IO ()
    init_ffi_type Ptr CType
    ffi_type Ptr (Ptr CType)
    elements
        (Ptr CType, IO ()) -> IO (Ptr CType, IO ())
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Ptr CType
    ffi_type, Ptr CType -> IO ()
    forall a. Ptr a -> IO ()
    free Ptr CType
    ffi_type IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Ptr (Ptr CType) -> IO ()
    forall a. Ptr a -> IO ()
    free Ptr (Ptr CType)
    elements)

    sizeAndAlignmentOfCType :: Ptr CType -> IO (Int, Int)
    sizeAndAlignmentOfCType :: Ptr CType -> IO (Int, Int)
    sizeAndAlignmentOfCType Ptr CType
    cType = do
      (CSize
    size, CUShort
    alignment) <- Ptr CType -> IO (CSize, CUShort)
    ffi_type_size_and_alignment Ptr CType
    cType
      if CSize
    size CSize -> CSize -> Bool
    forall a. Eq a => a -> a -> Bool
    /= CSize
    0 Bool -> Bool -> Bool
    && CUShort
    alignment CUShort -> CUShort -> Bool
    forall a. Eq a => a -> a -> Bool
    /= CUShort
    0
      then (Int, Int) -> IO (Int, Int)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CSize -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral CSize
    size, CUShort -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral CUShort
    alignment)
      else do
        -- The type's size and alignment haven't been initialized

        -- so we force it with a call to `ffi_prep_cif`.

        C_ffi_status
    status <- Int -> (Ptr CIF -> IO C_ffi_status) -> IO C_ffi_status
    forall a b. Int -> (Ptr a -> IO b) -> IO b
    allocaBytes Int
    sizeOf_cif ((Ptr CIF -> IO C_ffi_status) -> IO C_ffi_status)
    -> (Ptr CIF -> IO C_ffi_status) -> IO C_ffi_status
    forall a b. (a -> b) -> a -> b
    $ \Ptr CIF
    cif ->
                    Ptr CIF
    -> C_ffi_status
    -> CUInt
    -> Ptr CType
    -> Ptr (Ptr CType)
    -> IO C_ffi_status
    ffi_prep_cif Ptr CIF
    cif C_ffi_status
    ffi_default_abi CUInt
    0 Ptr CType
    cType Ptr (Ptr CType)
    forall a. Ptr a
    nullPtr
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (C_ffi_status
    status C_ffi_status -> C_ffi_status -> Bool
    forall a. Eq a => a -> a -> Bool
    == C_ffi_status
    ffi_ok) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
          [Char] -> IO ()
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "sizeAndAlignmentOfCType: ffi_prep_cif failed"
        (CSize
    size, CUShort
    alignment) <- Ptr CType -> IO (CSize, CUShort)
    ffi_type_size_and_alignment Ptr CType
    cType
        (Int, Int) -> IO (Int, Int)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CSize -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral CSize
    size, CUShort -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral CUShort
    alignment)

    callFFI :: FunPtr a -> RetType b -> [Arg] -> IO b
    callFFI :: forall a b. FunPtr a -> RetType b -> [Arg] -> IO b
    callFFI FunPtr a
    funPtr (RetType (Ptr CType -> Ptr CValue -> IO ()) -> IO b
    actRet) [Arg]
    args
        = Int -> (Ptr CIF -> IO b) -> IO b
    forall a b. Int -> (Ptr a -> IO b) -> IO b
    allocaBytes Int
    sizeOf_cif ((Ptr CIF -> IO b) -> IO b) -> (Ptr CIF -> IO b) -> IO b
    forall a b. (a -> b) -> a -> b
    $ \Ptr CIF
    cif ->
            Int -> (Ptr (Ptr CType) -> IO b) -> IO b
    forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
    allocaArray Int
    n ((Ptr (Ptr CType) -> IO b) -> IO b)
    -> (Ptr (Ptr CType) -> IO b) -> IO b
    forall a b. (a -> b) -> a -> b
    $ \Ptr (Ptr CType)
    cTypesPtr ->
                Int -> (Ptr (Ptr CValue) -> IO b) -> IO b
    forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
    allocaArray Int
    n ((Ptr (Ptr CValue) -> IO b) -> IO b)
    -> (Ptr (Ptr CValue) -> IO b) -> IO b
    forall a b. (a -> b) -> a -> b
    $ \Ptr (Ptr CValue)
    cValuesPtr ->
                    let
                        doCall :: IO b
    doCall  = (Ptr CType -> Ptr CValue -> IO ()) -> IO b
    actRet ((Ptr CType -> Ptr CValue -> IO ()) -> IO b)
    -> (Ptr CType -> Ptr CValue -> IO ()) -> IO b
    forall a b. (a -> b) -> a -> b
    $ \Ptr CType
    cRetType Ptr CValue
    cRetValue -> do
                                    C_ffi_status
    status <- Ptr CIF
    -> C_ffi_status
    -> CUInt
    -> Ptr CType
    -> Ptr (Ptr CType)
    -> IO C_ffi_status
    ffi_prep_cif Ptr CIF
    cif C_ffi_status
    ffi_default_abi (Int -> CUInt
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    n) Ptr CType
    cRetType Ptr (Ptr CType)
    cTypesPtr
                                    Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (C_ffi_status
    status C_ffi_status -> C_ffi_status -> Bool
    forall a. Eq a => a -> a -> Bool
    == C_ffi_status
    ffi_ok) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
                                        [Char] -> IO ()
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "callFFI: ffi_prep_cif failed"
                                    Ptr CIF -> FunPtr a -> Ptr CValue -> Ptr (Ptr CValue) -> IO ()
    forall a.
    Ptr CIF -> FunPtr a -> Ptr CValue -> Ptr (Ptr CValue) -> IO ()
    ffi_call Ptr CIF
    cif FunPtr a
    funPtr Ptr CValue
    cRetValue Ptr (Ptr CValue)
    cValuesPtr
                        addArg :: (Int, Arg) -> IO a -> IO a
    addArg (Int
    i, Arg forall a. (Ptr CType -> Ptr CValue -> IO a) -> IO a
    actArg) IO a
    goArgs
                                = (Ptr CType -> Ptr CValue -> IO a) -> IO a
    forall a. (Ptr CType -> Ptr CValue -> IO a) -> IO a
    actArg ((Ptr CType -> Ptr CValue -> IO a) -> IO a)
    -> (Ptr CType -> Ptr CValue -> IO a) -> IO a
    forall a b. (a -> b) -> a -> b
    $ \Ptr CType
    cType Ptr CValue
    cValue -> do
                                    Ptr (Ptr CType) -> Int -> Ptr CType -> IO ()
    forall a. Storable a => Ptr a -> Int -> a -> IO ()
    pokeElemOff Ptr (Ptr CType)
    cTypesPtr Int
    i Ptr CType
    cType
                                    Ptr (Ptr CValue) -> Int -> Ptr CValue -> IO ()
    forall a. Storable a => Ptr a -> Int -> a -> IO ()
    pokeElemOff Ptr (Ptr CValue)
    cValuesPtr Int
    i Ptr CValue
    cValue
                                    IO a
    goArgs
                    in
                        ((Int, Arg) -> IO b -> IO b) -> IO b -> [(Int, Arg)] -> IO b
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (Int, Arg) -> IO b -> IO b
    forall {a}. (Int, Arg) -> IO a -> IO a
    addArg IO b
    doCall ([(Int, Arg)] -> IO b) -> [(Int, Arg)] -> IO b
    forall a b. (a -> b) -> a -> b
    $ [Int] -> [Arg] -> [(Int, Arg)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Int
    0..] [Arg]
    args
        where
            n :: Int
    n = [Arg] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Arg]
    args