{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | A 'Context' is used to define the capabilities of the Template Haskell code
-- that handles the inline C code. See the documentation of the data type for
-- more details.
--
-- In practice, a 'Context' will have to be defined for each library that
-- defines new C types, to allow the TemplateHaskell code to interpret said
-- types correctly.

module Language.C.Inline.Context
  ( -- * 'TypesTable'
    TypesTable
  , Purity(..)
  , convertType
  , CArray
  , typeNamesFromTypesTable

    -- * 'AntiQuoter'
  , AntiQuoter(..)
  , AntiQuoterId
  , SomeAntiQuoter(..)
  , AntiQuoters

    -- * 'Context'
  , Context(..)
  , baseCtx
  , fptrCtx
  , funCtx
  , vecCtx
  , VecCtx(..)
  , bsCtx
  ) where

import           Control.Applicative ((<|>))
import           Control.Monad (mzero, forM)
import           Control.Monad.Trans.Class (lift)
import           Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BS
import           Data.Coerce
import           Data.Int (Int8, Int16, Int32, Int64)
import qualified Data.Map as Map
import           Data.Typeable (Typeable)
import qualified Data.Vector.Storable as V
import qualified Data.Vector.Storable.Mutable as VM
import           Data.Word (Word8, Word16, Word32, Word64)
import           Foreign.C.Types
import           Foreign.ForeignPtr (withForeignPtr)
import           Foreign.Ptr (Ptr, FunPtr, freeHaskellFunPtr)
import           Foreign.Storable (Storable)
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
import qualified Text.Parser.Token as Parser
import qualified Data.HashSet as HashSet


#if MIN_VERSION_base(4,9,0)
import           Data.Semigroup (Semigroup, (<>))
#else
import           Data.Monoid ((<>))
#endif

#if __GLASGOW_HASKELL__ < 710
import           Data.Monoid (Monoid(..))
import           Data.Traversable (traverse)
#endif

import           Language.C.Inline.FunPtr
import qualified Language.C.Types as C
import           Language.C.Inline.HaskellIdentifier

-- | A mapping from 'C.TypeSpecifier's to Haskell types.  Needed both to
-- parse C types, and to convert them to Haskell types.
type TypesTable = Map.Map C.TypeSpecifier TH.TypeQ

-- | A data type to indicate whether the user requested pure or IO
-- function from Haskell
data Purity
  = Pure
  | IO
  deriving (Purity -> Purity -> Bool
(Purity -> Purity -> Bool)
-> (Purity -> Purity -> Bool) -> Eq Purity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Purity -> Purity -> Bool
$c/= :: Purity -> Purity -> Bool
== :: Purity -> Purity -> Bool
$c== :: Purity -> Purity -> Bool
Eq, Int -> Purity -> ShowS
[Purity] -> ShowS
Purity -> String
(Int -> Purity -> ShowS)
-> (Purity -> String) -> ([Purity] -> ShowS) -> Show Purity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Purity] -> ShowS
$cshowList :: [Purity] -> ShowS
show :: Purity -> String
$cshow :: Purity -> String
showsPrec :: Int -> Purity -> ShowS
$cshowsPrec :: Int -> Purity -> ShowS
Show)

