{-# LINE 1 "src/Foreign/LibFFI/Dynamic/CIF.hsc" #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Foreign.LibFFI.Dynamic.CIF
    ( ABI(..)
    , defaultABI

    , SomeCIF(..)
    , getCIF

    , CIF(..)
    , toSomeCIF
    , cif
    , cifWithABI

    , abi
    , retType
    , argTypes, nArgs
    , cifFlags

    , SigType, SigReturn
    , retTypeOf, argTypesOf
    , call, callWithABI, callWithCIF
    ) where

import Control.Applicative
import Data.Hashable
import Data.Interned
import Data.List
import Foreign.LibFFI.Dynamic.Base
import Foreign.LibFFI.Dynamic.FFIType
import Foreign.LibFFI.Dynamic.Type
import Foreign.C.Types
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable
import System.IO.Unsafe



newtype ABI = ABI CInt
    deriving (Eq, Ord, Show, Storable)

instance Hashable ABI where
    hashWithSalt salt (ABI x) =
        hashWithSalt salt (fromIntegral x :: Int)

defaultABI = ABI (2)
{-# LINE 50 "src/Foreign/LibFFI/Dynamic/CIF.hsc" #-}

newtype SomeCIF = SomeCIF (Ptr SomeCIF)
    deriving (Eq, Ord, Show)

instance Interned SomeCIF where
    data Description SomeCIF = Sig ABI SomeType [SomeType]
        deriving (Eq, Show)
    type Uninterned SomeCIF = Description SomeCIF

    describe = id
    identify _ (Sig abi ret args) = unsafePerformIO $ do
        -- these should not be freed as long as the returned @a@ is reachable
        cif <- SomeCIF <$> mallocBytes ((32))
{-# LINE 63 "src/Foreign/LibFFI/Dynamic/CIF.hsc" #-}

        let nArgs = fromIntegral (length args)
        argTypes <- newArray args

        -- TODO: check return code
        ffi_prep_cif cif abi nArgs ret argTypes

        return cif

    cache = cifCache

{-# NOINLINE cifCache #-}
cifCache :: Cache SomeCIF
cifCache = mkCache

instance Hashable (Description SomeCIF) where
    hashWithSalt salt (Sig abi ret args) =
        foldl' hashWithSalt (hashWithSalt salt abi) (ret : args)

foreign import ccall ffi_prep_cif :: SomeCIF -> ABI -> CInt -> SomeType -> Ptr SomeType -> IO FFI_Status

getCIF :: ABI -> SomeType -> [SomeType] -> SomeCIF
getCIF abi retType argTypes = intern (Sig abi retType argTypes)

class SigType t where
    type SigReturn t

    retTypeOf'  :: p t ->  SomeType
    argTypesOf' :: p t -> [SomeType]

retTypeOf :: SigType t => p t -> SomeType
retTypeOf = retTypeOf'

argTypesOf :: SigType t => p t -> [SomeType]
argTypesOf = argTypesOf'

instance FFIType t => SigType (IO t) where
    type SigReturn (IO t) = t

    retTypeOf' = ffiTypeOf_ . (const Nothing :: p (IO b) -> Maybe b)
    argTypesOf' _ = []

instance (FFIType a, SigType b) => SigType (a -> b) where
    type SigReturn (a -> b) = SigReturn b

    retTypeOf' = retTypeOf . (const Nothing :: p (a -> b) -> Maybe b)
    argTypesOf' p
        = ffiTypeOf_ ((const Nothing :: p (a -> b) -> Maybe a) p)
        : argTypesOf ((const Nothing :: p (a -> b) -> Maybe b) p)

newtype CIF a = CIF SomeCIF
    deriving (Eq, Ord, Show)

toSomeCIF :: CIF a -> SomeCIF
toSomeCIF (CIF c) = c

cif :: SigType t => CIF t
cif = cifWithABI defaultABI

cifWithABI :: SigType t => ABI -> CIF t
cifWithABI abi = theCIF
    where
        theCIF = CIF (getCIF abi (retTypeOf theCIF) (argTypesOf theCIF))

call :: SigType t => FunPtr t -> Ptr (SigReturn t) -> Ptr (Ptr ()) -> IO ()
call = callWithCIF theCIF
    where
        {-# NOINLINE theCIF #-}
        theCIF = cif

callWithABI :: SigType t => ABI -> FunPtr t -> Ptr (SigReturn t) -> Ptr (Ptr ()) -> IO ()
callWithABI abi = callWithCIF theCIF
    where
        {-# NOINLINE theCIF #-}
        theCIF = cifWithABI abi

foreign import ccall "ffi_call"
    callWithCIF :: CIF a -> FunPtr a -> Ptr (SigReturn a) -> Ptr (Ptr ()) -> IO ()

abi :: SomeCIF -> ABI
abi (SomeCIF p) = unsafePerformIO $ do
    ((\hsc_ptr -> peekByteOff hsc_ptr 0)) p
{-# LINE 145 "src/Foreign/LibFFI/Dynamic/CIF.hsc" #-}

retType :: SomeCIF -> SomeType
retType (SomeCIF p) = unsafePerformIO $ do
    ((\hsc_ptr -> peekByteOff hsc_ptr 16)) p
{-# LINE 149 "src/Foreign/LibFFI/Dynamic/CIF.hsc" #-}

argTypes :: SomeCIF -> [SomeType]
argTypes cif@(SomeCIF p) = unsafePerformIO $ do
    ts <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p :: IO (Ptr SomeType)
{-# LINE 153 "src/Foreign/LibFFI/Dynamic/CIF.hsc" #-}
    peekArray (nArgs cif) ts

nArgs :: SomeCIF -> Int
nArgs (SomeCIF p) = unsafePerformIO $ do
    n  <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) p :: IO CUInt
{-# LINE 158 "src/Foreign/LibFFI/Dynamic/CIF.hsc" #-}
    return $! fromIntegral n

cifFlags :: SomeCIF -> CUInt
cifFlags (SomeCIF p) = unsafePerformIO $ do
    ((\hsc_ptr -> peekByteOff hsc_ptr 28)) p