    {-# LANGUAGE LambdaCase #-}
    module Data.GI.CodeGen.Callable
        ( genCCallableWrapper
        , genDynamicCallableWrapper
        , ForeignSymbol(..)

        , hOutType
        , skipRetVal
        , arrayLengths
        , arrayLengthsMap
        , callableSignature
        , Signature(..)
        , fixupCallerAllocates

        , callableHInArgs
        , callableHOutArgs

        , wrapMaybe
        , inArgInterfaces
        ) where

    import Control.Monad (forM, forM_, when, void)
    import Data.Bool (bool)
    import Data.List (nub)
    import Data.Maybe (isJust)
    #if !MIN_VERSION_base(4,13,0)
    import Data.Monoid ((<>))
    #endif
    import Data.Tuple (swap)
    import qualified Data.Map as Map
    import qualified Data.Text as T
    import Data.Text (Text)

    import Data.GI.CodeGen.API
    import Data.GI.CodeGen.Code
    import Data.GI.CodeGen.Conversions
    import Data.GI.CodeGen.Haddock (deprecatedPragma, writeHaddock,
                                    writeDocumentation, RelativeDocPosition(..),
                                    writeArgDocumentation, writeReturnDocumentation)
    import Data.GI.CodeGen.SymbolNaming
    import Data.GI.CodeGen.Transfer
    import Data.GI.CodeGen.Type
    import Data.GI.CodeGen.Util

    import Text.Show.Pretty (ppShow)

    hOutType :: Callable -> [Arg] -> ExcCodeGen TypeRep
    hOutType :: Callable -> [Arg] -> ExcCodeGen TypeRep
    hOutType Callable
    callable [Arg]
    outArgs = do
      hReturnType <- case Callable -> Maybe Type
    returnType Callable
    callable of
                       Maybe Type
    Nothing -> TypeRep -> ExcCodeGen TypeRep
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TypeRep -> ExcCodeGen TypeRep) -> TypeRep -> ExcCodeGen TypeRep
    forall a b. (a -> b) -> a -> b
    $ Text -> TypeRep
    con0 Text
    "()"
                       Just Type
    r -> if Callable -> Bool
    skipRetVal Callable
    callable
                                 then TypeRep -> ExcCodeGen TypeRep
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TypeRep -> ExcCodeGen TypeRep) -> TypeRep -> ExcCodeGen TypeRep
    forall a b. (a -> b) -> a -> b
    $ Text -> TypeRep
    con0 Text
    "()"
                                 else Type -> ExcCodeGen TypeRep
    forall e. Type -> CodeGen e TypeRep
    haskellType Type
    r
      hOutArgTypes <- forM outArgs $ \Arg
    outarg ->
                      Arg -> CodeGen CGError Bool
    forall e. Arg -> CodeGen e Bool
    wrapMaybe Arg
    outarg CodeGen CGError Bool
    -> (Bool -> ExcCodeGen TypeRep) -> ExcCodeGen TypeRep
    forall a b.
    ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    -> (a
        -> ReaderT
             CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) b)
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= ExcCodeGen TypeRep
    -> ExcCodeGen TypeRep -> Bool -> ExcCodeGen TypeRep
    forall a. a -> a -> Bool -> a
    bool
                                    (Type -> ExcCodeGen TypeRep
    forall e. Type -> CodeGen e TypeRep
    haskellType (Arg -> Type
    argType Arg
    outarg))
                                    (TypeRep -> TypeRep
    maybeT (TypeRep -> TypeRep) -> ExcCodeGen TypeRep -> ExcCodeGen TypeRep
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Type -> ExcCodeGen TypeRep
    forall e. Type -> CodeGen e TypeRep
    haskellType (Arg -> Type
    argType Arg
    outarg))
      nullableReturnType <- maybe (return False) typeIsNullable (returnType callable)
      let maybeHReturnType = if Callable -> Bool
    returnMayBeNull Callable
    callable
                                Bool -> Bool -> Bool
    && Bool -> Bool
    not (Callable -> Bool
    skipRetVal Callable
    callable)
                                Bool -> Bool -> Bool
    && Bool
    nullableReturnType
                             then TypeRep -> TypeRep
    maybeT TypeRep
    hReturnType
                             else TypeRep
    hReturnType
      return $ case (outArgs, typeShow maybeHReturnType) of
                 ([], Text
    _)   -> TypeRep
    maybeHReturnType
                 ([Arg]
    _, Text
    "()") -> Text
    "(,)" Text -> [TypeRep] -> TypeRep
    `con` [TypeRep]
    hOutArgTypes
                 ([Arg], Text)
    _         -> Text
    "(,)" Text -> [TypeRep] -> TypeRep
    `con` (TypeRep
    maybeHReturnType TypeRep -> [TypeRep] -> [TypeRep]
    forall a. a -> [a] -> [a]
    : [TypeRep]
    hOutArgTypes)

    -- | Generate a foreign import for the given C symbol. Return the name
    -- of the corresponding Haskell identifier.
    mkForeignImport :: Text -> Callable -> CodeGen e Text
    mkForeignImport :: forall e. Text -> Callable -> CodeGen e Text
    mkForeignImport Text
    cSymbol Callable
    callable = do
        Text -> CodeGen e ()
    forall e. Text -> CodeGen e ()
    line Text
    first
        CodeGen e () -> CodeGen e ()
    forall e a. CodeGen e a -> CodeGen e a
    indent (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
    forall a b. (a -> b) -> a -> b
    $ do
            (Arg -> CodeGen e ()) -> [Arg] -> CodeGen e ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (\Arg
    a -> Text -> CodeGen e ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen e ())
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
    -> CodeGen e ()
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< Arg
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
    forall {e}.
    Arg
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
    fArgStr Arg
    a) (Callable -> [Arg]
    args Callable
    callable)
            Bool -> CodeGen e () -> CodeGen e ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Callable -> Bool
    callableThrows Callable
    callable) (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
    forall a b. (a -> b) -> a -> b
    $
                   Text -> CodeGen e ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
    forall a b. (a -> b) -> a -> b
    $ Int -> Text -> Text
    padTo Int
    40 Text
    "Ptr (Ptr GError) -> " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "-- error"
            Text -> CodeGen e ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen e ())
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
    -> CodeGen e ()
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
    forall {e}.
    ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
    last
        Text
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Text
    hSymbol
        where
        hSymbol :: Text
    hSymbol = if (Char -> Bool) -> Text -> Bool
    T.any (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '_') Text
    cSymbol
                  then Text -> Text
    lcFirst Text
    cSymbol
                  else Text
    "_" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    cSymbol
        first :: Text
    first = Text
    "foreign import ccall \"" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    cSymbol Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "\" " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    hSymbol Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " :: "
        fArgStr :: Arg
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
    fArgStr Arg
    arg = do
            ft <- Type -> CodeGen e TypeRep
    forall e. Type -> CodeGen e TypeRep
    foreignType (Type -> CodeGen e TypeRep) -> Type -> CodeGen e TypeRep
    forall a b. (a -> b) -> a -> b
    $ Arg -> Type
    argType Arg
    arg
            let ft' = if Arg -> Direction
    direction Arg
    arg Direction -> Direction -> Bool
    forall a. Eq a => a -> a -> Bool
    == Direction
    DirectionIn Bool -> Bool -> Bool
    || Arg -> Bool
    argCallerAllocates Arg
    arg
                      then TypeRep
    ft
                      else TypeRep -> TypeRep
    ptr TypeRep
    ft
            let start = TypeRep -> Text
    typeShow TypeRep
    ft' Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " -> "
            return $ padTo 40 start <> "-- " <> (argCName arg)
                       <> " : " <> tshow (argType arg)
        last :: ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
    last = TypeRep -> Text
    typeShow (TypeRep -> Text) -> (TypeRep -> TypeRep) -> TypeRep -> Text
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> TypeRep -> TypeRep
    io (TypeRep -> Text)
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) TypeRep
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> case Callable -> Maybe Type
    returnType Callable
    callable of
                                     Maybe Type
    Nothing -> TypeRep
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) TypeRep
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TypeRep
     -> ReaderT
          CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) TypeRep)
    -> TypeRep
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) TypeRep
    forall a b. (a -> b) -> a -> b
    $ Text -> TypeRep
    con0 Text
    "()"
                                     Just Type
    r  -> Type
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) TypeRep
    forall e. Type -> CodeGen e TypeRep
    foreignType Type
    r

    -- | Make a wrapper for foreign `FunPtr`s of the given type. Return
    -- the name of the resulting dynamic Haskell wrapper.
    mkDynamicImport :: Text -> CodeGen e Text
    mkDynamicImport :: forall e. Text -> CodeGen e Text
    mkDynamicImport Text
    typeSynonym = do
      Text -> CodeGen e ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "foreign import ccall \"dynamic\" " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    dynamic Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " :: FunPtr "
               Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    typeSynonym Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " -> " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    typeSynonym
      Text
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Text
    dynamic
          where dynamic :: Text
    dynamic = Text
    "__dynamic_" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    typeSynonym

    -- | Given an argument to a function, return whether it should be
    -- wrapped in a maybe type (useful for nullable types). We do some
    -- sanity checking to make sure that the argument is actually nullable
    -- (a relatively common annotation mistake is to mix up (optional)
    -- with (nullable)).
    wrapMaybe :: Arg -> CodeGen e Bool
    wrapMaybe :: forall e. Arg -> CodeGen e Bool
    wrapMaybe Arg
    arg = if Arg -> Bool
    mayBeNull Arg
    arg
                    then Type -> CodeGen e Bool
    forall e. Type -> CodeGen e Bool
    typeIsNullable (Arg -> Type
    argType Arg
    arg)
                    else Bool -> CodeGen e Bool
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False

    -- | Given the list of arguments returns the list of constraints and the
    -- list of types in the signature.
    inArgInterfaces :: [Arg] -> ExposeClosures -> ExcCodeGen ([Text], [Text])
    inArgInterfaces :: [Arg] -> ExposeClosures -> ExcCodeGen ([Text], [Text])
    inArgInterfaces [Arg]
    args ExposeClosures
    expose = do
      CodeGen CGError ()
    forall e. CodeGen e ()
    resetTypeVariableScope
      [Arg] -> ExcCodeGen ([Text], [Text])
    forall {e}.
    [Arg]
    -> ReaderT
         CodeGenConfig
         (StateT (CGState, ModuleInfo) (Except e))
         ([Text], [Text])
    go [Arg]
    args
      where go :: [Arg]
    -> ReaderT
         CodeGenConfig
         (StateT (CGState, ModuleInfo) (Except e))
         ([Text], [Text])
    go [] = ([Text], [Text])
    -> ReaderT
         CodeGenConfig
         (StateT (CGState, ModuleInfo) (Except e))
         ([Text], [Text])
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([], [])
            go (Arg
    arg:[Arg]
    args) = do
              (t, cons) <- Type -> ExposeClosures -> CodeGen e (Text, [Text])
    forall e. Type -> ExposeClosures -> CodeGen e (Text, [Text])
    argumentType (Arg -> Type
    argType Arg
    arg) ExposeClosures
    expose
              t' <- wrapMaybe arg >>= bool (return t)
                (return $ "Maybe (" <> t <> ")")
              (restCons, restTypes) <- go args
              return (cons <> restCons, t' : restTypes)

    -- Given a callable, return a list of (array, length) pairs, where in
    -- each pair "length" is the argument holding the length of the
    -- (non-zero-terminated, non-fixed size) C array.
    arrayLengthsMap :: Callable -> [(Arg, Arg)] -- List of (array, length)
    arrayLengthsMap :: Callable -> [(Arg, Arg)]
    arrayLengthsMap Callable
    callable = [Arg] -> [(Arg, Arg)] -> [(Arg, Arg)]
    go (Callable -> [Arg]
    args Callable
    callable) []
        where
          go :: [Arg] -> [(Arg, Arg)] -> [(Arg, Arg)]
          go :: [Arg] -> [(Arg, Arg)] -> [(Arg, Arg)]
    go [] [(Arg, Arg)]
    acc = [(Arg, Arg)]
    acc
          go (Arg
    a:[Arg]
    as) [(Arg, Arg)]
    acc = case Arg -> Type
    argType Arg
    a of
                            TCArray Bool
    False Int
    fixedSize Int
    length Type
    _ ->
                                if Int
    fixedSize Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > -Int
    1 Bool -> Bool -> Bool
    || Int
    length Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == -Int
    1
                                then [Arg] -> [(Arg, Arg)] -> [(Arg, Arg)]
    go [Arg]
    as [(Arg, Arg)]
    acc
                                else [Arg] -> [(Arg, Arg)] -> [(Arg, Arg)]
    go [Arg]
    as ([(Arg, Arg)] -> [(Arg, Arg)]) -> [(Arg, Arg)] -> [(Arg, Arg)]
    forall a b. (a -> b) -> a -> b
    $ (Arg
    a, (Callable -> [Arg]
    args Callable
    callable)[Arg] -> Int -> Arg
    forall a. HasCallStack => [a] -> Int -> a
    !!Int
    length) (Arg, Arg) -> [(Arg, Arg)] -> [(Arg, Arg)]
    forall a. a -> [a] -> [a]
    : [(Arg, Arg)]
    acc
                            Type
    _ -> [Arg] -> [(Arg, Arg)] -> [(Arg, Arg)]
    go [Arg]
    as [(Arg, Arg)]
    acc

    -- Return the list of arguments of the callable that contain length
    -- arguments, including a possible length for the result of calling
    -- the function.
    arrayLengths :: Callable -> [Arg]
    arrayLengths :: Callable -> [Arg]
    arrayLengths Callable
    callable = ((Arg, Arg) -> Arg) -> [(Arg, Arg)] -> [Arg]
    forall a b. (a -> b) -> [a] -> [b]
    map (Arg, Arg) -> Arg
    forall a b. (a, b) -> b
    snd (Callable -> [(Arg, Arg)]
    arrayLengthsMap Callable
    callable) [Arg] -> [Arg] -> [Arg]
    forall a. Semigroup a => a -> a -> a
    <>
                   -- Often one of the arguments is just the length of
                   -- the result.
                   case Callable -> Maybe Type
    returnType Callable
    callable of
                     Just (TCArray Bool
    False (-1) Int
    length Type
    _) ->
                         if Int
    length Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > -Int
    1
                         then [(Callable -> [Arg]
    args Callable
    callable)[Arg] -> Int -> Arg
    forall a. HasCallStack => [a] -> Int -> a
    !!Int
    length]
                         else []
                     Maybe Type
    _ -> []

    -- This goes through a list of [(a,b)], and tags every entry where the
    -- "b" field has occurred before with the value of "a" for which it
    -- occurred. (The first appearance is not tagged.)
    classifyDuplicates :: Ord b => [(a, b)] -> [(a, b, Maybe a)]
    classifyDuplicates :: forall b a. Ord b => [(a, b)] -> [(a, b, Maybe a)]
    classifyDuplicates [(a, b)]
    args = Map b a -> [(a, b)] -> [(a, b, Maybe a)]
    forall b a. Ord b => Map b a -> [(a, b)] -> [(a, b, Maybe a)]
    doClassify Map b a
    forall k a. Map k a
    Map.empty [(a, b)]
    args
        where doClassify :: Ord b => Map.Map b a -> [(a, b)] -> [(a, b, Maybe a)]
              doClassify :: forall b a. Ord b => Map b a -> [(a, b)] -> [(a, b, Maybe a)]
    doClassify Map b a
    _ [] = []
              doClassify Map b a
    found ((a
    value, b
    key):[(a, b)]
    args) =
                  (a
    value, b
    key, b -> Map b a -> Maybe a
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup b
    key Map b a
    found) (a, b, Maybe a) -> [(a, b, Maybe a)] -> [(a, b, Maybe a)]
    forall a. a -> [a] -> [a]
    :
                    Map b a -> [(a, b)] -> [(a, b, Maybe a)]
    forall b a. Ord b => Map b a -> [(a, b)] -> [(a, b, Maybe a)]
    doClassify (b -> a -> Map b a -> Map b a
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    Map.insert b
    key a
    value Map b a
    found) [(a, b)]
    args

    -- Read the length of in array arguments from the corresponding
    -- Haskell objects. A subtlety is that sometimes a single length
    -- argument is expected from the C side to encode the length of
    -- various lists. Ideally we would encode this in the types, but the
    -- resulting API would be rather cumbersome. We insted perform runtime
    -- checks to make sure that the given lists have the same length.
    readInArrayLengths :: Name -> Callable -> [Arg] -> ExcCodeGen ()
    readInArrayLengths :: Name -> Callable -> [Arg] -> CodeGen CGError ()
    readInArrayLengths Name
    name Callable
    callable [Arg]
    hInArgs = do
      let lengthMaps :: [(Arg, Arg, Maybe Arg)]
    lengthMaps = [(Arg, Arg)] -> [(Arg, Arg, Maybe Arg)]
    forall b a. Ord b => [(a, b)] -> [(a, b, Maybe a)]
    classifyDuplicates ([(Arg, Arg)] -> [(Arg, Arg, Maybe Arg)])
    -> [(Arg, Arg)] -> [(Arg, Arg, Maybe Arg)]
    forall a b. (a -> b) -> a -> b
    $ Callable -> [(Arg, Arg)]
    arrayLengthsMap Callable
    callable
      [(Arg, Arg, Maybe Arg)]
    -> ((Arg, Arg, Maybe Arg) -> CodeGen CGError ())
    -> CodeGen CGError ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ [(Arg, Arg, Maybe Arg)]
    lengthMaps (((Arg, Arg, Maybe Arg) -> CodeGen CGError ())
     -> CodeGen CGError ())
    -> ((Arg, Arg, Maybe Arg) -> CodeGen CGError ())
    -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ \(Arg
    array, Arg
    length, Maybe Arg
    duplicate) ->
          Bool -> CodeGen CGError () -> CodeGen CGError ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Arg
    array Arg -> [Arg] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [Arg]
    hInArgs) (CodeGen CGError () -> CodeGen CGError ())
    -> CodeGen CGError () -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $
            case Maybe Arg
    duplicate of
            Maybe Arg
    Nothing -> Arg -> Arg -> CodeGen CGError ()
    readInArrayLength Arg
    array Arg
    length
            Just Arg
    previous -> Name -> Arg -> Arg -> Arg -> CodeGen CGError ()
    checkInArrayLength Name
    name Arg
    array Arg
    length Arg
    previous

    -- Read the length of an array into the corresponding variable.
    readInArrayLength :: Arg -> Arg -> ExcCodeGen ()
    readInArrayLength :: Arg -> Arg -> CodeGen CGError ()
    readInArrayLength Arg
    array Arg
    length = do
      let lvar :: Text
    lvar = Arg -> Text
    escapedArgName Arg
    length
          avar :: Text
    avar = Arg -> Text
    escapedArgName Arg
    array
      Arg -> CodeGen CGError Bool
    forall e. Arg -> CodeGen e Bool
    wrapMaybe Arg
    array CodeGen CGError Bool
    -> (Bool -> CodeGen CGError ()) -> CodeGen CGError ()
    forall a b.
    ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    -> (a
        -> ReaderT
             CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) b)
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= CodeGen CGError ()
    -> CodeGen CGError () -> Bool -> CodeGen CGError ()
    forall a. a -> a -> Bool -> a
    bool
                    (do
                      al <- Text -> Type -> ExcCodeGen Text
    computeArrayLength Text
    avar (Arg -> Type
    argType Arg
    array)
                      line $ "let " <> lvar <> " = " <> al)
                    (do
                      Text -> CodeGen CGError ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen CGError ()) -> Text -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "let " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    lvar Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " = case " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    avar Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " of"
                      CodeGen CGError () -> CodeGen CGError ()
    forall e a. CodeGen e a -> CodeGen e a
    indent (CodeGen CGError () -> CodeGen CGError ())
    -> CodeGen CGError () -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ CodeGen CGError () -> CodeGen CGError ()
    forall e a. CodeGen e a -> CodeGen e a
    indent (CodeGen CGError () -> CodeGen CGError ())
    -> CodeGen CGError () -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ do
                        Text -> CodeGen CGError ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen CGError ()) -> Text -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "Nothing -> 0"
                        let jarray :: Text
    jarray = Text
    "j" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text -> Text
    ucFirst Text
    avar
                        al <- Text -> Type -> ExcCodeGen Text
    computeArrayLength Text
    jarray (Arg -> Type
    argType Arg
    array)
                        line $ "Just " <> jarray <> " -> " <> al)

    -- Check that the given array has a length equal to the given length
    -- variable.
    checkInArrayLength :: Name -> Arg -> Arg -> Arg -> ExcCodeGen ()
    checkInArrayLength :: Name -> Arg -> Arg -> Arg -> CodeGen CGError ()
    checkInArrayLength Name
    n Arg
    array Arg
    length Arg
    previous = do
      let name :: Text
    name = Name -> Text
    lowerName Name
    n
          funcName :: Text
    funcName = Name -> Text
    namespace Name
    n Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "." Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    name
          lvar :: Text
    lvar = Arg -> Text
    escapedArgName Arg
    length
          avar :: Text
    avar = Arg -> Text
    escapedArgName Arg
    array
          expectedLength :: Text
    expectedLength = Text
    avar Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "_expected_length_"
          pvar :: Text
    pvar = Arg -> Text
    escapedArgName Arg
    previous
      Arg -> CodeGen CGError Bool
    forall e. Arg -> CodeGen e Bool
    wrapMaybe Arg
    array CodeGen CGError Bool
    -> (Bool -> CodeGen CGError ()) -> CodeGen CGError ()
    forall a b.
    ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    -> (a
        -> ReaderT
             CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) b)
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= CodeGen CGError ()
    -> CodeGen CGError () -> Bool -> CodeGen CGError ()
    forall a. a -> a -> Bool -> a
    bool
                (do
                  al <- Text -> Type -> ExcCodeGen Text
    computeArrayLength Text
    avar (Arg -> Type
    argType Arg
    array)
                  line $ "let " <> expectedLength <> " = " <> al)
                (do
                  Text -> CodeGen CGError ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen CGError ()) -> Text -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "let " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    expectedLength Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " = case " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    avar Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " of"
                  CodeGen CGError () -> CodeGen CGError ()
    forall e a. CodeGen e a -> CodeGen e a
    indent (CodeGen CGError () -> CodeGen CGError ())
    -> CodeGen CGError () -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ CodeGen CGError () -> CodeGen CGError ()
    forall e a. CodeGen e a -> CodeGen e a
    indent (CodeGen CGError () -> CodeGen CGError ())
    -> CodeGen CGError () -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ do
                    Text -> CodeGen CGError ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen CGError ()) -> Text -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "Nothing -> 0"
                    let jarray :: Text
    jarray = Text
    "j" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text -> Text
    ucFirst Text
    avar
                    al <- Text -> Type -> ExcCodeGen Text
    computeArrayLength Text
    jarray (Arg -> Type
    argType Arg
    array)
                    line $ "Just " <> jarray <> " -> " <> al)
      Text -> CodeGen CGError ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen CGError ()) -> Text -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "when (" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    expectedLength Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " /= " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    lvar Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    ") $"
      CodeGen CGError () -> CodeGen CGError ()
    forall e a. CodeGen e a -> CodeGen e a
    indent (CodeGen CGError () -> CodeGen CGError ())
    -> CodeGen CGError () -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ Text -> CodeGen CGError ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen CGError ()) -> Text -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "error \"" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    funcName Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " : length of '" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    avar Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <>
                 Text
    "' does not agree with that of '" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    pvar Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "'.\""

    -- | Whether to skip the return value in the generated bindings. The
    -- C convention is that functions throwing an error and returning
    -- a gboolean set the boolean to TRUE iff there is no error, so
    -- the information is always implicit in whether we emit an
    -- exception or not, so the return value can be omitted from the
    -- generated bindings without loss of information (and omitting it
    -- gives rise to a nicer API). See
    -- https://bugzilla.gnome.org/show_bug.cgi?id=649657
    skipRetVal :: Callable -> Bool
    skipRetVal :: Callable -> Bool
    skipRetVal Callable
    callable = (Callable -> Bool
    skipReturn Callable
    callable) Bool -> Bool -> Bool
    ||
                          (Callable -> Bool
    callableThrows Callable
    callable Bool -> Bool -> Bool
    &&
                            Callable -> Maybe Type
    returnType Callable
    callable Maybe Type -> Maybe Type -> Bool
    forall a. Eq a => a -> a -> Bool
    == Type -> Maybe Type
    forall a. a -> Maybe a
    Just (BasicType -> Type
    TBasicType BasicType
    TBoolean))

    freeInArgs' :: (Arg -> Text -> Text -> ExcCodeGen [Text]) ->
                   Callable -> Map.Map Text Text -> ExcCodeGen [Text]
    freeInArgs' :: (Arg -> Text -> Text -> ExcCodeGen [Text])
    -> Callable -> Map Text Text -> ExcCodeGen [Text]
    freeInArgs' Arg -> Text -> Text -> ExcCodeGen [Text]
    freeFn Callable
    callable Map Text Text
    nameMap = [[Text]] -> [Text]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ([[Text]] -> [Text])
    -> ReaderT
         CodeGenConfig
         (StateT (CGState, ModuleInfo) (Except CGError))
         [[Text]]
    -> ExcCodeGen [Text]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except CGError))
      [[Text]]
    actions
        where
          actions :: ExcCodeGen [[Text]]
          actions :: ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except CGError))
      [[Text]]
    actions = [Arg]
    -> (Arg -> ExcCodeGen [Text])
    -> ReaderT
         CodeGenConfig
         (StateT (CGState, ModuleInfo) (Except CGError))
         [[Text]]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    t a -> (a -> m b) -> m (t b)
    forM (Callable -> [Arg]
    args Callable
    callable) ((Arg -> ExcCodeGen [Text])
     -> ReaderT
          CodeGenConfig
          (StateT (CGState, ModuleInfo) (Except CGError))
          [[Text]])
    -> (Arg -> ExcCodeGen [Text])
    -> ReaderT
         CodeGenConfig
         (StateT (CGState, ModuleInfo) (Except CGError))
         [[Text]]
    forall a b. (a -> b) -> a -> b
    $ \Arg
    arg ->
            case Text -> Map Text Text -> Maybe Text
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup (Arg -> Text
    escapedArgName Arg
    arg) Map Text Text
    nameMap of
              Just Text
    name -> Arg -> Text -> Text -> ExcCodeGen [Text]
    freeFn Arg
    arg Text
    name (Text -> ExcCodeGen [Text]) -> Text -> ExcCodeGen [Text]
    forall a b. (a -> b) -> a -> b
    $
                           -- Pass in the length argument in case it's needed.
                           case Arg -> Type
    argType Arg
    arg of
                             TCArray Bool
    False (-1) (-1) Type
    _ ->
                               Text -> Text
    parenthesize (Text
    "length " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Arg -> Text
    escapedArgName Arg
    arg)
                             TCArray Bool
    False (-1) Int
    length Type
    _ ->
                                 Arg -> Text
    escapedArgName (Arg -> Text) -> Arg -> Text
    forall a b. (a -> b) -> a -> b
    $ (Callable -> [Arg]
    args Callable
    callable)[Arg] -> Int -> Arg
    forall a. HasCallStack => [a] -> Int -> a
    !!Int
    length
                             Type
    _ -> Text
    forall a. HasCallStack => a
    undefined
              Maybe Text
    Nothing -> Text -> ExcCodeGen [Text]
    forall a. Text -> ExcCodeGen a
    badIntroError (Text -> ExcCodeGen [Text]) -> Text -> ExcCodeGen [Text]
    forall a b. (a -> b) -> a -> b
    $ Text
    "freeInArgs: do not understand " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Arg -> Text
    forall a. Show a => a -> Text
    tshow Arg
    arg

    -- | Return the list of actions freeing the memory associated with the
    -- callable variables. This is run if the call to the C function
    -- succeeds, if there is an error freeInArgsOnError below is called
    -- instead.
    freeInArgs :: Callable -> Map.Map Text Text -> ExcCodeGen [Text]
    freeInArgs :: Callable -> Map Text Text -> ExcCodeGen [Text]
    freeInArgs = (Arg -> Text -> Text -> ExcCodeGen [Text])
    -> Callable -> Map Text Text -> ExcCodeGen [Text]
    freeInArgs' Arg -> Text -> Text -> ExcCodeGen [Text]
    freeInArg

    -- | Return the list of actions freeing the memory associated with the
    -- callable variables. This is run in case there is an error during
    -- the call.
    freeInArgsOnError :: Callable -> Map.Map Text Text -> ExcCodeGen [Text]
    freeInArgsOnError :: Callable -> Map Text Text -> ExcCodeGen [Text]
    freeInArgsOnError = (Arg -> Text -> Text -> ExcCodeGen [Text])
    -> Callable -> Map Text Text -> ExcCodeGen [Text]
    freeInArgs' Arg -> Text -> Text -> ExcCodeGen [Text]
    freeInArgOnError

    -- Marshall the haskell arguments into their corresponding C
    -- equivalents. omitted gives a list of DirectionIn arguments that
    -- should be ignored, as they will be dealt with separately.
    prepareArgForCall :: [Arg] -> Arg -> ExposeClosures -> ExcCodeGen Text
    prepareArgForCall :: [Arg] -> Arg -> ExposeClosures -> ExcCodeGen Text
    prepareArgForCall [Arg]
    omitted Arg
    arg ExposeClosures
    expose = do
      callback <- Type -> CodeGen CGError (Maybe API)
    forall e. HasCallStack => Type -> CodeGen e (Maybe API)
    findAPI (Arg -> Type
    argType Arg
    arg) CodeGen CGError (Maybe API)
    -> (Maybe API
        -> ReaderT
             CodeGenConfig
             (StateT (CGState, ModuleInfo) (Except CGError))
             (Maybe Callback))
    -> ReaderT
         CodeGenConfig
         (StateT (CGState, ModuleInfo) (Except CGError))
         (Maybe Callback)
    forall a b.
    ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    -> (a
        -> ReaderT
             CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) b)
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>=
                    \case Just (APICallback Callback
    c) -> Maybe Callback
    -> ReaderT
         CodeGenConfig
         (StateT (CGState, ModuleInfo) (Except CGError))
         (Maybe Callback)
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Callback -> Maybe Callback
    forall a. a -> Maybe a
    Just Callback
    c)
                          Maybe API
    _ -> Maybe Callback
    -> ReaderT
         CodeGenConfig
         (StateT (CGState, ModuleInfo) (Except CGError))
         (Maybe Callback)
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe Callback
    forall a. Maybe a
    Nothing

      when (isJust callback && direction arg /= DirectionIn) $
           notImplementedError "Only callbacks with DirectionIn are supported"

      case direction arg of
        Direction
    DirectionIn -> if Arg
    arg Arg -> [Arg] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [Arg]
    omitted
                       then Text -> ExcCodeGen Text
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Text -> ExcCodeGen Text)
    -> (Arg -> Text) -> Arg -> ExcCodeGen Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Arg -> Text
    escapedArgName (Arg -> ExcCodeGen Text) -> Arg -> ExcCodeGen Text
    forall a b. (a -> b) -> a -> b
    $ Arg
    arg
                       else case Maybe Callback
    callback of
                            Just Callback
    c -> if Callable -> Bool
    callableThrows (Callback -> Callable
    cbCallable Callback
    c)
                                      -- See [Note: Callables that throw]
                                      then Text -> ExcCodeGen Text
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Arg -> Text
    escapedArgName Arg
    arg)
                                      else Arg -> Callback -> ExposeClosures -> ExcCodeGen Text
    forall e. Arg -> Callback -> ExposeClosures -> CodeGen e Text
    prepareInCallback Arg
    arg Callback
    c ExposeClosures
    expose
                            Maybe Callback
    Nothing -> Arg -> ExcCodeGen Text
    prepareInArg Arg
    arg
        Direction
    DirectionInout -> Arg -> ExcCodeGen Text
    prepareInoutArg Arg
    arg
        Direction
    DirectionOut -> Arg -> ExcCodeGen Text
    prepareOutArg Arg
    arg

    prepareInArg :: Arg -> ExcCodeGen Text
    prepareInArg :: Arg -> ExcCodeGen Text
    prepareInArg Arg
    arg = do
      let name :: Text
    name = Arg -> Text
    escapedArgName Arg
    arg
      Arg -> CodeGen CGError Bool
    forall e. Arg -> CodeGen e Bool
    wrapMaybe Arg
    arg CodeGen CGError Bool
    -> (Bool -> ExcCodeGen Text) -> ExcCodeGen Text
    forall a b.
    ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    -> (a
        -> ReaderT
             CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) b)
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= ExcCodeGen Text -> ExcCodeGen Text -> Bool -> ExcCodeGen Text
    forall a. a -> a -> Bool -> a
    bool
                (Text -> CodeGen CGError Converter -> ExcCodeGen Text
    forall e. Text -> CodeGen e Converter -> CodeGen e Text
    convert Text
    name (CodeGen CGError Converter -> ExcCodeGen Text)
    -> CodeGen CGError Converter -> ExcCodeGen Text
    forall a b. (a -> b) -> a -> b
    $ Type -> Transfer -> CodeGen CGError Converter
    hToF (Arg -> Type
    argType Arg
    arg) (Arg -> Transfer
    transfer Arg
    arg))
                (do
                  let maybeName :: Text
    maybeName = Text
    "maybe" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text -> Text
    ucFirst Text
    name
                  nullPtr <- Type -> CodeGen CGError (Maybe Text)
    forall e. Type -> CodeGen e (Maybe Text)
    nullPtrForType (Arg -> Type
    argType Arg
    arg) CodeGen CGError (Maybe Text)
    -> (Maybe Text -> ExcCodeGen Text) -> ExcCodeGen Text
    forall a b.
    ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    -> (a
        -> ReaderT
             CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) b)
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \case
                    Maybe Text
    Nothing -> Text -> ExcCodeGen Text
    forall a. HasCallStack => Text -> a
    terror (Text -> ExcCodeGen Text) -> Text -> ExcCodeGen Text
    forall a b. (a -> b) -> a -> b
    $ Text
    "Unexpected non-pointer type " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Type -> Text
    forall a. Show a => a -> Text
    tshow (Arg -> Type
    argType Arg
    arg)
                    Just Text
    null -> Text -> ExcCodeGen Text
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Text
    null
                  line $ maybeName <> " <- case " <> name <> " of"
                  indent $ do
                    line $ "Nothing -> return " <> nullPtr
                    let jName = Text
    "j" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text -> Text
    ucFirst Text
    name
                    line $ "Just " <> jName <> " -> do"
                    indent $ do
                             converted <- convert jName $ hToF (argType arg)
                                                               (transfer arg)
                             line $ "return " <> converted
                    return maybeName)

    -- | Callbacks are a fairly special case, we treat them separately.
    prepareInCallback :: Arg -> Callback -> ExposeClosures -> CodeGen e Text
    prepareInCallback :: forall e. Arg -> Callback -> ExposeClosures -> CodeGen e Text
    prepareInCallback Arg
    arg callback :: Callback
    callback@(Callback {cbCallable :: Callback -> Callable
    cbCallable = Callable
    cb}) ExposeClosures
    expose = do
      let name :: Text
    name = Arg -> Text
    escapedArgName Arg
    arg
          ptrName :: Text
    ptrName = Text
    "ptr" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    name
          scope :: Scope
    scope = Arg -> Scope
    argScope Arg
    arg

      (maker, wrapper, drop) <-
          case Arg -> Type
    argType Arg
    arg of
            TInterface Name
    tn ->
                do
                  let Name Text
    _ Text
    n = API -> Name -> Name
    normalizedAPIName (Callback -> API
    APICallback Callback
    callback) Name
    tn
                  drop <- if Callable -> Bool
    callableHasClosures Callable
    cb Bool -> Bool -> Bool
    && ExposeClosures
    expose ExposeClosures -> ExposeClosures -> Bool
    forall a. Eq a => a -> a -> Bool
    == ExposeClosures
    WithoutClosures
                          then Text -> Maybe Text
    forall a. a -> Maybe a
    Just (Text -> Maybe Text)
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
    -> ReaderT
         CodeGenConfig
         (StateT (CGState, ModuleInfo) (Except e))
         (Maybe Text)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Text
    -> Name
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
    forall e. Text -> Name -> CodeGen e Text
    qualifiedSymbol (Text -> Text
    callbackDropClosures Text
    n) Name
    tn
                          else Maybe Text
    -> ReaderT
         CodeGenConfig
         (StateT (CGState, ModuleInfo) (Except e))
         (Maybe Text)
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe Text
    forall a. Maybe a
    Nothing
                  wrapper <- qualifiedSymbol (callbackHaskellToForeign n) tn
                  maker <- qualifiedSymbol (callbackWrapperAllocator n) tn
                  return (maker, wrapper, drop)
            Type
    _ -> Text
    -> ReaderT
         CodeGenConfig
         (StateT (CGState, ModuleInfo) (Except e))
         (Text, Text, Maybe Text)
    forall a. HasCallStack => Text -> a
    terror (Text
     -> ReaderT
          CodeGenConfig
          (StateT (CGState, ModuleInfo) (Except e))
          (Text, Text, Maybe Text))
    -> Text
    -> ReaderT
         CodeGenConfig
         (StateT (CGState, ModuleInfo) (Except e))
         (Text, Text, Maybe Text)
    forall a b. (a -> b) -> a -> b
    $ Text
    "prepareInCallback : Not an interface! " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> String -> Text
    T.pack (Arg -> String
    forall a. Show a => a -> String
    ppShow Arg
    arg)

      wrapMaybe arg >>= bool
                (do
                  let name' = Text -> Text
    prime Text
    name
                      dropped =
                          case Maybe Text
    drop of
                            Just Text
    dropper -> Text -> Text
    parenthesize (Text
    dropper Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    name)
                            Maybe Text
    Nothing -> Text
    name
                  -- ScopeTypeAsync callbacks are somewhat tricky: they
                  -- will be called only once, and the data associated to
                  -- them will be invalid after the first call.
                  --
                  -- So we pass them a pointer to a dynamically allocated
                  -- `Ptr FunPtr`, which contains a pointer to the
                  -- `FunPtr` we dynamically allocate wrapping the Haskell
                  -- function. On first invocation, the wrapper will then
                  -- free this memory.
                  p <- if (scope == ScopeTypeAsync)
                       then do ft <- typeShow <$> foreignType (argType arg)
                               line $ ptrName <> " <- callocMem :: IO (Ptr (" <> ft <> "))"
                               return $ parenthesize $ "Just " <> ptrName
                       else return "Nothing"

                  line $ name' <> " <- " <> maker <> " "
                           <> parenthesize (wrapper <> " " <> p <> " " <> dropped)
                  when (scope == ScopeTypeAsync) $
                       line $ "poke " <> ptrName <> " " <> name'
                  return name')
                (do
                  let maybeName = Text
    "maybe" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text -> Text
    ucFirst Text
    name
                  line $ maybeName <> " <- case " <> name <> " of"
                  indent $ do
                    line $ "Nothing -> return FP.nullFunPtr"
                    let jName = Text
    "j" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text -> Text
    ucFirst Text
    name
                        jName' = Text -> Text
    prime Text
    jName
                    line $ "Just " <> jName <> " -> do"
                    indent $ do
                             let dropped = case Maybe Text
    drop of
                                       Just Text
    dropper ->
                                           Text -> Text
    parenthesize (Text
    dropper Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    jName)
                                       Maybe Text
    Nothing -> Text
    jName
                             p <- if (scope == ScopeTypeAsync)
                               then do ft <- typeShow <$> foreignType (argType arg)
                                       line $ ptrName <> " <- callocMem :: IO (Ptr (" <> ft <> "))"
                                       return $ parenthesize $ "Just " <> ptrName
                               else return "Nothing"

                             line $ jName' <> " <- " <> maker <> " "
                                      <> parenthesize (wrapper <> " "
                                                       <> p <> " " <> dropped)
                             when (scope == ScopeTypeAsync) $
                                  line $ "poke " <> ptrName <> " " <> jName'
                             line $ "return " <> jName'
                  return maybeName)

    prepareInoutArg :: Arg -> ExcCodeGen Text
    prepareInoutArg :: Arg -> ExcCodeGen Text
    prepareInoutArg Arg
    arg = do
      name' <- Arg -> ExcCodeGen Text
    prepareInArg Arg
    arg
      ft <- foreignType $ argType arg

      if argCallerAllocates arg
        then return name'
        else do
        -- Check that if the argument type is managed, the C type is a
        -- pointer to a pointer. This is not perfect, but it helps to
        -- detect some relatively common introspection errors that would
        -- lead to crashes.
        managed <- isManaged (argType arg)
        when managed $
          case argCType arg of
            Maybe Text
    Nothing -> Text -> CodeGen CGError ()
    forall a. Text -> ExcCodeGen a
    badIntroError (Text -> CodeGen CGError ()) -> Text -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "Missing C type for argument ‘" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <>
                       Arg -> Text
    argCName Arg
    arg Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "’"
            Just Text
    ctype -> Bool -> CodeGen CGError () -> CodeGen CGError ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Bool -> Bool
    not (Bool -> Bool) -> Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ Text
    "**" Text -> Text -> Bool
    `T.isSuffixOf` Text
    ctype) (CodeGen CGError () -> CodeGen CGError ())
    -> CodeGen CGError () -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $
                          Text -> CodeGen CGError ()
    forall a. Text -> ExcCodeGen a
    badIntroError (Text -> CodeGen CGError ()) -> Text -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "C type for argument ‘" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <>
                          Arg -> Text
    argCName Arg
    arg Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "’ is not a pointer to a pointer"
        name'' <- genConversion (prime name') $
                  literal $ M $ "allocMem :: " <> typeShow (io $ ptr ft)
        line $ "poke " <> name'' <> " " <> name'
        return name''

    prepareOutArg :: Arg -> ExcCodeGen Text
    prepareOutArg :: Arg -> ExcCodeGen Text
    prepareOutArg Arg
    arg = do
      let name :: Text
    name = Arg -> Text
    escapedArgName Arg
    arg
      ft <- Type -> ExcCodeGen TypeRep
    forall e. Type -> CodeGen e TypeRep
    foreignType (Type -> ExcCodeGen TypeRep) -> Type -> ExcCodeGen TypeRep
    forall a b. (a -> b) -> a -> b
    $ Arg -> Type
    argType Arg
    arg
      if argCallerAllocates arg
      then do
        allocInfo <- typeAllocInfo (argType arg)
        case allocInfo of
          Just (TypeAlloc Text
    allocator Int
    _) -> do
              Text -> Converter -> ExcCodeGen Text
    forall e. Text -> Converter -> CodeGen e Text
    genConversion Text
    name (Converter -> ExcCodeGen Text) -> Converter -> ExcCodeGen Text
    forall a b. (a -> b) -> a -> b
    $ Constructor -> Converter
    literal (Constructor -> Converter) -> Constructor -> Converter
    forall a b. (a -> b) -> a -> b
    $ Text -> Constructor
    M (Text -> Constructor) -> Text -> Constructor
    forall a b. (a -> b) -> a -> b
    $ Text
    allocator Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <>
                                Text
    " :: " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> TypeRep -> Text
    typeShow (TypeRep -> TypeRep
    io TypeRep
    ft)
          Maybe TypeAllocInfo
    Nothing ->
              Text -> ExcCodeGen Text
    forall a. Text -> ExcCodeGen a
    notImplementedError (Text -> ExcCodeGen Text) -> Text -> ExcCodeGen Text
    forall a b. (a -> b) -> a -> b
    $ (Text
    "Don't know how to allocate \""
                                     Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Arg -> Text
    argCName Arg
    arg Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "\" of type "
                                     Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Type -> Text
    forall a. Show a => a -> Text
    tshow (Arg -> Type
    argType Arg
    arg))
      else do
        -- Initialize pointers to NULL to avoid a crash in case the function
        -- does not initialize it.
        isPtr <- typeIsPtr (argType arg)
        let alloc = if Bool
    isPtr
                    then Text
    "callocMem"
                    else Text
    "allocMem"
        genConversion name $ literal $ M $ alloc <> " :: " <> typeShow (io $ ptr ft)

    -- Convert a non-zero terminated out array, stored in a variable
    -- named "aname", into the corresponding Haskell object.
    convertOutCArray :: Callable -> Type -> Text -> Map.Map Text Text ->
                        Transfer -> (Text -> Text) -> ExcCodeGen Text
    convertOutCArray :: Callable
    -> Type
    -> Text
    -> Map Text Text
    -> Transfer
    -> (Text -> Text)
    -> ExcCodeGen Text
    convertOutCArray Callable
    callable t :: Type
    t@(TCArray Bool
    False Int
    fixed Int
    length Type
    _) Text
    aname
                     Map Text Text
    nameMap Transfer
    transfer Text -> Text
    primeLength = do
      if Int
    fixed Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > -Int
    1
      then do
        unpacked <- Text -> CodeGen CGError Converter -> ExcCodeGen Text
    forall e. Text -> CodeGen e Converter -> CodeGen e Text
    convert Text
    aname (CodeGen CGError Converter -> ExcCodeGen Text)
    -> CodeGen CGError Converter -> ExcCodeGen Text
    forall a b. (a -> b) -> a -> b
    $ Text -> Type -> Transfer -> CodeGen CGError Converter
    unpackCArray (Int -> Text
    forall a. Show a => a -> Text
    tshow Int
    fixed) Type
    t Transfer
    transfer
        -- Free the memory associated with the array.
        freeContainerType transfer t aname undefined
        return unpacked
      else do
        Bool -> CodeGen CGError () -> CodeGen CGError ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Int
    length Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == -Int
    1) (CodeGen CGError () -> CodeGen CGError ())
    -> CodeGen CGError () -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $
             Text -> CodeGen CGError ()
    forall a. Text -> ExcCodeGen a
    badIntroError (Text -> CodeGen CGError ()) -> Text -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "Unknown length for \"" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    aname Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "\""
        let lname :: Text
    lname = Arg -> Text
    escapedArgName (Arg -> Text) -> Arg -> Text
    forall a b. (a -> b) -> a -> b
    $ (Callable -> [Arg]
    args Callable
    callable)[Arg] -> Int -> Arg
    forall a. HasCallStack => [a] -> Int -> a
    !!Int
    length
        lname' <- case Text -> Map Text Text -> Maybe Text
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup Text
    lname Map Text Text
    nameMap of
                    Just Text
    n -> Text -> ExcCodeGen Text
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Text
    n
                    Maybe Text
    Nothing ->
                        Text -> ExcCodeGen Text
    forall a. Text -> ExcCodeGen a
    badIntroError (Text -> ExcCodeGen Text) -> Text -> ExcCodeGen Text
    forall a b. (a -> b) -> a -> b
    $ Text
    "Couldn't find out array length " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <>
                                                Text
    lname
        let lname'' = Text -> Text
    primeLength Text
    lname'
        unpacked <- convert aname $ unpackCArray lname'' t transfer
        -- Free the memory associated with the array.
        freeContainerType transfer t aname lname''
        return unpacked

    -- Remove the warning, this should never be reached.
    convertOutCArray Callable
    _ Type
    t Text
    _ Map Text Text
    _ Transfer
    _ Text -> Text
    _ =
        Text -> ExcCodeGen Text
    forall a. HasCallStack => Text -> a
    terror (Text -> ExcCodeGen Text) -> Text -> ExcCodeGen Text
    forall a b. (a -> b) -> a -> b
    $ Text
    "convertOutCArray : unexpected " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Type -> Text
    forall a. Show a => a -> Text
    tshow Type
    t

    -- Read the array lengths for out arguments.
    readOutArrayLengths :: Callable -> Map.Map Text Text -> ExcCodeGen ()
    readOutArrayLengths :: Callable -> Map Text Text -> CodeGen CGError ()
    readOutArrayLengths Callable
    callable Map Text Text
    nameMap = do
      let lNames :: [Text]
    lNames = [Text] -> [Text]
    forall a. Eq a => [a] -> [a]
    nub ([Text] -> [Text]) -> [Text] -> [Text]
    forall a b. (a -> b) -> a -> b
    $ (Arg -> Text) -> [Arg] -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    map Arg -> Text
    escapedArgName ([Arg] -> [Text]) -> [Arg] -> [Text]
    forall a b. (a -> b) -> a -> b
    $
                   (Arg -> Bool) -> [Arg] -> [Arg]
    forall a. (a -> Bool) -> [a] -> [a]
    filter ((Direction -> Direction -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Direction
    DirectionIn) (Direction -> Bool) -> (Arg -> Direction) -> Arg -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Arg -> Direction
    direction) ([Arg] -> [Arg]) -> [Arg] -> [Arg]
    forall a b. (a -> b) -> a -> b
    $
                   Callable -> [Arg]
    arrayLengths Callable
    callable
      [Text] -> (Text -> ExcCodeGen Text) -> CodeGen CGError ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ [Text]
    lNames ((Text -> ExcCodeGen Text) -> CodeGen CGError ())
    -> (Text -> ExcCodeGen Text) -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ \Text
    lname -> do
        lname' <- case Text -> Map Text Text -> Maybe Text
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup Text
    lname Map Text Text
    nameMap of
                       Just Text
    n -> Text -> ExcCodeGen Text
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Text
    n
                       Maybe Text
    Nothing ->
                           Text -> ExcCodeGen Text
    forall a. Text -> ExcCodeGen a
    badIntroError (Text -> ExcCodeGen Text) -> Text -> ExcCodeGen Text
    forall a b. (a -> b) -> a -> b
    $ Text
    "Couldn't find out array length " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <>
                                                   Text
    lname
        genConversion lname' $ apply $ M "peek"

    -- Touch DirectionIn arguments so we are sure that they exist when the
    -- C function was called.
    touchInArg :: Arg -> ExcCodeGen ()
    touchInArg :: Arg -> CodeGen CGError ()
    touchInArg Arg
    arg = Bool -> CodeGen CGError () -> CodeGen CGError ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Arg -> Direction
    direction Arg
    arg Direction -> Direction -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Direction
    DirectionOut) (CodeGen CGError () -> CodeGen CGError ())
    -> CodeGen CGError () -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ do
      let name :: Text
    name = Arg -> Text
    escapedArgName Arg
    arg
      case Type -> Maybe Type
    elementType (Arg -> Type
    argType Arg
    arg) of
        Just Type
    a -> do
          managed <- Type -> CodeGen CGError Bool
    forall e. Type -> CodeGen e Bool
    isManaged Type
    a
          when managed $ wrapMaybe arg >>= bool
                  (line $ "mapM_ touchManagedPtr " <> name)
                  (line $ "whenJust " <> name <> " (mapM_ touchManagedPtr)")
        Maybe Type
    Nothing -> do
          managed <- Type -> CodeGen CGError Bool
    forall e. Type -> CodeGen e Bool
    isManaged (Arg -> Type
    argType Arg
    arg)
          when managed $ wrapMaybe arg >>= bool
               (line $ "touchManagedPtr " <> name)
               (line $ "whenJust " <> name <> " touchManagedPtr")

    -- Find the association between closure arguments and their
    -- corresponding callback.
    closureToCallbackMap :: Callable -> ExcCodeGen (Map.Map Int Arg)
    closureToCallbackMap :: Callable -> ExcCodeGen (Map Int Arg)
    closureToCallbackMap Callable
    callable =
        -- The introspection info does not specify the closure for destroy
        -- notify's associated with a callback, since it is implicitly the
        -- same one as the ScopeTypeNotify callback associated with the
        -- DestroyNotify.
        [Arg] -> Map Int Arg -> ExcCodeGen (Map Int Arg)
    go ((Arg -> Bool) -> [Arg] -> [Arg]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Bool -> Bool
    not (Bool -> Bool) -> (Arg -> Bool) -> Arg -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Arg -> [Arg] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [Arg]
    destroyers)) ([Arg] -> [Arg]) -> [Arg] -> [Arg]
    forall a b. (a -> b) -> a -> b
    $ Callable -> [Arg]
    args Callable
    callable) Map Int Arg
    forall k a. Map k a
    Map.empty

        where destroyers :: [Arg]
    destroyers = (Int -> Arg) -> [Int] -> [Arg]
    forall a b. (a -> b) -> [a] -> [b]
    map (Callable -> [Arg]
    args Callable
    callable[Arg] -> Int -> Arg
    forall a. HasCallStack => [a] -> Int -> a
    !!) ([Int] -> [Arg]) -> ([Arg] -> [Int]) -> [Arg] -> [Arg]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Int -> Bool) -> [Int] -> [Int]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    /= -Int
    1) ([Int] -> [Int]) -> ([Arg] -> [Int]) -> [Arg] -> [Int]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Arg -> Int) -> [Arg] -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map Arg -> Int
    argDestroy
                           ([Arg] -> [Arg]) -> [Arg] -> [Arg]
    forall a b. (a -> b) -> a -> b
    $ Callable -> [Arg]
    args Callable
    callable

              go :: [Arg] -> Map.Map Int Arg -> ExcCodeGen (Map.Map Int Arg)
              go :: [Arg] -> Map Int Arg -> ExcCodeGen (Map Int Arg)
    go [] Map Int Arg
    m = Map Int Arg -> ExcCodeGen (Map Int Arg)
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Map Int Arg
    m
              go (Arg
    arg:[Arg]
    as) Map Int Arg
    m =
                  if Arg -> Scope
    argScope Arg
    arg Scope -> Scope -> Bool
    forall a. Eq a => a -> a -> Bool
    == Scope
    ScopeTypeInvalid
                  then [Arg] -> Map Int Arg -> ExcCodeGen (Map Int Arg)
    go [Arg]
    as Map Int Arg
    m
                  else case Arg -> Int
    argClosure Arg
    arg of
                      (-1) -> [Arg] -> Map Int Arg -> ExcCodeGen (Map Int Arg)
    go [Arg]
    as Map Int Arg
    m
                      Int
    c -> case Int -> Map Int Arg -> Maybe Arg
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup Int
    c Map Int Arg
    m of
                          Just Arg
    _ -> Text -> ExcCodeGen (Map Int Arg)
    forall a. Text -> ExcCodeGen a
    notImplementedError (Text -> ExcCodeGen (Map Int Arg))
    -> Text -> ExcCodeGen (Map Int Arg)
    forall a b. (a -> b) -> a -> b
    $
                                    Text
    "Closure for multiple callbacks unsupported"
                                    Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> String -> Text
    T.pack (Arg -> String
    forall a. Show a => a -> String
    ppShow Arg
    arg) Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "\n"
                                    Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> String -> Text
    T.pack (Callable -> String
    forall a. Show a => a -> String
    ppShow Callable
    callable)
                          Maybe Arg
    Nothing -> [Arg] -> Map Int Arg -> ExcCodeGen (Map Int Arg)
    go [Arg]
    as (Map Int Arg -> ExcCodeGen (Map Int Arg))
    -> Map Int Arg -> ExcCodeGen (Map Int Arg)
    forall a b. (a -> b) -> a -> b
    $ Int -> Arg -> Map Int Arg -> Map Int Arg
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    Map.insert Int
    c Arg
    arg Map Int Arg
    m

    -- user_data style arguments.
    prepareClosures :: Callable -> Map.Map Text Text -> ExcCodeGen ()
    prepareClosures :: Callable -> Map Text Text -> CodeGen CGError ()
    prepareClosures Callable
    callable Map Text Text
    nameMap = do
      m <- Callable -> ExcCodeGen (Map Int Arg)
    closureToCallbackMap Callable
    callable
      let closures = (Int -> Bool) -> [Int] -> [Int]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    /= -Int
    1) ([Int] -> [Int]) -> ([Arg] -> [Int]) -> [Arg] -> [Int]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Arg -> Int) -> [Arg] -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map Arg -> Int
    argClosure ([Arg] -> [Int]) -> [Arg] -> [Int]
    forall a b. (a -> b) -> a -> b
    $ Callable -> [Arg]
    args Callable
    callable
      forM_ closures $ \Int
    closure ->
          case Int -> Map Int Arg -> Maybe Arg
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup Int
    closure Map Int Arg
    m of
            Maybe Arg
    Nothing -> Text -> CodeGen CGError ()
    forall a. Text -> ExcCodeGen a
    badIntroError (Text -> CodeGen CGError ()) -> Text -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "Closure not found! "
                                    Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "\nClosure: " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Int -> Text
    forall a. Show a => a -> Text
    tshow Int
    closure
                                    Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "\nc2cm: " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> String -> Text
    T.pack (Map Int Arg -> String
    forall a. Show a => a -> String
    ppShow Map Int Arg
    m)
                                    Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "\ncallable: " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> String -> Text
    T.pack (Callable -> String
    forall a. Show a => a -> String
    ppShow Callable
    callable)
            Just Arg
    cb -> do
              let closureName :: Text
    closureName = Arg -> Text
    escapedArgName (Arg -> Text) -> Arg -> Text
    forall a b. (a -> b) -> a -> b
    $ (Callable -> [Arg]
    args Callable
    callable)[Arg] -> Int -> Arg
    forall a. HasCallStack => [a] -> Int -> a
    !!Int
    closure
                  n :: Text
    n = Arg -> Text
    escapedArgName Arg
    cb
              n' <- case Text -> Map Text Text -> Maybe Text
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup Text
    n Map Text Text
    nameMap of
                      Just Text
    n -> Text -> ExcCodeGen Text
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Text
    n
                      Maybe Text
    Nothing -> Text -> ExcCodeGen Text
    forall a. Text -> ExcCodeGen a
    badIntroError (Text -> ExcCodeGen Text) -> Text -> ExcCodeGen Text
    forall a b. (a -> b) -> a -> b
    $ Text
    "Cannot find closure name!! "
                                               Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> String -> Text
    T.pack (Callable -> String
    forall a. Show a => a -> String
    ppShow Callable
    callable) Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "\n"
                                               Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> String -> Text
    T.pack (Map Text Text -> String
    forall a. Show a => a -> String
    ppShow Map Text Text
    nameMap)
              -- Check that the given closure is an actual callback type.
              maybeAPI <- findAPI (argType cb)
              case maybeAPI of
                Just (APICallback Callback
    _) -> do
                  case Arg -> Scope
    argScope Arg
    cb of
                    Scope
    ScopeTypeInvalid -> Text -> CodeGen CGError ()
    forall a. Text -> ExcCodeGen a
    badIntroError (Text -> CodeGen CGError ()) -> Text -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "Invalid scope! "
                                                  Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> String -> Text
    T.pack (Callable -> String
    forall a. Show a => a -> String
    ppShow Callable
    callable)
                    Scope
    ScopeTypeNotified -> do
                      Text -> CodeGen CGError ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen CGError ()) -> Text -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "let " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    closureName Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " = castFunPtrToPtr " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    n'
                      case Arg -> Int
    argDestroy Arg
    cb of
                        (-1) -> Text -> CodeGen CGError ()
    forall a. Text -> ExcCodeGen a
    badIntroError (Text -> CodeGen CGError ()) -> Text -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $
                                Text
    "ScopeTypeNotified without destructor! "
                                Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> String -> Text
    T.pack (Callable -> String
    forall a. Show a => a -> String
    ppShow Callable
    callable)
                        Int
    k -> do
                          let destroyArg :: Arg
    destroyArg = (Callable -> [Arg]
    args Callable
    callable)[Arg] -> Int -> Arg
    forall a. HasCallStack => [a] -> Int -> a
    !!Int
    k
                              destroyName :: Text
    destroyName = Arg -> Text
    escapedArgName Arg
    destroyArg
                          destroyFun <- case Arg -> Type
    argType Arg
    destroyArg of
                            TInterface (Name Text
    "GLib" Text
    "DestroyNotify") ->
                              Text -> ExcCodeGen Text
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Text
    "SP.safeFreeFunPtrPtr"
                            TInterface (Name Text
    "GObject" Text
    "ClosureNotify") ->
                              Text -> ExcCodeGen Text
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Text
    "SP.safeFreeFunPtrPtr'"
                            Type
    _ -> Text -> ExcCodeGen Text
    forall a. Text -> ExcCodeGen a
    notImplementedError (Text -> ExcCodeGen Text) -> Text -> ExcCodeGen Text
    forall a b. (a -> b) -> a -> b
    $ Text
    "Unknown destroy type: " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Type -> Text
    forall a. Show a => a -> Text
    tshow (Arg -> Type
    argType Arg
    destroyArg)
                          line $ "let " <> destroyName <> " = " <> destroyFun
                    Scope
    ScopeTypeAsync -> do
                      Text -> CodeGen CGError ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen CGError ()) -> Text -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "let " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    closureName Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " = nullPtr"
                      case Arg -> Int
    argDestroy Arg
    cb of
                        -- Async callbacks don't really need destroy
                        -- notifications, as they can always be released
                        -- at the end of the callback.
                        (-1) -> () -> CodeGen CGError ()
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                        Int
    n -> let destroyName :: Text
    destroyName = Arg -> Text
    escapedArgName (Arg -> Text) -> Arg -> Text
    forall a b. (a -> b) -> a -> b
    $ (Callable -> [Arg]
    args Callable
    callable)[Arg] -> Int -> Arg
    forall a. HasCallStack => [a] -> Int -> a
    !!Int
    n
                             in Text -> CodeGen CGError ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen CGError ()) -> Text -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "let " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    destroyName Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " = FP.nullFunPtr"
                    Scope
    ScopeTypeCall -> Text -> CodeGen CGError ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen CGError ()) -> Text -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "let " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    closureName Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " = nullPtr"
                    Scope
    ScopeTypeForever -> Text -> CodeGen CGError ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen CGError ()) -> Text -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "let " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    closureName Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " = nullPtr"
                Maybe API
    _ -> Text -> CodeGen CGError ()
    forall a. Text -> ExcCodeGen a
    badIntroError (Text -> CodeGen CGError ()) -> Text -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "Closure \"" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    n Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "\" is not a callback."

    freeCallCallbacks :: Callable -> Map.Map Text Text -> ExcCodeGen ()
    freeCallCallbacks :: Callable -> Map Text Text -> CodeGen CGError ()
    freeCallCallbacks Callable
    callable Map Text Text
    nameMap =
        [Arg] -> (Arg -> CodeGen CGError ()) -> CodeGen CGError ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ (Callable -> [Arg]
    args Callable
    callable) ((Arg -> CodeGen CGError ()) -> CodeGen CGError ())
    -> (Arg -> CodeGen CGError ()) -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ \Arg
    arg -> do
           let name :: Text
    name = Arg -> Text
    escapedArgName Arg
    arg
           name' <- case Text -> Map Text Text -> Maybe Text
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup Text
    name Map Text Text
    nameMap of
                      Just Text
    n -> Text -> ExcCodeGen Text
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Text
    n
                      Maybe Text
    Nothing -> Text -> ExcCodeGen Text
    forall a. Text -> ExcCodeGen a
    badIntroError (Text -> ExcCodeGen Text) -> Text -> ExcCodeGen Text
    forall a b. (a -> b) -> a -> b
    $ Text
    "Could not find " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    name
                                    Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " in " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> String -> Text
    T.pack (Callable -> String
    forall a. Show a => a -> String
    ppShow Callable
    callable) Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "\n"
                                    Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> String -> Text
    T.pack (Map Text Text -> String
    forall a. Show a => a -> String
    ppShow Map Text Text
    nameMap)
           when (argScope arg == ScopeTypeCall) $ do
             isCallback <- typeIsCallback (argType arg)
             if isCallback
               then line $ "safeFreeFunPtr $ castFunPtrToPtr " <> name'
               else comment $ "XXX: Ignoring scope annotation on a non-callback argument: " <> name

    -- | Format the signature of the Haskell binding for the `Callable`.
    formatHSignature :: Callable -> ForeignSymbol -> ExposeClosures -> ExcCodeGen ()
    formatHSignature :: Callable -> ForeignSymbol -> ExposeClosures -> CodeGen CGError ()
    formatHSignature Callable
    callable ForeignSymbol
    symbol ExposeClosures
    expose = do
      sig <- Callable -> ForeignSymbol -> ExposeClosures -> ExcCodeGen Signature
    callableSignature Callable
    callable ForeignSymbol
    symbol ExposeClosures
    expose
      indent $ do
          let constraints = Text
    "B.CallStack.HasCallStack" Text -> [Text] -> [Text]
    forall a. a -> [a] -> [a]
    : Signature -> [Text]
    signatureConstraints Signature
    sig
          line $ "(" <> T.intercalate ", " constraints <> ") =>"
          forM_ (zip ("" : repeat "-> ") (signatureArgTypes sig)) $
            \(Text
    prefix, (Maybe Arg
    maybeArg, Text
    t)) -> do
              Text -> CodeGen CGError ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen CGError ()) -> Text -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ Text
    prefix Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    t
              case Maybe Arg
    maybeArg of
                Maybe Arg
    Nothing -> () -> CodeGen CGError ()
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                Just Arg
    arg -> Arg -> CodeGen CGError ()
    forall e. Arg -> CodeGen e ()
    writeArgDocumentation Arg
    arg
          let resultPrefix = if [(Maybe Arg, Text)] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null (Signature -> [(Maybe Arg, Text)]
    signatureArgTypes Signature
    sig)
                             then Text
    ""
                             else Text
    "-> "
          line $ resultPrefix <> signatureReturnType sig
          writeReturnDocumentation (signatureCallable sig) (skipRetVal callable)

    -- | Name for the first argument in dynamic wrappers (the `FunPtr`).
    funPtr :: Text
    funPtr :: Text
    funPtr = Text
    "__funPtr"

    -- | Signature for a callable.
    data Signature = Signature { Signature -> Callable
    signatureCallable    :: Callable
                               , Signature -> [Text]
    signatureConstraints :: [Text]
                               , Signature -> [(Maybe Arg, Text)]
    signatureArgTypes    :: [(Maybe Arg, Text)]
                               , Signature -> Text
    signatureReturnType  :: Text
                               }

    -- | The Haskell signature for the given callable. It returns a tuple
    -- ([constraints], [(type, argname)]).
    callableSignature :: Callable -> ForeignSymbol -> ExposeClosures
                      -> ExcCodeGen Signature
    callableSignature :: Callable -> ForeignSymbol -> ExposeClosures -> ExcCodeGen Signature
    callableSignature Callable
    callable ForeignSymbol
    symbol ExposeClosures
    expose = do
      let ([Arg]
    hInArgs, [Arg]
    _) = Callable -> ExposeClosures -> ([Arg], [Arg])
    callableHInArgs Callable
    callable
                                        (case ForeignSymbol
    symbol of
                                           KnownForeignSymbol Text
    _ -> ExposeClosures
    WithoutClosures
                                           DynamicForeignSymbol DynamicWrapper
    _ -> ExposeClosures
    WithClosures)
      (argConstraints, types) <- [Arg] -> ExposeClosures -> ExcCodeGen ([Text], [Text])
    inArgInterfaces [Arg]
    hInArgs ExposeClosures
    expose
      let constraints = (Text
    "MonadIO m" Text -> [Text] -> [Text]
    forall a. a -> [a] -> [a]
    : [Text]
    argConstraints)
      outType <- hOutType callable (callableHOutArgs callable)
      return $ Signature {
          signatureCallable = callable,
          signatureConstraints = constraints,
          signatureReturnType = typeShow ("m" `con` [outType]),
          signatureArgTypes = case symbol of
              KnownForeignSymbol Text
    _ -> [Maybe Arg] -> [Text] -> [(Maybe Arg, Text)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip ((Arg -> Maybe Arg) -> [Arg] -> [Maybe Arg]
    forall a b. (a -> b) -> [a] -> [b]
    map Arg -> Maybe Arg
    forall a. a -> Maybe a
    Just [Arg]
    hInArgs) [Text]
    types
              DynamicForeignSymbol DynamicWrapper
    w -> [Maybe Arg] -> [Text] -> [(Maybe Arg, Text)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip (Maybe Arg
    forall a. Maybe a
    Nothing Maybe Arg -> [Maybe Arg] -> [Maybe Arg]
    forall a. a -> [a] -> [a]
    : (Arg -> Maybe Arg) -> [Arg] -> [Maybe Arg]
    forall a b. (a -> b) -> [a] -> [b]
    map Arg -> Maybe Arg
    forall a. a -> Maybe a
    Just [Arg]
    hInArgs)
                                        (Text
    "FunPtr " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> DynamicWrapper -> Text
    dynamicType DynamicWrapper
    w Text -> [Text] -> [Text]
    forall a. a -> [a] -> [a]
    : [Text]
    types)
          }

    -- | "In" arguments for the given callable on the Haskell side,
    -- together with the omitted arguments.
    callableHInArgs :: Callable -> ExposeClosures -> ([Arg], [Arg])
    callableHInArgs :: Callable -> ExposeClosures -> ([Arg], [Arg])
    callableHInArgs Callable
    callable ExposeClosures
    expose =
        let inArgs :: [Arg]
    inArgs = (Arg -> Bool) -> [Arg] -> [Arg]
    forall a. (a -> Bool) -> [a] -> [a]
    filter ((Direction -> Direction -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Direction
    DirectionOut) (Direction -> Bool) -> (Arg -> Direction) -> Arg -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Arg -> Direction
    direction) ([Arg] -> [Arg]) -> [Arg] -> [Arg]
    forall a b. (a -> b) -> a -> b
    $ Callable -> [Arg]
    args Callable
    callable
                     -- We do not expose user_data arguments,
                     -- destroynotify arguments, and C array length
                     -- arguments to Haskell code.
            closures :: [Arg]
    closures = (Int -> Arg) -> [Int] -> [Arg]
    forall a b. (a -> b) -> [a] -> [b]
    map (Callable -> [Arg]
    args Callable
    callable[Arg] -> Int -> Arg
    forall a. HasCallStack => [a] -> Int -> a
    !!) ([Int] -> [Arg]) -> ([Arg] -> [Int]) -> [Arg] -> [Arg]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Int -> Bool) -> [Int] -> [Int]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    /= -Int
    1) ([Int] -> [Int]) -> ([Arg] -> [Int]) -> [Arg] -> [Int]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Arg -> Int) -> [Arg] -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map Arg -> Int
    argClosure ([Arg] -> [Arg]) -> [Arg] -> [Arg]
    forall a b. (a -> b) -> a -> b
    $ [Arg]
    inArgs
            destroyers :: [Arg]
    destroyers = (Int -> Arg) -> [Int] -> [Arg]
    forall a b. (a -> b) -> [a] -> [b]
    map (Callable -> [Arg]
    args Callable
    callable[Arg] -> Int -> Arg
    forall a. HasCallStack => [a] -> Int -> a
    !!) ([Int] -> [Arg]) -> ([Arg] -> [Int]) -> [Arg] -> [Arg]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Int -> Bool) -> [Int] -> [Int]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    /= -Int
    1) ([Int] -> [Int]) -> ([Arg] -> [Int]) -> [Arg] -> [Int]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Arg -> Int) -> [Arg] -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map Arg -> Int
    argDestroy ([Arg] -> [Arg]) -> [Arg] -> [Arg]
    forall a b. (a -> b) -> a -> b
    $ [Arg]
    inArgs
            callbackUserData :: [Arg]
    callbackUserData = (Arg -> Bool) -> [Arg] -> [Arg]
    forall a. (a -> Bool) -> [a] -> [a]
    filter Arg -> Bool
    argCallbackUserData (Callable -> [Arg]
    args Callable
    callable)
            omitted :: [Arg]
    omitted = case ExposeClosures
    expose of
                        ExposeClosures
    WithoutClosures -> Callable -> [Arg]
    arrayLengths Callable
    callable [Arg] -> [Arg] -> [Arg]
    forall a. Semigroup a => a -> a -> a
    <> [Arg]
    closures [Arg] -> [Arg] -> [Arg]
    forall a. Semigroup a => a -> a -> a
    <> [Arg]
    destroyers [Arg] -> [Arg] -> [Arg]
    forall a. Semigroup a => a -> a -> a
    <> [Arg]
    callbackUserData
                        ExposeClosures
    WithClosures -> Callable -> [Arg]
    arrayLengths Callable
    callable
        in ((Arg -> Bool) -> [Arg] -> [Arg]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Arg -> [Arg] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` [Arg]
    omitted) [Arg]
    inArgs, [Arg]
    omitted)

    -- | "Out" arguments for the given callable on the Haskell side.
    callableHOutArgs :: Callable -> [Arg]
    callableHOutArgs :: Callable -> [Arg]
    callableHOutArgs Callable
    callable =
        let outArgs :: [Arg]
    outArgs = (Arg -> Bool) -> [Arg] -> [Arg]
    forall a. (a -> Bool) -> [a] -> [a]
    filter ((Direction -> Direction -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Direction
    DirectionIn) (Direction -> Bool) -> (Arg -> Direction) -> Arg -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Arg -> Direction
    direction) ([Arg] -> [Arg]) -> [Arg] -> [Arg]
    forall a b. (a -> b) -> a -> b
    $ Callable -> [Arg]
    args Callable
    callable
        in (Arg -> Bool) -> [Arg] -> [Arg]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Arg -> [Arg] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` (Callable -> [Arg]
    arrayLengths Callable
    callable)) [Arg]
    outArgs

    -- | Convert the result of the foreign call to Haskell.
    convertResult :: Name -> Callable -> Map.Map Text Text ->
                     ExcCodeGen Text
    convertResult :: Name -> Callable -> Map Text Text -> ExcCodeGen Text
    convertResult Name
    n Callable
    callable Map Text Text
    nameMap =
        if Callable -> Bool
    skipRetVal Callable
    callable Bool -> Bool -> Bool
    || Callable -> Maybe Type
    returnType Callable
    callable Maybe Type -> Maybe Type -> Bool
    forall a. Eq a => a -> a -> Bool
    == Maybe Type
    forall a. Maybe a
    Nothing
        then Text -> ExcCodeGen Text
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> Text
    forall a. HasCallStack => String -> a
    error String
    "convertResult: unreachable code reached, bug!")
        else do
          nullableReturnType <- CodeGen CGError Bool
    -> (Type -> CodeGen CGError Bool)
    -> Maybe Type
    -> CodeGen CGError Bool
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (Bool -> CodeGen CGError Bool
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False) Type -> CodeGen CGError Bool
    forall e. Type -> CodeGen e Bool
    typeIsNullable (Callable -> Maybe Type
    returnType Callable
    callable)
          if returnMayBeNull callable && nullableReturnType
          then do
            line $ "maybeResult <- convertIfNonNull result $ \\result' -> do"
            indent $ do
                 converted <- unwrappedConvertResult "result'"
                 line $ "return " <> converted
                 return "maybeResult"
          else do
            when nullableReturnType $
                 line $ "checkUnexpectedReturnNULL \"" <> lowerName n
                          <> "\" result"
            unwrappedConvertResult "result"

        where
          unwrappedConvertResult :: Text -> ExcCodeGen Text
    unwrappedConvertResult Text
    rname =
              case Callable -> Maybe Type
    returnType Callable
    callable of
                -- Arrays without length information cannot be converted
                -- into Haskell values.
                Just (t :: Type
    t@(TCArray Bool
    False (-1) (-1) Type
    _)) ->
                    Text -> ExcCodeGen Text
    forall a. Text -> ExcCodeGen a
    badIntroError (Text
    "`" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Type -> Text
    forall a. Show a => a -> Text
    tshow Type
    t Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <>
                    Text
    "' is an array type, but contains no length information,\n"
                    Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "so it cannot be unpacked.")
                -- Not zero-terminated C arrays require knowledge of the
                -- length, so we deal with them directly.
                Just (t :: Type
    t@(TCArray Bool
    False Int
    _ Int
    _ Type
    _)) ->
                    Callable
    -> Type
    -> Text
    -> Map Text Text
    -> Transfer
    -> (Text -> Text)
    -> ExcCodeGen Text
    convertOutCArray Callable
    callable Type
    t Text
    rname Map Text Text
    nameMap
                                     (Callable -> Transfer
    returnTransfer Callable
    callable) Text -> Text
    prime
                Just Type
    t -> do
                    result <- Text -> CodeGen CGError Converter -> ExcCodeGen Text
    forall e. Text -> CodeGen e Converter -> CodeGen e Text
    convert Text
    rname (CodeGen CGError Converter -> ExcCodeGen Text)
    -> CodeGen CGError Converter -> ExcCodeGen Text
    forall a b. (a -> b) -> a -> b
    $ Type -> Transfer -> CodeGen CGError Converter
    fToH Type
    t (Callable -> Transfer
    returnTransfer Callable
    callable)
                    freeContainerType (returnTransfer callable) t rname undefined
                    return result
                Maybe Type
    Nothing -> Text -> ExcCodeGen Text
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> Text
    forall a. HasCallStack => String -> a
    error String
    "unwrappedConvertResult: bug!")

    -- | Marshal a foreign out argument to Haskell, returning the name of
    -- the variable containing the converted Haskell value.
    convertOutArg :: Callable -> Map.Map Text Text -> Arg -> ExcCodeGen Text
    convertOutArg :: Callable -> Map Text Text -> Arg -> ExcCodeGen Text
    convertOutArg Callable
    callable Map Text Text
    nameMap Arg
    arg = do
      let name :: Text
    name = Arg -> Text
    escapedArgName Arg
    arg
      inName <- case Text -> Map Text Text -> Maybe Text
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup Text
    name Map Text Text
    nameMap of
          Just Text
    name' -> Text -> ExcCodeGen Text
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Text
    name'
          Maybe Text
    Nothing -> Text -> ExcCodeGen Text
    forall a. Text -> ExcCodeGen a
    badIntroError (Text -> ExcCodeGen Text) -> Text -> ExcCodeGen Text
    forall a b. (a -> b) -> a -> b
    $ Text
    "Parameter " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    name Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " not found!"
      case argType arg of
          t :: Type
    t@(TCArray Bool
    False (-1) (-1) Type
    _) ->
              if Arg -> Bool
    argCallerAllocates Arg
    arg
              then Text -> ExcCodeGen Text
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Text
    inName
              else  Text -> ExcCodeGen Text
    forall a. Text -> ExcCodeGen a
    badIntroError (Text
    "`" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Type -> Text
    forall a. Show a => a -> Text
    tshow Type
    t Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <>
                    Text
    "' is an array type, but contains no length information,\n"
                    Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "so it cannot be unpacked.")
          t :: Type
    t@(TCArray Bool
    False Int
    _ Int
    _ Type
    _) -> do
              aname' <- if Arg -> Bool
    argCallerAllocates Arg
    arg
                        then Text -> ExcCodeGen Text
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Text
    inName
                        else Text -> Converter -> ExcCodeGen Text
    forall e. Text -> Converter -> CodeGen e Text
    genConversion Text
    inName (Converter -> ExcCodeGen Text) -> Converter -> ExcCodeGen Text
    forall a b. (a -> b) -> a -> b
    $ Constructor -> Converter
    apply (Constructor -> Converter) -> Constructor -> Converter
    forall a b. (a -> b) -> a -> b
    $ Text -> Constructor
    M Text
    "peek"
              let arrayLength = if Arg -> Bool
    argCallerAllocates Arg
    arg
                                then Text -> Text
    forall a. a -> a
    id
                                else Text -> Text
    prime
                  wrapArray Text
    a = Callable
    -> Type
    -> Text
    -> Map Text Text
    -> Transfer
    -> (Text -> Text)
    -> ExcCodeGen Text
    convertOutCArray Callable
    callable Type
    t Text
    a
                                    Map Text Text
    nameMap (Arg -> Transfer
    transfer Arg
    arg) Text -> Text
    arrayLength
              wrapMaybe arg >>= bool
                     (wrapArray aname')
                     (do line $ "maybe" <> ucFirst aname'
                             <> " <- convertIfNonNull " <> aname'
                             <> " $ \\" <> prime aname' <> " -> do"
                         indent $ do
                             wrapped <- wrapArray (prime aname')
                             line $ "return " <> wrapped
                         return $ "maybe" <> ucFirst aname')
          Type
    t -> do
              peeked <- if Arg -> Bool
    argCallerAllocates Arg
    arg
                       then Text -> ExcCodeGen Text
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Text
    inName
                       else Text -> Converter -> ExcCodeGen Text
    forall e. Text -> Converter -> CodeGen e Text
    genConversion Text
    inName (Converter -> ExcCodeGen Text) -> Converter -> ExcCodeGen Text
    forall a b. (a -> b) -> a -> b
    $ Constructor -> Converter
    apply (Constructor -> Converter) -> Constructor -> Converter
    forall a b. (a -> b) -> a -> b
    $ Text -> Constructor
    M Text
    "peek"
              -- If we alloc we always take control of the resulting
              -- memory, otherwise we may leak.
              let transfer' = if Arg -> Bool
    argCallerAllocates Arg
    arg
                             then Transfer
    TransferEverything
                             else Arg -> Transfer
    transfer Arg
    arg
              result <- do
                  let wrap Text
    ptr = Text -> CodeGen CGError Converter -> ExcCodeGen Text
    forall e. Text -> CodeGen e Converter -> CodeGen e Text
    convert Text
    ptr (CodeGen CGError Converter -> ExcCodeGen Text)
    -> CodeGen CGError Converter -> ExcCodeGen Text
    forall a b. (a -> b) -> a -> b
    $ Type -> Transfer -> CodeGen CGError Converter
    fToH (Arg -> Type
    argType Arg
    arg) Transfer
    transfer'
                  wrapMaybe arg >>= bool
                      (wrap peeked)
                      (do line $ "maybe" <> ucFirst peeked
                              <> " <- convertIfNonNull " <> peeked
                              <> " $ \\" <> prime peeked <> " -> do"
                          indent $ do
                              wrapped <- wrap (prime peeked)
                              line $ "return " <> wrapped
                          return $ "maybe" <> ucFirst peeked)
              -- Free the memory associated with the out argument
              freeContainerType transfer' t peeked undefined
              return result

    -- | Convert the list of out arguments to Haskell, returning the
    -- names of the corresponding variables containing the marshaled values.
    convertOutArgs :: Callable -> Map.Map Text Text -> [Arg] -> ExcCodeGen [Text]
    convertOutArgs :: Callable -> Map Text Text -> [Arg] -> ExcCodeGen [Text]
    convertOutArgs Callable
    callable Map Text Text
    nameMap [Arg]
    hOutArgs =
        [Arg] -> (Arg -> ExcCodeGen Text) -> ExcCodeGen [Text]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    t a -> (a -> m b) -> m (t b)
    forM [Arg]
    hOutArgs (Callable -> Map Text Text -> Arg -> ExcCodeGen Text
    convertOutArg Callable
    callable Map Text Text
    nameMap)

    -- | Invoke the given C function, taking care of errors.
    invokeCFunction :: Callable -> ForeignSymbol -> [Text] -> CodeGen e ()
    invokeCFunction :: forall e. Callable -> ForeignSymbol -> [Text] -> CodeGen e ()
    invokeCFunction Callable
    callable ForeignSymbol
    symbol [Text]
    argNames = do
      let returnBind :: Text
    returnBind = case Callable -> Maybe Type
    returnType Callable
    callable of
                         Maybe Type
    Nothing -> Text
    ""
                         Maybe Type
    _       -> if Callable -> Bool
    skipRetVal Callable
    callable
                                    then Text
    "_ <- "
                                    else Text
    "result <- "
          maybeCatchGErrors :: Text
    maybeCatchGErrors = if Callable -> Bool
    callableThrows Callable
    callable
                              then Text
    "propagateGError $ "
                              else Text
    ""
          call :: Text
    call = case ForeignSymbol
    symbol of
                   KnownForeignSymbol Text
    s -> Text
    s
                   DynamicForeignSymbol DynamicWrapper
    w -> Text -> Text
    parenthesize (DynamicWrapper -> Text
    dynamicWrapper DynamicWrapper
    w
                                                          Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    funPtr)
      Text -> CodeGen e ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
    forall a b. (a -> b) -> a -> b
    $ Text
    returnBind Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    maybeCatchGErrors
               Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    call Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> ([Text] -> Text
    T.concat ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Text -> Text) -> [Text] -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    map (Text
    " " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <>)) [Text]
    argNames

    -- | Return the result of the call, possibly including out arguments.
    returnResult :: Callable -> Text -> [Text] -> CodeGen e ()
    returnResult :: forall e. Callable -> Text -> [Text] -> CodeGen e ()
    returnResult Callable
    callable Text
    result [Text]
    pps =
        if Callable -> Bool
    skipRetVal Callable
    callable Bool -> Bool -> Bool
    || Callable -> Maybe Type
    returnType Callable
    callable Maybe Type -> Maybe Type -> Bool
    forall a. Eq a => a -> a -> Bool
    == Maybe Type
    forall a. Maybe a
    Nothing
        then case [Text]
    pps of
            []      -> Text -> CodeGen e ()
    forall e. Text -> CodeGen e ()
    line Text
    "return ()"
            (Text
    pp:[]) -> Text -> CodeGen e ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "return " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    pp
            [Text]
    _       -> Text -> CodeGen e ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "return (" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text -> [Text] -> Text
    T.intercalate Text
    ", " [Text]
    pps Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    ")"
        else case [Text]
    pps of
            [] -> Text -> CodeGen e ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "return " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    result
            [Text]
    _  -> Text -> CodeGen e ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "return (" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text -> [Text] -> Text
    T.intercalate Text
    ", " (Text
    result Text -> [Text] -> [Text]
    forall a. a -> [a] -> [a]
    : [Text]
    pps) Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    ")"

    -- | Generate a Haskell wrapper for the given foreign function.
    genHaskellWrapper :: Name -> ForeignSymbol -> Callable ->
                         ExposeClosures -> ExcCodeGen Text
    genHaskellWrapper :: Name
    -> ForeignSymbol -> Callable -> ExposeClosures -> ExcCodeGen Text
    genHaskellWrapper Name
    n ForeignSymbol
    symbol Callable
    callable ExposeClosures
    expose = ExcCodeGen Text -> ExcCodeGen Text
    forall e a. CodeGen e a -> CodeGen e a
    group (ExcCodeGen Text -> ExcCodeGen Text)
    -> ExcCodeGen Text -> ExcCodeGen Text
    forall a b. (a -> b) -> a -> b
    $ do
        let name :: Text
    name = case ForeignSymbol
    symbol of
                     KnownForeignSymbol Text
    _ -> Name -> Text
    lowerName Name
    n
                     DynamicForeignSymbol DynamicWrapper
    _ -> Text -> Text
    callbackDynamicWrapper (Name -> Text
    upperName Name
    n)
            ([Arg]
    hInArgs, [Arg]
    omitted) = Callable -> ExposeClosures -> ([Arg], [Arg])
    callableHInArgs Callable
    callable ExposeClosures
    expose
            hOutArgs :: [Arg]
    hOutArgs = Callable -> [Arg]
    callableHOutArgs Callable
    callable

        Text -> CodeGen CGError ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen CGError ()) -> Text -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ Text
    name Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " ::"
        Callable -> ForeignSymbol -> ExposeClosures -> CodeGen CGError ()
    formatHSignature Callable
    callable ForeignSymbol
    symbol ExposeClosures
    expose
        let argNames :: [Text]
    argNames = case ForeignSymbol
    symbol of
                         KnownForeignSymbol Text
    _ -> (Arg -> Text) -> [Arg] -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    map Arg -> Text
    escapedArgName [Arg]
    hInArgs
                         DynamicForeignSymbol DynamicWrapper
    _ ->
                             Text
    funPtr Text -> [Text] -> [Text]
    forall a. a -> [a] -> [a]
    : (Arg -> Text) -> [Arg] -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    map Arg -> Text
    escapedArgName [Arg]
    hInArgs
        Text -> CodeGen CGError ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen CGError ()) -> Text -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ Text
    name Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text -> [Text] -> Text
    T.intercalate Text
    " " [Text]
    argNames Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " = liftIO $ do"
        CodeGen CGError () -> CodeGen CGError ()
    forall e a. CodeGen e a -> CodeGen e a
    indent (Name
    -> ForeignSymbol
    -> Callable
    -> [Arg]
    -> [Arg]
    -> [Arg]
    -> ExposeClosures
    -> CodeGen CGError ()
    genWrapperBody Name
    n ForeignSymbol
    symbol Callable
    callable [Arg]
    hInArgs [Arg]
    hOutArgs [Arg]
    omitted ExposeClosures
    expose)
        Text -> ExcCodeGen Text
    forall a.
    a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Text
    name

    -- | Generate the body of the Haskell wrapper for the given foreign symbol.
    genWrapperBody :: Name -> ForeignSymbol -> Callable ->
                      [Arg] -> [Arg] -> [Arg] ->
                      ExposeClosures ->
                      ExcCodeGen ()
    genWrapperBody :: Name
    -> ForeignSymbol
    -> Callable
    -> [Arg]
    -> [Arg]
    -> [Arg]
    -> ExposeClosures
    -> CodeGen CGError ()
    genWrapperBody Name
    n ForeignSymbol
    symbol Callable
    callable [Arg]
    hInArgs [Arg]
    hOutArgs [Arg]
    omitted ExposeClosures
    expose = do
        Name -> Callable -> [Arg] -> CodeGen CGError ()
    readInArrayLengths Name
    n Callable
    callable [Arg]
    hInArgs
        inArgNames <- [Arg] -> (Arg -> ExcCodeGen Text) -> ExcCodeGen [Text]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    t a -> (a -> m b) -> m (t b)
    forM (Callable -> [Arg]
    args Callable
    callable) ((Arg -> ExcCodeGen Text) -> ExcCodeGen [Text])
    -> (Arg -> ExcCodeGen Text) -> ExcCodeGen [Text]
    forall a b. (a -> b) -> a -> b
    $ \Arg
    arg ->
                      [Arg] -> Arg -> ExposeClosures -> ExcCodeGen Text
    prepareArgForCall [Arg]
    omitted Arg
    arg ExposeClosures
    expose
        -- Map from argument names to names passed to the C function
        let nameMap = [(Text, Text)] -> Map Text Text
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList ([(Text, Text)] -> Map Text Text)
    -> [(Text, Text)] -> Map Text Text
    forall a b. (a -> b) -> a -> b
    $ ([Text] -> [Text] -> [(Text, Text)])
    -> [Text] -> [Text] -> [(Text, Text)]
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip [Text] -> [Text] -> [(Text, Text)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Text]
    inArgNames
                                   ([Text] -> [(Text, Text)]) -> [Text] -> [(Text, Text)]
    forall a b. (a -> b) -> a -> b
    $ (Arg -> Text) -> [Arg] -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    map Arg -> Text
    escapedArgName ([Arg] -> [Text]) -> [Arg] -> [Text]
    forall a b. (a -> b) -> a -> b
    $ Callable -> [Arg]
    args Callable
    callable
        prepareClosures callable nameMap
        if callableThrows callable
        then do
            line "onException (do"
            indent $ do
                invokeCFunction callable symbol inArgNames
                readOutArrayLengths callable nameMap
                result <- convertResult n callable nameMap
                pps <- convertOutArgs callable nameMap hOutArgs
                freeCallCallbacks callable nameMap
                forM_ (args callable) touchInArg
                mapM_ line =<< freeInArgs callable nameMap
                returnResult callable result pps
            line " ) (do"
            indent $ do
                freeCallCallbacks callable nameMap
                actions <- freeInArgsOnError callable nameMap
                case actions of
                    [] -> Text -> CodeGen CGError ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen CGError ()) -> Text -> CodeGen CGError ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "return ()"
                    [Text]
    _ -> (Text -> CodeGen CGError ()) -> [Text] -> CodeGen CGError ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ Text -> CodeGen CGError ()
    forall e. Text -> CodeGen e ()
    line [Text]
    actions
            line " )"
        else do
            invokeCFunction callable symbol inArgNames
            readOutArrayLengths callable nameMap
            result <- convertResult n callable nameMap
            pps <- convertOutArgs callable nameMap hOutArgs
            freeCallCallbacks callable nameMap
            forM_ (args callable) touchInArg
            mapM_ line =<< freeInArgs callable nameMap
            returnResult callable result pps

    -- | caller-allocates arguments are arguments that the caller
    -- allocates, and the called function modifies. They are marked as
    -- 'out' argumens in the introspection data, we sometimes treat them
    -- as 'inout' arguments instead. The semantics are somewhat tricky:
    -- for memory management purposes they should be treated as "in"
    -- arguments, but from the point of view of the exposed API they
    -- should be treated as "out" or "inout". Unfortunately we cannot
    -- always just assume that they are purely "out", so in many cases the
    -- generated API is somewhat suboptimal (since the initial values are
    -- not important): for example for g_io_channel_read_chars the size of
    -- the buffer to read is determined by the caller-allocates
    -- argument. As a compromise, we assume that we can allocate anything
    -- that is not a TCArray of length determined by an argument.
    fixupCallerAllocates :: Callable -> Callable
    fixupCallerAllocates :: Callable -> Callable
    fixupCallerAllocates Callable
    c =
        Callable
    c{args = map (fixupLength . fixupDir) (args c)}
        where fixupDir :: Arg -> Arg
              fixupDir :: Arg -> Arg
    fixupDir Arg
    a = case Arg -> Type
    argType Arg
    a of
                             TCArray Bool
    _ Int
    _ Int
    l Type
    _ ->
                                 if Arg -> Bool
    argCallerAllocates Arg
    a Bool -> Bool -> Bool
    && Int
    l Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > -Int
    1
                                 then Arg
    a { direction = DirectionInout
                                        , transfer = TransferEverything }
                                 else Arg
    a
                             Type
    _ -> Arg
    a

              lengthsMap :: Map.Map Arg Arg
              lengthsMap :: Map Arg Arg
    lengthsMap = [(Arg, Arg)] -> Map Arg Arg
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList (((Arg, Arg) -> (Arg, Arg)) -> [(Arg, Arg)] -> [(Arg, Arg)]
    forall a b. (a -> b) -> [a] -> [b]
    map (Arg, Arg) -> (Arg, Arg)
    forall a b. (a, b) -> (b, a)
    swap (Callable -> [(Arg, Arg)]
    arrayLengthsMap Callable
    c))

              -- Length arguments of caller-allocates arguments should be
              -- treated as "in".
              fixupLength :: Arg -> Arg
              fixupLength :: Arg -> Arg
    fixupLength Arg
    a = case Arg -> Map Arg Arg -> Maybe Arg
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup Arg
    a Map Arg Arg
    lengthsMap of
                                Maybe Arg
    Nothing -> Arg
    a
                                Just Arg
    array ->
                                    if Arg -> Bool
    argCallerAllocates Arg
    array
                                    then Arg
    a {direction = DirectionIn}
                                    else Arg
    a

    -- | The foreign symbol to wrap. It is either a foreign symbol wrapped
    -- in a foreign import, in which case we are given the name of the
    -- Haskell wrapper, or alternatively the information about a "dynamic"
    -- wrapper in scope.
    data ForeignSymbol = KnownForeignSymbol Text -- ^ Haskell symbol in scope.
                       | DynamicForeignSymbol DynamicWrapper
                         -- ^ Info about the dynamic wrapper.

    -- | Information about a dynamic wrapper.
    data DynamicWrapper = DynamicWrapper {
          DynamicWrapper -> Text
    dynamicWrapper :: Text    -- ^ Haskell dynamic wrapper
        , DynamicWrapper -> Text
    dynamicType    :: Text    -- ^ Name of the type synonym for the
                                    -- type of the function to be wrapped.
        }

    -- | Some debug info for the callable.
    genCallableDebugInfo :: Callable -> CodeGen e ()
    genCallableDebugInfo :: forall e. Callable -> CodeGen e ()
    genCallableDebugInfo Callable
    callable =
        CodeGen e () -> CodeGen e ()
    forall e a. CodeGen e a -> CodeGen e a
    group (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
    forall a b. (a -> b) -> a -> b
    $ do
          Text -> [Arg] -> CodeGen e ()
    forall a e. Show a => Text -> a -> CodeGen e ()
    commentShow Text
    "Args" (Callable -> [Arg]
    args Callable
    callable)
          Text -> [Arg] -> CodeGen e ()
    forall a e. Show a => Text -> a -> CodeGen e ()
    commentShow Text
    "Lengths" (Callable -> [Arg]
    arrayLengths Callable
    callable)
          Text -> Maybe Type -> CodeGen e ()
    forall a e. Show a => Text -> a -> CodeGen e ()
    commentShow Text
    "returnType" (Callable -> Maybe Type
    returnType Callable
    callable)
          Text -> CodeGen e ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "-- throws : " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> (Bool -> Text
    forall a. Show a => a -> Text
    tshow (Bool -> Text) -> Bool -> Text
    forall a b. (a -> b) -> a -> b
    $ Callable -> Bool
    callableThrows Callable
    callable)
          Text -> CodeGen e ()
    forall e. Text -> CodeGen e ()
    line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
    forall a b. (a -> b) -> a -> b
    $ Text
    "-- Skip return : " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> (Bool -> Text
    forall a. Show a => a -> Text
    tshow (Bool -> Text) -> Bool -> Text
    forall a b. (a -> b) -> a -> b
    $ Callable -> Bool
    skipReturn Callable
    callable)
          Bool -> CodeGen e () -> CodeGen e ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Callable -> Bool
    skipReturn Callable
    callable Bool -> Bool -> Bool
    && Callable -> Maybe Type
    returnType Callable
    callable Maybe Type -> Maybe Type -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Type -> Maybe Type
    forall a. a -> Maybe a
    Just (BasicType -> Type
    TBasicType BasicType
    TBoolean)) (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
    forall a b. (a -> b) -> a -> b
    $
               do Text -> CodeGen e ()
    forall e. Text -> CodeGen e ()
    line Text
    "-- XXX return value ignored, but it is not a boolean."
                  Text -> CodeGen e ()
    forall e. Text -> CodeGen e ()
    line Text
    "--     This may be a memory leak?"
      where commentShow :: Show a => Text -> a -> CodeGen e ()
            commentShow :: forall a e. Show a => Text -> a -> CodeGen e ()
    commentShow Text
    prefix a
    s =
              let padding :: Text
    padding = Int -> Text -> Text
    T.replicate (Text -> Int
    T.length Text
    prefix Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    2) Text
    " "
                  padded :: [Text]
    padded = case Text -> [Text]
    T.lines (String -> Text
    T.pack (String -> Text) -> String -> Text
    forall a b. (a -> b) -> a -> b
    $ a -> String
    forall a. Show a => a -> String
    ppShow a
    s) of
                             [] -> []
                             (Text
    f:[Text]
    rest) -> Text
    "-- " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    prefix Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    ": " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    f Text -> [Text] -> [Text]
    forall a. a -> [a] -> [a]
    :
                                         (Text -> Text) -> [Text] -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    map ((Text
    "-- " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    padding) Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <>) [Text]
    rest
              in (Text
     -> ReaderT
          CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
    -> [Text]
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ Text
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
    forall e. Text -> CodeGen e ()
    line [Text]
    padded

    -- | Generate a wrapper for a known C symbol.
    genCCallableWrapper :: Name -> Text -> Callable -> ExcCodeGen ()
    genCCallableWrapper :: Name -> Text -> Callable -> CodeGen CGError ()
    genCCallableWrapper Name
    n Text
    cSymbol Callable
    callable
      | Callable -> Maybe Bool
    callableResolvable Callable
    callable Maybe Bool -> Maybe Bool -> Bool
    forall a. Eq a => a -> a -> Bool
    == Maybe Bool
    forall a. Maybe a
    Nothing =
          -- If we reach this point there is some internal error.
          Text -> CodeGen CGError ()
    forall a. HasCallStack => Text -> a
    terror (Text
    "Resolvability of “" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    cSymbol Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "” unkown.")
      | Callable -> Maybe Bool
    callableResolvable Callable
    callable Maybe Bool -> Maybe Bool -> Bool
    forall a. Eq a => a -> a -> Bool
    == Bool -> Maybe Bool
    forall a. a -> Maybe a
    Just Bool
    False =
          Text -> CodeGen CGError ()
    forall a. Text -> ExcCodeGen a
    badIntroError (Text
    "Could not resolve the symbol “" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    cSymbol
                         Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "” in the “" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Name -> Text
    namespace Name
    n
                         Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "” namespace, ignoring.")
      | Bool
    otherwise = do
          Callable -> CodeGen CGError ()
    forall e. Callable -> CodeGen e ()
    genCallableDebugInfo Callable
    callable

          let callable' :: Callable
    callable' = Callable -> Callable
    fixupCallerAllocates Callable
    callable

          hSymbol <- Text -> Callable -> ExcCodeGen Text
    forall e. Text -> Callable -> CodeGen e Text
    mkForeignImport Text
    cSymbol Callable
    callable'

          blank

          deprecatedPragma (lowerName n) (callableDeprecated callable)
          writeDocumentation DocBeforeSymbol (callableDocumentation callable)
          void (genHaskellWrapper n (KnownForeignSymbol hSymbol) callable'
                WithoutClosures)

    -- | For callbacks we do not need to keep track of which arguments are
    -- closures.
    forgetClosures :: Callable -> Callable
    forgetClosures :: Callable -> Callable
    forgetClosures Callable
    c = Callable
    c {args = map forgetClosure (args c)}
        where forgetClosure :: Arg -> Arg
              forgetClosure :: Arg -> Arg
    forgetClosure Arg
    arg = Arg
    arg {argClosure = -1,
                                       argCallbackUserData = False}

    -- | Generate a wrapper for a dynamic C symbol (i.e. a Haskell
    -- function that will invoke its first argument, which should be a
    -- `FunPtr` of the appropriate type). The caller should have created a
    -- type synonym with the right type for the foreign symbol.
    genDynamicCallableWrapper :: Name -> Text -> Callable ->
                                 ExcCodeGen Text
    genDynamicCallableWrapper :: Name -> Text -> Callable -> ExcCodeGen Text
    genDynamicCallableWrapper Name
    n Text
    typeSynonym Callable
    callable = do
      Callable -> CodeGen CGError ()
    forall e. Callable -> CodeGen e ()
    genCallableDebugInfo Callable
    callable

      let callable' :: Callable
    callable' = Callable -> Callable
    forgetClosures (Callable -> Callable
    fixupCallerAllocates Callable
    callable)

      wrapper <- Text -> ExcCodeGen Text
    forall e. Text -> CodeGen e Text
    mkDynamicImport Text
    typeSynonym

      blank

      writeHaddock DocBeforeSymbol dynamicDoc

      let dyn = DynamicWrapper { dynamicWrapper :: Text
    dynamicWrapper = Text
    wrapper
                               , dynamicType :: Text
    dynamicType    = Text
    typeSynonym }
      genHaskellWrapper n (DynamicForeignSymbol dyn) callable' WithClosures

      where
        dynamicDoc :: Text
        dynamicDoc :: Text
    dynamicDoc = Text
    "Given a pointer to a foreign C function, wrap it into a function callable from Haskell."