{-# 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
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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Purity] -> ShowS
$cshowList :: [Purity] -> ShowS
show :: Purity -> [Char]
$cshow :: Purity -> [Char]
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
  { 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 forall a. Semigroup a => a -> a -> a
<> Context -> TypesTable
ctxTypesTable Context
ctx2
    , ctxAntiQuoters :: AntiQuoters
ctxAntiQuoters = Context -> AntiQuoters
ctxAntiQuoters Context
ctx1 forall a. Semigroup a => a -> a -> a
<> Context -> AntiQuoters
ctxAntiQuoters Context
ctx2
    , ctxOutput :: Maybe ShowS
ctxOutput = Context -> Maybe ShowS
ctxOutput Context
ctx1 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 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 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 = forall a. Monoid a => a
mempty
    , ctxAntiQuoters :: AntiQuoters
ctxAntiQuoters = forall a. Monoid a => a
mempty
    , ctxOutput :: Maybe ShowS
ctxOutput = forall a. Maybe a
Nothing
    , ctxForeignSrcLang :: Maybe ForeignSrcLang
ctxForeignSrcLang = forall a. Maybe a
Nothing
    , ctxEnableCpp :: Bool
ctxEnableCpp = Bool
False
    , ctxRawObjectCompile :: Maybe ([Char] -> Q [Char])
ctxRawObjectCompile = 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 = forall a. Monoid a => a
mempty
  { ctxTypesTable :: TypesTable
ctxTypesTable = TypesTable
baseTypesTable
  }

baseTypesTable :: Map.Map C.TypeSpecifier TH.TypeQ
baseTypesTable :: TypesTable
baseTypesTable = 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 forall a. Maybe a
Nothing, [t| CChar |])
  , (Maybe Sign -> TypeSpecifier
C.Char (forall a. a -> Maybe a
Just Sign
C.Signed), [t| CSChar |])
  , (Maybe Sign -> TypeSpecifier
C.Char (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 = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
          Just TypeQ
ty -> forall (m :: * -> *) a. Monad m => a -> m a
return TypeQ
ty
        [Type]
hsTy <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TypeSpecifier]
cTys forall a b. (a -> b) -> a -> b
$ \TypeSpecifier
cTys'  -> Type CIdentifier -> MaybeT Q Type
go (forall i. Specifiers -> TypeSpecifier -> Type i
C.TypeSpecifier forall a. HasCallStack => a
undefined TypeSpecifier
cTys')
        case [Type]
hsTy of
          [] -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Can not find template parameters."
          (Type
a:[]) ->
            forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
TH.AppT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ
symbol forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return Type
a
          [Type]
other ->
            let tuple :: Type
tuple = 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 (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
other)) [Type]
other
            in forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
TH.AppT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ
symbol forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 (forall a. Read a => [Char] -> a
read [Char]
num)))
        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 forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeSpecifier
cSpec TypesTable
cTypes of
          Maybe TypeQ
Nothing -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
          Just TypeQ
ty -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [t| Ptr $(ty) |]
      C.TypeSpecifier Specifiers
_specs TypeSpecifier
cSpec ->
        case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeSpecifier
cSpec TypesTable
cTypes of
          Maybe TypeQ
Nothing -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
          Just TypeQ
