{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

module Language.C.Inline.FunPtr
  ( mkFunPtr
  , mkFunPtrFromName
  , peekFunPtr
  , uniqueFfiImportName
  ) where

import           Foreign.Ptr (FunPtr)
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH

------------------------------------------------------------------------
-- FFI wrappers

-- | @$('mkFunPtr' [t| 'CDouble' -> 'IO' 'CDouble' |] @ generates a foreign import
-- wrapper of type
--
-- @
-- ('CDouble' -> 'IO' 'CDouble') -> 'IO' ('FunPtr' ('CDouble' -> 'IO' 'CDouble'))
-- @
--
-- And invokes it.
mkFunPtr :: TH.TypeQ -> TH.ExpQ
mkFunPtr :: TypeQ -> ExpQ
mkFunPtr TypeQ
hsTy = do
  Name
ffiImportName <- Q Name
uniqueFfiImportName
  Dec
dec <- forall (m :: * -> *).
Quote m =>
Callconv -> Safety -> String -> Name -> m Type -> m Dec
TH.forImpD Callconv
TH.CCall Safety
TH.Safe String
"wrapper" Name
ffiImportName [t| $(hsTy) -> IO (FunPtr $(hsTy)) |]
  [Dec] -> Q ()
TH.addTopDecls [Dec
dec]
  forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
ffiImportName

-- | @$('mkFunPtrFromName' 'foo)@, if @foo :: 'CDouble' -> 'IO'
-- 'CDouble'@, splices in an expression of type @'IO' ('FunPtr'
-- ('CDouble' -> 'IO' 'CDouble'))@.
mkFunPtrFromName :: TH.Name -> TH.ExpQ
mkFunPtrFromName :: Name -> ExpQ
mkFunPtrFromName Name
name = do
  Info
i <- Name -> Q Info
TH.reify Name
name
  case Info
i of
#if MIN_VERSION_template_haskell(2,11,0)
    TH.VarI Name
_ Type
ty Maybe Dec
_ -> [| $(mkFunPtr (return ty)) $(TH.varE name) |]
#else
    TH.VarI _ ty _ _ -> [| $(mkFunPtr (return ty)) $(TH.varE name) |]
#endif
    Info
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mkFunPtrFromName: expecting a variable as argument."

-- | @$('peekFunPtr' [t| 'CDouble' -> 'IO' 'CDouble' |])@ generates a foreign import
-- dynamic of type
--
-- @
-- 'FunPtr' ('CDouble' -> 'IO' 'CDouble') -> ('CDouble' -> 'IO' 'CDouble')
-- @
--
-- And invokes it.
peekFunPtr :: TH.TypeQ -> TH.ExpQ
peekFunPtr :: TypeQ -> ExpQ
peekFunPtr TypeQ
hsTy = do
  Name
ffiImportName <- Q Name
uniqueFfiImportName
  Dec
dec <- forall (m :: * -> *).
Quote m =>
Callconv -> Safety -> String -> Name -> m Type -> m Dec
TH.forImpD Callconv
TH.CCall Safety
TH.Safe String
"dynamic" Name
ffiImportName [t| FunPtr $(hsTy) -> $(hsTy) |]
  [Dec] -> Q ()
TH.addTopDecls [Dec
dec]
  forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
ffiImportName

-- TODO absurdly, I need to 'newName' twice for things to work.  I found
-- this hack in language-c-inline.  Why is this?
uniqueFfiImportName :: TH.Q TH.Name
uniqueFfiImportName :: Q Name
uniqueFfiImportName = forall (m :: * -> *). Quote m => String -> m Name
TH.newName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"inline_c_ffi"