{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MonoLocalBinds #-}

module Language.C.Inline.Internal
    ( -- * Context handling
      setContext
    , getContext

      -- * Substitution
    , Substitutions(..)
    , substitute
    , getHaskellType

      -- * Emitting and invoking C code
      --
      -- | The functions in this section let us access more the C file
      -- associated with the current module.  They can be used to build
      -- additional features on top of the basic machinery.  All of
      -- @inline-c@ is based upon the functions defined here.

      -- ** Emitting C code
    , emitVerbatim

      -- ** Inlining C code
      -- $embedding
    , Code(..)
    , inlineCode
    , inlineExp
    , inlineItems

      -- * Parsing
      --
      -- | These functions are used to parse the anti-quotations.  They're
      -- exposed for testing purposes, you really should not use them.
    , SomeEq
    , toSomeEq
    , fromSomeEq
    , ParameterType(..)
    , ParseTypedC(..)
    , parseTypedC
    , runParserInQ
    , splitTypedC

      -- * Utility functions for writing quasiquoters
    , genericQuote
    , funPtrQuote
    ) where

import           Control.Applicative
import           Control.Monad (forM, void, msum)
import           Control.Monad.State (evalStateT, StateT, get, put)
import           Control.Monad.Trans.Class (lift)
import           Data.Foldable (forM_)
import qualified Data.Map as Map
import           Data.Maybe (fromMaybe)
import           Data.Traversable (for)
import           Data.Typeable (Typeable, cast)
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Quote as TH
import qualified Language.Haskell.TH.Syntax as TH
import           System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO)
import qualified Text.Parsec as Parsec
import qualified Text.Parsec.Pos as Parsec
import qualified Text.Parser.Char as Parser
import qualified Text.Parser.Combinators as Parser
import qualified Text.Parser.LookAhead as Parser
import qualified Text.Parser.Token as Parser
import           Text.PrettyPrint.ANSI.Leijen ((<+>))
import qualified Text.PrettyPrint.ANSI.Leijen as PP
import qualified Data.List as L
import qualified Data.Char as C
import           Data.Hashable (Hashable)
import           Foreign.Ptr (FunPtr)
import qualified Data.Map as M

-- We cannot use getQ/putQ before 7.10.3 because of <https://ghc.haskell.org/trac/ghc/ticket/10596>
#define USE_GETQ (__GLASGOW_HASKELL__ > 710 || (__GLASGOW_HASKELL__ == 710 && __GLASGOW_HASKELL_PATCHLEVEL1__ >= 3))

#if !USE_GETQ
import           Control.Concurrent.MVar (MVar, newMVar, modifyMVar_, readMVar)
#endif

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

data ModuleState = ModuleState
  { ModuleState -> Context
msContext :: Context
  , ModuleState -> Int
msGeneratedNames :: Int
  , ModuleState -> [[Char]]
msFileChunks :: [String]
  } deriving (Typeable)

getModuleState :: TH.Q (Maybe ModuleState)
putModuleState :: ModuleState -> TH.Q ()

#if USE_GETQ

getModuleState :: Q (Maybe ModuleState)
getModuleState = Q (Maybe ModuleState)
forall a. Typeable a => Q (Maybe a)
TH.getQ
putModuleState :: ModuleState -> Q ()
putModuleState = ModuleState -> Q ()
forall a. Typeable a => a -> Q ()
TH.putQ

#else

-- | Identifier for the current module.  Currently we use the file name.
-- Since we're pairing Haskell files with C files, it makes more sense
-- to use the file name.  I'm not sure if it's possible to compile two
-- modules with the same name in one run of GHC, but in this way we make
-- sure that we don't run into trouble even it is.
type ModuleId = String

getModuleId :: TH.Q ModuleId
getModuleId = TH.loc_filename <$> TH.location

-- | 'MVar' storing the state for all the modules we visited.  Note that
-- currently we do not bother with cleaning up the state after we're
-- done compiling a module.  TODO if there is an easy way, clean up the
-- state.
{-# NOINLINE moduleStatesVar #-}
moduleStatesVar :: MVar (Map.Map ModuleId ModuleState)
moduleStatesVar = unsafePerformIO $ newMVar Map.empty

getModuleState = do
  moduleStates <- TH.runIO (readMVar moduleStatesVar)
  moduleId <- getModuleId
  return (Map.lookup moduleId moduleStates)

putModuleState ms = do
  moduleId <- getModuleId
  TH.runIO (modifyMVar_ moduleStatesVar (return . Map.insert moduleId ms))

#endif


-- | Make sure that 'moduleStatesVar' and the respective C file are up
--   to date.
initialiseModuleState
  :: Maybe Context
  -- ^ The 'Context' to use if we initialise the module.  If 'Nothing',
  -- 'baseCtx' will be used.
  -> TH.Q Context
initialiseModuleState :: Maybe Context -> Q Context
initialiseModuleState Maybe Context
mbContext = do
  Maybe ModuleState
mbModuleState <- Q (Maybe ModuleState)
getModuleState
  case Maybe ModuleState
mbModuleState of
    Just ModuleState
moduleState -> Context -> Q Context
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleState -> Context
msContext ModuleState
moduleState)
    Maybe ModuleState
Nothing -> do
      -- Add hook to add the file
      Q () -> Q ()
TH.addModFinalizer (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ do
        Maybe ModuleState
mbMs <- Q (Maybe ModuleState)
getModuleState
        ModuleState
ms <- case Maybe ModuleState
mbMs of
          Maybe ModuleState
Nothing -> [Char] -> Q ModuleState
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"inline-c: ModuleState not present (initialiseModuleState)"
          Just ModuleState
ms -> ModuleState -> Q ModuleState
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleState
ms
        let lang :: ForeignSrcLang
lang = ForeignSrcLang -> Maybe ForeignSrcLang -> ForeignSrcLang
forall a. a -> Maybe a -> a
fromMaybe ForeignSrcLang
TH.LangC (Context -> Maybe ForeignSrcLang
ctxForeignSrcLang Context
context)
#if MIN_VERSION_base(4,12,0)
        ForeignSrcLang -> [Char] -> Q ()
TH.addForeignSource ForeignSrcLang
lang ([[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Char]] -> [[Char]]
forall a. [a] -> [a]
reverse (ModuleState -> [[Char]]
msFileChunks ModuleState
ms)))
#else
        TH.addForeignFile lang (concat (reverse (msFileChunks ms)))
#endif
      let moduleState :: ModuleState
moduleState = ModuleState :: Context -> Int -> [[Char]] -> ModuleState
ModuleState
            { msContext :: Context
msContext = Context
context
            , msGeneratedNames :: Int
msGeneratedNames = Int
0
            , msFileChunks :: [[Char]]
msFileChunks = [[Char]]
forall a. Monoid a => a
mempty
            }
      ModuleState -> Q ()
putModuleState ModuleState
moduleState
      Context -> Q Context
forall (m :: * -> *) a. Monad m => a -> m a
return Context
context
  where
    context :: Context
context = Context -> Maybe Context -> Context
forall a. a -> Maybe a -> a
fromMaybe Context
baseCtx Maybe Context
mbContext

-- | Gets the current 'Context'.  Also makes sure that the current
-- module is initialised.
getContext :: TH.Q Context
getContext :: Q Context
getContext = Maybe Context -> Q Context
initialiseModuleState Maybe Context
forall a. Maybe a
Nothing

modifyModuleState :: (ModuleState -> (ModuleState, a)) -> TH.Q a
modifyModuleState :: forall a. (ModuleState -> (ModuleState, a)) -> Q a
modifyModuleState ModuleState -> (ModuleState, a)
f = do
  Maybe ModuleState
mbModuleState <- Q (Maybe ModuleState)
getModuleState
  case Maybe ModuleState
mbModuleState of
    Maybe ModuleState
Nothing -> [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"inline-c: ModuleState not present (modifyModuleState)"
    Just ModuleState
ms -> do
      let (ModuleState
ms', a
x) = ModuleState -> (ModuleState, a)
f ModuleState
ms
      ModuleState -> Q ()
putModuleState ModuleState
ms'
      a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-- $context
--
-- The inline C functions ('cexp', 'c', etc.) need a 'Context' to
-- operate.  Said context can be explicitely set with 'setContext'.
-- Otherwise, at the first usage of one of the TH functions in this
-- module the 'Context' is implicitely set to 'baseCtx'.

-- | Sets the 'Context' for the current module.  This function, if
-- called, must be called before any of the other TH functions in this
-- module.  Fails if that's not the case.
setContext :: Context -> TH.Q ()
setContext :: Context -> Q ()
setContext Context
ctx = do
  Maybe ModuleState
mbModuleState <- Q (Maybe ModuleState)
getModuleState
  Maybe ModuleState -> (ModuleState -> Q Any) -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe ModuleState
mbModuleState ((ModuleState -> Q Any) -> Q ()) -> (ModuleState -> Q Any) -> Q ()
forall a b. (a -> b) -> a -> b
$ \ModuleState
_ms ->
    [Char] -> Q Any
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"inline-c: The module has already been initialised (setContext)."
  Q Context -> Q ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Q Context -> Q ()) -> Q Context -> Q ()
forall a b. (a -> b) -> a -> b
$ Maybe Context -> Q Context
initialiseModuleState (Maybe Context -> Q Context) -> Maybe Context -> Q Context
forall a b. (a -> b) -> a -> b
$ Context -> Maybe Context
forall a. a -> Maybe a
Just Context
ctx

bumpGeneratedNames :: TH.Q Int
bumpGeneratedNames :: Q Int
bumpGeneratedNames = do
  (ModuleState -> (ModuleState, Int)) -> Q Int
