FunPtr.hs

{-# 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 hsTy = do
  ffiImportName <- 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 = do
  i <- TH.reify name
  case i of
#if MIN_VERSION_template_haskell(2,11,0)
    TH.VarI _ ty _ -> [| $(mkFunPtr (return ty)) $(TH.varE name) |]
#else
    TH.VarI _ ty _ _ -> [| $(mkFunPtr (return ty)) $(TH.varE name) |]
#endif
    _ -> fail "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 hsTy = do
  ffiImportName <- 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 = TH.newName . show =<< TH.newName "inline_c_ffi"