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

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

import           Data.Maybe (isJust)
import           Foreign.Ptr (FunPtr)
import           System.Environment (lookupEnv)
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
  ffiImportName <- Q Name
uniqueFfiImportName
  -- See note [ghcide-support]
  usingGhcide <- TH.runIO $ isJust <$> lookupEnv "__GHCIDE__"
  if usingGhcide
    then do
      [e|error "inline-c: A 'usingGhcide' mkFunPtr stub was evaluated -- this should not happen" :: $(hsTy) -> IO (FunPtr $(hsTy)) |]
    else do -- Actual foreign function call generation.
      dec <- TH.forImpD TH.CCall TH.Safe "wrapper" ffiImportName [t| $(hsTy) -> IO (FunPtr $(hsTy)) |]
      TH.addTopDecls [dec]
      TH.varE 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
  i <- Name -> Q Info
TH.reify Name
name
  case i of
#if MIN_VERSION_template_haskell(2,11,0)
    TH.VarI Name
_ Type
ty Maybe Dec
_ -> [| $(TypeQ -> ExpQ
mkFunPtr (Type -> TypeQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)) $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
name) |]
#else
    TH.VarI _ ty _ _ -> [| $(mkFunPtr (return ty)) $(TH.varE name) |]
#endif
    Info
_ -> String -> ExpQ
forall a. String -> Q a
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
  ffiImportName <- Q Name
uniqueFfiImportName
  usingGhcide <- TH.runIO $ isJust <$> lookupEnv "__GHCIDE__"
  -- See note [ghcide-support]
  if usingGhcide
    then do
      [e|error "inline-c: A 'usingGhcide' peekFunPtr stub was evaluated -- this should not happen" :: FunPtr $(hsTy) -> $(hsTy) |]
    else do -- Actual foreign function call generation.
      dec <- TH.forImpD TH.CCall TH.Safe "dynamic" ffiImportName [t| FunPtr $(hsTy) -> $(hsTy) |]
      TH.addTopDecls [dec]
      TH.varE 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 = String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName (String -> Q Name) -> (Name -> String) -> Name -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. Show a => a -> String
show (Name -> Q Name) -> Q Name -> Q Name
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"inline_c_ffi"