ty -> 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 <- 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
        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'
        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'
        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
        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 = forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList
  [ CIdentifier
id' | C.TypeName CIdentifier
id' <- 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
  Maybe Name
mbHsName <- [Char] -> Q (Maybe Name)
TH.lookupValueName forall a b. (a -> b) -> a -> b
$ HaskellIdentifier -> [Char]
unHaskellIdentifier HaskellIdentifier
s
  case Maybe Name
mbHsName of
    Maybe Name
Nothing -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot capture Haskell variable " forall a. [a] -> [a] -> [a]
++ HaskellIdentifier -> [Char]
unHaskellIdentifier HaskellIdentifier
s forall a. [a] -> [a] -> [a]
++
                      [Char]
", because it's not in scope. (" forall a. [a] -> [a] -> [a]
++ [Char]
err forall a. [a] -> [a] -> [a]
++ [Char]
")"
    Just Name
hsName -> 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
  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 -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot convert C type (" forall a. [a] -> [a] -> [a]
++ [Char]
err forall a. [a] -> [a] -> [a]
++ [Char]
")"
    Just Type
hsType -> 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 = forall a. Monoid a => a
mempty
  { ctxAntiQuoters :: AntiQuoters
ctxAntiQuoters = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [([Char]
"fptr-ptr", forall a. (Eq a, Typeable a) => AntiQuoter a -> SomeAntiQuoter
SomeAntiQuoter AntiQuoter HaskellIdentifier
fptrAntiQuoter)]
  }

fptrAntiQuoter :: AntiQuoter HaskellIdentifier
fptrAntiQuoter :: AntiQuoter HaskellIdentifier
fptrAntiQuoter = 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 <- [Char] -> Purity -> TypesTable -> Type CIdentifier -> TypeQ
convertType_ [Char]
"fptrCtx" Purity
purity TypesTable
cTypes Type CIdentifier
cTy
      Exp
hsExp <- [Char] -> HaskellIdentifier -> ExpQ
getHsVariable [Char]
"fptrCtx" HaskellIdentifier
cId
      Exp
hsExp' <- [| withForeignPtr (coerce $(return hsExp)) |]
      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 = forall a. Monoid a => a
mempty
  { ctxAntiQuoters :: AntiQuoters
ctxAntiQuoters = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [([Char]
"fun", forall a. (Eq a, Typeable a) => AntiQuoter a -> SomeAntiQuoter
SomeAntiQuoter AntiQuoter HaskellIdentifier
funPtrAntiQuoter)
                                  ,([Char]
"fun-alloc", forall a. (Eq a, Typeable a) => AntiQuoter a -> SomeAntiQuoter
SomeAntiQuoter AntiQuoter HaskellIdentifier
funAllocPtrAntiQuoter)]
  }

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

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

bsPtrAntiQuoter :: AntiQuoter HaskellIdentifier
bsPtrAntiQuoter :: AntiQuoter HaskellIdentifier
bsPtrAntiQuoter = AntiQuoter
  { aqParser :: forall (m :: * -> *).
CParser HaskellIdentifier m =>
m (CIdentifier, Type CIdentifier, HaskellIdentifier)
aqParser = do
      HaskellIdentifier
hId <- forall i (m :: * -> *). CParser i m => m i
C.parseIdentifier
      Bool
useCpp <- forall i (m :: * -> *). CParser i m => m Bool
C.parseEnableCpp
      let cId :: CIdentifier
cId = Bool -> HaskellIdentifier -> CIdentifier
mangleHaskellIdentifier Bool
useCpp HaskellIdentifier
hId
      forall (m :: * -> *) a. Monad m => a -> m a
return (CIdentifier
cId, forall i. [TypeQualifier] -> Type i -> Type i
C.Ptr [] (forall i. Specifiers -> TypeSpecifier -> Type i
C.TypeSpecifier forall a. Monoid a => a
mempty (Maybe Sign -> TypeSpecifier
C.Char 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 <- [Char] -> HaskellIdentifier -> ExpQ
getHsVariable [Char]
"bsCtx" HaskellIdentifier
cId
          Exp
hsExp' <- [| \cont -> BS.unsafeUseAsCString $(return hsExp) $ \ptr -> cont ptr  |]
          forall (m :: * -> *) a. Monad m => a -> m a
return (Type
hsTy, Exp
hsExp')
        Type CIdentifier
_ ->
          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
      HaskellIdentifier
hId <- forall i (m :: * -> *). CParser i m => m i
C.parseIdentifier
      Bool
useCpp <- forall i (m :: * -> *). CParser i m => m Bool
C.parseEnableCpp
      let cId :: CIdentifier
cId = Bool -> HaskellIdentifier -> CIdentifier
mangleHaskellIdentifier Bool
useCpp HaskellIdentifier
hId
      forall (m :: * -> *) a. Monad m => a -> m a
return (CIdentifier
cId, forall i. Specifiers -> TypeSpecifier -> Type i
C.TypeSpecifier 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 <- [Char] -> HaskellIdentifier -> ExpQ
getHsVariable [Char]
"bsCtx" HaskellIdentifier
cId
          Exp
hsExp' <- [| fromIntegral (BS.length $(return hsExp)) |]
          Type
hsTy <- [t| CLong |]
          Exp
hsExp'' <- [| \cont -> cont $(return hsExp') |]
          forall (m :: * -> *) a. Monad m => a -> m a
return (Type
hsTy, Exp
hsExp'')
        Type CIdentifier
_ -> do
          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
      HaskellIdentifier
hId <- forall i (m :: * -> *). CParser i m => m i
C.parseIdentifier
      Bool
useCpp <- forall i (m :: * -> *). CParser i m => m Bool
C.parseEnableCpp
      let cId :: CIdentifier
cId = Bool -> HaskellIdentifier -> CIdentifier
mangleHaskellIdentifier Bool
useCpp HaskellIdentifier
hId
      forall (m :: * -> *) a. Monad m => a -> m a
return (CIdentifier
cId, forall i. [TypeQualifier] -> Type i -> Type i
C.Ptr [] (forall i. Specifiers -> TypeSpecifier -> Type i
C.TypeSpecifier forall a. Monoid a => a
mempty (Maybe Sign -> TypeSpecifier
C.Char 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 <- [Char] -> HaskellIdentifier -> ExpQ
getHsVariable [Char]
"bsCtx" HaskellIdentifier
cId
          Exp
hsExp' <- [| \cont -> BS.useAsCString $(return hsExp) $ \ptr -> cont ptr  |]
          forall (m :: * -> *) a. Monad m => a -> m a
return (Type
hsTy, Exp
hsExp')
        Type CIdentifier
_ ->
          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
  ParameterDeclaration HaskellIdentifier
cTy <- forall (m :: * -> *) a. TokenParsing m => m a -> m a
Parser.parens forall i (m :: * -> *).
(CParser i m, Pretty i) =>
m (ParameterDeclaration i)
C.parseParameterDeclaration
  Bool
useCpp <- forall i (m :: * -> *). CParser i m => m Bool
C.parseEnableCpp
  case forall i. ParameterDeclaration i -> Maybe i
C.parameterDeclarationId ParameterDeclaration HaskellIdentifier
cTy of
    Maybe HaskellIdentifier
Nothing -> 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
     Type CIdentifier
cTy' <- forall (m :: * -> *).
CParser HaskellIdentifier m =>
Type HaskellIdentifier -> m (Type CIdentifier)
deHaskellifyCType forall a b. (a -> b) -> a -> b
$ forall i. ParameterDeclaration i -> Type i
C.parameterDeclarationType ParameterDeclaration HaskellIdentifier
cTy
     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 :: forall (m :: * -> *).
CParser HaskellIdentifier m =>
Type HaskellIdentifier -> m (Type CIdentifier)
deHaskellifyCType = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ \HaskellIdentifier
hId -> do
  Bool
useCpp <- forall i (m :: * -> *). CParser i m => m Bool
C.parseEnableCpp
  case Bool -> [Char] -> Either [Char] CIdentifier
C.cIdentifierFromString Bool
useCpp (HaskellIdentifier -> [Char]
unHaskellIdentifier HaskellIdentifier
hId) of
    Left [Char]
err -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Illegal Haskell identifier " forall a. [a] -> [a] -> [a]
++ HaskellIdentifier -> [Char]
unHaskellIdentifier HaskellIdentifier
hId forall a. [a] -> [a] -> [a]
++
                       [Char]
" in C type:\n" forall a. [a] -> [a] -> [a]
++ [Char]
err
    Right CIdentifier
x -> forall (m :: * -> *) a. Monad m => a -> m a
return CIdentifier
x