{-# 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
$c== :: Purity -> Purity -> Bool
== :: Purity -> Purity -> Bool
$c/= :: Purity -> Purity -> Bool
/= :: Purity -> Purity -> Bool
Eq, Int -> Purity -> ShowS
[Purity] -> ShowS
Purity -> [Char]
(Int -> Purity -> ShowS)
-> (Purity -> [Char]) -> ([Purity] -> ShowS) -> Show Purity
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Purity -> ShowS
showsPrec :: Int -> Purity -> ShowS
$cshow :: Purity -> [Char]
show :: Purity -> [Char]
$cshowList :: [Purity] -> ShowS
showList :: [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
  { forall a.
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.
  , forall a.
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
    -- ^ Compile source code to raw object.
  , Context -> Maybe ([Char] -> Q [Char])
ctxRawObjectCompile :: Maybe (String -> TH.Q FilePath)
  }


#if MIN_VERSION_base(4,9,0)
instance Semigroup Context where
  Context
ctx2 <> :: Context -> Context -> Context
<> Context
ctx1 = 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 a. Maybe a -> Maybe a -> Maybe a
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 a. Maybe a -> Maybe a -> Maybe a
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
    , ctxRawObjectCompile :: Maybe ([Char] -> Q [Char])
ctxRawObjectCompile = Context -> Maybe ([Char] -> Q [Char])
ctxRawObjectCompile Context
ctx1 Maybe ([Char] -> Q [Char])
-> Maybe ([Char] -> Q [Char]) -> Maybe ([Char] -> Q [Char])
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Context -> Maybe ([Char] -> Q [Char])
ctxRawObjectCompile Context
ctx2
    }
#endif

instance Monoid Context where
  mempty :: Context
mempty = 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
    , ctxRawObjectCompile :: Maybe ([Char] -> Q [Char])
ctxRawObjectCompile = Maybe ([Char] -> Q [Char])
forall a. Maybe a
Nothing
    }

#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
    , ctxRawObjectCompile = ctxRawObjectCompile ctx1 <|> ctxRawObjectCompile 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 = 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'))
        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 a. MaybeT Q a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
          Just TypeQ
ty -> TypeQ -> MaybeT Q TypeQ
forall a. a -> MaybeT Q a
forall (m :: * -> *) a. Monad m => a -> m a
return TypeQ
ty
        hsTy <- forM cTys $ \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 hsTy of
          [] -> [Char] -> MaybeT Q Type
