{-# LANGUAGE Rank2Types, DeriveDataTypeable, ScopedTypeVariables #-}
{- | This module defines the basic CInvoke machinery.
    You will need this to create support for new FFI types, or when the
    standard garbage collection behaviour doesn't suffice. -}
module Foreign.CInvoke.Base (
    FFIException(..),

    -- * High level interface
    -- | In the high level interface, everything is under control of the garbage collector.

    -- ** Contexts
    Context,
    newContext,

    -- ** Libraries
    Library,
    loadLibrary,

    -- ** Symbols
    Symbol,
    loadSymbol,
    cinvoke,
    withSymbol,

    -- ** Function arguments
    Arg(..),
    mkStorableArg,
    mkPointerArg,

    -- ** Function return types
    RetType(..),
    mkStorableRetType,
    withRetType,

    -- * Low level interface
    -- | In the low level interface, memory has to be managed manually.

    -- ** Contexts
    CContext,
    newContextPtr,
    freeContextPtr,

    -- ** Libraries
    CLibrary,
    loadLibraryPtr,
    freeLibraryPtr,

    -- ** Symbols
    CSymbol,
    loadSymbolPtr,
    cinvokePtr,

) where

import Control.Monad
import Control.Exception
import Data.Typeable
import Data.IORef
import Foreign.C.String
import Foreign.C.Types
import Foreign.Ptr
import Foreign.ForeignPtr hiding (newForeignPtr)
import Foreign.Concurrent
import Foreign.Storable
import Foreign.Marshal

import Foreign.CInvoke.Internal
import Foreign.TreePtr

import System.Mem

-- | Things you can pass as arguments to foreign functions called with 'cinvoke'.
newtype Arg
    {- | The higher order function inside an 'Arg' must call its argument function with two parameters:
        A 'CChar' representing the type of the argument in C (see the cinvoke docs) and a pointer to the C value.
        This function will then take the marshalled argument and pass it to the C function.
        -}
    = Arg { unArg :: forall a. (CChar -> Ptr CValue -> IO a) -> IO a }

storableToCChar     :: Storable a => a -> Char
storableToCChar a   = case sizeOf a of
                        1   -> '1'
                        2   -> '2'
                        4   -> '4'
                        8   -> '8'
                        i   -> error $ "cinvoke: storableToCChar: unsupported size: " ++ show i

{- | @mkStorableArg@ can be used to automatically define 'Arg' constructor functions for 'Storable' types.
    For example,

    >   import System.Posix
    >
    >   argCOff = mkStorableArg :: COff -> Arg

    N.B. This only works for types @a@ where @sizeOf (undefined :: a) \`elem\` [1, 2, 4, 8]@, and yields a run-time error otherwise.
-}
mkStorableArg       :: forall a. Storable a => a -> Arg
mkStorableArg       = mkStorableArg' (storableToCChar (undefined :: a))
    where
        mkStorableArg' cType a = Arg $ \withArg ->
            with a $ \p ->
                withArg (castCharToCChar cType) (castPtr p)

{- | @mkPointerArg@ can be used to build 'Arg' constructor functions types that are represented by pointers in C.
    For example, 'argString' has been defined as follows:

    >   import Foreign.C.String
    >   import Foreign.Marshal.Alloc
    >
    >   argString   :: String -> Arg
    >   argString   = mkPointerArg newCString free
-}
mkPointerArg :: (a -> IO (Ptr b)) -> (Ptr b -> IO ()) -> a -> Arg
mkPointerArg newA freeA a = Arg $ \withArg ->
    bracket (newA a) freeA $ \p ->
        with p $ \pp ->
            withArg (castCharToCChar 'p') (castPtr pp)

-- | Types you can return from 'cinvoke'.
newtype RetType a
    {- | The higher order function inside an 'RetType' must call its argument function with two parameters:
        A 'CChar' representing the return type in C (see the cinvoke docs) and a pointer where the C result may be stored.
        The argument function will then perform the actual FFI call, after which the higher order function is expected to take the
        stored value back into Haskell country.
        -}
    = RetType { unRetType :: (CChar -> Ptr CValue -> IO ()) -> IO a }

instance Functor RetType where
    fmap f  = withRetType (return . f)

{- | Apply an IO performing function to a 'RetType'.
    For example, 'retString' has been defined as follows:

    > import Foreign.C.String
    >
    > retString :: RetType String
    > retString = withRetType peekCString (retPtr retCChar)
-}
withRetType :: (a -> IO b) -> RetType a -> RetType b
withRetType f (RetType withPoke) = RetType $ withPoke >=> f

{- | @mkStorableRetType@ can be used to automatically define 'RetType' values for 'Storable' types.
    For example,

    >   import System.Posix
    >
    >   retCOff = mkStorableRetType :: RetType COff

    N.B. This only works for types @a@ where @sizeOf (undefined :: a) \`elem\` [1, 2, 4, 8]@, and yields a run-time error otherwise.
-}
mkStorableRetType   :: forall a. Storable a => RetType a
mkStorableRetType   = mkStorableRetType' (storableToCChar (undefined :: a))
    where
        mkStorableRetType' cType
            = RetType $ \write -> alloca $ \cValue -> write (castCharToCChar cType) (castPtr cValue) >> peek cValue

-- | The type used for CInvoke errors.
data FFIException
    = FFIException String
    deriving (Show, Typeable)

instance Exception FFIException

ffiError cContext
    = cinv_context_geterrormsg cContext >>= peekCString
        >>= throwIO . FFIException

{- | 'cinvokePtr' is passed a cinvoke context, a pointer to a dynamically loaded function,
    a 'RetType' representing the return type of the function, and a list of 'Arg' values
    representing the values to pass to the foreign function.
    In case of error, an 'FFIException' will be thrown.
    Consider using 'cinvoke' instead. -}
cinvokePtr :: Ptr CContext -> Ptr () -> RetType b -> [Arg] -> IO b
cinvokePtr cContext ptr (RetType actRet) args
    = allocaArray0 1 $ \cRetTypePtr ->
      allocaArray0 n $ \cTypesPtr ->
      allocaArray n $ \cValuesPtr ->
            let
                createFunction
                    = onNull (ffiError cContext)
                        $ cinv_function_create cContext default_callconv cRetTypePtr cTypesPtr

                deleteFunction cFunction = do
                    status <- cinv_function_delete cContext cFunction
                    when (status /= success_status) $ ffiError cContext

                doCall  = actRet $ \cType cValue -> do
                                pokeElemOff cRetTypePtr 0 cType
                                pokeElemOff cRetTypePtr 1 0
                                pokeElemOff cTypesPtr n 0
                                bracket createFunction deleteFunction $ \cFunction -> do
                                    status <- cinv_function_invoke cContext cFunction (castPtrToFunPtr ptr) cValue cValuesPtr
                                    when (status /= success_status) $ ffiError cContext

                addArg (i, Arg actArg) goArgs
                        = actArg $ \cType cValue -> do
                            pokeElemOff cTypesPtr i cType
                            pokeElemOff cValuesPtr i cValue
                            goArgs
            in
                foldr addArg doCall (zip [0..] args)
    where
        n = length args

{- | 'cinvoke' is passed a 'Symbol' pointing to a dynamically loaded function,
    a 'RetType' representing the return type of the function, and a list of 'Arg' values
    representing the values to pass to the foreign function.
    In case of error, an 'FFIException' will be thrown.
    'cinvokePtr' can be used instead by people who like mucking around with pointers. -}
cinvoke :: Symbol -> RetType b -> [Arg] -> IO b
cinvoke (Symbol ctp fp) retType args
    = withTreePtr ctp $ \cContext ->
        withForeignPtr fp $ \ptr ->
            cinvokePtr cContext ptr retType args

onNull e a = do
    ptr <- a
    when (ptr == nullPtr) e
    return ptr

-- | Most CInvoke calls take a 'Context' as a parameter. In multi-threaded programs, it is safe to use one 'Context' per thread.
newtype Context = Context (TreePtr CContext)
    deriving Show

{- | Returns a pointer to a newly created CInvoke context. This context can be freed again with 'freeContextPtr'.
    Consider using 'newContext' instead. -}
newContextPtr :: IO (Ptr CContext)
newContextPtr = onNull (throwIO $ FFIException "newContextPtr failed")
                    cinv_context_create

-- | Free a CInvoke context that has been created with 'newContextPtr'.
freeContextPtr :: Ptr CContext -> IO ()
freeContextPtr cContext = cinv_context_delete cContext >> return ()

{- | Create a new 'Context', that will be garbage collected when necessary.

    'newContextPtr' and 'freeContextPtr' can be used in cases where manual memory management is preferred. -}
newContext :: IO Context
newContext = do
    cContext <- newContextPtr
    Context `liftM` newTreePtr cContext (freeContextPtr cContext)

-- | Represents a loaded shared object (DLL).
data Library = Library (TreePtr CContext) (TreePtr CLibrary)
    deriving Show

{- | @loadLibraryPtr cxt lib@ uses the context pointer @cxt@ to load the library named @lib@.
    If @lib@ is not a full path, the library-path will be used to try to locate the named shared library.
    When the library cannot be loaded, an 'FFIException' will be thrown.
    The resulting library must be closed again with 'freeLibraryPtr'.
    
    'loadLibraryPtr' is primarily useful when 'loadLibrary' does not provide enough control about when the loaded
    library is freed again. As each opened library usually implies an open
    file, one might worry about limits on the maximum number of simultaneously open files. -}
loadLibraryPtr :: Ptr CContext -> String -> IO (Ptr CLibrary)
loadLibraryPtr cContext path
    = withCString path $ \cPath -> do
        onNull (ffiError cContext)
                        $ cinv_library_create cContext cPath

-- | Free a library opened by 'loadLibraryPtr'.
freeLibraryPtr :: Ptr CContext -> Ptr CLibrary -> IO ()
freeLibraryPtr cContext cLibrary = cinv_library_delete cContext cLibrary >> return ()

{- | @loadLibrary cxt lib@ uses the 'Context' @cxt@ to load the library named @lib@.
    If @lib@ is not a full path, the library-path will be used to try to locate the named shared library.
    When the library cannot be loaded, an 'FFIException' will be thrown.
    The resulting library will be closed by the garbage collector.
    
    'loadLibraryPtr' and 'freeLibraryPtr' can be used in cases where manual memory management is preferred.
    -}
loadLibrary :: Context -> String -> IO Library
loadLibrary (Context tp) path
    = withTreePtr tp $ \cContext -> do
        cLibrary <- loadLibraryPtr cContext path
        Library tp `liftM` addNode cLibrary (freeLibraryPtr cContext cLibrary) tp

{- | A 'Symbol' represents a symbol in a shared library.
    It can be used either by passing it to 'cinvoke' or 'cinvokePtr',
    or by calling 'withSymbol' on it. -}
data Symbol = Symbol (TreePtr CContext) (ForeignPtr ())
    deriving Show

{- | Internally, a 'Symbol' is just a pointer into a loaded shared library.
    'withSymbol' allows for direct access to this pointer.
    This pointer must not be used after 'withSymbol' has returned. -}
withSymbol :: Symbol -> (Ptr a -> IO b) -> IO b
withSymbol (Symbol _ fp) f = withForeignPtr fp $ f . castPtr

{- | @loadSymbolPtr cxt lib name@ tries to lookup the symbol @name@ from the opened library @lib@,
    using the cinvoke context @cxt@.
    An 'FFIException' is thrown on failure. Care must be taken not to free either the context or the library
    as long as the returned symbol may still be used.

    Consider using 'loadSymbol' instead. -}
loadSymbolPtr :: Ptr CContext -> Ptr CLibrary -> String -> IO (Ptr ())
loadSymbolPtr cContext cLibrary sym
    = withCString sym $ \cSym -> do
        onNull (ffiError cContext)
                $ cinv_library_load_entrypoint cContext cLibrary cSym

{- | @loadSymbol lib name@ tries to lookup the symbol @name@ from the opened library @lib@.
    An 'FFIException' is thrown on failure. The loaded symbol will keep its library alive for the garbage collector.
    When manual memory management is preferred, one may choose to use 'loadSymbolPtr' instead. -}
loadSymbol :: Library -> String -> IO Symbol
loadSymbol (Library ctp ltp) sym
    = withTreePtr ctp $ \cContext ->
        withTreePtr ltp $ \cLibrary -> do
            ptr <- loadSymbolPtr cContext cLibrary sym
            let final = return ()
            Symbol ctp `liftM` addLeaf ptr final ltp