-- | Specifies how to parse and process an antiquotation in the C code.
--
-- All antiquotations (apart from plain variable capture) have syntax
--
-- @
-- $XXX:YYY
-- @
--
-- Where @XXX@ is the name of the antiquoter and @YYY@ is something
-- parseable by the respective 'aqParser'.
data AntiQuoter a = AntiQuoter
  { AntiQuoter a
-> forall (m :: * -> *).
   CParser HaskellIdentifier m =>
   m (CIdentifier, Type CIdentifier, a)
aqParser :: forall m. C.CParser HaskellIdentifier m => m (C.CIdentifier, C.Type C.CIdentifier, a)
    -- ^ Parses the body of the antiquotation, returning a hint for the name to
    -- assign to the variable that will replace the anti-quotation, the type of
    -- said variable, and some arbitrary data which will then be fed to
    -- 'aqMarshaller'.
    --
    -- The 'C.Type' has 'Void' as an identifier type to make sure that
    -- no names appear in it.
  , AntiQuoter a
-> Purity -> TypesTable -> Type CIdentifier -> a -> Q (Type, Exp)
aqMarshaller :: Purity -> TypesTable -> C.Type C.CIdentifier -> a -> TH.Q (TH.Type, TH.Exp)
    -- ^ Takes the requested purity, the current 'TypesTable', and the
    -- type and the body returned by 'aqParser'.
    --
    -- Returns the Haskell type for the parameter, and the Haskell expression
    -- that will be passed in as the parameter.
    --
    -- If the the type returned is @ty@, the 'TH.Exp' __must__ have type @forall
    -- a. (ty -> IO a) -> IO a@. This allows to do resource handling when
    -- preparing C values.
    --
    -- Care must be taken regarding 'Purity'. Specifically, the generated IO
    -- computation must be idempotent to guarantee its safety when used in pure
    -- code. We cannot prevent the IO computation from being inlined, hence
    -- potentially duplicated. If non-idempotent marshallers are required (e.g.
    -- if an update to some global state is needed), it is best to throw an
    -- error when 'Purity' is 'Pure' (for example "you cannot use context X with
    -- @pure@"), which will show up at compile time.
  }

-- | An identifier for a 'AntiQuoter'.
type AntiQuoterId = String

-- | Existential wrapper around 'AntiQuoter'.
data SomeAntiQuoter = forall a. (Eq a, Typeable a) => SomeAntiQuoter (AntiQuoter a)

type AntiQuoters = Map.Map AntiQuoterId SomeAntiQuoter

-- | A 'Context' stores various information needed to produce the files with
-- the C code derived from the inline C snippets.
--
-- 'Context's can be composed with their 'Monoid' instance, where 'mappend' is
-- right-biased -- in @'mappend' x y@ @y@ will take precedence over @x@.
data Context = Context
  { Context -> TypesTable
ctxTypesTable :: TypesTable
    -- ^ Needed to convert C types to Haskell types.
  , Context -> AntiQuoters
ctxAntiQuoters :: AntiQuoters
    -- ^ Needed to parse and process antiquotations.
  , Context -> Maybe ShowS
ctxOutput :: Maybe (String -> String)
    -- ^ This function is used to post-process the functions generated
    -- from the C snippets.  Currently just used to specify C linkage
    -- when generating C++ code.
  , Context -> Maybe ForeignSrcLang
ctxForeignSrcLang :: Maybe TH.ForeignSrcLang
    -- ^ TH.LangC by default
  , Context -> Bool
ctxEnableCpp :: Bool
  }


#if MIN_VERSION_base(4,9,0)
instance Semigroup Context where
  Context
ctx2 <> :: Context -> Context -> Context
<> Context
ctx1 = Context :: TypesTable
-> AntiQuoters
-> Maybe ShowS
-> Maybe ForeignSrcLang
-> Bool
-> Context
Context
    { ctxTypesTable :: TypesTable
ctxTypesTable = Context -> TypesTable
ctxTypesTable Context
ctx1 TypesTable -> TypesTable -> TypesTable
forall a. Semigroup a => a -> a -> a
<> Context -> TypesTable
ctxTypesTable Context
ctx2
    , ctxAntiQuoters :: AntiQuoters
ctxAntiQuoters = Context -> AntiQuoters
ctxAntiQuoters Context
ctx1 AntiQuoters -> AntiQuoters -> AntiQuoters
forall a. Semigroup a => a -> a -> a
<> Context -> AntiQuoters
ctxAntiQuoters Context
ctx2
    , ctxOutput :: Maybe ShowS
ctxOutput = Context -> Maybe ShowS
ctxOutput Context
ctx1 Maybe ShowS -> Maybe ShowS -> Maybe ShowS
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Context -> Maybe ShowS
ctxOutput Context
ctx2
    , ctxForeignSrcLang :: Maybe ForeignSrcLang
ctxForeignSrcLang = Context -> Maybe ForeignSrcLang
ctxForeignSrcLang Context
ctx1 Maybe ForeignSrcLang
-> Maybe ForeignSrcLang -> Maybe ForeignSrcLang
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Context -> Maybe ForeignSrcLang
ctxForeignSrcLang Context
ctx2
    , ctxEnableCpp :: Bool
ctxEnableCpp = Context -> Bool
ctxEnableCpp Context
ctx1 Bool -> Bool -> Bool
|| Context -> Bool
ctxEnableCpp Context
ctx2
    }
#endif

instance Monoid Context where
  mempty :: Context
mempty = Context :: TypesTable
-> AntiQuoters
-> Maybe ShowS
-> Maybe ForeignSrcLang
-> Bool
-> Context
Context
    { ctxTypesTable :: TypesTable
ctxTypesTable = TypesTable
forall a. Monoid a => a
mempty
    , ctxAntiQuoters :: AntiQuoters
ctxAntiQuoters = AntiQuoters
forall a. Monoid a => a
mempty
    , ctxOutput :: Maybe ShowS
ctxOutput = Maybe ShowS
forall a. Maybe a
Nothing
    , ctxForeignSrcLang :: Maybe ForeignSrcLang
ctxForeignSrcLang = Maybe ForeignSrcLang
forall a. Maybe a
Nothing
    , ctxEnableCpp :: Bool
ctxEnableCpp = Bool
False
    }

#if !MIN_VERSION_base(4,11,0)
  mappend ctx2 ctx1 = Context
    { ctxTypesTable = ctxTypesTable ctx1 <> ctxTypesTable ctx2
    , ctxAntiQuoters = ctxAntiQuoters ctx1 <> ctxAntiQuoters ctx2
    , ctxOutput = ctxOutput ctx1 <|> ctxOutput ctx2
    , ctxForeignSrcLang = ctxForeignSrcLang ctx1 <|> ctxForeignSrcLang ctx2
    , ctxEnableCpp = ctxEnableCpp ctx1 || ctxEnableCpp ctx2
    }
#endif

-- | Context useful to work with vanilla C. Used by default.
--
-- 'ctxTypesTable': converts C basic types to their counterparts in
-- "Foreign.C.Types".
--
-- No 'ctxAntiQuoters'.
baseCtx :: Context
baseCtx :: Context
baseCtx = Context
forall a. Monoid a => a
mempty
  { ctxTypesTable :: TypesTable
ctxTypesTable = TypesTable
baseTypesTable
  }

baseTypesTable :: Map.Map C.TypeSpecifier TH.TypeQ
baseTypesTable :: TypesTable
baseTypesTable = [(TypeSpecifier, TypeQ)] -> TypesTable
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  [ (TypeSpecifier
C.Void, [t| () |])
  -- Types from Foreign.C.Types in the order in which they are presented there,
  -- along with its documentation's section headers.
  --
  -- Integral types
  , (TypeSpecifier
C.Bool, [t| CBool |])
  , (Maybe Sign -> TypeSpecifier
C.Char Maybe Sign
forall a. Maybe a
Nothing, [t| CChar |])
  , (Maybe Sign -> TypeSpecifier
C.Char (Sign -> Maybe Sign
forall a. a -> Maybe a
Just Sign
C.Signed), [t| CSChar |])
  , (Maybe Sign -> TypeSpecifier
C.Char (Sign -> Maybe Sign
forall a. a -> Maybe a
Just Sign
C.Unsigned), [t| CUChar |])
  , (Sign -> TypeSpecifier
C.Short Sign
C.Signed, [t| CShort |])
  , (Sign -> TypeSpecifier
C.Short Sign
C.Unsigned, [t| CUShort |])
  , (Sign -> TypeSpecifier
C.Int Sign
C.Signed, [t| CInt |])
  , (Sign -> TypeSpecifier
C.Int Sign
C.Unsigned, [t| CUInt |])
  , (Sign -> TypeSpecifier
C.Long Sign
C.Signed, [t| CLong |])
  , (Sign -> TypeSpecifier
C.Long Sign
C.Unsigned, [t| CULong |])
  , (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
"ptrdiff_t", [t| CPtrdiff |])
  , (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
"size_t", [t| CSize |])
  , (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
"wchar_t", [t| CWchar |])
  , (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
"sig_atomic_t", [t| CSigAtomic |])
  , (Sign -> TypeSpecifier
C.LLong Sign
C.Signed, [t| CLLong |])
  , (Sign -> TypeSpecifier
C.LLong Sign
C.Unsigned, [t| CULLong |])
  , (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
"intptr_t", [t| CIntPtr |])
  , (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
"uintptr_t", [t| CUIntPtr |])
  , (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
"intmax_t", [t| CIntMax |])
  , (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
"uintmax_t", [t| CUIntMax |])
  -- Numeric types
  , (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
"clock_t", [t| CClock |])
  , (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
"time_t", [t| CTime |])
  , (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
"useconds_t", [t| CUSeconds |])
  , (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
"suseconds_t", [t| CSUSeconds |])
  -- Floating types
  , (TypeSpecifier
C.Float, [t| CFloat |])
  , (TypeSpecifier
C.Double, [t| CDouble |])
  -- Other types
  , (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
"FILE", [t| CFile |])
  , (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
"fpos_t", [t| CFpos |])
  , (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
"jmp_buf", [t| CJmpBuf |])
  -- Types from stdint.h that can be statically mapped to their Haskell
  -- equivalents. Excludes int_fast*_t and int_least*_t and the corresponding
  -- unsigned types, since their sizes are platform-specific.
  , (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
"int8_t", [t| Int8 |])
  , (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
"int16_t", [t| Int16 |])
  , (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
"int32_t", [t| Int32 |])
  , (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
"int64_t", [t| Int64 |])
  , (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
"uint8_t", [t| Word8 |])
  , (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
"uint16_t", [t| Word16 |])
  , (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
"uint32_t", [t| Word32 |])
  , (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
"uint64_t", [t| Word64 |])
  ]

-- | An alias for 'Ptr'.
type CArray = Ptr

------------------------------------------------------------------------
-- Type conversion

-- | Given a 'Context', it uses its 'ctxTypesTable' to convert
-- arbitrary C types.
convertType
  :: Purity
  -> TypesTable
  -> C.Type C.CIdentifier
  -> TH.Q (Maybe TH.Type)
convertType :: Purity -> TypesTable -> Type CIdentifier -> Q (Maybe Type)
convertType Purity
purity TypesTable
cTypes = MaybeT Q Type -> Q (Maybe Type)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT Q Type -> Q (Maybe Type))
-> (Type CIdentifier -> MaybeT Q Type)
-> Type CIdentifier
-> Q (Maybe Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type CIdentifier -> MaybeT Q Type
go
  where
    goDecl :: ParameterDeclaration CIdentifier -> MaybeT Q Type
goDecl = Type CIdentifier -> MaybeT Q Type
go (Type CIdentifier -> MaybeT Q Type)
-> (ParameterDeclaration CIdentifier -> Type CIdentifier)
-> ParameterDeclaration CIdentifier
-> MaybeT Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParameterDeclaration CIdentifier -> Type CIdentifier
forall i. ParameterDeclaration i -> Type i
C.parameterDeclarationType

    go :: C.Type C.CIdentifier -> MaybeT TH.Q TH.Type
    go :: Type CIdentifier -> MaybeT Q Type
go Type CIdentifier
cTy = do
     case Type CIdentifier
cTy of
      C.TypeSpecifier Specifiers
_specs (C.Template CIdentifier
ident' [TypeSpecifier]
cTys) -> do
--        let symbol = TH.LitT (TH.StrTyLit (C.unCIdentifier ident'))
        TypeQ
symbol <- case TypeSpecifier -> TypesTable -> Maybe TypeQ
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (CIdentifier -> TypeSpecifier
C.TypeName CIdentifier
ident') TypesTable
cTypes of
          Maybe TypeQ
Nothing -> MaybeT Q TypeQ
forall (m :: * -> *) a. MonadPlus m => m a
mzero
          Just TypeQ
ty -> TypeQ -> MaybeT Q TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return TypeQ
ty
        [Type]
hsTy <- [TypeSpecifier]
-> (TypeSpecifier -> MaybeT Q Type) -> MaybeT Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TypeSpecifier]
cTys ((TypeSpecifier -> MaybeT Q Type) -> MaybeT Q [Type])
-> (TypeSpecifier -> MaybeT Q Type) -> MaybeT Q [Type]
forall a b. (a -> b) -> a -> b
$ \TypeSpecifier
cTys'  -> Type CIdentifier -> MaybeT Q Type
go (Specifiers -> TypeSpecifier -> Type CIdentifier
forall i. Specifiers -> TypeSpecifier -> Type i
C.TypeSpecifier Specifiers
forall a. HasCallStack => a
undefined TypeSpecifier
cTys')
        case [Type]
hsTy of
          (Type
a:[]) ->
            TypeQ -> MaybeT Q Type
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [t| $(symbol) $(return a) |]
          (Type
a:Type
b:[]) ->
            TypeQ -> MaybeT Q Type
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [t| $(symbol) '($(return a),$(return b))|]
          (Type
a:Type
b:Type
c:[]) ->
            TypeQ -> MaybeT Q Type
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [t| $(symbol) '($(return a),$(return b),$(return c))|]
          (Type
a:Type
b:Type
c:Type
d:[]) ->
            TypeQ -> MaybeT Q Type
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [t| $(symbol) '($(return a),$(return b),$(return c),$(return d))|]
          (Type
a:Type
b:Type
c:Type
d:Type
e:[]) ->
            TypeQ -> MaybeT Q Type
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [t| $(symbol) '($(return a),$(return b),$(return c),$(return d),$(return e))|]
          [] -> String -> MaybeT Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> MaybeT Q Type) -> String -> MaybeT Q Type
forall a b. (a -> b) -> a -> b
$ String
"Can not find template parameters."
          [Type]
_ -> String -> MaybeT Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> MaybeT Q Type) -> String -> MaybeT Q Type
forall a b. (a -> b) -> a -> b
$ String
"Find too many template parameters. num = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
hsTy)
      C.TypeSpecifier Specifiers
_specs (C.TemplateConst String
num) -> do
        let n :: Type
n = (TyLit -> Type
TH.LitT (Integer -> TyLit
TH.NumTyLit (String -> Integer
forall a. Read a => String -> a
read String
num)))
        TypeQ -> MaybeT Q Type
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [t| $(return n) |]
      C.TypeSpecifier Specifiers
_specs (C.TemplatePointer TypeSpecifier
cSpec) -> do
        case TypeSpecifier -> TypesTable -> Maybe TypeQ
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeSpecifier
cSpec TypesTable
cTypes of
          Maybe TypeQ
Nothing -> MaybeT Q Type
forall (m :: * -> *) a. MonadPlus m => m a
mzero
          Just TypeQ
ty -> TypeQ -> MaybeT Q Type
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [t| Ptr $(ty) |]
      C.TypeSpecifier Specifiers
_specs TypeSpecifier
cSpec ->
        case TypeSpecifier -> TypesTable -> Maybe TypeQ
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeSpecifier
cSpec TypesTable
cTypes of
          Maybe TypeQ
Nothing -> MaybeT Q Type
forall (m :: * -> *) a. MonadPlus m => m a
mzero
          Just TypeQ
ty -> TypeQ -> MaybeT Q Type
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TypeQ
ty
      C.Ptr [TypeQualifier]
_quals (C.Proto Type CIdentifier
retType [ParameterDeclaration CIdentifier]
pars) -> do
        Type
hsRetType <- Type CIdentifier -> MaybeT Q Type
go Type CIdentifier
retType
        [Type]
hsPars <- (ParameterDeclaration CIdentifier -> MaybeT Q Type)
-> [ParameterDeclaration CIdentifier] -> MaybeT Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ParameterDeclaration CIdentifier -> MaybeT Q Type
goDecl [ParameterDeclaration CIdentifier]
pars
        TypeQ -> MaybeT Q Type
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [t| FunPtr $(buildArr hsPars hsRetType) |]
      C.Ptr [TypeQualifier]
_quals Type CIdentifier
cTy' -> do
        Type
hsTy <- Type CIdentifier -> MaybeT Q Type
go Type CIdentifier
cTy'
        TypeQ -> MaybeT Q Type
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [t| Ptr $(return hsTy) |]
      C.Array ArrayType CIdentifier
_mbSize Type CIdentifier
cTy' -> do
        Type
hsTy <- Type CIdentifier -> MaybeT Q Type
go Type CIdentifier
cTy'
        TypeQ -> MaybeT Q Type
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [t| CArray $(return hsTy) |]
      C.Proto Type CIdentifier
_retType [ParameterDeclaration CIdentifier]
_pars -> do
        -- We cannot convert standalone prototypes
        MaybeT Q Type
forall (m :: * -> *) a. MonadPlus m => m a
mzero

    buildArr :: [Type] -> Type -> TypeQ
buildArr [] Type
hsRetType =
      case Purity
purity of
        Purity
Pure -> [t| $(return hsRetType) |]
        Purity
IO -> [t| IO $(return hsRetType) |]
    buildArr (Type
hsPar : [Type]
hsPars) Type
hsRetType =
      [t| $(return hsPar) -> $(buildArr hsPars hsRetType) |]

typeNamesFromTypesTable :: TypesTable -> C.TypeNames
typeNamesFromTypesTable :: TypesTable -> TypeNames
typeNamesFromTypesTable TypesTable
cTypes = [CIdentifier] -> TypeNames
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList
  [ CIdentifier
id' | C.TypeName CIdentifier
id' <- TypesTable -> [TypeSpecifier]
forall k a. Map k a -> [k]
Map.keys TypesTable
cTypes ]

------------------------------------------------------------------------
-- Useful contexts

getHsVariable :: String -> HaskellIdentifier -> TH.ExpQ
getHsVariable :: String -> HaskellIdentifier -> ExpQ
getHsVariable String
err HaskellIdentifier
s = do
  Maybe Name
mbHsName <- String -> Q (Maybe Name)
TH.lookupValueName (String -> Q (Maybe Name)) -> String -> Q (Maybe Name)
forall a b. (a -> b) -> a -> b
$ HaskellIdentifier -> String
unHaskellIdentifier HaskellIdentifier
s
  case Maybe Name
mbHsName of
    Maybe Name
Nothing -> String -> ExpQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ String
"Cannot capture Haskell variable " String -> ShowS
forall a. [a] -> [a] -> [a]
++ HaskellIdentifier -> String
unHaskellIdentifier HaskellIdentifier
s String -> ShowS
forall a. [a] -> [a] -> [a]
++
                      String
", because it's not in scope. (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
    Just Name
hsName -> Name -> ExpQ
TH.varE Name
hsName

convertType_ :: String -> Purity -> TypesTable -> C.Type C.CIdentifier -> TH.Q TH.Type
convertType_ :: String -> Purity -> TypesTable -> Type CIdentifier -> TypeQ
convertType_ String
err Purity
purity TypesTable
cTypes Type CIdentifier
cTy = do
  Maybe Type
mbHsType <- Purity -> TypesTable -> Type CIdentifier -> Q (Maybe Type)
convertType Purity
purity TypesTable
cTypes Type CIdentifier
cTy
  case Maybe Type
mbHsType of
    Maybe Type
Nothing -> String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> TypeQ) -> String -> TypeQ
forall a b. (a -> b) -> a -> b
$ String
"Cannot convert C type (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
    Just Type
hsType -> Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
hsType

-- | This 'Context' adds support for 'ForeignPtr' arguments. It adds a unique
-- marshaller called @fptr-ptr@. For example, @$fptr-ptr:(int *x)@ extracts the
-- bare C pointer out of foreign pointer @x@.
fptrCtx :: Context
fptrCtx :: Context
fptrCtx = Context
forall a. Monoid a => a
mempty
  { ctxAntiQuoters :: AntiQuoters
ctxAntiQuoters = [(String, SomeAntiQuoter)] -> AntiQuoters
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String
"fptr-ptr", AntiQuoter HaskellIdentifier -> SomeAntiQuoter
forall a. (Eq a, Typeable a) => AntiQuoter a -> SomeAntiQuoter
SomeAntiQuoter AntiQuoter HaskellIdentifier
fptrAntiQuoter)]
  }

fptrAntiQuoter :: AntiQuoter HaskellIdentifier
fptrAntiQuoter :: AntiQuoter HaskellIdentifier
fptrAntiQuoter = AntiQuoter :: forall a.
(forall (m :: * -> *).
 CParser HaskellIdentifier m =>
 m (CIdentifier, Type CIdentifier, a))
-> (Purity -> TypesTable -> Type CIdentifier -> a -> Q (Type, Exp))
-> AntiQuoter a
AntiQuoter
  { aqParser :: forall (m :: * -> *).
CParser HaskellIdentifier m =>
m (CIdentifier, Type CIdentifier, HaskellIdentifier)
aqParser = forall (m :: * -> *).
CParser HaskellIdentifier m =>
m (CIdentifier, Type CIdentifier, HaskellIdentifier)
cDeclAqParser
  , aqMarshaller :: Purity
-> TypesTable
-> Type CIdentifier
-> HaskellIdentifier
-> Q (Type, Exp)
aqMarshaller = \Purity
purity TypesTable
cTypes Type CIdentifier
cTy HaskellIdentifier
cId -> do
      Type
hsTy <- String -> Purity -> TypesTable -> Type CIdentifier -> TypeQ
convertType_ String
"fptrCtx" Purity
purity TypesTable
cTypes Type CIdentifier
cTy
      Exp
hsExp <- String -> HaskellIdentifier -> ExpQ
getHsVariable String
"fptrCtx" HaskellIdentifier
cId
      Exp
hsExp' <- [| withForeignPtr (coerce $(return hsExp)) |]
      (Type, Exp) -> Q (Type, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
hsTy, Exp
hsExp')
  }

-- | This 'Context' includes a 'AntiQuoter' that removes the need for
-- explicitely creating 'FunPtr's, named @"fun"@ along with one which
-- allocates new memory which must be manually freed named @"fun-alloc"@.
--
-- For example, we can capture function @f@ of type @CInt -> CInt -> IO
-- CInt@ in C code using @$fun:(int (*f)(int, int))@.
--
-- When used in a @pure@ embedding, the Haskell function will have to be
-- pure too.  Continuing the example above we'll have @CInt -> CInt ->
-- IO CInt@.
--
-- Does not include the 'baseCtx', since most of the time it's going to
-- be included as part of larger contexts.
--
-- IMPORTANT: When using the @fun@ anti quoter, one must be aware that
-- the function pointer which is automatically generated is freed when
-- the code contained in the block containing the anti quoter exits.
-- Thus, if you need the function pointer to be longer-lived, you must
-- allocate it and free it manually using 'freeHaskellFunPtr'.
-- We provide utilities to easily
-- allocate them (see 'Language.C.Inline.mkFunPtr').
--
-- IMPORTANT: When using the @fun-alloc@ anti quoter, one must free the allocated
-- function pointer. The GHC runtime provides a function to do this,
-- 'hs_free_fun_ptr' available in the 'HsFFI.h' header.

funCtx :: Context
funCtx :: Context
funCtx = Context
forall a. Monoid a => a
mempty
  { ctxAntiQuoters :: AntiQuoters
ctxAntiQuoters = [(String, SomeAntiQuoter)] -> AntiQuoters
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String
"fun", AntiQuoter HaskellIdentifier -> SomeAntiQuoter
forall a. (Eq a, Typeable a) => AntiQuoter a -> SomeAntiQuoter
SomeAntiQuoter AntiQuoter HaskellIdentifier
funPtrAntiQuoter)
                                  ,(String
"fun-alloc", AntiQuoter HaskellIdentifier -> SomeAntiQuoter
forall a. (Eq a, Typeable a) => AntiQuoter a -> SomeAntiQuoter
SomeAntiQuoter AntiQuoter HaskellIdentifier
funAllocPtrAntiQuoter)]
  }

funPtrAntiQuoter :: AntiQuoter HaskellIdentifier
funPtrAntiQuoter :: AntiQuoter HaskellIdentifier
funPtrAntiQuoter = AntiQuoter :: forall a.
(forall (m :: * -> *).
 CParser HaskellIdentifier m =>
 m (CIdentifier, Type CIdentifier, a))
-> (Purity -> TypesTable -> Type CIdentifier -> a -> Q (Type, Exp))
-> AntiQuoter a
AntiQuoter
  { aqParser :: forall (m :: * -> *).
CParser HaskellIdentifier m =>
m (CIdentifier, Type CIdentifier, HaskellIdentifier)
aqParser = forall (m :: * -> *).
CParser HaskellIdentifier m =>
m (CIdentifier, Type CIdentifier, HaskellIdentifier)
cDeclAqParser
  , aqMarshaller :: Purity
-> TypesTable
-> Type CIdentifier
-> HaskellIdentifier
-> Q (Type, Exp)
aqMarshaller = \Purity
purity TypesTable
cTypes Type CIdentifier
cTy HaskellIdentifier
cId -> do
      Type
hsTy <- String -> Purity -> TypesTable -> Type CIdentifier -> TypeQ
convertType_ String
"funCtx" Purity
purity TypesTable
cTypes Type CIdentifier
cTy
      Exp
hsExp <- String -> HaskellIdentifier -> ExpQ
getHsVariable String
"funCtx" HaskellIdentifier
cId
      case Type
hsTy of
        TH.AppT (TH.ConT Name
n) Type
hsTy' | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''FunPtr -> do
          Exp
hsExp' <- [| \cont -> do
              funPtr <- $(mkFunPtr (return hsTy')) $(return hsExp)
              x <- cont funPtr
              freeHaskellFunPtr funPtr
              return x
            |]
          (Type, Exp) -> Q (Type, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
hsTy, Exp
hsExp')
        Type
_ -> String -> Q (Type, Exp)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"The `fun' marshaller captures function pointers only"
  }

funAllocPtrAntiQuoter :: AntiQuoter HaskellIdentifier
funAllocPtrAntiQuoter :: AntiQuoter HaskellIdentifier
funAllocPtrAntiQuoter = AntiQuoter :: forall a.
(forall (m :: * -> *).
 CParser HaskellIdentifier m =>
 m (CIdentifier, Type CIdentifier, a))
-> (Purity -> TypesTable -> Type CIdentifier -> a -> Q (Type, Exp))
-> AntiQuoter a
AntiQuoter
  { aqParser :: forall (m :: * -> *).
CParser HaskellIdentifier m =>
m (CIdentifier, Type CIdentifier, HaskellIdentifier)
aqParser = forall (m :: * -> *).
CParser HaskellIdentifier m =>
m (CIdentifier, Type CIdentifier, HaskellIdentifier)
cDeclAqParser
  , aqMarshaller :: Purity
-> TypesTable
-> Type CIdentifier
-> HaskellIdentifier
-> Q (Type, Exp)
aqMarshaller = \Purity
purity TypesTable
cTypes Type CIdentifier
cTy HaskellIdentifier
cId -> do
      Type
hsTy <- String -> Purity -> TypesTable -> Type CIdentifier -> TypeQ
convertType_ String
"funCtx" Purity
purity TypesTable
cTypes Type CIdentifier
cTy
      Exp
hsExp <- String -> HaskellIdentifier -> ExpQ
getHsVariable String
"funCtx" HaskellIdentifier
cId
      case Type
hsTy of
        TH.AppT (TH.ConT Name
n) Type
hsTy' | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''FunPtr -> do
          Exp
hsExp' <- [| \cont -> do
              funPtr <- $(mkFunPtr (return hsTy')) $(return hsExp)
              cont funPtr
            |]
          (Type, Exp) -> Q (Type, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
hsTy, Exp
hsExp')
        Type
_ -> String -> Q (Type, Exp)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"The `fun-alloc' marshaller captures function pointers only"
  }

-- | This 'Context' includes two 'AntiQuoter's that allow to easily use
-- Haskell vectors in C.
--
-- Specifically, the @vec-len@ and @vec-ptr@ will get the length and the
-- pointer underlying mutable ('V.IOVector') and immutable ('V.Vector')
-- storable vectors.
--
-- Note that if you use 'vecCtx' to manipulate immutable vectors you
-- must make sure that the vector is not modified in the C code.
--
-- To use @vec-len@, simply write @$vec-len:x@, where @x@ is something
-- of type @'V.IOVector' a@ or @'V.Vector' a@, for some @a@.  To use
-- @vec-ptr@ you need to specify the type of the pointer,
-- e.g. @$vec-len:(int *x)@ will work if @x@ has type @'V.IOVector'
-- 'CInt'@.
vecCtx :: Context
vecCtx :: Context
vecCtx = Context
forall a. Monoid a => a
mempty
  { ctxAntiQuoters :: AntiQuoters
ctxAntiQuoters = [(String, SomeAntiQuoter)] -> AntiQuoters
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (String
"vec-ptr", AntiQuoter HaskellIdentifier -> SomeAntiQuoter
forall a. (Eq a, Typeable a) => AntiQuoter a -> SomeAntiQuoter
SomeAntiQuoter AntiQuoter HaskellIdentifier
vecPtrAntiQuoter)
      , (String
"vec-len", AntiQuoter HaskellIdentifier -> SomeAntiQuoter
forall a. (Eq a, Typeable a) => AntiQuoter a -> SomeAntiQuoter
SomeAntiQuoter AntiQuoter HaskellIdentifier
vecLenAntiQuoter)
      ]
  }

-- | Type class used to implement the anti-quoters in 'vecCtx'.
class VecCtx a where
  type VecCtxScalar a :: *

  vecCtxLength :: a -> Int
  vecCtxUnsafeWith :: a -> (Ptr (VecCtxScalar a) -> IO b) -> IO b

instance Storable a => VecCtx (V.Vector a) where
  type VecCtxScalar (V.Vector a) = a

  vecCtxLength :: Vector a -> Int
vecCtxLength = Vector a -> Int
forall a. Storable a => Vector a -> Int
V.length
  vecCtxUnsafeWith :: Vector a -> (Ptr (VecCtxScalar (Vector a)) -> IO b) -> IO b
vecCtxUnsafeWith = Vector a -> (Ptr (VecCtxScalar (Vector a)) -> IO b) -> IO b
forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
V.unsafeWith

instance Storable a => VecCtx (VM.IOVector a) where
  type VecCtxScalar (VM.IOVector a) = a

  vecCtxLength :: IOVector a -> Int
vecCtxLength = IOVector a -> Int
forall a s. Storable a => MVector s a -> Int
VM.length
  vecCtxUnsafeWith :: IOVector a -> (Ptr (VecCtxScalar (IOVector a)) -> IO b) -> IO b
vecCtxUnsafeWith = IOVector a -> (Ptr (VecCtxScalar (IOVector a)) -> IO b) -> IO b
forall a b. Storable a => IOVector a -> (Ptr a -> IO b) -> IO b
VM.unsafeWith

vecPtrAntiQuoter :: AntiQuoter HaskellIdentifier
vecPtrAntiQuoter :: AntiQuoter HaskellIdentifier
vecPtrAntiQuoter = AntiQuoter :: forall a.
(forall (m :: * -> *).
 CParser HaskellIdentifier m =>
 m (CIdentifier, Type CIdentifier, a))
-> (Purity -> TypesTable -> Type CIdentifier -> a -> Q (Type, Exp))
-> AntiQuoter a
AntiQuoter
  { aqParser :: forall (m :: * -> *).
CParser HaskellIdentifier m =>
m (CIdentifier, Type CIdentifier, HaskellIdentifier)
aqParser = forall (m :: * -> *).
CParser HaskellIdentifier m =>
m (CIdentifier, Type CIdentifier, HaskellIdentifier)
cDeclAqParser
  , aqMarshaller :: Purity
-> TypesTable
-> Type CIdentifier
-> HaskellIdentifier
-> Q (Type, Exp)
aqMarshaller = \Purity
purity TypesTable
cTypes Type CIdentifier
cTy HaskellIdentifier
cId -> do
      Type
hsTy <- String -> Purity -> TypesTable -> Type CIdentifier -> TypeQ
convertType_ String
"vecCtx" Purity
purity TypesTable
cTypes Type CIdentifier
cTy
      Exp
hsExp <- String -> HaskellIdentifier -> ExpQ
getHsVariable String
"vecCtx" HaskellIdentifier
cId
      Exp
hsExp' <- [| vecCtxUnsafeWith $(return hsExp) |]
      (Type, Exp) -> Q (Type, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
hsTy, Exp
hsExp')
  }

vecLenAntiQuoter :: AntiQuoter HaskellIdentifier
vecLenAntiQuoter :: AntiQuoter HaskellIdentifier
vecLenAntiQuoter = AntiQuoter :: forall a.
(forall (m :: * -> *).
 CParser HaskellIdentifier m =>
 m (CIdentifier, Type CIdentifier, a))
-> (Purity -> TypesTable -> Type CIdentifier -> a -> Q (Type, Exp))
-> AntiQuoter a
AntiQuoter
  { aqParser :: forall (m :: * -> *).
CParser HaskellIdentifier m =>
m (CIdentifier, Type CIdentifier, HaskellIdentifier)
aqParser = do
      HaskellIdentifier
hId <- m HaskellIdentifier
forall i (m :: * -> *). CParser i m => m i
C.parseIdentifier
      Bool
useCpp <- m Bool
forall i (m :: * -> *). CParser i m => m Bool
C.parseEnableCpp
      let cId :: CIdentifier
cId = Bool -> HaskellIdentifier -> CIdentifier
mangleHaskellIdentifier Bool
useCpp HaskellIdentifier
hId
      (CIdentifier, Type CIdentifier, HaskellIdentifier)
-> m (CIdentifier, Type CIdentifier, HaskellIdentifier)
forall (m :: * -> *) a. Monad m => a -> m a
return (CIdentifier
cId, Specifiers -> TypeSpecifier -> Type CIdentifier
forall i. Specifiers -> TypeSpecifier -> Type i
C.TypeSpecifier Specifiers
forall a. Monoid a => a
mempty (Sign -> TypeSpecifier
C.Long Sign
C.Signed), HaskellIdentifier
hId)
  , aqMarshaller :: Purity
-> TypesTable
-> Type CIdentifier
-> HaskellIdentifier
-> Q (Type, Exp)
aqMarshaller = \Purity
_purity TypesTable
_cTypes Type CIdentifier
cTy HaskellIdentifier
cId -> do
      case Type CIdentifier
cTy of
        C.TypeSpecifier Specifiers
_ (C.Long Sign
C.Signed) -> do
          Exp
hsExp <- String -> HaskellIdentifier -> ExpQ
getHsVariable String
"vecCtx" HaskellIdentifier
cId
          Exp
hsExp' <- [| fromIntegral (vecCtxLength $(return hsExp)) |]
          Type
hsTy <- [t| CLong |]
          Exp
hsExp'' <- [| \cont -> cont $(return hsExp') |]
          (Type, Exp) -> Q (Type, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
hsTy, Exp
hsExp'')
        Type CIdentifier
_ -> do
          String -> Q (Type, Exp)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"impossible: got type different from `long' (vecCtx)"
  }


-- | 'bsCtx' serves exactly the same purpose as 'vecCtx', but only for
-- 'BS.ByteString'.  @vec-ptr@ becomes @bs-ptr@, and @vec-len@ becomes
-- @bs-len@.  You don't need to specify the type of the pointer in
-- @bs-ptr@, it will always be @char*@.
--
-- Moreover, @bs-cstr@ works as @bs-ptr@ but it provides a null-terminated
-- copy of the given 'BS.ByteString'.
bsCtx :: Context
bsCtx :: Context
bsCtx = Context
forall a. Monoid a => a
mempty
  { ctxAntiQuoters :: AntiQuoters
ctxAntiQuoters = [(String, SomeAntiQuoter)] -> AntiQuoters
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (String
"bs-ptr", AntiQuoter HaskellIdentifier -> SomeAntiQuoter
forall a. (Eq a, Typeable a) => AntiQuoter a -> SomeAntiQuoter
SomeAntiQuoter AntiQuoter HaskellIdentifier
bsPtrAntiQuoter)
      , (String
"bs-len", AntiQuoter HaskellIdentifier -> SomeAntiQuoter
forall a. (Eq a, Typeable a) => AntiQuoter a -> SomeAntiQuoter
SomeAntiQuoter AntiQuoter HaskellIdentifier
bsLenAntiQuoter)
      , (String
"bs-cstr", AntiQuoter HaskellIdentifier -> SomeAntiQuoter
forall a. (Eq a, Typeable a) => AntiQuoter a -> SomeAntiQuoter
SomeAntiQuoter AntiQuoter HaskellIdentifier
bsCStrAntiQuoter)
      ]
  }

bsPtrAntiQuoter :: AntiQuoter HaskellIdentifier
bsPtrAntiQuoter :: AntiQuoter HaskellIdentifier
bsPtrAntiQuoter = AntiQuoter :: forall a.
(forall (m :: * -> *).
 CParser HaskellIdentifier m =>
 m (CIdentifier, Type CIdentifier, a))
-> (Purity -> TypesTable -> Type CIdentifier -> a -> Q (Type, Exp))
-> AntiQuoter a
AntiQuoter
  { aqParser :: forall (m :: * -> *).
CParser HaskellIdentifier m =>
m (CIdentifier, Type CIdentifier, HaskellIdentifier)
aqParser = do
      HaskellIdentifier
hId <- m HaskellIdentifier
forall i (m :: * -> *). CParser i m => m i
C.parseIdentifier
      Bool
useCpp <- m Bool
forall i (m :: * -> *). CParser i m => m Bool
C.parseEnableCpp
      let cId :: CIdentifier
cId = Bool -> HaskellIdentifier -> CIdentifier
mangleHaskellIdentifier Bool
useCpp HaskellIdentifier
hId
      (CIdentifier, Type CIdentifier, HaskellIdentifier)
-> m (CIdentifier, Type CIdentifier, HaskellIdentifier)
forall (m :: * -> *) a. Monad m => a -> m a
return (CIdentifier
cId, [TypeQualifier] -> Type CIdentifier -> Type CIdentifier
forall i. [TypeQualifier] -> Type i -> Type i
C.Ptr [] (Specifiers -> TypeSpecifier -> Type CIdentifier
forall i. Specifiers -> TypeSpecifier -> Type i
C.TypeSpecifier Specifiers
forall a. Monoid a => a
mempty (Maybe Sign -> TypeSpecifier
C.Char Maybe Sign
forall a. Maybe a
Nothing)), HaskellIdentifier
hId)
  , aqMarshaller :: Purity
-> TypesTable
-> Type CIdentifier
-> HaskellIdentifier
-> Q (Type, Exp)
aqMarshaller = \Purity
_purity TypesTable
_cTypes Type CIdentifier
cTy HaskellIdentifier
cId -> do
      case Type CIdentifier
cTy of
        C.Ptr [TypeQualifier]
_ (C.TypeSpecifier Specifiers
_ (C.Char Maybe Sign
Nothing)) -> do
          Type
hsTy <- [t| Ptr CChar |]
          Exp
hsExp <- String -> HaskellIdentifier -> ExpQ
getHsVariable String
"bsCtx" HaskellIdentifier
cId
          Exp
hsExp' <- [| \cont -> BS.unsafeUseAsCString $(return hsExp) $ \ptr -> cont ptr  |]
          (Type, Exp) -> Q (Type, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
hsTy, Exp
hsExp')
        Type CIdentifier
_ ->
          String -> Q (Type, Exp)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"impossible: got type different from `char *' (bsCtx)"
  }

bsLenAntiQuoter :: AntiQuoter HaskellIdentifier
bsLenAntiQuoter :: AntiQuoter HaskellIdentifier
bsLenAntiQuoter = AntiQuoter :: forall a.
(forall (m :: * -> *).
 CParser HaskellIdentifier m =>
 m (CIdentifier, Type CIdentifier, a))
-> (Purity -> TypesTable -> Type CIdentifier -> a -> Q (Type, Exp))
-> AntiQuoter a
AntiQuoter
  { aqParser :: forall (m :: * -> *).
CParser HaskellIdentifier m =>
m (CIdentifier, Type CIdentifier, HaskellIdentifier)
aqParser = do
      HaskellIdentifier
hId <- m HaskellIdentifier
forall i (m :: * -> *). CParser i m => m i
C.parseIdentifier
      Bool
useCpp <- m Bool
forall i (m :: * -> *). CParser i m => m Bool
C.parseEnableCpp
      let cId :: CIdentifier
cId = Bool -> HaskellIdentifier -> CIdentifier
mangleHaskellIdentifier Bool
useCpp HaskellIdentifier
hId
      (CIdentifier, Type CIdentifier, HaskellIdentifier)
-> m (CIdentifier, Type CIdentifier, HaskellIdentifier)
forall (m :: * -> *) a. Monad m => a -> m a
return (CIdentifier
cId, Specifiers -> TypeSpecifier -> Type CIdentifier
forall i. Specifiers -> TypeSpecifier -> Type i
C.TypeSpecifier Specifiers
forall a. Monoid a => a
mempty (Sign -> TypeSpecifier
C.Long Sign
C.Signed), HaskellIdentifier
hId)
  , aqMarshaller :: Purity
-> TypesTable
-> Type CIdentifier
-> HaskellIdentifier
-> Q (Type, Exp)
aqMarshaller = \Purity
_purity TypesTable
_cTypes Type CIdentifier
cTy HaskellIdentifier
cId -> do
      case Type CIdentifier
cTy of
        C.TypeSpecifier Specifiers
_ (C.Long Sign
C.Signed) -> do
          Exp
hsExp <- String -> HaskellIdentifier -> ExpQ
getHsVariable String
"bsCtx" HaskellIdentifier
cId
          Exp
hsExp' <- [| fromIntegral (BS.length $(return hsExp)) |]
          Type
hsTy <- [t| CLong |]
          Exp
hsExp'' <- [| \cont -> cont $(return hsExp') |]
          (Type, Exp) -> Q (Type, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
hsTy, Exp
hsExp'')
        Type CIdentifier
_ -> do
          String -> Q (Type, Exp)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"impossible: got type different from `long' (bsCtx)"
  }

bsCStrAntiQuoter :: AntiQuoter HaskellIdentifier
bsCStrAntiQuoter :: AntiQuoter HaskellIdentifier
bsCStrAntiQuoter = AntiQuoter :: forall a.
(forall (m :: * -> *).
 CParser HaskellIdentifier m =>
 m (CIdentifier, Type CIdentifier, a))
-> (Purity -> TypesTable -> Type CIdentifier -> a -> Q (Type, Exp))
-> AntiQuoter a
AntiQuoter
  { aqParser :: forall (m :: * -> *).
CParser HaskellIdentifier m =>
m (CIdentifier, Type CIdentifier, HaskellIdentifier)
aqParser = do
      HaskellIdentifier
hId <- m HaskellIdentifier
forall i (m :: * -> *). CParser i m => m i
C.parseIdentifier
      Bool
useCpp <- m Bool
forall i (m :: * -> *). CParser i m => m Bool
C.parseEnableCpp
      let cId :: CIdentifier
cId = Bool -> HaskellIdentifier -> CIdentifier
mangleHaskellIdentifier Bool
useCpp HaskellIdentifier
hId
      (CIdentifier, Type CIdentifier, HaskellIdentifier)
-> m (CIdentifier, Type CIdentifier, HaskellIdentifier)
forall (m :: * -> *) a. Monad m => a -> m a
return (CIdentifier
cId, [TypeQualifier] -> Type CIdentifier -> Type CIdentifier
forall i. [TypeQualifier] -> Type i -> Type i
C.Ptr [] (Specifiers -> TypeSpecifier -> Type CIdentifier
forall i. Specifiers -> TypeSpecifier -> Type i
C.TypeSpecifier Specifiers
forall a. Monoid a => a
mempty (Maybe Sign -> TypeSpecifier
C.Char Maybe Sign
forall a. Maybe a
Nothing)), HaskellIdentifier
hId)
  , aqMarshaller :: Purity
-> TypesTable
-> Type CIdentifier
-> HaskellIdentifier
-> Q (Type, Exp)
aqMarshaller = \Purity
_purity TypesTable
_cTypes Type CIdentifier
cTy HaskellIdentifier
cId -> do
      case Type CIdentifier
cTy of
        C.Ptr [TypeQualifier]
_ (C.TypeSpecifier Specifiers
_ (C.Char Maybe Sign
Nothing)) -> do
          Type
hsTy <- [t| Ptr CChar |]
          Exp
hsExp <- String -> HaskellIdentifier -> ExpQ
getHsVariable String
"bsCtx" HaskellIdentifier
cId
          Exp
hsExp' <- [| \cont -> BS.useAsCString $(return hsExp) $ \ptr -> cont ptr  |]
          (Type, Exp) -> Q (Type, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
hsTy, Exp
hsExp')
        Type CIdentifier
_ ->
          String -> Q (Type, Exp)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"impossible: got type different from `char *' (bsCtx)"
  }


-- Utils
------------------------------------------------------------------------

cDeclAqParser
  :: C.CParser HaskellIdentifier m
  => m (C.CIdentifier, C.Type C.CIdentifier, HaskellIdentifier)
cDeclAqParser :: m (CIdentifier, Type CIdentifier, HaskellIdentifier)
cDeclAqParser = do
  ParameterDeclaration HaskellIdentifier
cTy <- m (ParameterDeclaration HaskellIdentifier)
-> m (ParameterDeclaration HaskellIdentifier)
forall (m :: * -> *) a. TokenParsing m => m a -> m a
Parser.parens m (ParameterDeclaration HaskellIdentifier)
forall i (m :: * -> *).
(CParser i m, Pretty i) =>
m (ParameterDeclaration i)
C.parseParameterDeclaration
  Bool
useCpp <- m Bool
forall i (m :: * -> *). CParser i m => m Bool
C.parseEnableCpp
  case ParameterDeclaration HaskellIdentifier -> Maybe HaskellIdentifier
forall i. ParameterDeclaration i -> Maybe i
C.parameterDeclarationId ParameterDeclaration HaskellIdentifier
cTy of
    Maybe HaskellIdentifier
Nothing -> String -> m (CIdentifier, Type CIdentifier, HaskellIdentifier)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Every captured function must be named (funCtx)"
    Just HaskellIdentifier
hId -> do
     let cId :: CIdentifier
cId = Bool -> HaskellIdentifier -> CIdentifier
mangleHaskellIdentifier Bool
useCpp HaskellIdentifier
hId
     Type CIdentifier
cTy' <- Type HaskellIdentifier -> m (Type CIdentifier)
forall (m :: * -> *).
CParser HaskellIdentifier m =>
Type HaskellIdentifier -> m (Type CIdentifier)
deHaskellifyCType (Type HaskellIdentifier -> m (Type CIdentifier))
-> Type HaskellIdentifier -> m (Type CIdentifier)
forall a b. (a -> b) -> a -> b
$ ParameterDeclaration HaskellIdentifier -> Type HaskellIdentifier
forall i. ParameterDeclaration i -> Type i
C.parameterDeclarationType ParameterDeclaration HaskellIdentifier
cTy
     (CIdentifier, Type CIdentifier, HaskellIdentifier)
-> m (CIdentifier, Type CIdentifier, HaskellIdentifier)
forall (m :: * -> *) a. Monad m => a -> m a
return (CIdentifier
cId, Type CIdentifier
cTy', HaskellIdentifier
hId)

deHaskellifyCType
  :: C.CParser HaskellIdentifier m
  => C.Type HaskellIdentifier -> m (C.Type C.CIdentifier)
deHaskellifyCType :: Type HaskellIdentifier -> m (Type CIdentifier)
deHaskellifyCType = (HaskellIdentifier -> m CIdentifier)
-> Type HaskellIdentifier -> m (Type CIdentifier)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((HaskellIdentifier -> m CIdentifier)
 -> Type HaskellIdentifier -> m (Type CIdentifier))
-> (HaskellIdentifier -> m CIdentifier)
-> Type HaskellIdentifier
-> m (Type CIdentifier)
forall a b. (a -> b) -> a -> b
$ \HaskellIdentifier
hId -> do
  Bool
useCpp <- m Bool
forall i (m :: * -> *). CParser i m => m Bool
C.parseEnableCpp
  case Bool -> String -> Either String CIdentifier
C.cIdentifierFromString Bool
useCpp (HaskellIdentifier -> String
unHaskellIdentifier HaskellIdentifier
hId) of
    Left String
err -> String -> m CIdentifier
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m CIdentifier) -> String -> m CIdentifier
forall a b. (a -> b) -> a -> b
$ String
"Illegal Haskell identifier " String -> ShowS
forall a. [a] -> [a] -> [a]
++ HaskellIdentifier -> String
unHaskellIdentifier HaskellIdentifier
hId String -> ShowS
forall a. [a] -> [a] -> [a]
++
                       String
" in C type:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err
    Right CIdentifier
x -> CIdentifier -> m CIdentifier
forall (m :: * -> *) a. Monad m => a -> m a
return CIdentifier
x