forall a. [Char] -> MaybeT Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> MaybeT Q Type) -> [Char] -> MaybeT Q Type
forall a b. (a -> b) -> a -> b
$ [Char]
"Can not find template parameters."
          (Type
a:[]) ->
            TypeQ -> MaybeT Q Type
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TypeQ -> MaybeT Q Type) -> TypeQ -> MaybeT Q Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
TH.AppT (Type -> Type -> Type) -> TypeQ -> Q (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ
symbol Q (Type -> Type) -> TypeQ -> TypeQ
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> TypeQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
a
          [Type]
other ->
            let tuple :: Type
tuple = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Type
tuple Type
arg -> Type -> Type -> Type
TH.AppT Type
tuple Type
arg) (Int -> Type
TH.PromotedTupleT ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
other)) [Type]
other
            in TypeQ -> MaybeT Q Type
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TypeQ -> MaybeT Q Type) -> TypeQ -> MaybeT Q Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
TH.AppT (Type -> Type -> Type) -> TypeQ -> Q (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ
symbol Q (Type -> Type) -> TypeQ -> TypeQ
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> TypeQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
tuple
      C.TypeSpecifier Specifiers
_specs (C.TemplateConst [Char]
num) -> do
        let n :: Type
n = (TyLit -> Type
TH.LitT (Integer -> TyLit
TH.NumTyLit ([Char] -> Integer
forall a. Read a => [Char] -> a
read [Char]
num)))
        TypeQ -> MaybeT Q Type
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [t| $(Type -> TypeQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
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 a. MaybeT Q a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
          Just TypeQ
ty -> TypeQ -> MaybeT Q Type
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [t| Ptr $(TypeQ
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 a. MaybeT Q a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
          Just TypeQ
ty -> TypeQ -> MaybeT Q Type
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
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
        hsRetType <- Type CIdentifier -> MaybeT Q Type
go Type CIdentifier
retType
        hsPars <- mapM goDecl pars
        lift [t| FunPtr $(buildArr hsPars hsRetType) |]
      C.Ptr [TypeQualifier]
_quals Type CIdentifier
cTy' -> do
        hsTy <- Type CIdentifier -> MaybeT Q Type
go Type CIdentifier
cTy'
        lift [t| Ptr $(return hsTy) |]
      C.Array ArrayType CIdentifier
_mbSize Type CIdentifier
cTy' -> do
        hsTy <- Type CIdentifier -> MaybeT Q Type
go Type CIdentifier
cTy'
        lift [t| CArray $(return hsTy) |]
      C.Proto Type CIdentifier
_retType [ParameterDeclaration CIdentifier]
_pars -> do
        -- We cannot convert standalone prototypes
        mzero

    buildArr :: [Type] -> Type -> TypeQ
buildArr [] Type
hsRetType =
      case Purity
purity of
        Purity
Pure -> [t| $(Type -> TypeQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
hsRetType) |]
        Purity
IO -> [t| IO $(Type -> TypeQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
hsRetType) |]
    buildArr (Type
hsPar : [Type]
hsPars) Type
hsRetType =
      [t| $(Type -> TypeQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
hsPar) -> $([Type] -> Type -> TypeQ
buildArr [Type]
hsPars Type
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 :: [Char] -> HaskellIdentifier -> ExpQ
getHsVariable [Char]
err HaskellIdentifier
s = do
  mbHsName <- [Char] -> Q (Maybe Name)
TH.lookupValueName ([Char] -> Q (Maybe Name)) -> [Char] -> Q (Maybe Name)
forall a b. (a -> b) -> a -> b
$ HaskellIdentifier -> [Char]
unHaskellIdentifier HaskellIdentifier
s
  case mbHsName of
    Maybe Name
Nothing -> [Char] -> ExpQ
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> ExpQ) -> [Char] -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot capture Haskell variable " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ HaskellIdentifier -> [Char]
unHaskellIdentifier HaskellIdentifier
s [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                      [Char]
", because it's not in scope. (" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
err [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
")"
    Just Name
hsName -> Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
hsName

convertType_ :: String -> Purity -> TypesTable -> C.Type C.CIdentifier -> TH.Q TH.Type
convertType_ :: [Char] -> Purity -> TypesTable -> Type CIdentifier -> TypeQ
convertType_ [Char]
err Purity
purity TypesTable
cTypes Type CIdentifier
cTy = do
  mbHsType <- Purity -> TypesTable -> Type CIdentifier -> Q (Maybe Type)
convertType Purity
purity TypesTable
cTypes Type CIdentifier
cTy
  case mbHsType of
    Maybe Type
Nothing -> [Char] -> TypeQ
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> TypeQ) -> [Char] -> TypeQ
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot convert C type (" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
err [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
")"
    Just Type
hsType -> Type -> TypeQ
forall a. a -> Q a
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 = Map.fromList [("fptr-ptr", SomeAntiQuoter fptrAntiQuoter)]
  }

fptrAntiQuoter :: AntiQuoter HaskellIdentifier
fptrAntiQuoter :: AntiQuoter HaskellIdentifier
fptrAntiQuoter = AntiQuoter
  { aqParser :: forall (m :: * -> *).
CParser HaskellIdentifier m =>
m (CIdentifier, Type CIdentifier, HaskellIdentifier)
aqParser = m (CIdentifier, Type CIdentifier, HaskellIdentifier)
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
      hsTy <- [Char] -> Purity -> TypesTable -> Type CIdentifier -> TypeQ
convertType_ [Char]
"fptrCtx" Purity
purity TypesTable
cTypes Type CIdentifier
cTy
      hsExp <- getHsVariable "fptrCtx" cId
      hsExp' <- [| withForeignPtr (coerce $(return hsExp)) |]
      return (hsTy, 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 = Map.fromList [("fun", SomeAntiQuoter funPtrAntiQuoter)
                                  ,("fun-alloc", SomeAntiQuoter funAllocPtrAntiQuoter)]
  }

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

funAllocPtrAntiQuoter :: AntiQuoter HaskellIdentifier
funAllocPtrAntiQuoter :: AntiQuoter HaskellIdentifier
funAllocPtrAntiQuoter = AntiQuoter
  { aqParser :: forall (m :: * -> *).
CParser HaskellIdentifier m =>
m (CIdentifier, Type CIdentifier, HaskellIdentifier)
aqParser = m (CIdentifier, Type CIdentifier, HaskellIdentifier)
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
      hsTy <- [Char] -> Purity -> TypesTable -> Type CIdentifier -> TypeQ
convertType_ [Char]
"funCtx" Purity
purity TypesTable
cTypes Type CIdentifier
cTy
      hsExp <- getHsVariable "funCtx" cId
      case hsTy of
        TH.AppT (TH.ConT Name
n) Type
hsTy' | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''FunPtr -> do
          hsExp' <- [| \cont -> do
              funPtr <- $(TypeQ -> ExpQ
mkFunPtr (Type -> TypeQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
hsTy')) $(Exp -> ExpQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
hsExp)
              cont funPtr
            |]
          return (hsTy, hsExp')
        Type
_ -> [Char] -> Q (Type, Exp)
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"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 = Map.fromList
      [ ("vec-ptr", SomeAntiQuoter vecPtrAntiQuoter)
      , ("vec-len", SomeAntiQuoter 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 :: forall b.
Vector a -> (Ptr (VecCtxScalar (Vector a)) -> IO b) -> IO b
vecCtxUnsafeWith = Vector a -> (Ptr a -> IO b) -> IO b
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 :: forall b.
IOVector a -> (Ptr (VecCtxScalar (IOVector a)) -> IO b) -> IO b
vecCtxUnsafeWith = IOVector a -> (Ptr a -> IO b) -> IO b
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
  { aqParser :: forall (m :: * -> *).
CParser HaskellIdentifier m =>
m (CIdentifier, Type CIdentifier, HaskellIdentifier)
aqParser = m (CIdentifier, Type CIdentifier, HaskellIdentifier)
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
      hsTy <- [Char] -> Purity -> TypesTable -> Type CIdentifier -> TypeQ
convertType_ [Char]
"vecCtx" Purity
purity TypesTable
cTypes Type CIdentifier
cTy
      hsExp <- getHsVariable "vecCtx" cId
      hsExp' <- [| vecCtxUnsafeWith $(return hsExp) |]
      return (hsTy, hsExp')
  }

vecLenAntiQuoter :: AntiQuoter HaskellIdentifier
vecLenAntiQuoter :: AntiQuoter HaskellIdentifier
vecLenAntiQuoter = AntiQuoter
  { aqParser :: forall (m :: * -> *).
CParser HaskellIdentifier m =>
m (CIdentifier, Type CIdentifier, HaskellIdentifier)
aqParser = do
      hId <- m HaskellIdentifier
forall i (m :: * -> *). CParser i m => m i
C.parseIdentifier
      useCpp <- C.parseEnableCpp
      let cId = Bool -> HaskellIdentifier -> CIdentifier
mangleHaskellIdentifier Bool
useCpp HaskellIdentifier
hId
      return (cId, C.TypeSpecifier mempty (C.Long C.Signed), 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
          hsExp <- [Char] -> HaskellIdentifier -> ExpQ
getHsVariable [Char]
"vecCtx" HaskellIdentifier
cId
          hsExp' <- [| fromIntegral (vecCtxLength $(return hsExp)) |]
          hsTy <- [t| CLong |]
          hsExp'' <- [| \cont -> cont $(return hsExp') |]
          return (hsTy, hsExp'')
        Type CIdentifier
_ -> do
          [Char] -> Q (Type, Exp)
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"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 = Map.fromList
      [ ("bs-ptr", SomeAntiQuoter bsPtrAntiQuoter)
      , ("bs-len", SomeAntiQuoter bsLenAntiQuoter)
      , ("bs-cstr", SomeAntiQuoter bsCStrAntiQuoter)
      ]
  }

bsPtrAntiQuoter :: AntiQuoter HaskellIdentifier
bsPtrAntiQuoter :: AntiQuoter HaskellIdentifier
bsPtrAntiQuoter = AntiQuoter
  { aqParser :: forall (m :: * -> *).
CParser HaskellIdentifier m =>
m (CIdentifier, Type CIdentifier, HaskellIdentifier)
aqParser = do
      hId <- m HaskellIdentifier
forall i (m :: * -> *). CParser i m => m i
C.parseIdentifier
      useCpp <- C.parseEnableCpp
      let cId = Bool -> HaskellIdentifier -> CIdentifier
mangleHaskellIdentifier Bool
useCpp HaskellIdentifier
hId
      return (cId, C.Ptr [] (C.TypeSpecifier mempty (C.Char Nothing)), 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
          hsTy <- [t| Ptr CChar |]
          hsExp <- getHsVariable "bsCtx" cId
          hsExp' <- [| \cont -> BS.unsafeUseAsCString $(return hsExp) $ \ptr -> cont ptr  |]
          return (hsTy, hsExp')
        Type CIdentifier
_ ->
          [Char] -> Q (Type, Exp)
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"impossible: got type different from `char *' (bsCtx)"
  }

bsLenAntiQuoter :: AntiQuoter HaskellIdentifier
bsLenAntiQuoter :: AntiQuoter HaskellIdentifier
bsLenAntiQuoter = AntiQuoter
  { aqParser :: forall (m :: * -> *).
CParser HaskellIdentifier m =>
m (CIdentifier, Type CIdentifier, HaskellIdentifier)
aqParser = do
      hId <- m HaskellIdentifier
forall i (m :: * -> *). CParser i m => m i
C.parseIdentifier
      useCpp <- C.parseEnableCpp
      let cId = Bool -> HaskellIdentifier -> CIdentifier
mangleHaskellIdentifier Bool
useCpp HaskellIdentifier
hId
      return (cId, C.TypeSpecifier mempty (C.Long C.Signed), 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
          hsExp <- [Char] -> HaskellIdentifier -> ExpQ
getHsVariable [Char]
"bsCtx" HaskellIdentifier
cId
          hsExp' <- [| fromIntegral (BS.length $(return hsExp)) |]
          hsTy <- [t| CLong |]
          hsExp'' <- [| \cont -> cont $(return hsExp') |]
          return (hsTy, hsExp'')
        Type CIdentifier
_ -> do
          [Char] -> Q (Type, Exp)
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"impossible: got type different from `long' (bsCtx)"
  }

bsCStrAntiQuoter :: AntiQuoter HaskellIdentifier
bsCStrAntiQuoter :: AntiQuoter HaskellIdentifier
bsCStrAntiQuoter = AntiQuoter
  { aqParser :: forall (m :: * -> *).
CParser HaskellIdentifier m =>
m (CIdentifier, Type CIdentifier, HaskellIdentifier)
aqParser = do
      hId <- m HaskellIdentifier
forall i (m :: * -> *). CParser i m => m i
C.parseIdentifier
      useCpp <- C.parseEnableCpp
      let cId = Bool -> HaskellIdentifier -> CIdentifier
mangleHaskellIdentifier Bool
useCpp HaskellIdentifier
hId
      return (cId, C.Ptr [] (C.TypeSpecifier mempty (C.Char Nothing)), 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
          hsTy <- [t| Ptr CChar |]
          hsExp <- getHsVariable "bsCtx" cId
          hsExp' <- [| \cont -> BS.useAsCString $(return hsExp) $ \ptr -> cont ptr  |]
          return (hsTy, hsExp')
        Type CIdentifier
_ ->
          [Char] -> Q (Type, Exp)
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"impossible: got type different from `char *' (bsCtx)"
  }


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

cDeclAqParser
  :: C.CParser HaskellIdentifier m
  => m (C.CIdentifier, C.Type C.CIdentifier, HaskellIdentifier)
cDeclAqParser :: forall (m :: * -> *).
CParser HaskellIdentifier m =>
m (CIdentifier, Type CIdentifier, HaskellIdentifier)
cDeclAqParser = do
  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
  useCpp <- C.parseEnableCpp
  case C.parameterDeclarationId cTy of
    Maybe HaskellIdentifier
Nothing -> [Char] -> m (CIdentifier, Type CIdentifier, HaskellIdentifier)
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Every captured function must be named (funCtx)"
    Just HaskellIdentifier
hId -> do
     let cId :: CIdentifier
cId = Bool -> HaskellIdentifier -> CIdentifier
mangleHaskellIdentifier Bool
useCpp HaskellIdentifier
hId
     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
     return (cId, cTy', hId)

deHaskellifyCType
  :: C.CParser HaskellIdentifier m
  => C.Type HaskellIdentifier -> m (C.Type C.CIdentifier)
deHaskellifyCType :: forall (m :: * -> *).
CParser HaskellIdentifier m =>
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Type a -> f (Type 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
  useCpp <- m Bool
forall i (m :: * -> *). CParser i m => m Bool
C.parseEnableCpp
  case C.cIdentifierFromString useCpp (unHaskellIdentifier hId) of
    Left [Char]
err -> [Char] -> m CIdentifier
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> m CIdentifier) -> [Char] -> m CIdentifier
forall a b. (a -> b) -> a -> b
$ [Char]
"Illegal Haskell identifier " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ HaskellIdentifier -> [Char]
unHaskellIdentifier HaskellIdentifier
hId [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                       [Char]
" in C type:\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
err
    Right CIdentifier
x -> CIdentifier -> m CIdentifier
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return CIdentifier
x