    {-# 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
        , emitBlock

          -- ** 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

          -- * Line directives
        , lineDirective
        , here
        , shiftLines

          -- * 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, isJust)
    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.Environment (lookupEnv)
    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           Prettyprinter ((<+>))
    import qualified Prettyprinter as PP
    import qualified Prettyprinter.Render.String 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 -> [String]
    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
      mbModuleState <- Q (Maybe ModuleState)
    getModuleState
      case mbModuleState of
        Just ModuleState
    moduleState -> Context -> Q Context
    forall a. a -> Q a
    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
            mbMs <- Q (Maybe ModuleState)
    getModuleState
            ms <- case mbMs of
              Maybe ModuleState
    Nothing -> String -> Q ModuleState
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "inline-c: ModuleState not present (initialiseModuleState)"
              Just ModuleState
    ms -> ModuleState -> Q ModuleState
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ModuleState
    ms
            let lang = ForeignSrcLang -> Maybe ForeignSrcLang -> ForeignSrcLang
    forall a. a -> Maybe a -> a
    fromMaybe ForeignSrcLang
    TH.LangC (Context -> Maybe ForeignSrcLang
    ctxForeignSrcLang Context
    context)
                addForeignSource =
    #if MIN_VERSION_base(4,12,0)
                  ForeignSrcLang -> String -> Q ()
    TH.addForeignSource
    #else
                  TH.addForeignFile
    #endif
                src = ([String] -> String
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ([String] -> [String]
    forall a. [a] -> [a]
    reverse (ModuleState -> [String]
    msFileChunks ModuleState
    ms)))
            case (lang, ctxRawObjectCompile context) of
              (ForeignSrcLang
    TH.RawObject, Just String -> Q String
    compile) -> String -> Q String
    compile String
    src Q String -> (String -> Q ()) -> Q ()
    forall a b. Q a -> (a -> Q b) -> Q b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= ForeignSrcLang -> String -> Q ()
    TH.addForeignFilePath ForeignSrcLang
    lang
              (ForeignSrcLang
    _, Maybe (String -> Q String)
    _)  -> ForeignSrcLang -> String -> Q ()
    addForeignSource ForeignSrcLang
    lang String
    src
          let moduleState :: ModuleState
    moduleState = ModuleState
                { msContext :: Context
    msContext = Context
    context
                , msGeneratedNames :: Int
    msGeneratedNames = Int
    0
                , msFileChunks :: [String]
    msFileChunks = [String]
    forall a. Monoid a => a
    mempty
                }
          ModuleState -> Q ()
    putModuleState ModuleState
    moduleState
          Context -> Q Context
    forall a. a -> Q a
    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
      mbModuleState <- Q (Maybe ModuleState)
    getModuleState
      case mbModuleState of
        Maybe ModuleState
    Nothing -> String -> Q a
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "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 a. 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
      mbModuleState <- Q (Maybe ModuleState)
    getModuleState
      forM_ mbModuleState $ \ModuleState
    _ms ->
        String -> Q (ZonkAny 6)
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "inline-c: The module has already been initialised (setContext)."
      void $ initialiseModuleState $ Just 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 = c' + 1}, Int
    c')

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

    -- | Simply appends some string to the module's C file.  Use with care.
    emitVerbatim :: String -> TH.DecsQ
    emitVerbatim :: String -> DecsQ
    emitVerbatim String
    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 :: String
    chunk = String
    "\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    s String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\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 = chunk : msFileChunks ms}, ())
      [Dec] -> DecsQ
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []

    -- | Simply appends some string of block to the module's C file.  Use with care.
    emitBlock :: TH.QuasiQuoter
    emitBlock :: QuasiQuoter
    emitBlock = TH.QuasiQuoter
      { quoteExp :: String -> Q Exp
    TH.quoteExp = Q Exp -> String -> Q Exp
    forall a b. a -> b -> a
    const (Q Exp -> String -> Q Exp) -> Q Exp -> String -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ String -> Q Exp
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "inline-c: quoteExp not implemented (quoteCode)"
      , quotePat :: String -> Q Pat
    TH.quotePat = Q Pat -> String -> Q Pat
    forall a b. a -> b -> a
    const (Q Pat -> String -> Q Pat) -> Q Pat -> String -> Q Pat
    forall a b. (a -> b) -> a -> b
    $ String -> Q Pat
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "inline-c: quotePat not implemented (quoteCode)"
      , quoteType :: String -> Q Type
    TH.quoteType = Q Type -> String -> Q Type
    forall a b. a -> b -> a
    const (Q Type -> String -> Q Type) -> Q Type -> String -> Q Type
    forall a b. (a -> b) -> a -> b
    $ String -> Q Type
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "inline-c: quoteType not implemented (quoteCode)"
      , quoteDec :: String -> DecsQ
    TH.quoteDec = String -> DecsQ
    emitVerbatim
      }

    ------------------------------------------------------------------------
    -- 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 -> Q Type
    codeType :: TH.TypeQ
        -- ^ Type of the foreign call.
      , Code -> String
    codeFunName :: String
        -- ^ Name of the function to call in the code below.
      , Code -> String
    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 -> Q Exp
    inlineCode Code{Bool
    String
    Maybe Loc
    Q Type
    Safety
    codeCallSafety :: Code -> Safety
    codeLoc :: Code -> Maybe Loc
    codeType :: Code -> Q Type
    codeFunName :: Code -> String
    codeDefs :: Code -> String
    codeFunPtr :: Code -> Bool
    codeCallSafety :: Safety
    codeLoc :: Maybe Loc
    codeType :: Q Type
    codeFunName :: String
    codeDefs :: String
    codeFunPtr :: Bool
    ..} = do
      -- Write out definitions
      ctx <- Q Context
    getContext
      let out = (String -> String) -> Maybe (String -> String) -> String -> String
    forall a. a -> Maybe a -> a
    fromMaybe String -> String
    forall a. a -> a
    id (Maybe (String -> String) -> String -> String)
    -> Maybe (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ Context -> Maybe (String -> String)
    ctxOutput Context
    ctx
      let directive = String -> (Loc -> String) -> Maybe Loc -> String
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe String
    "" Loc -> String
    lineDirective Maybe Loc
    codeLoc
      void $ emitVerbatim $ out $ directive ++ codeDefs
      -- Create and add the FFI declaration.
      ffiImportName <- uniqueFfiImportName
      -- Note [ghcide-support]
      -- haskell-language-server / ghcide cannot handle code that use
      -- `addForeignFile`/`addForeignSource` as we do here; it will result
      -- in linker errors during TH evaluations, see:
      -- <https://github.com/haskell/haskell-language-server/issues/365#issuecomment-976294466>
      -- Thus for GHCIDE, simply generate a call to `error` instead of a call to a foreign import.
      usingGhcide <- TH.runIO $ isJust <$> lookupEnv "__GHCIDE__"
      if usingGhcide
        then do
          [e|error "inline-c: A 'usingGhcide' inlineCode stub was evaluated -- this should not happen" :: $(if codeFunPtr then [t| FunPtr $(codeType) |] else codeType) |]
        else do -- Actual foreign function call generation.
          dec <- if codeFunPtr
            then TH.forImpD TH.CCall codeCallSafety ("&" ++ codeFunName) ffiImportName [t| FunPtr $(codeType) |]
            else TH.forImpD TH.CCall codeCallSafety codeFunName ffiImportName codeType
          TH.addTopDecls [dec]
          TH.varE ffiImportName

    uniqueCName :: Maybe String -> TH.Q String
    uniqueCName :: Maybe String -> Q String
    uniqueCName Maybe String
    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.
      c' <- Q Int
    bumpGeneratedNames
      module_ <- TH.loc_module <$> TH.location
      let replaceDot Char
    '.' = Char
    '_'
          replaceDot Char
    c = Char
    c
      let postfix = case Maybe String
    mbPostfix of
            Maybe String
    Nothing -> String
    ""
            Just String
    s -> String
    "_" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    s String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "_"
      return $ "inline_c_" ++ map replaceDot module_ ++ "_" ++ show c' ++ 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
    -> Q Type
    -> Type CIdentifier
    -> [(CIdentifier, Type CIdentifier)]
    -> String
    -> Q Exp
    inlineExp Safety
    callSafety Loc
    loc Q Type
    type_ Type CIdentifier
    cRetType [(CIdentifier, Type CIdentifier)]
    cParams String
    cExp =
      Safety
    -> Bool
    -> Maybe String
    -> Loc
    -> Q Type
    -> Type CIdentifier
    -> [(CIdentifier, Type CIdentifier)]
    -> String
    -> Q Exp
    inlineItems Safety
    callSafety Bool
    False Maybe String
    forall a. Maybe a
    Nothing Loc
    loc Q Type
    type_ Type CIdentifier
    cRetType [(CIdentifier, Type CIdentifier)]
    cParams String
    cItems
      where
        cItems :: String
    cItems = case Type CIdentifier
    cRetType of
          C.TypeSpecifier Specifiers
    _quals TypeSpecifier
    C.Void -> String
    cExp String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ";"
          Type CIdentifier
    _ -> String
    "return (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    cExp String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ");"

    -- | 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 String
    -> Loc
    -> Q Type
    -> Type CIdentifier
    -> [(CIdentifier, Type CIdentifier)]
    -> String
    -> Q Exp
    inlineItems Safety
    callSafety Bool
    funPtr Maybe String
    mbPostfix Loc
    loc Q Type
    type_ Type CIdentifier
    cRetType [(CIdentifier, Type CIdentifier)]
    cParams String
    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)
      ctx <- Q Context
    getContext
      funName <- uniqueCName mbPostfix
      cFunName <- case C.cIdentifierFromString (ctxEnableCpp ctx) funName of
        Left String
    err -> String -> Q CIdentifier
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q CIdentifier) -> String -> Q CIdentifier
    forall a b. (a -> b) -> a -> b
    $ String
    "inlineItems: impossible, generated bad C identifier " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                           String
    "funName:\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    err
        Right CIdentifier
    x -> CIdentifier -> Q CIdentifier
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return CIdentifier
    x
      let 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 = Doc (ZonkAny 4) -> String
    forall ann. Doc ann -> String
    prettyOneLine (ParameterDeclaration CIdentifier -> Doc (ZonkAny 4)
    forall a ann. Pretty a => a -> Doc ann
    forall ann. ParameterDeclaration CIdentifier -> Doc ann
    PP.pretty ParameterDeclaration CIdentifier
    decl) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " { " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    cItems String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " }\n"
      inlineCode $ Code
        { codeCallSafety = callSafety
        , codeLoc = Just loc
        , codeType = type_
        , codeFunName = funName
        , codeDefs = defs
        , codeFunPtr = 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 =>
    String
    -> CParserContext ident
    -> (forall (m :: * -> *). CParser ident m => m a)
    -> Q a
    runParserInQ String
    s CParserContext ident
    ctx forall (m :: * -> *). CParser ident m => m a
    p = do
      loc <- Q Loc
    TH.location
      let (line, col) = TH.loc_start loc
      let parsecLoc = String -> Int -> Int -> SourcePos
    Parsec.newPos (Loc -> String
    TH.loc_filename Loc
    loc) Int
    line Int
    col
      let p' = ParsecT String () Identity ()
    -> ReaderT (CParserContext ident) (ParsecT String () Identity) ()
    forall (m :: * -> *) a.
    Monad m =>
    m a -> ReaderT (CParserContext ident) m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (SourcePos -> ParsecT String () Identity ()
    forall (m :: * -> *) s u. Monad m => SourcePos -> ParsecT s u m ()
    Parsec.setPosition SourcePos
    parsecLoc) ReaderT (CParserContext ident) (ParsecT String () Identity) ()
    -> ReaderT (CParserContext ident) (ParsecT String () Identity) a
    -> ReaderT (CParserContext ident) (ParsecT String () Identity) a
    forall a b.
    ReaderT (CParserContext ident) (ParsecT String () Identity) a
    -> ReaderT (CParserContext ident) (ParsecT String () Identity) b
    -> ReaderT (CParserContext ident) (ParsecT String () Identity) b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> ReaderT (CParserContext ident) (ParsecT String () Identity) a
    forall (m :: * -> *). CParser ident m => m a
    p ReaderT (CParserContext ident) (ParsecT String () Identity) a
    -> ReaderT (CParserContext ident) (ParsecT String () Identity) ()
    -> ReaderT (CParserContext ident) (ParsecT String () Identity) a
    forall a b.
    ReaderT (CParserContext ident) (ParsecT String () Identity) a
    -> ReaderT (CParserContext ident) (ParsecT String () Identity) b
    -> ReaderT (CParserContext ident) (ParsecT String () Identity) a
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
    <* ParsecT String () Identity ()
    -> ReaderT (CParserContext ident) (ParsecT String () Identity) ()
    forall (m :: * -> *) a.
    Monad m =>
    m a -> ReaderT (CParserContext ident) m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift ParsecT String () Identity ()
    forall (m :: * -> *). Parsing m => m ()
    Parser.eof
      case C.runCParser ctx (TH.loc_filename loc) s p' of
        Left ParseError
    err -> do
          -- TODO consider prefixing with "error while parsing C" or similar
          String -> Q a
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q a) -> String -> Q a
    forall a b. (a -> b) -> a -> b
    $ ParseError -> String
    forall a. Show a => a -> String
    show ParseError
    err
        Right a
    res -> do
          a -> Q a
    forall a. 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 -> String
    show SomeEq
    _ = String
    "<<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 -> String -> String
    [ParameterType] -> String -> String
    ParameterType -> String
    (Int -> ParameterType -> String -> String)
    -> (ParameterType -> String)
    -> ([ParameterType] -> String -> String)
    -> Show ParameterType
    forall a.
    (Int -> a -> String -> String)
    -> (a -> String) -> ([a] -> String -> String) -> Show a
    $cshowsPrec :: Int -> ParameterType -> String -> String
    showsPrec :: Int -> ParameterType -> String -> String
    $cshow :: ParameterType -> String
    show :: ParameterType -> String
    $cshowList :: [ParameterType] -> String -> String
    showList :: [ParameterType] -> String -> String
    Show, ParameterType -> ParameterType -> Bool
    (ParameterType -> ParameterType -> Bool)
    -> (ParameterType -> ParameterType -> Bool) -> Eq ParameterType
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: ParameterType -> ParameterType -> Bool
    == :: ParameterType -> ParameterType -> Bool
    $c/= :: ParameterType -> ParameterType -> Bool
    /= :: 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 -> String
    ptcBody :: String
      }

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

    applySubstitutions :: String -> TH.Q String
    applySubstitutions :: String -> Q String
    applySubstitutions String
    str = do
      subs <- Map String (String -> String)
    -> (Substitutions -> Map String (String -> String))
    -> Maybe Substitutions
    -> Map String (String -> String)
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Map String (String -> String)
    forall a. Monoid a => a
    mempty Substitutions -> Map String (String -> String)
    unSubstitutions (Maybe Substitutions -> Map String (String -> String))
    -> Q (Maybe Substitutions) -> Q (Map String (String -> String))
    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 String () Identity String]
    -> ParsecT String () Identity String
    forall (t :: * -> *) (m :: * -> *) a.
    (Foldable t, MonadPlus m) =>
    t (m a) -> m a
    msum ([ParsecT String () Identity String]
     -> ParsecT String () Identity String)
    -> [ParsecT String () Identity String]
    -> ParsecT String () Identity String
    forall a b. (a -> b) -> a -> b
    $ (((String, String -> String) -> ParsecT String () Identity String)
     -> [(String, String -> String)]
     -> [ParsecT String () Identity String])
    -> [(String, String -> String)]
    -> ((String, String -> String)
        -> ParsecT String () Identity String)
    -> [ParsecT String () Identity String]
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip ((String, String -> String) -> ParsecT String () Identity String)
    -> [(String, String -> String)]
    -> [ParsecT String () Identity String]
    forall a b. (a -> b) -> [a] -> [b]
    map (Map String (String -> String) -> [(String, String -> String)]
    forall k a. Map k a -> [(k, a)]
    M.toList Map String (String -> String)
    subs) (((String, String -> String) -> ParsecT String () Identity String)
     -> [ParsecT String () Identity String])
    -> ((String, String -> String)
        -> ParsecT String () Identity String)
    -> [ParsecT String () Identity String]
    forall a b. (a -> b) -> a -> b
    $ \( String
    subName, String -> String
    subFunc ) ->
            ParsecT String () Identity String
    -> ParsecT String () Identity String
    forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
    Parsec.try (ParsecT String () Identity String
     -> ParsecT String () Identity String)
    -> ParsecT String () Identity String
    -> ParsecT String () Identity String
    forall a b. (a -> b) -> a -> b
    $ do
              _ <- String -> ParsecT String () Identity String
    forall s (m :: * -> *) u.
    Stream s m Char =>
    String -> ParsecT s u m String
    Parsec.string (Char
    '@' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    subName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "(")
              subArg <- Parsec.manyTill Parsec.anyChar (Parsec.char ')')
              return (subFunc subArg)
      let someChar = (Char -> String -> String
    forall a. a -> [a] -> [a]
    :[]) (Char -> String)
    -> ParsecT String u Identity Char
    -> ParsecT String u Identity String
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ParsecT String u Identity Char
    forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
    Parsec.anyChar
      case Parsec.parse (many (substitution <|> someChar)) "" str of
        Left ParseError
    _ -> String -> Q String
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Substitution failed (should be impossible)"
        Right [String]
    chunks -> String -> Q String
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([String] -> String
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [String]
    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. [(String, String -> String)] -> Q a -> Q a
    substitute [(String, String -> String)]
    subsList Q a
    cont = do
      oldSubs <- Map String (String -> String)
    -> (Substitutions -> Map String (String -> String))
    -> Maybe Substitutions
    -> Map String (String -> String)
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Map String (String -> String)
    forall a. Monoid a => a
    mempty Substitutions -> Map String (String -> String)
    unSubstitutions (Maybe Substitutions -> Map String (String -> String))
    -> Q (Maybe Substitutions) -> Q (Map String (String -> String))
    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 = [(String, String -> String)] -> Map String (String -> String)
    forall k a. Ord k => [(k, a)] -> Map k a
    M.fromList [(String, String -> String)]
    subsList
      let conflicting = Map String (String -> String)
    -> Map String (String -> String) -> Map String (String -> String)
    forall k a b. Ord k => Map k a -> Map k b -> Map k a
    M.intersection Map String (String -> String)
    subs Map String (String -> String)
    oldSubs
      newSubs <-
        if M.null conflicting
          then return (Substitutions (M.union oldSubs subs))
          else fail ("Conflicting substitutions `" ++ show (M.keys conflicting) ++ "`")
      TH.putQ newSubs *> cont <* TH.putQ (Substitutions 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 -> String -> Q Type
    getHaskellType Bool
    pureFunctions String
    cTypeStr = do
      ctx <- Q Context
    getContext
      let cParseCtx = Bool -> TypeNames -> CParserContext CIdentifier
    C.cCParserContext (Context -> Bool
    ctxEnableCpp Context
    ctx) (TypesTable -> TypeNames
    typeNamesFromTypesTable (Context -> TypesTable
    ctxTypesTable Context
    ctx))
      cType <- runParserInQ cTypeStr cParseCtx C.parseType
      cToHs ctx (if pureFunctions then Pure else IO) 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
      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
      void $ Parser.char '{'
      (cParams, cBody) <- evalStateT parseBody 0
      return $ ParseTypedC cRetType cParams cBody
      where
        parseBody
          :: StateT Int m ([(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String)
        parseBody :: StateT
      Int m ([(CIdentifier, Type CIdentifier, ParameterType)], String)
    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.
          s <- StateT Int m Char -> StateT Int m Char -> StateT Int m String
    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 String)
    -> StateT Int m Char -> StateT Int m String
    forall a b. (a -> b) -> a -> b
    $
               StateT Int m Char -> StateT Int m Char
    forall a. StateT Int m a -> StateT Int m a
    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 a. StateT Int m a -> StateT Int m a -> StateT Int m a
    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
    '$')
          (decls, s') <- msum
            [ do Parser.try $ do -- Try because we might fail to parse the 'eof'
                    -- 'symbolic' because we want to consume whitespace
                   void $ Parser.symbolic '}'
                   Parser.eof
                 return ([], "")
            , do void $ Parser.char '}'
                 (decls, s') <- parseBody
                 return (decls, "}" ++ s')
            , do void $ Parser.char '$'
                 (decls1, s1) <- parseEscapedDollar <|> parseAntiQuote <|> parseTypedCapture
                 (decls2, s2) <- parseBody
                 return (decls1 ++ decls2, s1 ++ s2)
            ]
          return (decls, s ++ s')
          where

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

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

        freshId :: CIdentifier -> StateT Int m CIdentifier
    freshId CIdentifier
    s = do
          c <- StateT Int m Int
    forall s (m :: * -> *). MonadState s m => m s
    get
          put $ c + 1
          case C.cIdentifierFromString useCpp (C.unCIdentifier s ++ "_inline_c_" ++ show c) of
            Left String
    _err -> String -> StateT Int m CIdentifier
    forall a. HasCallStack => String -> a
    error String
    "freshId: The impossible happened"
            Right CIdentifier
    x -> CIdentifier -> StateT Int m CIdentifier
    forall a. a -> StateT Int m a
    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 :: String
    hsIdentS = HaskellIdentifier -> String
    unHaskellIdentifier HaskellIdentifier
    hsIdent
          case Bool -> String -> Either String CIdentifier
    C.cIdentifierFromString Bool
    useCpp String
    hsIdentS of
            Left String
    err -> String -> n CIdentifier
    forall a. String -> n a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> n CIdentifier) -> String -> n CIdentifier
    forall a b. (a -> b) -> a -> b
    $ String
    "Haskell identifier " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    hsIdentS String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " in illegal position" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                               String
    "in C type\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Doc (ZonkAny 3) -> String
    forall ann. Doc ann -> String
    pretty80 (Type HaskellIdentifier -> Doc (ZonkAny 3)
    forall a ann. Pretty a => a -> Doc ann
    forall ann. Type HaskellIdentifier -> Doc ann
    PP.pretty Type HaskellIdentifier
    cTy) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                               String
    "A C identifier was expected, but:\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    err
            Right CIdentifier
    cIdent -> CIdentifier -> n CIdentifier
    forall a. a -> n a
    forall (m :: * -> *) a. Monad m => a -> m a
    return CIdentifier
    cIdent

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

    cToHs :: Context -> Purity -> C.Type C.CIdentifier -> TH.TypeQ
    cToHs :: Context -> Purity -> Type CIdentifier -> Q Type
    cToHs Context
    ctx Purity
    purity Type CIdentifier
    cTy = do
      mbHsTy <- Purity -> TypesTable -> Type CIdentifier -> Q (Maybe Type)
    convertType Purity
    purity (Context -> TypesTable
    ctxTypesTable Context
    ctx) Type CIdentifier
    cTy
      case mbHsTy of
        Maybe Type
    Nothing -> String -> Q Type
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q Type) -> String -> Q Type
    forall a b. (a -> b) -> a -> b
    $ String
    "Could not resolve Haskell type for C type " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Doc (ZonkAny 1) -> String
    forall ann. Doc ann -> String
    pretty80 (Type CIdentifier -> Doc (ZonkAny 1)
    forall a ann. Pretty a => a -> Doc ann
    forall ann. Type CIdentifier -> Doc ann
    PP.pretty Type CIdentifier
    cTy)
        Just Type
    hsTy -> Type -> Q Type
    forall a. a -> Q a
    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
        -> Q Type
        -> Type CIdentifier
        -> [(CIdentifier, Type CIdentifier)]
        -> String
        -> Q Exp)
    -> QuasiQuoter
    genericQuote Purity
    purity Loc
    -> Q Type
    -> Type CIdentifier
    -> [(CIdentifier, Type CIdentifier)]
    -> String
    -> Q Exp
    build = (String -> Q Exp) -> QuasiQuoter
    quoteCode ((String -> Q Exp) -> QuasiQuoter)
    -> (String -> Q Exp) -> QuasiQuoter
    forall a b. (a -> b) -> a -> b
    $ \String
    rawStr -> do
        ctx <- Q Context
    getContext
        here <- TH.location
        s <- applySubstitutions rawStr
        ParseTypedC cType cParams cExp <-
          runParserInQ s
            (haskellCParserContext (ctxEnableCpp ctx) (typeNamesFromTypesTable (ctxTypesTable ctx)))
            (parseTypedC (ctxEnableCpp ctx) (ctxAntiQuoters ctx))
        hsType <- cToHs ctx purity cType
        hsParams <- forM cParams $ \(CIdentifier
    _cId, Type CIdentifier
    cTy, ParameterType
    parTy) -> do
          case ParameterType
    parTy of
            Plain HaskellIdentifier
    s' -> do
              hsTy <- Context -> Purity -> Type CIdentifier -> Q Type
    cToHs Context
    ctx Purity
    purity Type CIdentifier
    cTy
              let hsName = String -> Name
    TH.mkName (HaskellIdentifier -> String
    unHaskellIdentifier HaskellIdentifier
    s')
              hsExp <- [| \cont -> cont ($(TH.varE hsName) :: $(return hsTy)) |]
              return (hsTy, hsExp)
            AntiQuote String
    antiId SomeEq
    dyn -> do
              case String -> AntiQuoters -> Maybe SomeAntiQuoter
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup String
    antiId (Context -> AntiQuoters
    ctxAntiQuoters Context
    ctx) of
                Maybe SomeAntiQuoter
    Nothing ->
                  String -> Q (Type, Exp)
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q (Type, Exp)) -> String -> Q (Type, Exp)
    forall a b. (a -> b) -> a -> b
    $ String
    "IMPOSSIBLE: could not find anti-quoter " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    forall a. Show a => a -> String
    show String
    antiId String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                         String
    ". (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 ->
                    String -> Q (Type, Exp)
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail  (String -> Q (Type, Exp)) -> String -> Q (Type, Exp)
    forall a b. (a -> b) -> a -> b
    $ String
    "IMPOSSIBLE: could not cast value for anti-quoter " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                            String -> String
    forall a. Show a => a -> String
    show String
    antiId String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ". (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 = Type -> [Type] -> Q Type
    convertCFunSig Type
    hsType ([Type] -> Q Type) -> [Type] -> Q Type
    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
    cId, Type CIdentifier
    cTy) | (CIdentifier
    cId, Type CIdentifier
    cTy, ParameterType
    _) <- [(CIdentifier, Type CIdentifier, ParameterType)]
    cParams]
        ioCall <- buildFunCall ctx (build here hsFunType cType cParams' cExp) (map snd hsParams) []
        -- If the user requested a pure function, make it so.
        case purity of
          -- Using unsafeDupablePerformIO to increase performance of pure calls, see <https://github.com/fpco/inline-c/issues/115>
          Purity
    Pure -> [| unsafeDupablePerformIO $(Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Exp
    ioCall) |]
          Purity
    IO -> Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Exp
    ioCall
      where
        buildFunCall :: Context -> TH.ExpQ -> [TH.Exp] -> [TH.Name] -> TH.ExpQ
        buildFunCall :: Context -> Q Exp -> [Exp] -> [Name] -> Q Exp
    buildFunCall Context
    _ctx Q Exp
    f [] [Name]
    args =
          (Q Exp -> Name -> Q Exp) -> Q Exp -> [Name] -> Q Exp
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl (\Q Exp
    f' Name
    arg -> [| $Q Exp
    f' $(Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    TH.varE Name
    arg) |]) Q Exp
    f [Name]
    args
        buildFunCall Context
    ctx Q Exp
    f (Exp
    hsExp : [Exp]
    params) [Name]
    args =
           [| $(Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Exp
    hsExp) $ \arg ->
                $(Context -> Q Exp -> [Exp] -> [Name] -> Q Exp
    buildFunCall Context
    ctx Q Exp
    f [Exp]
    params ([Name]
    args [Name] -> [Name] -> [Name]
    forall a. [a] -> [a] -> [a]
    ++ ['arg]))
           |]

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

    -- NOTE: splitTypedC wouldn't be necessary if inline-c-cpp could reuse C.block
    -- internals with a clean interface.
    -- This would be a significant refactoring but presumably it would lead to an
    -- api that could let users write their own quasiquoters a bit more conveniently.

    -- | Returns the type and the body separately.
    splitTypedC :: String -> (String, String, Int)
    splitTypedC :: String -> (String, String, Int)
    splitTypedC String
    s = (String -> String
    trim String
    ty, String
    bodyIndent String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    body, Int
    bodyLineShift)
      where (String
    ty, String
    body) = (Char -> Bool) -> String -> (String, String)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    span (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '{') String
    s
            trim :: String -> String
    trim String
    x = (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    L.dropWhileEnd Char -> Bool
    C.isSpace ((Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    C.isSpace String
    x)

            -- We may need to correct the line number of the body
            bodyLineShift :: Int
    bodyLineShift = String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length ((Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '\n') String
    ty)

            -- Indentation is relevant for error messages when the syntax is:
            -- [C.foo| type
            --   { foo(); }
            -- |]
            bodyIndent :: String
    bodyIndent =
              let precedingSpaceReversed :: String
    precedingSpaceReversed =
                    (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    takeWhile (\Char
    c -> Char -> Bool
    C.isSpace Char
    c) (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $
                    String -> String
    forall a. [a] -> [a]
    reverse (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $
                    String
    ty
                  (String
    precedingSpacesTabsReversed, String
    precedingLine) =
                    (Char -> Bool) -> String -> (String, String)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    span (Char -> String -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` (String
    "\n\r" :: [Char])) String
    precedingSpaceReversed
              in case String
    precedingLine of
                (Char
    '\n':String
    _) -> String -> String
    forall a. [a] -> [a]
    reverse String
    precedingSpacesTabsReversed
                (Char
    '\r':String
    _) -> String -> String
    forall a. [a] -> [a]
    reverse String
    precedingSpacesTabsReversed
                String
    _ -> String
    "" -- it wasn't indentation after all; just spaces after the type

    -- | 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 -> String
    funPtrBody :: String
      , FunPtrDecl -> Maybe String
    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
    $c== :: FunPtrDecl -> FunPtrDecl -> Bool
    == :: FunPtrDecl -> FunPtrDecl -> Bool
    $c/= :: FunPtrDecl -> FunPtrDecl -> Bool
    /= :: FunPtrDecl -> FunPtrDecl -> Bool
    Eq, Int -> FunPtrDecl -> String -> String
    [FunPtrDecl] -> String -> String
    FunPtrDecl -> String
    (Int -> FunPtrDecl -> String -> String)
    -> (FunPtrDecl -> String)
    -> ([FunPtrDecl] -> String -> String)
    -> Show FunPtrDecl
    forall a.
    (Int -> a -> String -> String)
    -> (a -> String) -> ([a] -> String -> String) -> Show a
    $cshowsPrec :: Int -> FunPtrDecl -> String -> String
    showsPrec :: Int -> FunPtrDecl -> String -> String
    $cshow :: FunPtrDecl -> String
    show :: FunPtrDecl -> String
    $cshowList :: [FunPtrDecl] -> String -> String
    showList :: [FunPtrDecl] -> String -> String
    Show)

    funPtrQuote :: TH.Safety -> TH.QuasiQuoter
    funPtrQuote :: Safety -> QuasiQuoter
    funPtrQuote Safety
    callSafety = (String -> Q Exp) -> QuasiQuoter
    quoteCode ((String -> Q Exp) -> QuasiQuoter)
    -> (String -> Q Exp) -> QuasiQuoter
    forall a b. (a -> b) -> a -> b
    $ \String
    rawCode -> do
      loc <- Q Loc
    TH.location
      ctx <- getContext
      code <- applySubstitutions rawCode
      FunPtrDecl{..} <- runParserInQ code (C.cCParserContext (ctxEnableCpp ctx) (typeNamesFromTypesTable (ctxTypesTable ctx))) parse
      hsRetType <- cToHs ctx IO funPtrReturnType
      hsParams <- forM funPtrParameters (\(CIdentifier
    _ident, Type CIdentifier
    typ_) -> Context -> Purity -> Type CIdentifier -> Q Type
    cToHs Context
    ctx Purity
    IO Type CIdentifier
    typ_)
      let hsFunType = Type -> [Type] -> Q Type
    convertCFunSig Type
    hsRetType [Type]
    hsParams
      inlineItems callSafety True funPtrName loc hsFunType funPtrReturnType funPtrParameters funPtrBody
      where
        convertCFunSig :: TH.Type -> [TH.Type] -> TH.TypeQ
        convertCFunSig :: Type -> [Type] -> Q Type
    convertCFunSig Type
    retType [Type]
    params0 = do
          [Type] -> Q Type
    go [Type]
    params0
          where
            go :: [Type] -> Q Type
    go [] =
              [t| IO $(Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    retType) |]
            go (Type
    paramType : [Type]
    params) = do
              [t| $(Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    paramType) -> $([Type] -> Q Type
    go [Type]
    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 mbName protoTyp <- m (ParameterDeclaration CIdentifier)
    forall i (m :: * -> *).
    (CParser i m, Pretty i) =>
    m (ParameterDeclaration i)
    C.parseParameterDeclaration
          case protoTyp of
            C.Proto Type CIdentifier
    retType [ParameterDeclaration CIdentifier]
    paramList -> do
              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 -> String -> m (CIdentifier, Type CIdentifier)
    forall a. String -> m a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> m (CIdentifier, Type CIdentifier))
    -> String -> m (CIdentifier, Type CIdentifier)
    forall a b. (a -> b) -> a -> b
    $ Doc (ZonkAny 5) -> String
    forall ann. Doc ann -> String
    pretty80 (Doc (ZonkAny 5) -> String) -> Doc (ZonkAny 5) -> String
    forall a b. (a -> b) -> a -> b
    $
                  Doc (ZonkAny 5)
    "Un-named captured variable in decl" Doc (ZonkAny 5) -> Doc (ZonkAny 5) -> Doc (ZonkAny 5)
    forall ann. Doc ann -> Doc ann -> Doc ann
    <+> ParameterDeclaration CIdentifier -> Doc (ZonkAny 5)
    forall a ann. Pretty a => a -> Doc ann
    forall ann. ParameterDeclaration CIdentifier -> Doc ann
    PP.pretty ParameterDeclaration CIdentifier
    decl
                Just CIdentifier
    declId -> (CIdentifier, Type CIdentifier)
    -> m (CIdentifier, Type CIdentifier)
    forall a. a -> m a
    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
              void (Parser.symbolic '{')
              body <- parseBody
              return FunPtrDecl
                { funPtrReturnType = retType
                , funPtrParameters = args
                , funPtrBody = body
                , funPtrName = fmap C.unCIdentifier mbName
                }
            Type CIdentifier
    _ -> String -> m FunPtrDecl
    forall a. String -> m a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> m FunPtrDecl) -> String -> m FunPtrDecl
    forall a b. (a -> b) -> a -> b
    $ String
    "Expecting function declaration"

        parseBody :: C.CParser C.CIdentifier m => m String
        parseBody :: forall (m :: * -> *). CParser CIdentifier m => m String
    parseBody = do
          s <- m Char -> m Char -> m String
    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 String) -> m Char -> m String
    forall a b. (a -> b) -> a -> b
    $
               m Char -> m Char
    forall a. m a -> m a
    forall (m :: * -> *) a. LookAheadParsing m => m a -> m a
    Parser.lookAhead (Char -> m Char
    forall (m :: * -> *). CharParsing m => Char -> m Char
    Parser.char Char
    '}')
          s' <- msum
            [ do Parser.try $ do -- Try because we might fail to parse the 'eof'
                    -- 'symbolic' because we want to consume whitespace
                   void $ Parser.symbolic '}'
                   Parser.eof
                 return ""
            , do void $ Parser.char '}'
                 s' <- parseBody
                 return ("}" ++ s')
            ]
          return (s ++ s')

    ------------------------------------------------------------------------
    -- Line directives

    -- | Tell the C compiler where the next line came from.
    --
    -- Example:
    --
    -- @@@
    -- there <- location
    -- f (unlines
    --   [ lineDirective $(here)
    --   , "generated_code_user_did_not_write()"
    --   , lineDirective there
    --   ] ++ userCode
    -- ])
    -- @@@
    --
    -- Use @lineDirective $(C.here)@ when generating code, so that any errors or
    -- warnings report the location of the generating haskell module, rather than
    -- tangentially related user code that doesn't contain the actual problem.
    lineDirective :: TH.Loc -> String
    lineDirective :: Loc -> String
    lineDirective Loc
    l = String
    "#line " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    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) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    forall a. Show a => a -> String
    show (Loc -> String
    TH.loc_filename Loc
    l ) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\n"

    -- | Get the location of the code you're looking at, for use with
    -- 'lineDirective'; place before generated code that user did not write.
    here :: TH.ExpQ
    here :: Q Exp
    here = [| $(Q Loc
    TH.location Q Loc -> (Loc -> Q Exp) -> Q Exp
    forall a b. Q a -> (a -> Q b) -> Q b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \(TH.Loc String
    a String
    b String
    c (Int
    d1, Int
    d2) (Int
    e1, Int
    e2)) ->
        [|Loc
          $(String -> Q Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => String -> m Exp
    TH.lift String
    a)
          $(String -> Q Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => String -> m Exp
    TH.lift String
    b)
          $(String -> Q Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => String -> m Exp
    TH.lift String
    c)
          ($(Int -> Q Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => Int -> m Exp
    TH.lift Int
    d1), $(Int -> Q Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => Int -> m Exp
    TH.lift Int
    d2))
          ($(Int -> Q Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => Int -> m Exp
    TH.lift Int
    e1), $(Int -> Q Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => Int -> m Exp
    TH.lift Int
    e2))
        |])
      |]

    shiftLines :: Int -> TH.Loc -> TH.Loc
    shiftLines :: Int -> Loc -> Loc
    shiftLines Int
    n Loc
    l = Loc
    l
      { TH.loc_start =
          let (startLn, startCol) = TH.loc_start l
          in (startLn + n, startCol)
      , TH.loc_end =
          let (endLn, endCol) = TH.loc_end l
          in (endLn + n, endCol)
      }

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

    pretty80 :: PP.Doc ann -> String
    pretty80 :: forall ann. Doc ann -> String
    pretty80 Doc ann
    x = SimpleDocStream ann -> String
    forall ann. SimpleDocStream ann -> String
    PP.renderString (SimpleDocStream ann -> String) -> SimpleDocStream ann -> String
    forall a b. (a -> b) -> a -> b
    $ LayoutOptions -> Doc ann -> SimpleDocStream ann
    forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
    PP.layoutSmart (PP.LayoutOptions { layoutPageWidth :: PageWidth
    PP.layoutPageWidth = Int -> Double -> PageWidth
    PP.AvailablePerLine Int
    80 Double
    0.8 }) Doc ann
    x

    prettyOneLine :: PP.Doc ann -> String
    prettyOneLine :: forall ann. Doc ann -> String
    prettyOneLine Doc ann
    x = SimpleDocStream (ZonkAny 0) -> String
    forall ann. SimpleDocStream ann -> String
    PP.renderString (SimpleDocStream (ZonkAny 0) -> String)
    -> SimpleDocStream (ZonkAny 0) -> String
    forall a b. (a -> b) -> a -> b
    $ Doc ann -> SimpleDocStream (ZonkAny 0)
    forall ann1 ann2. Doc ann1 -> SimpleDocStream ann2
    PP.layoutCompact Doc ann
    x