forall a. (ModuleState -> (ModuleState, a)) -> Q a
modifyModuleState ((ModuleState -> (ModuleState, Int)) -> Q Int)
-> (ModuleState -> (ModuleState, Int)) -> Q Int
forall a b. (a -> b) -> a -> b
$ \ModuleState
ms ->
    let c' :: Int
c' = ModuleState -> Int
msGeneratedNames ModuleState
ms
    in (ModuleState
ms{msGeneratedNames :: Int
msGeneratedNames = Int
c' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1}, Int
c')

------------------------------------------------------------------------
-- Emitting

-- | Simply appends some string to the module's C file.  Use with care.
emitVerbatim :: String -> TH.DecsQ
emitVerbatim :: [Char] -> DecsQ
emitVerbatim [Char]
s = do
  -- Make sure that the 'ModuleState' is initialized
  Q Context -> Q ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Maybe Context -> Q Context
initialiseModuleState Maybe Context
forall a. Maybe a
Nothing)
  let chunk :: [Char]
chunk = [Char]
"\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
  (ModuleState -> (ModuleState, ())) -> Q ()
forall a. (ModuleState -> (ModuleState, a)) -> Q a
modifyModuleState ((ModuleState -> (ModuleState, ())) -> Q ())
-> (ModuleState -> (ModuleState, ())) -> Q ()
forall a b. (a -> b) -> a -> b
$ \ModuleState
ms ->
    (ModuleState
ms{msFileChunks :: [[Char]]
msFileChunks = [Char]
chunk [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: ModuleState -> [[Char]]
msFileChunks ModuleState
ms}, ())
  [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return []

------------------------------------------------------------------------
-- Inlining

-- $embedding
--
-- We use the 'Code' data structure to represent some C code that we
-- want to emit to the module's C file and immediately generate a
-- foreign call to.  For this reason, 'Code' includes both some C
-- definition, and enough information to be able to generate a foreign
-- call -- specifically the name of the function to call and the Haskell
-- type.
--
-- All the quasi-quoters work by constructing a 'Code' and calling
-- 'inlineCode'.

-- | Data type representing a list of C definitions with a typed and named entry
-- function.
--
-- We use it as a basis to inline and call C code.
data Code = Code
  { Code -> Safety
codeCallSafety :: TH.Safety
    -- ^ Safety of the foreign call.
  , Code -> Maybe Loc
codeLoc :: Maybe TH.Loc
    -- ^ The haskell source location used for the #line directive
  , Code -> TypeQ
codeType :: TH.TypeQ
    -- ^ Type of the foreign call.
  , Code -> [Char]
codeFunName :: String
    -- ^ Name of the function to call in the code below.
  , Code -> [Char]
codeDefs :: String
    -- ^ The C code.
  , Code -> Bool
codeFunPtr :: Bool
    -- ^ If 'True', the type will be wrapped in 'FunPtr', and
    -- the call will be static (e.g. prefixed by &).
  }

-- TODO use the #line CPP macro to have the functions in the C file
-- refer to the source location in the Haskell file they come from.
--
-- See <https://gcc.gnu.org/onlinedocs/cpp/Line-Control.html>.

-- | Inlines a piece of code inline.  The resulting 'TH.Exp' will have
-- the type specified in the 'codeType'.
--
-- In practice, this function outputs the C code to the module's C file,
-- and then inserts a foreign call of type 'codeType' calling the
-- provided 'codeFunName'.
--
-- Example:
--
-- @
-- c_add :: Int -> Int -> Int
-- c_add = $(do
--   here <- TH.location
--   inlineCode $ Code
--     TH.Unsafe                   -- Call safety
--     (Just here)
--     [t| Int -> Int -> Int |]    -- Call type
--     "francescos_add"            -- Call name
--     -- C Code
--     \"int francescos_add(int x, int y) { int z = x + y; return z; }\")
-- @
inlineCode :: Code -> TH.ExpQ
inlineCode :: Code -> ExpQ
inlineCode Code{Bool
[Char]
Maybe Loc
TypeQ
Safety
codeFunPtr :: Bool
codeDefs :: [Char]
codeFunName :: [Char]
codeType :: TypeQ
codeLoc :: Maybe Loc
codeCallSafety :: Safety
codeFunPtr :: Code -> Bool
codeDefs :: Code -> [Char]
codeFunName :: Code -> [Char]
codeType :: Code -> TypeQ
codeLoc :: Code -> Maybe Loc
codeCallSafety :: Code -> Safety
..} = do
  -- Write out definitions
  Context
ctx <- Q Context
getContext
  let out :: [Char] -> [Char]
out = ([Char] -> [Char]) -> Maybe ([Char] -> [Char]) -> [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char] -> [Char]
forall a. a -> a
id (Maybe ([Char] -> [Char]) -> [Char] -> [Char])
-> Maybe ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Context -> Maybe ([Char] -> [Char])
ctxOutput Context
ctx
  let directive :: [Char]
directive = [Char] -> (Loc -> [Char]) -> Maybe Loc -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (\Loc
l -> [Char]
"#line " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ((Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ Loc -> (Int, Int)
TH.loc_start Loc
l) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show (Loc -> [Char]
TH.loc_filename Loc
l ) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n") Maybe Loc
codeLoc
  DecsQ -> Q ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (DecsQ -> Q ()) -> DecsQ -> Q ()
forall a b. (a -> b) -> a -> b
$ [Char] -> DecsQ
emitVerbatim ([Char] -> DecsQ) -> [Char] -> DecsQ
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
out ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
directive [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
codeDefs
  -- Create and add the FFI declaration.
  Name
ffiImportName <- Q Name
uniqueFfiImportName
  Dec
dec <- if Bool
codeFunPtr
    then
      Callconv -> Safety -> [Char] -> Name -> TypeQ -> Q Dec
forall (m :: * -> *).
Quote m =>
Callconv -> Safety -> [Char] -> Name -> m Type -> m Dec
TH.forImpD Callconv
TH.CCall Safety
codeCallSafety ([Char]
"&" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
codeFunName) Name
ffiImportName [t| FunPtr $(codeType) |]
    else Callconv -> Safety -> [Char] -> Name -> TypeQ -> Q Dec
forall (m :: * -> *).
Quote m =>
Callconv -> Safety -> [Char] -> Name -> m Type -> m Dec
TH.forImpD Callconv
TH.CCall Safety
codeCallSafety [Char]
codeFunName Name
ffiImportName TypeQ
codeType
  [Dec] -> Q ()
TH.addTopDecls [Dec
dec]
  Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
ffiImportName

uniqueCName :: Maybe String -> TH.Q String
uniqueCName :: Maybe [Char] -> Q [Char]
uniqueCName Maybe [Char]
mbPostfix = do
  -- The name looks like this:
  -- inline_c_MODULE_INDEX_POSTFIX
  --
  -- Where:
  --  * MODULE is the module name but with _s instead of .s;
  --  * INDEX is a counter that keeps track of how many names we're generating
  --    for each module.
  --  * POSTFIX is an optional postfix to ease debuggability
  --
  -- we previously also generated a hash from the contents of the
  -- C code because of problems when cabal recompiled but now this
  -- is not needed anymore since we use 'addDependentFile' to compile
  -- the C code.
  Int
c' <- Q Int
bumpGeneratedNames
  [Char]
module_ <- Loc -> [Char]
TH.loc_module (Loc -> [Char]) -> Q Loc -> Q [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Loc
TH.location
  let replaceDot :: Char -> Char
replaceDot Char
'.' = Char
'_'
      replaceDot Char
c = Char
c
  let postfix :: [Char]
postfix = case Maybe [Char]
mbPostfix of
        Maybe [Char]
Nothing -> [Char]
""
        Just [Char]
s -> [Char]
"_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_"
  [Char] -> Q [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Q [Char]) -> [Char] -> Q [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"inline_c_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
replaceDot [Char]
module_ [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
c' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
postfix

-- | Same as 'inlineCItems', but with a single expression.
--
-- @
-- c_cos :: Double -> Double
-- c_cos = $(do
--   here <- TH.location
--   inlineExp
--     TH.Unsafe
--     here
--     [t| Double -> Double |]
--     (quickCParser_ \"double\" parseType)
--     [("x", quickCParser_ \"double\" parseType)]
--     "cos(x)")
-- @
inlineExp
  :: TH.Safety
  -- ^ Safety of the foreign call
  -> TH.Loc
  -- ^ The location to report
  -> TH.TypeQ
  -- ^ Type of the foreign call
  -> C.Type C.CIdentifier
  -- ^ Return type of the C expr
  -> [(C.CIdentifier, C.Type C.CIdentifier)]
  -- ^ Parameters of the C expr
  -> String
  -- ^ The C expression
  -> TH.ExpQ
inlineExp :: Safety
-> Loc
-> TypeQ
-> Type CIdentifier
-> [(CIdentifier, Type CIdentifier)]
-> [Char]
-> ExpQ
inlineExp Safety
callSafety Loc
loc TypeQ
type_ Type CIdentifier
cRetType [(CIdentifier, Type CIdentifier)]
cParams [Char]
cExp =
  Safety
-> Bool
-> Maybe [Char]
-> Loc
-> TypeQ
-> Type CIdentifier
-> [(CIdentifier, Type CIdentifier)]
-> [Char]
-> ExpQ
inlineItems Safety
callSafety Bool
False Maybe [Char]
forall a. Maybe a
Nothing Loc
loc TypeQ
type_ Type CIdentifier
cRetType [(CIdentifier, Type CIdentifier)]
cParams [Char]
cItems
  where
    cItems :: [Char]
cItems = case Type CIdentifier
cRetType of
      C.TypeSpecifier Specifiers
_quals TypeSpecifier
C.Void -> [Char]
cExp [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
";"
      Type CIdentifier
_ -> [Char]
"return (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cExp [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
");"

-- | Same as 'inlineCode', but accepts a string containing a list of C
-- statements instead instead than a full-blown 'Code'.  A function
-- containing the provided statement will be automatically generated.
--
-- @
-- c_cos :: Double -> Double
-- c_cos = $(do
--  here <- TH.location
--  inlineItems
--   TH.Unsafe
--   False
--   Nothing
--   here
--   [t| Double -> Double |]
--   (quickCParser_ \"double\" parseType)
--   [("x", quickCParser_ \"double\" parseType)]
--   "return cos(x);")
-- @
inlineItems
  :: TH.Safety
  -- ^ Safety of the foreign call
  -> Bool
  -- ^ Whether to return as a FunPtr or not
  -> Maybe String
  -- ^ Optional postfix for the generated name
  -> TH.Loc
  -- ^ The location to report
  -> TH.TypeQ
  -- ^ Type of the foreign call
  -> C.Type C.CIdentifier
  -- ^ Return type of the C expr
  -> [(C.CIdentifier, C.Type C.CIdentifier)]
  -- ^ Parameters of the C expr
  -> String
  -- ^ The C items
  -> TH.ExpQ
inlineItems :: Safety
-> Bool
-> Maybe [Char]
-> Loc
-> TypeQ
-> Type CIdentifier
-> [(CIdentifier, Type CIdentifier)]
-> [Char]
-> ExpQ
inlineItems Safety
callSafety Bool
funPtr Maybe [Char]
mbPostfix Loc
loc TypeQ
type_ Type CIdentifier
cRetType [(CIdentifier, Type CIdentifier)]
cParams [Char]
cItems = do
  let mkParam :: (i, Type i) -> ParameterDeclaration i
mkParam (i
id', Type i
paramTy) = Maybe i -> Type i -> ParameterDeclaration i
forall i. Maybe i -> Type i -> ParameterDeclaration i
C.ParameterDeclaration (i -> Maybe i
forall a. a -> Maybe a
Just i
id') Type i
paramTy
  let proto :: Type CIdentifier
proto = Type CIdentifier
-> [ParameterDeclaration CIdentifier] -> Type CIdentifier
forall i. Type i -> [ParameterDeclaration i] -> Type i
C.Proto Type CIdentifier
cRetType (((CIdentifier, Type CIdentifier)
 -> ParameterDeclaration CIdentifier)
-> [(CIdentifier, Type CIdentifier)]
-> [ParameterDeclaration CIdentifier]
forall a b. (a -> b) -> [a] -> [b]
map (CIdentifier, Type CIdentifier) -> ParameterDeclaration CIdentifier
forall {i}. (i, Type i) -> ParameterDeclaration i
mkParam [(CIdentifier, Type CIdentifier)]
cParams)
  Context
ctx <- Q Context
getContext
  [Char]
funName <- Maybe [Char] -> Q [Char]
uniqueCName Maybe [Char]
mbPostfix
  CIdentifier
cFunName <- case Bool -> [Char] -> Either [Char] CIdentifier
C.cIdentifierFromString (Context -> Bool
ctxEnableCpp Context
ctx) [Char]
funName of
    Left [Char]
err -> [Char] -> Q CIdentifier
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q CIdentifier) -> [Char] -> Q CIdentifier
forall a b. (a -> b) -> a -> b
$ [Char]
"inlineItems: impossible, generated bad C identifier " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                       [Char]
"funName:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err
    Right CIdentifier
x -> CIdentifier -> Q CIdentifier
forall (m :: * -> *) a. Monad m => a -> m a
return CIdentifier
x
  let decl :: ParameterDeclaration CIdentifier
decl = Maybe CIdentifier
-> Type CIdentifier -> ParameterDeclaration CIdentifier
forall i. Maybe i -> Type i -> ParameterDeclaration i
C.ParameterDeclaration (CIdentifier -> Maybe CIdentifier
forall a. a -> Maybe a
Just CIdentifier
cFunName) Type CIdentifier
proto
  let defs :: [Char]
defs = ParameterDeclaration CIdentifier -> [Char]
forall a. Pretty a => a -> [Char]
prettyOneLine ParameterDeclaration CIdentifier
decl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" { " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cItems [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" }\n"
  Code -> ExpQ
inlineCode (Code -> ExpQ) -> Code -> ExpQ
forall a b. (a -> b) -> a -> b
$ Code :: Safety -> Maybe Loc -> TypeQ -> [Char] -> [Char] -> Bool -> Code
Code
    { codeCallSafety :: Safety
codeCallSafety = Safety
callSafety
    , codeLoc :: Maybe Loc
codeLoc = Loc -> Maybe Loc
forall a. a -> Maybe a
Just Loc
loc
    , codeType :: TypeQ
codeType = TypeQ
type_
    , codeFunName :: [Char]
codeFunName = [Char]
funName
    , codeDefs :: [Char]
codeDefs = [Char]
defs
    , codeFunPtr :: Bool
codeFunPtr = Bool
funPtr
    }

------------------------------------------------------------------------
-- Parsing

runParserInQ
  :: (Hashable ident)
  => String
  -> C.CParserContext ident
  -> (forall m. C.CParser ident m => m a) -> TH.Q a
runParserInQ :: forall ident a.
Hashable ident =>
[Char]
-> CParserContext ident
-> (forall (m :: * -> *). CParser ident m => m a)
-> Q a
runParserInQ [Char]
s CParserContext ident
ctx forall (m :: * -> *). CParser ident m => m a
p = do
  Loc
loc <- Q Loc
TH.location
  let (Int
line, Int
col) = Loc -> (Int, Int)
TH.loc_start Loc
loc
  let parsecLoc :: SourcePos
parsecLoc = [Char] -> Int -> Int -> SourcePos
Parsec.newPos (Loc -> [Char]
TH.loc_filename Loc
loc) Int
line Int
col
  let p' :: ReaderT (CParserContext ident) (ParsecT [Char] () Identity) a
p' = ParsecT [Char] () Identity ()
-> ReaderT (CParserContext ident) (ParsecT [Char] () Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (SourcePos -> ParsecT [Char] () Identity ()
forall (m :: * -> *) s u. Monad m => SourcePos -> ParsecT s u m ()
Parsec.setPosition SourcePos
parsecLoc) ReaderT (CParserContext ident) (ParsecT [Char] () Identity) ()
-> ReaderT (CParserContext ident) (ParsecT [Char] () Identity) a
-> ReaderT (CParserContext ident) (ParsecT [Char] () Identity) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ReaderT (CParserContext ident) (ParsecT [Char] () Identity) a
forall (m :: * -> *). CParser ident m => m a
p ReaderT (CParserContext ident) (ParsecT [Char] () Identity) a
-> ReaderT (CParserContext ident) (ParsecT [Char] () Identity) ()
-> ReaderT (CParserContext ident) (ParsecT [Char] () Identity) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT [Char] () Identity ()
-> ReaderT (CParserContext ident) (ParsecT [Char] () Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ParsecT [Char] () Identity ()
forall (m :: * -> *). Parsing m => m ()
Parser.eof
  case CParserContext ident
-> [Char]
-> [Char]
-> ReaderT (CParserContext ident) (ParsecT [Char] () Identity) a
-> Either ParseError a
forall s i a.
Stream s Identity Char =>
CParserContext i
-> [Char]
-> s
-> ReaderT (CParserContext i) (Parsec s ()) a
-> Either ParseError a
C.runCParser CParserContext ident
ctx (Loc -> [Char]
TH.loc_filename Loc
loc) [Char]
s ReaderT (CParserContext ident) (ParsecT [Char] () Identity) a
p' of
    Left ParseError
err -> do
      -- TODO consider prefixing with "error while parsing C" or similar
      [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q a) -> [Char] -> Q a
forall a b. (a -> b) -> a -> b
$ ParseError -> [Char]
forall a. Show a => a -> [Char]
show ParseError
err
    Right a
res -> do
      a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

data SomeEq = forall a. (Typeable a, Eq a) => SomeEq a

instance Eq SomeEq where
  SomeEq a
x == :: SomeEq -> SomeEq -> Bool
== SomeEq a
y = case a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x of
    Maybe a
Nothing -> Bool
False
    Just a
x' -> a
x' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y

instance Show SomeEq where
  show :: SomeEq -> [Char]
show SomeEq
_ = [Char]
"<<SomeEq>>"

toSomeEq :: (Eq a, Typeable a) => a -> SomeEq
toSomeEq :: forall a. (Eq a, Typeable a) => a -> SomeEq
toSomeEq a
x = a -> SomeEq
forall a. (Typeable a, Eq a) => a -> SomeEq
SomeEq a
x

fromSomeEq :: (Eq a, Typeable a) => SomeEq -> Maybe a
fromSomeEq :: forall a. (Eq a, Typeable a) => SomeEq -> Maybe a
fromSomeEq (SomeEq a
x) = a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x

data ParameterType
  = Plain HaskellIdentifier                -- The name of the captured variable
  | AntiQuote AntiQuoterId SomeEq
  deriving (Int -> ParameterType -> [Char] -> [Char]
[ParameterType] -> [Char] -> [Char]
ParameterType -> [Char]
(Int -> ParameterType -> [Char] -> [Char])
-> (ParameterType -> [Char])
-> ([ParameterType] -> [Char] -> [Char])
-> Show ParameterType
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [ParameterType] -> [Char] -> [Char]
$cshowList :: [ParameterType] -> [Char] -> [Char]
show :: ParameterType -> [Char]
$cshow :: ParameterType -> [Char]
showsPrec :: Int -> ParameterType -> [Char] -> [Char]
$cshowsPrec :: Int -> ParameterType -> [Char] -> [Char]
Show, ParameterType -> ParameterType -> Bool
(ParameterType -> ParameterType -> Bool)
-> (ParameterType -> ParameterType -> Bool) -> Eq ParameterType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParameterType -> ParameterType -> Bool
$c/= :: ParameterType -> ParameterType -> Bool
== :: ParameterType -> ParameterType -> Bool
$c== :: ParameterType -> ParameterType -> Bool
Eq)

data ParseTypedC = ParseTypedC
  { ParseTypedC -> Type CIdentifier
ptcReturnType :: C.Type C.CIdentifier
  , ParseTypedC -> [(CIdentifier, Type CIdentifier, ParameterType)]
ptcParameters :: [(C.CIdentifier, C.Type C.CIdentifier, ParameterType)]
  , ParseTypedC -> [Char]
ptcBody :: String
  }

newtype Substitutions = Substitutions { Substitutions -> Map [Char] ([Char] -> [Char])
unSubstitutions :: M.Map String (String -> String) }

applySubstitutions :: String -> TH.Q String
applySubstitutions :: [Char] -> Q [Char]
applySubstitutions [Char]
str = do
  Map [Char] ([Char] -> [Char])
subs <- Map [Char] ([Char] -> [Char])
-> (Substitutions -> Map [Char] ([Char] -> [Char]))
-> Maybe Substitutions
-> Map [Char] ([Char] -> [Char])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map [Char] ([Char] -> [Char])
forall a. Monoid a => a
mempty Substitutions -> Map [Char] ([Char] -> [Char])
unSubstitutions (Maybe Substitutions -> Map [Char] ([Char] -> [Char]))
-> Q (Maybe Substitutions) -> Q (Map [Char] ([Char] -> [Char]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q (Maybe Substitutions)
forall a. Typeable a => Q (Maybe a)
TH.getQ
  let substitution :: ParsecT [Char] () Identity [Char]
substitution = [ParsecT [Char] () Identity [Char]]
-> ParsecT [Char] () Identity [Char]
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([ParsecT [Char] () Identity [Char]]
 -> ParsecT [Char] () Identity [Char])
-> [ParsecT [Char] () Identity [Char]]
-> ParsecT [Char] () Identity [Char]
forall a b. (a -> b) -> a -> b
$ ((([Char], [Char] -> [Char]) -> ParsecT [Char] () Identity [Char])
 -> [([Char], [Char] -> [Char])]
 -> [ParsecT [Char] () Identity [Char]])
-> [([Char], [Char] -> [Char])]
-> (([Char], [Char] -> [Char])
    -> ParsecT [Char] () Identity [Char])
-> [ParsecT [Char] () Identity [Char]]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (([Char], [Char] -> [Char]) -> ParsecT [Char] () Identity [Char])
-> [([Char], [Char] -> [Char])]
-> [ParsecT [Char] () Identity [Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Map [Char] ([Char] -> [Char]) -> [([Char], [Char] -> [Char])]
forall k a. Map k a -> [(k, a)]
M.toList Map [Char] ([Char] -> [Char])
subs) ((([Char], [Char] -> [Char]) -> ParsecT [Char] () Identity [Char])
 -> [ParsecT [Char] () Identity [Char]])
-> (([Char], [Char] -> [Char])
    -> ParsecT [Char] () Identity [Char])
-> [ParsecT [Char] () Identity [Char]]
forall a b. (a -> b) -> a -> b
$ \( [Char]
subName, [Char] -> [Char]
subFunc ) ->
        ParsecT [Char] () Identity [Char]
-> ParsecT [Char] () Identity [Char]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
Parsec.try (ParsecT [Char] () Identity [Char]
 -> ParsecT [Char] () Identity [Char])
-> ParsecT [Char] () Identity [Char]
-> ParsecT [Char] () Identity [Char]
forall a b. (a -> b) -> a -> b
$ do
          [Char]
_ <- [Char] -> ParsecT [Char] () Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
Parsec.string (Char
'@' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
subName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"(")
          [Char]
subArg <- ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity [Char]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
Parsec.manyTill ParsecT [Char] () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
Parsec.anyChar (Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
Parsec.char Char
')')
          [Char] -> ParsecT [Char] () Identity [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> [Char]
subFunc [Char]
subArg)
  let someChar :: ParsecT [Char] u Identity [Char]
someChar = (Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[]) (Char -> [Char])
-> ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Char] u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
Parsec.anyChar
  case Parsec [Char] () [[Char]]
-> [Char] -> [Char] -> Either ParseError [[Char]]
forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
Parsec.parse (ParsecT [Char] () Identity [Char] -> Parsec [Char] () [[Char]]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ParsecT [Char] () Identity [Char]
substitution ParsecT [Char] () Identity [Char]
-> ParsecT [Char] () Identity [Char]
-> ParsecT [Char] () Identity [Char]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT [Char] () Identity [Char]
forall {u}. ParsecT [Char] u Identity [Char]
someChar)) [Char]
"" [Char]
str of
    Left ParseError
_ -> [Char] -> Q [Char]
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Substitution failed (should be impossible)"
    Right [[Char]]
chunks -> [Char] -> Q [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]]
chunks)

-- | Define macros that can be used in the nested Template Haskell expression.
-- Macros can be used as @\@MACRO_NAME(input)@ in inline-c quotes, and will transform their input with the given function.
-- They can be useful for passing in types when defining Haskell instances for C++ template types.
substitute :: [ ( String, String -> String ) ] -> TH.Q a -> TH.Q a
substitute :: forall a. [([Char], [Char] -> [Char])] -> Q a -> Q a
substitute [([Char], [Char] -> [Char])]
subsList Q a
cont = do
  Map [Char] ([Char] -> [Char])
oldSubs <- Map [Char] ([Char] -> [Char])
-> (Substitutions -> Map [Char] ([Char] -> [Char]))
-> Maybe Substitutions
-> Map [Char] ([Char] -> [Char])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map [Char] ([Char] -> [Char])
forall a. Monoid a => a
mempty Substitutions -> Map [Char] ([Char] -> [Char])
unSubstitutions (Maybe Substitutions -> Map [Char] ([Char] -> [Char]))
-> Q (Maybe Substitutions) -> Q (Map [Char] ([Char] -> [Char]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q (Maybe Substitutions)
forall a. Typeable a => Q (Maybe a)
TH.getQ
  let subs :: Map [Char] ([Char] -> [Char])
subs = [([Char], [Char] -> [Char])] -> Map [Char] ([Char] -> [Char])
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [([Char], [Char] -> [Char])]
subsList
  let conflicting :: Map [Char] ([Char] -> [Char])
conflicting = Map [Char] ([Char] -> [Char])
-> Map [Char] ([Char] -> [Char]) -> Map [Char] ([Char] -> [Char])
forall k a b. Ord k => Map k a -> Map k b -> Map k a
M.intersection Map [Char] ([Char] -> [Char])
subs Map [Char] ([Char] -> [Char])
oldSubs
  Substitutions
newSubs <-
    if Map [Char] ([Char] -> [Char]) -> Bool
forall k a. Map k a -> Bool
M.null Map [Char] ([Char] -> [Char])
conflicting
      then Substitutions -> Q Substitutions
forall (m :: * -> *) a. Monad m => a -> m a
return (Map [Char] ([Char] -> [Char]) -> Substitutions
Substitutions (Map [Char] ([Char] -> [Char])
-> Map [Char] ([Char] -> [Char]) -> Map [Char] ([Char] -> [Char])
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map [Char] ([Char] -> [Char])
oldSubs Map [Char] ([Char] -> [Char])
subs))
      else [Char] -> Q Substitutions
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Conflicting substitutions `" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show (Map [Char] ([Char] -> [Char]) -> [[Char]]
forall k a. Map k a -> [k]
M.keys Map [Char] ([Char] -> [Char])
conflicting) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"`")
  Substitutions -> Q ()
forall a. Typeable a => a -> Q ()
TH.putQ Substitutions
newSubs Q () -> Q a -> Q a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Q a
cont Q a -> Q () -> Q a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Substitutions -> Q ()
forall a. Typeable a => a -> Q ()
TH.putQ (Map [Char] ([Char] -> [Char]) -> Substitutions
Substitutions Map [Char] ([Char] -> [Char])
oldSubs)

-- | Given a C type name, return the Haskell type in Template Haskell. The first parameter controls whether function pointers
-- should be mapped as pure or IO functions.
getHaskellType :: Bool -> String -> TH.TypeQ
getHaskellType :: Bool -> [Char] -> TypeQ
getHaskellType Bool
pureFunctions [Char]
cTypeStr = do
  Context
ctx <- Q Context
getContext
  let cParseCtx :: CParserContext CIdentifier
cParseCtx = Bool -> TypeNames -> CParserContext CIdentifier
C.cCParserContext (Context -> Bool
ctxEnableCpp Context
ctx) (TypesTable -> TypeNames
typeNamesFromTypesTable (Context -> TypesTable
ctxTypesTable Context
ctx))
  Type CIdentifier
cType <- [Char]
-> CParserContext CIdentifier
-> (forall (m :: * -> *).
    CParser CIdentifier m =>
    m (Type CIdentifier))
-> Q (Type CIdentifier)
forall ident a.
Hashable ident =>
[Char]
-> CParserContext ident
-> (forall (m :: * -> *). CParser ident m => m a)
-> Q a
runParserInQ [Char]
cTypeStr CParserContext CIdentifier
cParseCtx forall i (m :: * -> *). (CParser i m, Pretty i) => m (Type i)
forall (m :: * -> *). CParser CIdentifier m => m (Type CIdentifier)
C.parseType
  Context -> Purity -> Type CIdentifier -> TypeQ
cToHs Context
ctx (if Bool
pureFunctions then Purity
Pure else Purity
IO) Type CIdentifier
cType

-- To parse C declarations, we're faced with a bit of a problem: we want
-- to parse the anti-quotations so that Haskell identifiers are
-- accepted, but we want them to appear only as the root of
-- declarations.  For this reason, we parse allowing Haskell identifiers
-- everywhere, and then we "purge" Haskell identifiers everywhere but at
-- the root.
parseTypedC
  :: forall m. C.CParser HaskellIdentifier m
  => Bool -> AntiQuoters -> m ParseTypedC
  -- ^ Returns the return type, the captured variables, and the body.
parseTypedC :: forall (m :: * -> *).
CParser HaskellIdentifier m =>
Bool -> AntiQuoters -> m ParseTypedC
parseTypedC Bool
useCpp AntiQuoters
antiQs = do
  -- Parse return type (consume spaces first)
  m ()
forall (m :: * -> *). CharParsing m => m ()
Parser.spaces
  Type CIdentifier
cRetType <- Type HaskellIdentifier -> m (Type CIdentifier)
forall (n :: * -> *).
MonadFail n =>
Type HaskellIdentifier -> n (Type CIdentifier)
purgeHaskellIdentifiers (Type HaskellIdentifier -> m (Type CIdentifier))
-> m (Type HaskellIdentifier) -> m (Type CIdentifier)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Type HaskellIdentifier)
forall i (m :: * -> *). (CParser i m, Pretty i) => m (Type i)
C.parseType
  -- Parse the body
  m Char -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Char -> m ()) -> m Char -> m ()
forall a b. (a -> b) -> a -> b
$ Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
Parser.char Char
'{'
  ([(CIdentifier, Type CIdentifier, ParameterType)]
cParams, [Char]
cBody) <- StateT
  Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
-> Int
-> m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT
  Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
parseBody Int
0
  ParseTypedC -> m ParseTypedC
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseTypedC -> m ParseTypedC) -> ParseTypedC -> m ParseTypedC
forall a b. (a -> b) -> a -> b
$ Type CIdentifier
-> [(CIdentifier, Type CIdentifier, ParameterType)]
-> [Char]
-> ParseTypedC
ParseTypedC Type CIdentifier
cRetType [(CIdentifier, Type CIdentifier, ParameterType)]
cParams [Char]
cBody
  where
    parseBody
      :: StateT Int m ([(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String)
    parseBody :: StateT
  Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
parseBody = do
      -- Note that this code does not use "lexing" combinators (apart
      -- when appropriate) because we want to make sure to preserve
      -- whitespace after we substitute things.
      [Char]
s <- StateT Int m Char -> StateT Int m Char -> StateT Int m [Char]
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m [a]
Parser.manyTill StateT Int m Char
forall (m :: * -> *). CharParsing m => m Char
Parser.anyChar (StateT Int m Char -> StateT Int m [Char])
-> StateT Int m Char -> StateT Int m [Char]
forall a b. (a -> b) -> a -> b
$
           StateT Int m Char -> StateT Int m Char
forall (m :: * -> *) a. LookAheadParsing m => m a -> m a
Parser.lookAhead (Char -> StateT Int m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
Parser.char Char
'}' StateT Int m Char -> StateT Int m Char -> StateT Int m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> StateT Int m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
Parser.char Char
'$')
      ([(CIdentifier, Type CIdentifier, ParameterType)]
decls, [Char]
s') <- [StateT
   Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])]
-> StateT
     Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
        [ do StateT Int m () -> StateT Int m ()
forall (m :: * -> *) a. Parsing m => m a -> m a
Parser.try (StateT Int m () -> StateT Int m ())
-> StateT Int m () -> StateT Int m ()
forall a b. (a -> b) -> a -> b
$ do -- Try because we might fail to parse the 'eof'
                -- 'symbolic' because we want to consume whitespace
               StateT Int m Char -> StateT Int m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Int m Char -> StateT Int m ())
-> StateT Int m Char -> StateT Int m ()
forall a b. (a -> b) -> a -> b
$ Char -> StateT Int m Char
forall (m :: * -> *). TokenParsing m => Char -> m Char
Parser.symbolic Char
'}'
               StateT Int m ()
forall (m :: * -> *). Parsing m => m ()
Parser.eof
             ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
-> StateT
     Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Char]
"")
        , do StateT Int m Char -> StateT Int m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Int m Char -> StateT Int m ())
-> StateT Int m Char -> StateT Int m ()
forall a b. (a -> b) -> a -> b
$ Char -> StateT Int m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
Parser.char Char
'}'
             ([(CIdentifier, Type CIdentifier, ParameterType)]
decls, [Char]
s') <- StateT
  Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
parseBody
             ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
-> StateT
     Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return ([(CIdentifier, Type CIdentifier, ParameterType)]
decls, [Char]
"}" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s')
        , do StateT Int m Char -> StateT Int m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Int m Char -> StateT Int m ())
-> StateT Int m Char -> StateT Int m ()
forall a b. (a -> b) -> a -> b
$ Char -> StateT Int m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
Parser.char Char
'$'
             ([(CIdentifier, Type CIdentifier, ParameterType)]
decls1, [Char]
s1) <- StateT
  Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
forall a. StateT Int m ([a], [Char])
parseEscapedDollar StateT
  Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
-> StateT
     Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
-> StateT
     Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> StateT
  Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
parseAntiQuote StateT
  Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
-> StateT
     Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
-> StateT
     Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> StateT
  Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
parseTypedCapture
             ([(CIdentifier, Type CIdentifier, ParameterType)]
decls2, [Char]
s2) <- StateT
  Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
parseBody
             ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
-> StateT
     Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return ([(CIdentifier, Type CIdentifier, ParameterType)]
decls1 [(CIdentifier, Type CIdentifier, ParameterType)]
-> [(CIdentifier, Type CIdentifier, ParameterType)]
-> [(CIdentifier, Type CIdentifier, ParameterType)]
forall a. [a] -> [a] -> [a]
++ [(CIdentifier, Type CIdentifier, ParameterType)]
decls2, [Char]
s1 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s2)
        ]
      ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
-> StateT
     Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return ([(CIdentifier, Type CIdentifier, ParameterType)]
decls, [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s')
      where

    parseAntiQuote
      :: StateT Int m ([(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String)
    parseAntiQuote :: StateT
  Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
parseAntiQuote = [StateT
   Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])]
-> StateT
     Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
      [ do StateT Int m [Char] -> StateT Int m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Int m [Char] -> StateT Int m ())
-> StateT Int m [Char] -> StateT Int m ()
forall a b. (a -> b) -> a -> b
$ StateT Int m [Char] -> StateT Int m [Char]
forall (m :: * -> *) a. Parsing m => m a -> m a
Parser.try ([Char] -> StateT Int m [Char]
forall (m :: * -> *). CharParsing m => [Char] -> m [Char]
Parser.string ([Char] -> StateT Int m [Char]) -> [Char] -> StateT Int m [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
antiQId [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":") StateT Int m [Char] -> [Char] -> StateT Int m [Char]
forall (m :: * -> *) a. Parsing m => m a -> [Char] -> m a
Parser.<?> [Char]
"anti quoter id"
           (CIdentifier
s, Type CIdentifier
cTy, a
x) <- AntiQuoter a
-> forall (m :: * -> *).
   CParser HaskellIdentifier m =>
   m (CIdentifier, Type CIdentifier, a)
forall a.
AntiQuoter a
-> forall (m :: * -> *).
   CParser HaskellIdentifier m =>
   m (CIdentifier, Type CIdentifier, a)
aqParser AntiQuoter a
antiQ
           CIdentifier
id' <- CIdentifier -> StateT Int m CIdentifier
freshId CIdentifier
s
           ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
-> StateT
     Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return ([(CIdentifier
id', Type CIdentifier
cTy, [Char] -> SomeEq -> ParameterType
AntiQuote [Char]
antiQId (a -> SomeEq
forall a. (Eq a, Typeable a) => a -> SomeEq
toSomeEq a
x))], CIdentifier -> [Char]
C.unCIdentifier CIdentifier
id')
      | ([Char]
antiQId, SomeAntiQuoter AntiQuoter a
antiQ) <- AntiQuoters -> [([Char], SomeAntiQuoter)]
forall k a. Map k a -> [(k, a)]
Map.toList AntiQuoters
antiQs
      ]

    parseEscapedDollar :: StateT Int m ([a], String)
    parseEscapedDollar :: forall a. StateT Int m ([a], [Char])
parseEscapedDollar = do
      StateT Int m Char -> StateT Int m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Int m Char -> StateT Int m ())
-> StateT Int m Char -> StateT Int m ()
forall a b. (a -> b) -> a -> b
$ Char -> StateT Int m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
Parser.char Char
'$'
      ([a], [Char]) -> StateT Int m ([a], [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Char]
"$")

    parseTypedCapture
      :: StateT Int m ([(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String)
    parseTypedCapture :: StateT
  Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
parseTypedCapture = do
      StateT Int m Char -> StateT Int m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Int m Char -> StateT Int m ())
-> StateT Int m Char -> StateT Int m ()
forall a b. (a -> b) -> a -> b
$ Char -> StateT Int m Char
forall (m :: * -> *). TokenParsing m => Char -> m Char
Parser.symbolic Char
'('
      ParameterDeclaration HaskellIdentifier
decl <- StateT Int m (ParameterDeclaration HaskellIdentifier)
forall i (m :: * -> *).
(CParser i m, Pretty i) =>
m (ParameterDeclaration i)
C.parseParameterDeclaration
      Type CIdentifier
declType <- Type HaskellIdentifier -> StateT Int m (Type CIdentifier)
forall (n :: * -> *).
MonadFail n =>
Type HaskellIdentifier -> n (Type CIdentifier)
purgeHaskellIdentifiers (Type HaskellIdentifier -> StateT Int m (Type CIdentifier))
-> Type HaskellIdentifier -> StateT Int m (Type CIdentifier)
forall a b. (a -> b) -> a -> b
$ ParameterDeclaration HaskellIdentifier -> Type HaskellIdentifier
forall i. ParameterDeclaration i -> Type i
C.parameterDeclarationType ParameterDeclaration HaskellIdentifier
decl
      -- Purge the declaration type of all the Haskell identifiers.
      HaskellIdentifier
hId <- case ParameterDeclaration HaskellIdentifier -> Maybe HaskellIdentifier
forall i. ParameterDeclaration i -> Maybe i
C.parameterDeclarationId ParameterDeclaration HaskellIdentifier
decl of
        Maybe HaskellIdentifier
Nothing -> [Char] -> StateT Int m HaskellIdentifier
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> StateT Int m HaskellIdentifier)
-> [Char] -> StateT Int m HaskellIdentifier
forall a b. (a -> b) -> a -> b
$ Doc -> [Char]
forall a. Pretty a => a -> [Char]
pretty80 (Doc -> [Char]) -> Doc -> [Char]
forall a b. (a -> b) -> a -> b
$
          Doc
"Un-named captured variable in decl" Doc -> Doc -> Doc
<+> ParameterDeclaration HaskellIdentifier -> Doc
forall a. Pretty a => a -> Doc
PP.pretty ParameterDeclaration HaskellIdentifier
decl
        Just HaskellIdentifier
hId -> HaskellIdentifier -> StateT Int m HaskellIdentifier
forall (m :: * -> *) a. Monad m => a -> m a
return HaskellIdentifier
hId
      CIdentifier
id' <- CIdentifier -> StateT Int m CIdentifier
freshId (CIdentifier -> StateT Int m CIdentifier)
-> CIdentifier -> StateT Int m CIdentifier
forall a b. (a -> b) -> a -> b
$ Bool -> HaskellIdentifier -> CIdentifier
mangleHaskellIdentifier Bool
useCpp HaskellIdentifier
hId
      StateT Int m Char -> StateT Int m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Int m Char -> StateT Int m ())
-> StateT Int m Char -> StateT Int m ()
forall a b. (a -> b) -> a -> b
$ Char -> StateT Int m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
Parser.char Char
')'
      ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
-> StateT
     Int m ([(CIdentifier, Type CIdentifier, ParameterType)], [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return ([(CIdentifier
id', Type CIdentifier
declType, HaskellIdentifier -> ParameterType
Plain HaskellIdentifier
hId)], CIdentifier -> [Char]
C.unCIdentifier CIdentifier
id')

    freshId :: CIdentifier -> StateT Int m CIdentifier
freshId CIdentifier
s = do
      Int
c <- StateT Int m Int
forall s (m :: * -> *). MonadState s m => m s
get
      Int -> StateT Int m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int -> StateT Int m ()) -> Int -> StateT Int m ()
forall a b. (a -> b) -> a -> b
$ Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
      case Bool -> [Char] -> Either [Char] CIdentifier
C.cIdentifierFromString Bool
useCpp (CIdentifier -> [Char]
C.unCIdentifier CIdentifier
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_inline_c_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
c) of
        Left [Char]
_err -> [Char] -> StateT Int m CIdentifier
forall a. HasCallStack => [Char] -> a
error [Char]
"freshId: The impossible happened"
        Right CIdentifier
x -> CIdentifier -> StateT Int m CIdentifier
forall (m :: * -> *) a. Monad m => a -> m a
return CIdentifier
x

    -- The @m@ is polymorphic because we use this both for the plain
    -- parser and the StateT parser we use above.  We only need 'fail'.
    purgeHaskellIdentifiers
#if MIN_VERSION_base(4,13,0)
      :: forall n. MonadFail n
#else
      :: forall n. (Applicative n, Monad n)
#endif
      => C.Type HaskellIdentifier -> n (C.Type C.CIdentifier)
    purgeHaskellIdentifiers :: forall (n :: * -> *).
MonadFail n =>
Type HaskellIdentifier -> n (Type CIdentifier)
purgeHaskellIdentifiers Type HaskellIdentifier
cTy = Type HaskellIdentifier
-> (HaskellIdentifier -> n CIdentifier) -> n (Type CIdentifier)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Type HaskellIdentifier
cTy ((HaskellIdentifier -> n CIdentifier) -> n (Type CIdentifier))
-> (HaskellIdentifier -> n CIdentifier) -> n (Type CIdentifier)
forall a b. (a -> b) -> a -> b
$ \HaskellIdentifier
hsIdent -> do
      let hsIdentS :: [Char]
hsIdentS = HaskellIdentifier -> [Char]
unHaskellIdentifier HaskellIdentifier
hsIdent
      case Bool -> [Char] -> Either [Char] CIdentifier
C.cIdentifierFromString Bool
useCpp [Char]
hsIdentS of
        Left [Char]
err -> [Char] -> n CIdentifier
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> n CIdentifier) -> [Char] -> n CIdentifier
forall a b. (a -> b) -> a -> b
$ [Char]
"Haskell identifier " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
hsIdentS [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" in illegal position" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                           [Char]
"in C type\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type HaskellIdentifier -> [Char]
forall a. Pretty a => a -> [Char]
pretty80 Type HaskellIdentifier
cTy [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                           [Char]
"A C identifier was expected, but:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err
        Right CIdentifier
cIdent -> CIdentifier -> n CIdentifier
forall (m :: * -> *) a. Monad m => a -> m a
return CIdentifier
cIdent

quoteCode
  :: (String -> TH.ExpQ)
  -- ^ The parser
  -> TH.QuasiQuoter
quoteCode :: ([Char] -> ExpQ) -> QuasiQuoter
quoteCode [Char] -> ExpQ
p = QuasiQuoter :: ([Char] -> ExpQ)
-> ([Char] -> Q Pat)
-> ([Char] -> TypeQ)
-> ([Char] -> DecsQ)
-> QuasiQuoter
TH.QuasiQuoter
  { quoteExp :: [Char] -> ExpQ
TH.quoteExp = [Char] -> ExpQ
p
  , quotePat :: [Char] -> Q Pat
TH.quotePat = Q Pat -> [Char] -> Q Pat
forall a b. a -> b -> a
const (Q Pat -> [Char] -> Q Pat) -> Q Pat -> [Char] -> Q Pat
forall a b. (a -> b) -> a -> b
$ [Char] -> Q Pat
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"inline-c: quotePat not implemented (quoteCode)"
  , quoteType :: [Char] -> TypeQ
TH.quoteType = TypeQ -> [Char] -> TypeQ
forall a b. a -> b -> a
const (TypeQ -> [Char] -> TypeQ) -> TypeQ -> [Char] -> TypeQ
forall a b. (a -> b) -> a -> b
$ [Char] -> TypeQ
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"inline-c: quoteType not implemented (quoteCode)"
  , quoteDec :: [Char] -> DecsQ
TH.quoteDec = DecsQ -> [Char] -> DecsQ
forall a b. a -> b -> a
const (DecsQ -> [Char] -> DecsQ) -> DecsQ -> [Char] -> DecsQ
forall a b. (a -> b) -> a -> b
$ [Char] -> DecsQ
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"inline-c: quoteDec not implemented (quoteCode)"
  }

cToHs :: Context -> Purity -> C.Type C.CIdentifier -> TH.TypeQ
cToHs :: Context -> Purity -> Type CIdentifier -> TypeQ
cToHs Context
ctx Purity
purity Type CIdentifier
cTy = do
  Maybe Type
mbHsTy <- Purity -> TypesTable -> Type CIdentifier -> Q (Maybe Type)
convertType Purity
purity (Context -> TypesTable
ctxTypesTable Context
ctx) Type CIdentifier
cTy
  case Maybe Type
mbHsTy of
    Maybe Type
Nothing -> [Char] -> TypeQ
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> TypeQ) -> [Char] -> TypeQ
forall a b. (a -> b) -> a -> b
$ [Char]
"Could not resolve Haskell type for C type " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type CIdentifier -> [Char]
forall a. Pretty a => a -> [Char]
pretty80 Type CIdentifier
cTy
    Just Type
hsTy -> Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
hsTy

genericQuote
  :: Purity
  -> (TH.Loc -> TH.TypeQ -> C.Type C.CIdentifier -> [(C.CIdentifier, C.Type C.CIdentifier)] -> String -> TH.ExpQ)
  -- ^ Function building an Haskell expression, see 'inlineExp' for
  -- guidance on the other args.
  -> TH.QuasiQuoter
genericQuote :: Purity
-> (Loc
    -> TypeQ
    -> Type CIdentifier
    -> [(CIdentifier, Type CIdentifier)]
    -> [Char]
    -> ExpQ)
-> QuasiQuoter
genericQuote Purity
purity Loc
-> TypeQ
-> Type CIdentifier
-> [(CIdentifier, Type CIdentifier)]
-> [Char]
-> ExpQ
build = ([Char] -> ExpQ) -> QuasiQuoter
quoteCode (([Char] -> ExpQ) -> QuasiQuoter)
-> ([Char] -> ExpQ) -> QuasiQuoter
forall a b. (a -> b) -> a -> b
$ \[Char]
rawStr -> do
    Context
ctx <- Q Context
getContext
    Loc
here <- Q Loc
TH.location
    [Char]
s <- [Char] -> Q [Char]
applySubstitutions [Char]
rawStr
    ParseTypedC Type CIdentifier
cType [(CIdentifier, Type CIdentifier, ParameterType)]
cParams [Char]
cExp <-
      [Char]
-> CParserContext HaskellIdentifier
-> (forall (m :: * -> *).
    CParser HaskellIdentifier m =>
    m ParseTypedC)
-> Q ParseTypedC
forall ident a.
Hashable ident =>
[Char]
-> CParserContext ident
-> (forall (m :: * -> *). CParser ident m => m a)
-> Q a
runParserInQ [Char]
s
        (Bool -> TypeNames -> CParserContext HaskellIdentifier
haskellCParserContext (Context -> Bool
ctxEnableCpp Context
ctx) (TypesTable -> TypeNames
typeNamesFromTypesTable (Context -> TypesTable
ctxTypesTable Context
ctx)))
        (Bool -> AntiQuoters -> m ParseTypedC
forall (m :: * -> *).
CParser HaskellIdentifier m =>
Bool -> AntiQuoters -> m ParseTypedC
parseTypedC (Context -> Bool
ctxEnableCpp Context
ctx) (Context -> AntiQuoters
ctxAntiQuoters Context
ctx))
    Type
hsType <- Context -> Purity -> Type CIdentifier -> TypeQ
cToHs Context
ctx Purity
purity Type CIdentifier
cType
    [(Type, Exp)]
hsParams <- [(CIdentifier, Type CIdentifier, ParameterType)]
-> ((CIdentifier, Type CIdentifier, ParameterType)
    -> Q (Type, Exp))
-> Q [(Type, Exp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(CIdentifier, Type CIdentifier, ParameterType)]
cParams (((CIdentifier, Type CIdentifier, ParameterType) -> Q (Type, Exp))
 -> Q [(Type, Exp)])
-> ((CIdentifier, Type CIdentifier, ParameterType)
    -> Q (Type, Exp))
-> Q [(Type, Exp)]
forall a b. (a -> b) -> a -> b
$ \(CIdentifier
_cId, Type CIdentifier
cTy, ParameterType
parTy) -> do
      case ParameterType
parTy of
        Plain HaskellIdentifier
s' -> do
          Type
hsTy <- Context -> Purity -> Type CIdentifier -> TypeQ
cToHs Context
ctx Purity
purity Type CIdentifier
cTy
          let hsName :: Name
hsName = [Char] -> Name
TH.mkName (HaskellIdentifier -> [Char]
unHaskellIdentifier HaskellIdentifier
s')
          Exp
hsExp <- [| \cont -> cont ($(TH.varE hsName) :: $(return hsTy)) |]
          (Type, Exp) -> Q (Type, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
hsTy, Exp
hsExp)
        AntiQuote [Char]
antiId SomeEq
dyn -> do
          case [Char] -> AntiQuoters -> Maybe SomeAntiQuoter
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
antiId (Context -> AntiQuoters
ctxAntiQuoters Context
ctx) of
            Maybe SomeAntiQuoter
Nothing ->
              [Char] -> Q (Type, Exp)
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q (Type, Exp)) -> [Char] -> Q (Type, Exp)
forall a b. (a -> b) -> a -> b
$ [Char]
"IMPOSSIBLE: could not find anti-quoter " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
antiId [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                     [Char]
". (genericQuote)"
            Just (SomeAntiQuoter AntiQuoter a
antiQ) -> case SomeEq -> Maybe a
forall a. (Eq a, Typeable a) => SomeEq -> Maybe a
fromSomeEq SomeEq
dyn of
              Maybe a
Nothing ->
                [Char] -> Q (Type, Exp)
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail  ([Char] -> Q (Type, Exp)) -> [Char] -> Q (Type, Exp)
forall a b. (a -> b) -> a -> b
$ [Char]
"IMPOSSIBLE: could not cast value for anti-quoter " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                        [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
antiId [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
". (genericQuote)"
              Just a
x ->
                AntiQuoter a
-> Purity -> TypesTable -> Type CIdentifier -> a -> Q (Type, Exp)
forall a.
AntiQuoter a
-> Purity -> TypesTable -> Type CIdentifier -> a -> Q (Type, Exp)
aqMarshaller AntiQuoter a
antiQ Purity
purity (Context -> TypesTable
ctxTypesTable Context
ctx) Type CIdentifier
cTy a
x
    let hsFunType :: TypeQ
hsFunType = Type -> [Type] -> TypeQ
convertCFunSig Type
hsType ([Type] -> TypeQ) -> [Type] -> TypeQ
forall a b. (a -> b) -> a -> b
$ ((Type, Exp) -> Type) -> [(Type, Exp)] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type, Exp) -> Type
forall a b. (a, b) -> a
fst [(Type, Exp)]
hsParams
    let cParams' :: [(CIdentifier, Type CIdentifier)]
cParams' = [(CIdentifier
cId, Type CIdentifier
cTy) | (CIdentifier
cId, Type CIdentifier
cTy, ParameterType
_) <- [(CIdentifier, Type CIdentifier, ParameterType)]
cParams]
    Exp
ioCall <- Context -> ExpQ -> [Exp] -> [Name] -> ExpQ
buildFunCall Context
ctx (Loc
-> TypeQ
-> Type CIdentifier
-> [(CIdentifier, Type CIdentifier)]
-> [Char]
-> ExpQ
build Loc
here TypeQ
hsFunType Type CIdentifier
cType [(CIdentifier, Type CIdentifier)]
cParams' [Char]
cExp) (((Type, Exp) -> Exp) -> [(Type, Exp)] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Type, Exp) -> Exp
forall a b. (a, b) -> b
snd [(Type, Exp)]
hsParams) []
    -- If the user requested a pure function, make it so.
    case Purity
purity of
      -- Using unsafeDupablePerformIO to increase performance of pure calls, see <https://github.com/fpco/inline-c/issues/115>
      Purity
Pure -> [| unsafeDupablePerformIO $(return ioCall) |]
      Purity
IO -> Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
ioCall
  where
    buildFunCall :: Context -> TH.ExpQ -> [TH.Exp] -> [TH.Name] -> TH.ExpQ
    buildFunCall :: Context -> ExpQ -> [Exp] -> [Name] -> ExpQ
buildFunCall Context
_ctx ExpQ
f [] [Name]
args =
      (ExpQ -> Name -> ExpQ) -> ExpQ -> [Name] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
f' Name
arg -> [| $f' $(TH.varE arg) |]) ExpQ
f [Name]
args
    buildFunCall Context
ctx ExpQ
f (Exp
hsExp : [Exp]
params) [Name]
args =
       [| $(return hsExp) $ \arg ->
            $(buildFunCall ctx f params (args ++ ['arg]))
       |]

    convertCFunSig :: TH.Type -> [TH.Type] -> TH.TypeQ
    convertCFunSig :: Type -> [Type] -> TypeQ
convertCFunSig Type
retType [Type]
params0 = do
      [Type] -> TypeQ
go [Type]
params0
      where
        go :: [Type] -> TypeQ
go [] =
          [t| IO $(return retType) |]
        go (Type
paramType : [Type]
params) = do
          [t| $(return paramType) -> $(go params) |]

splitTypedC :: String -> (String, String)
  -- ^ Returns the type and the body separately
splitTypedC :: [Char] -> ([Char], [Char])
splitTypedC [Char]
s = ([Char] -> [Char]
trim [Char]
ty, case [Char]
body of
                            [] -> []
                            [Char]
r  -> [Char]
r)
  where ([Char]
ty, [Char]
body) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'{') [Char]
s
        trim :: [Char] -> [Char]
trim [Char]
x = (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
L.dropWhileEnd Char -> Bool
C.isSpace ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
C.isSpace [Char]
x)

-- | Data to parse for the 'funPtr' quasi-quoter.
data FunPtrDecl = FunPtrDecl
  { FunPtrDecl -> Type CIdentifier
funPtrReturnType :: C.Type C.CIdentifier
  , FunPtrDecl -> [(CIdentifier, Type CIdentifier)]
funPtrParameters :: [(C.CIdentifier, C.Type C.CIdentifier)]
  , FunPtrDecl -> [Char]
funPtrBody :: String
  , FunPtrDecl -> Maybe [Char]
funPtrName :: Maybe String
  } deriving (FunPtrDecl -> FunPtrDecl -> Bool
(FunPtrDecl -> FunPtrDecl -> Bool)
-> (FunPtrDecl -> FunPtrDecl -> Bool) -> Eq FunPtrDecl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FunPtrDecl -> FunPtrDecl -> Bool
$c/= :: FunPtrDecl -> FunPtrDecl -> Bool
== :: FunPtrDecl -> FunPtrDecl -> Bool
$c== :: FunPtrDecl -> FunPtrDecl -> Bool
Eq, Int -> FunPtrDecl -> [Char] -> [Char]
[FunPtrDecl] -> [Char] -> [Char]
FunPtrDecl -> [Char]
(Int -> FunPtrDecl -> [Char] -> [Char])
-> (FunPtrDecl -> [Char])
-> ([FunPtrDecl] -> [Char] -> [Char])
-> Show FunPtrDecl
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [FunPtrDecl] -> [Char] -> [Char]
$cshowList :: [FunPtrDecl] -> [Char] -> [Char]
show :: FunPtrDecl -> [Char]
$cshow :: FunPtrDecl -> [Char]
showsPrec :: Int -> FunPtrDecl -> [Char] -> [Char]
$cshowsPrec :: Int -> FunPtrDecl -> [Char] -> [Char]
Show)

funPtrQuote :: TH.Safety -> TH.QuasiQuoter
funPtrQuote :: Safety -> QuasiQuoter
funPtrQuote Safety
callSafety = ([Char] -> ExpQ) -> QuasiQuoter
quoteCode (([Char] -> ExpQ) -> QuasiQuoter)
-> ([Char] -> ExpQ) -> QuasiQuoter
forall a b. (a -> b) -> a -> b
$ \[Char]
rawCode -> do
  Loc
loc <- Q Loc
TH.location
  Context
ctx <- Q Context
getContext
  [Char]
code <- [Char] -> Q [Char]
applySubstitutions [Char]
rawCode
  FunPtrDecl{[Char]
[(CIdentifier, Type CIdentifier)]
Maybe [Char]
Type CIdentifier
funPtrName :: Maybe [Char]
funPtrBody :: [Char]
funPtrParameters :: [(CIdentifier, Type CIdentifier)]
funPtrReturnType :: Type CIdentifier
funPtrName :: FunPtrDecl -> Maybe [Char]
funPtrBody :: FunPtrDecl -> [Char]
funPtrParameters :: FunPtrDecl -> [(CIdentifier, Type CIdentifier)]
funPtrReturnType :: FunPtrDecl -> Type CIdentifier
..} <- [Char]
-> CParserContext CIdentifier
-> (forall (m :: * -> *). CParser CIdentifier m => m FunPtrDecl)
-> Q FunPtrDecl
forall ident a.
Hashable ident =>
[Char]
-> CParserContext ident
-> (forall (m :: * -> *). CParser ident m => m a)
-> Q a
runParserInQ [Char]
code (Bool -> TypeNames -> CParserContext CIdentifier
C.cCParserContext (Context -> Bool
ctxEnableCpp Context
ctx) (TypesTable -> TypeNames
typeNamesFromTypesTable (Context -> TypesTable
ctxTypesTable Context
ctx))) forall (m :: * -> *). CParser CIdentifier m => m FunPtrDecl
parse
  Type
hsRetType <- Context -> Purity -> Type CIdentifier -> TypeQ
cToHs Context
ctx Purity
IO Type CIdentifier
funPtrReturnType
  [Type]
hsParams <- [(CIdentifier, Type CIdentifier)]
-> ((CIdentifier, Type CIdentifier) -> TypeQ) -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(CIdentifier, Type CIdentifier)]
funPtrParameters (\(CIdentifier
_ident, Type CIdentifier
typ_) -> Context -> Purity -> Type CIdentifier -> TypeQ
cToHs Context
ctx Purity
IO Type CIdentifier
typ_)
  let hsFunType :: TypeQ
hsFunType = Type -> [Type] -> TypeQ
convertCFunSig Type
hsRetType [Type]
hsParams
  Safety
-> Bool
-> Maybe [Char]
-> Loc
-> TypeQ
-> Type CIdentifier
-> [(CIdentifier, Type CIdentifier)]
-> [Char]
-> ExpQ
inlineItems Safety
callSafety Bool
True Maybe [Char]
funPtrName Loc
loc TypeQ
hsFunType Type CIdentifier
funPtrReturnType [(CIdentifier, Type CIdentifier)]
funPtrParameters [Char]
funPtrBody
  where
    convertCFunSig :: TH.Type -> [TH.Type] -> TH.TypeQ
    convertCFunSig :: Type -> [Type] -> TypeQ
convertCFunSig Type
retType [Type]
params0 = do
      [Type] -> TypeQ
go [Type]
params0
      where
        go :: [Type] -> TypeQ
go [] =
          [t| IO $(return retType) |]
        go (Type
paramType : [Type]
params) = do
          [t| $(return paramType) -> $(go params) |]

    parse :: C.CParser C.CIdentifier m => m FunPtrDecl
    parse :: forall (m :: * -> *). CParser CIdentifier m => m FunPtrDecl
parse = do
      -- skip spaces
      m ()
forall (m :: * -> *). CharParsing m => m ()
Parser.spaces
      -- parse a proto
      C.ParameterDeclaration Maybe CIdentifier
mbName Type CIdentifier
protoTyp <- m (ParameterDeclaration CIdentifier)
forall i (m :: * -> *).
(CParser i m, Pretty i) =>
m (ParameterDeclaration i)
C.parseParameterDeclaration
      case Type CIdentifier
protoTyp of
        C.Proto Type CIdentifier
retType [ParameterDeclaration CIdentifier]
paramList -> do
          [(CIdentifier, Type CIdentifier)]
args <- [ParameterDeclaration CIdentifier]
-> (ParameterDeclaration CIdentifier
    -> m (CIdentifier, Type CIdentifier))
-> m [(CIdentifier, Type CIdentifier)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ParameterDeclaration CIdentifier]
paramList ((ParameterDeclaration CIdentifier
  -> m (CIdentifier, Type CIdentifier))
 -> m [(CIdentifier, Type CIdentifier)])
-> (ParameterDeclaration CIdentifier
    -> m (CIdentifier, Type CIdentifier))
-> m [(CIdentifier, Type CIdentifier)]
forall a b. (a -> b) -> a -> b
$ \ParameterDeclaration CIdentifier
decl -> case ParameterDeclaration CIdentifier -> Maybe CIdentifier
forall i. ParameterDeclaration i -> Maybe i
C.parameterDeclarationId ParameterDeclaration CIdentifier
decl of
            Maybe CIdentifier
Nothing -> [Char] -> m (CIdentifier, Type CIdentifier)
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> m (CIdentifier, Type CIdentifier))
-> [Char] -> m (CIdentifier, Type CIdentifier)
forall a b. (a -> b) -> a -> b
$ Doc -> [Char]
forall a. Pretty a => a -> [Char]
pretty80 (Doc -> [Char]) -> Doc -> [Char]
forall a b. (a -> b) -> a -> b
$
              Doc
"Un-named captured variable in decl" Doc -> Doc -> Doc
<+> ParameterDeclaration CIdentifier -> Doc
forall a. Pretty a => a -> Doc
PP.pretty ParameterDeclaration CIdentifier
decl
            Just CIdentifier
declId -> (CIdentifier, Type CIdentifier)
-> m (CIdentifier, Type CIdentifier)
forall (m :: * -> *) a. Monad m => a -> m a
return (CIdentifier
declId, ParameterDeclaration CIdentifier -> Type CIdentifier
forall i. ParameterDeclaration i -> Type i
C.parameterDeclarationType ParameterDeclaration CIdentifier
decl)
          -- get the rest of the body
          m Char -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> m Char
forall (m :: * -> *). TokenParsing m => Char -> m Char
Parser.symbolic Char
'{')
          [Char]
body <- m [Char]
forall (m :: * -> *). CParser CIdentifier m => m [Char]
parseBody
          FunPtrDecl -> m FunPtrDecl
forall (m :: * -> *) a. Monad m => a -> m a
return FunPtrDecl :: Type CIdentifier
-> [(CIdentifier, Type CIdentifier)]
-> [Char]
-> Maybe [Char]
-> FunPtrDecl
FunPtrDecl
            { funPtrReturnType :: Type CIdentifier
funPtrReturnType = Type CIdentifier
retType
            , funPtrParameters :: [(CIdentifier, Type CIdentifier)]
funPtrParameters = [(CIdentifier, Type CIdentifier)]
args
            , funPtrBody :: [Char]
funPtrBody = [Char]
body
            , funPtrName :: Maybe [Char]
funPtrName = (CIdentifier -> [Char]) -> Maybe CIdentifier -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CIdentifier -> [Char]
C.unCIdentifier Maybe CIdentifier
mbName
            }
        Type CIdentifier
_ -> [Char] -> m FunPtrDecl
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> m FunPtrDecl) -> [Char] -> m FunPtrDecl
forall a b. (a -> b) -> a -> b
$ [Char]
"Expecting function declaration"

    parseBody :: C.CParser C.CIdentifier m => m String
    parseBody :: forall (m :: * -> *). CParser CIdentifier m => m [Char]
parseBody = do
      [Char]
s <- m Char -> m Char -> m [Char]
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m [a]
Parser.manyTill m Char
forall (m :: * -> *). CharParsing m => m Char
Parser.anyChar (m Char -> m [Char]) -> m Char -> m [Char]
forall a b. (a -> b) -> a -> b
$
           m Char -> m Char
forall (m :: * -> *) a. LookAheadParsing m => m a -> m a
Parser.lookAhead (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
Parser.char Char
'}')
      [Char]
s' <- [m [Char]] -> m [Char]
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
        [ do m () -> m ()
forall (m :: * -> *) a. Parsing m => m a -> m a
Parser.try (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do -- Try because we might fail to parse the 'eof'
                -- 'symbolic' because we want to consume whitespace
               m Char -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Char -> m ()) -> m Char -> m ()
forall a b. (a -> b) -> a -> b
$ Char -> m Char
forall (m :: * -> *). TokenParsing m => Char -> m Char
Parser.symbolic Char
'}'
               m ()
forall (m :: * -> *). Parsing m => m ()
Parser.eof
             [Char] -> m [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
""
        , do m Char -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Char -> m ()) -> m Char -> m ()
forall a b. (a -> b) -> a -> b
$ Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
Parser.char Char
'}'
             [Char]
s' <- m [Char]
forall (m :: * -> *). CParser CIdentifier m => m [Char]
parseBody
             [Char] -> m [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
"}" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s')
        ]
      [Char] -> m [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s')

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

pretty80 :: PP.Pretty a => a -> String
pretty80 :: forall a. Pretty a => a -> [Char]
pretty80 a
x = SimpleDoc -> [Char] -> [Char]
PP.displayS (Float -> Int -> Doc -> SimpleDoc
PP.renderPretty Float
0.8 Int
80 (a -> Doc
forall a. Pretty a => a -> Doc
PP.pretty a
x)) [Char]
""

prettyOneLine :: PP.Pretty a => a -> String
prettyOneLine :: forall a. Pretty a => a -> [Char]
prettyOneLine a
x = SimpleDoc -> [Char] -> [Char]
PP.displayS (Doc -> SimpleDoc
PP.renderCompact (a -> Doc
forall a. Pretty a => a -> Doc
PP.pretty a
x)) [Char]
""