{-# 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
callable outArgs :: [Arg]
outArgs = do
  TypeRep
hReturnType <- case Callable -> Maybe Type
returnType Callable
callable of
                   Nothing -> TypeRep -> ExcCodeGen TypeRep
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 "()"
                   Just r :: Type
r -> if Callable -> Bool
skipRetVal Callable
callable
                             then TypeRep -> ExcCodeGen TypeRep
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 "()"
                             else Type -> CodeGen TypeRep
haskellType Type
r
  [TypeRep]
hOutArgTypes <- [Arg]
-> (Arg -> ExcCodeGen TypeRep)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     [TypeRep]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Arg]
outArgs ((Arg -> ExcCodeGen TypeRep)
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except CGError))
      [TypeRep])
-> (Arg -> ExcCodeGen TypeRep)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     [TypeRep]
forall a b. (a -> b) -> a -> b
$ \outarg :: Arg
outarg ->
                  Arg -> CodeGen Bool
wrapMaybe Arg
outarg BaseCodeGen CGError Bool
-> (Bool -> ExcCodeGen TypeRep) -> ExcCodeGen TypeRep
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 -> CodeGen 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 -> CodeGen TypeRep
haskellType (Arg -> Type
argType Arg
outarg))
  Bool
nullableReturnType <- BaseCodeGen CGError Bool
-> (Type -> BaseCodeGen CGError Bool)
-> Maybe Type
-> BaseCodeGen CGError Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> BaseCodeGen CGError Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) Type -> BaseCodeGen CGError Bool
Type -> CodeGen Bool
typeIsNullable (Callable -> Maybe Type
returnType Callable
callable)
  let maybeHReturnType :: TypeRep
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
  TypeRep -> ExcCodeGen TypeRep
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeRep -> ExcCodeGen TypeRep) -> TypeRep -> ExcCodeGen TypeRep
forall a b. (a -> b) -> a -> b
$ case ([Arg]
outArgs, TypeRep -> Text
typeShow TypeRep
maybeHReturnType) of
             ([], _)   -> TypeRep
maybeHReturnType
             (_, "()") -> "(,)" Text -> [TypeRep] -> TypeRep
`con` [TypeRep]
hOutArgTypes
             _         -> "(,)" 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 Text
mkForeignImport :: Text -> Callable -> CodeGen Text
mkForeignImport cSymbol :: Text
cSymbol callable :: Callable
callable = do
    Text -> CodeGen ()
line Text
first
    BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
        (Arg -> BaseCodeGen e ()) -> [Arg] -> BaseCodeGen e ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\a :: Arg
a -> Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ())
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
-> BaseCodeGen 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 -> BaseCodeGen e () -> BaseCodeGen e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Callable -> Bool
callableThrows Callable
callable) (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$
               Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
padTo 40 "Ptr (Ptr GError) -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "-- error"
        Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ())
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
-> BaseCodeGen e ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ReaderT
  CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
CodeGen Text
last
    Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
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
== '_') Text
cSymbol
              then Text -> Text
lcFirst Text
cSymbol
              else "_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cSymbol
    first :: Text
first = "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
forall a. Semigroup a => a -> a -> a
<> Text
hSymbol Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: "
    fArgStr :: Arg
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
fArgStr arg :: Arg
arg = do
        TypeRep
ft <- Type -> BaseCodeGen e TypeRep
Type -> CodeGen TypeRep
foreignType (Type -> BaseCodeGen e TypeRep) -> Type -> BaseCodeGen e TypeRep
forall a b. (a -> b) -> a -> b
$ Arg -> Type
argType Arg
arg
        let ft' :: TypeRep
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 :: Text
start = TypeRep -> Text
typeShow TypeRep
ft' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " -> "
        Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
padTo 40 Text
start Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "-- " 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 -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a. Show a => a -> Text
tshow (Arg -> Type
argType Arg
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
                                 Nothing -> TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) TypeRep
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 "()"
                                 Just r :: Type
r  -> Type -> CodeGen 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 Text
mkDynamicImport :: Text -> CodeGen Text
mkDynamicImport typeSynonym :: Text
typeSynonym = do
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "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
<> " :: 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
forall a. Semigroup a => a -> a -> a
<> Text
typeSynonym
  Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
dynamic
      where dynamic :: Text
dynamic = "__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 Bool
wrapMaybe :: Arg -> CodeGen Bool
wrapMaybe arg :: Arg
arg = if Arg -> Bool
mayBeNull Arg
arg
                then Type -> CodeGen Bool
typeIsNullable (Arg -> Type
argType Arg
arg)
                else Bool -> BaseCodeGen e Bool
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 args :: [Arg]
args expose :: ExposeClosures
expose = do
  BaseCodeGen CGError ()
CodeGen ()
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 (m :: * -> *) a. Monad m => a -> m a
return ([], [])
        go (arg :: Arg
arg:args :: [Arg]
args) = do
          (t :: Text
t, cons :: [Text]
cons) <- Type -> ExposeClosures -> CodeGen (Text, [Text])
argumentType (Arg -> Type
argType Arg
arg) ExposeClosures
expose
          Text
t' <- Arg -> CodeGen Bool
wrapMaybe Arg
arg BaseCodeGen e Bool
-> (Bool
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT
  CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
-> Bool
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a. a -> a -> Bool -> a
bool (Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
t)
            (Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a b. (a -> b) -> a -> b
$ "Maybe (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")")
          (restCons :: [Text]
restCons, restTypes :: [Text]
restTypes) <- [Arg]
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     ([Text], [Text])
go [Arg]
args
          ([Text], [Text])
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     ([Text], [Text])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text]
cons [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
restCons, Text
t' Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
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
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 [] acc :: [(Arg, Arg)]
acc = [(Arg, Arg)]
acc
      go (a :: Arg
a:as :: [Arg]
as) acc :: [(Arg, Arg)]
acc = case Arg -> Type
argType Arg
a of
                        TCArray False fixedSize :: Int
fixedSize length :: Int
length _ ->
                            if Int
fixedSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> -1 Bool -> Bool -> Bool
|| Int
length Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -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. [a] -> Int -> a
!!Int
length) (Arg, Arg) -> [(Arg, Arg)] -> [(Arg, Arg)]
forall a. a -> [a] -> [a]
: [(Arg, Arg)]
acc
                        _ -> [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
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 False (-1) length :: Int
length _) ->
                     if Int
length Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> -1
                     then [(Callable -> [Arg]
args Callable
callable)[Arg] -> Int -> Arg
forall a. [a] -> Int -> a
!!Int
length]
                     else []
                 _ -> []

-- 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 :: [(a, b)] -> [(a, b, Maybe a)]
classifyDuplicates args :: [(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 :: Map b a -> [(a, b)] -> [(a, b, Maybe a)]
doClassify _ [] = []
          doClassify found :: Map b a
found ((value :: a
value, key :: b
key):args :: [(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] -> BaseCodeGen CGError ()
readInArrayLengths name :: Name
name callable :: Callable
callable hInArgs :: [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) -> BaseCodeGen CGError ())
-> BaseCodeGen 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) -> BaseCodeGen CGError ())
 -> BaseCodeGen CGError ())
-> ((Arg, Arg, Maybe Arg) -> BaseCodeGen CGError ())
-> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ \(array :: Arg
array, length :: Arg
length, duplicate :: Maybe Arg
duplicate) ->
      Bool -> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Arg
array Arg -> [Arg] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Arg]
hInArgs) (BaseCodeGen CGError () -> BaseCodeGen CGError ())
-> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$
        case Maybe Arg
duplicate of
        Nothing -> Arg -> Arg -> BaseCodeGen CGError ()
readInArrayLength Arg
array Arg
length
        Just previous :: Arg
previous -> Name -> Arg -> Arg -> Arg -> BaseCodeGen 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 -> BaseCodeGen CGError ()
readInArrayLength array :: Arg
array length :: Arg
length = do
  let lvar :: Text
lvar = Arg -> Text
escapedArgName Arg
length
      avar :: Text
avar = Arg -> Text
escapedArgName Arg
array
  Arg -> CodeGen Bool
wrapMaybe Arg
array BaseCodeGen CGError Bool
-> (Bool -> BaseCodeGen CGError ()) -> BaseCodeGen CGError ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BaseCodeGen CGError ()
-> BaseCodeGen CGError () -> Bool -> BaseCodeGen CGError ()
forall a. a -> a -> Bool -> a
bool
                (do
                  Text
al <- Text -> Type -> ExcCodeGen Text
computeArrayLength Text
avar (Arg -> Type
argType Arg
array)
                  Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "let " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
lvar Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
al)
                (do
                  Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "let " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
lvar Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = case " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
avar Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " of"
                  BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen CGError () -> BaseCodeGen CGError ())
-> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen CGError () -> BaseCodeGen CGError ())
-> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ do
                    Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "Nothing -> 0"
                    let jarray :: Text
jarray = "j" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
avar
                    Text
al <- Text -> Type -> ExcCodeGen Text
computeArrayLength Text
jarray (Arg -> Type
argType Arg
array)
                    Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "Just " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
jarray Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
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 -> BaseCodeGen CGError ()
checkInArrayLength n :: Name
n array :: Arg
array length :: Arg
length previous :: 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
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
<> "_expected_length_"
      pvar :: Text
pvar = Arg -> Text
escapedArgName Arg
previous
  Arg -> CodeGen Bool
wrapMaybe Arg
array BaseCodeGen CGError Bool
-> (Bool -> BaseCodeGen CGError ()) -> BaseCodeGen CGError ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BaseCodeGen CGError ()
-> BaseCodeGen CGError () -> Bool -> BaseCodeGen CGError ()
forall a. a -> a -> Bool -> a
bool
            (do
              Text
al <- Text -> Type -> ExcCodeGen Text
computeArrayLength Text
avar (Arg -> Type
argType Arg
array)
              Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "let " 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
forall a. Semigroup a => a -> a -> a
<> Text
al)
            (do
              Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "let " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
expectedLength Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = case " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
avar Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " of"
              BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen CGError () -> BaseCodeGen CGError ())
-> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen CGError () -> BaseCodeGen CGError ())
-> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ do
                Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "Nothing -> 0"
                let jarray :: Text
jarray = "j" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
avar
                Text
al <- Text -> Type -> ExcCodeGen Text
computeArrayLength Text
jarray (Arg -> Type
argType Arg
array)
                Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "Just " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
jarray Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
al)
  Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "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
forall a. Semigroup a => a -> a -> a
<> Text
lvar Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ") $"
  BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen CGError () -> BaseCodeGen CGError ())
-> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "error \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
funcName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " : length of '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
avar Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
             "' 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
<> "'.\""

-- | 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 = (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' freeFn :: Arg -> Text -> Text -> ExcCodeGen [Text]
freeFn callable :: Callable
callable nameMap :: 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
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 name :: 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 False (-1) (-1) _ ->
                           Text -> Text
parenthesize ("length " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Arg -> Text
escapedArgName Arg
arg)
                         TCArray False (-1) length :: Int
length _ ->
                             Arg -> Text
escapedArgName (Arg -> Text) -> Arg -> Text
forall a b. (a -> b) -> a -> b
$ (Callable -> [Arg]
args Callable
callable)[Arg] -> Int -> Arg
forall a. [a] -> Int -> a
!!Int
length
                         _ -> Text
forall a. HasCallStack => a
undefined
          Nothing -> Text -> ExcCodeGen [Text]
forall a. Text -> ExcCodeGen a
badIntroError (Text -> ExcCodeGen [Text]) -> Text -> ExcCodeGen [Text]
forall a b. (a -> b) -> a -> b
$ "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 omitted :: [Arg]
omitted arg :: Arg
arg expose :: ExposeClosures
expose = do
  Maybe Callback
callback <- Type -> CodeGen (Maybe API)
findAPI (Arg -> Type
argType Arg
arg) BaseCodeGen CGError (Maybe API)
-> (Maybe API
    -> ReaderT
         CodeGenConfig
         (StateT (CGState, ModuleInfo) (Except CGError))
         (Maybe Callback))
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Callback)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                \case Just (APICallback c :: Callback
c) -> Maybe Callback
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Callback)
forall (m :: * -> *) a. Monad m => a -> m a
return (Callback -> Maybe Callback
forall a. a -> Maybe a
Just Callback
c)
                      _ -> Maybe Callback
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Callback)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Callback
forall a. Maybe a
Nothing

  Bool -> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Callback -> Bool
forall a. Maybe a -> Bool
isJust Maybe Callback
callback Bool -> Bool -> Bool
&& Arg -> Direction
direction Arg
arg Direction -> Direction -> Bool
forall a. Eq a => a -> a -> Bool
/= Direction
DirectionIn) (BaseCodeGen CGError () -> BaseCodeGen CGError ())
-> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$
       Text -> BaseCodeGen CGError ()
forall a. Text -> ExcCodeGen a
notImplementedError "Only callbacks with DirectionIn are supported"

  case Arg -> Direction
direction Arg
arg of
    DirectionIn -> if Arg
arg Arg -> [Arg] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Arg]
omitted
                   then Text -> ExcCodeGen Text
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 c :: Callback
c -> if Callable -> Bool
callableThrows (Callback -> Callable
cbCallable Callback
c)
                                  -- See [Note: Callables that throw]
                                  then Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Arg -> Text
escapedArgName Arg
arg)
                                  else Arg -> Callback -> ExposeClosures -> CodeGen Text
prepareInCallback Arg
arg Callback
c ExposeClosures
expose
                        Nothing -> Arg -> ExcCodeGen Text
prepareInArg Arg
arg
    DirectionInout -> Arg -> ExcCodeGen Text
prepareInoutArg Arg
arg
    DirectionOut -> Arg -> ExcCodeGen Text
prepareOutArg Arg
arg

prepareInArg :: Arg -> ExcCodeGen Text
prepareInArg :: Arg -> ExcCodeGen Text
prepareInArg arg :: Arg
arg = do
  let name :: Text
name = Arg -> Text
escapedArgName Arg
arg
  Arg -> CodeGen Bool
wrapMaybe Arg
arg BaseCodeGen CGError Bool
-> (Bool -> ExcCodeGen Text) -> ExcCodeGen Text
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 -> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall e. Text -> BaseCodeGen e Converter -> BaseCodeGen e Text
convert Text
name (BaseCodeGen CGError Converter -> ExcCodeGen Text)
-> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ Type -> Transfer -> BaseCodeGen CGError Converter
hToF (Arg -> Type
argType Arg
arg) (Arg -> Transfer
transfer Arg
arg))
            (do
              let maybeName :: Text
maybeName = "maybe" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
name
              Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ Text
maybeName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " <- case " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " of"
              ExcCodeGen Text -> ExcCodeGen Text
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen Text -> ExcCodeGen Text)
-> ExcCodeGen Text -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ do
                Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "Nothing -> return nullPtr"
                let jName :: Text
jName = "j" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
name
                Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "Just " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
jName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " -> do"
                BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen CGError () -> BaseCodeGen CGError ())
-> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ do
                         Text
converted <- Text -> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall e. Text -> BaseCodeGen e Converter -> BaseCodeGen e Text
convert Text
jName (BaseCodeGen CGError Converter -> ExcCodeGen Text)
-> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ Type -> Transfer -> BaseCodeGen CGError Converter
hToF (Arg -> Type
argType Arg
arg)
                                                           (Arg -> Transfer
transfer Arg
arg)
                         Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "return " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
converted
                Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
maybeName)

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

  (maker :: Text
maker, wrapper :: Text
wrapper, drop :: Maybe Text
drop) <-
      case Arg -> Type
argType Arg
arg of
        TInterface tn :: Name
tn@(Name _ n :: Text
n) ->
            do
              Maybe Text
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 -> CodeGen Text
qualifiedSymbol (Text -> Text
callbackDropClosures Text
n) Name
tn
                      else Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
              Text
wrapper <- Text -> Name -> CodeGen Text
qualifiedSymbol (Text -> Text
callbackHaskellToForeign Text
n) Name
tn
              Text
maker <- Text -> Name -> CodeGen Text
qualifiedSymbol (Text -> Text
callbackWrapperAllocator Text
n) Name
tn
              (Text, Text, Maybe Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Text, Text, Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
maker, Text
wrapper, Maybe Text
drop)
        _ -> Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Text, Text, Maybe Text)
forall a. 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
$ "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)

  Arg -> CodeGen Bool
wrapMaybe Arg
arg BaseCodeGen e Bool
-> (Bool
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT
  CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
-> Bool
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a. a -> a -> Bool -> a
bool
            (do
              let name' :: Text
name' = Text -> Text
prime Text
name
                  dropped :: Text
dropped =
                      case Maybe Text
drop of
                        Just dropper :: Text
dropper -> Text -> Text
parenthesize (Text
dropper Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name)
                        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.
              Text
p <- if (Scope
scope Scope -> Scope -> Bool
forall a. Eq a => a -> a -> Bool
== Scope
ScopeTypeAsync)
                   then do Text
ft <- TypeRep -> Text
typeShow (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
<$> Type -> CodeGen TypeRep
foreignType (Arg -> Type
argType Arg
arg)
                           Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
ptrName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " <- callocMem :: IO (Ptr (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ft Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "))"
                           Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
parenthesize (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ "Just " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ptrName
                   else Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Nothing"

              Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " <- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
maker Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " "
                       Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
parenthesize (Text
wrapper Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dropped)
              Bool -> BaseCodeGen e () -> BaseCodeGen e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Scope
scope Scope -> Scope -> Bool
forall a. Eq a => a -> a -> Bool
== Scope
ScopeTypeAsync) (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$
                   Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "poke " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ptrName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name'
              Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
name')
            (do
              let maybeName :: Text
maybeName = "maybe" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
name
              Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
maybeName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " <- case " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " of"
              BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
                Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "Nothing -> return (castPtrToFunPtr nullPtr)"
                let jName :: Text
jName = "j" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
name
                    jName' :: Text
jName' = Text -> Text
prime Text
jName
                Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "Just " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
jName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " -> do"
                BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
                         let dropped :: Text
dropped = case Maybe Text
drop of
                                   Just dropper :: Text
dropper ->
                                       Text -> Text
parenthesize (Text
dropper Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
jName)
                                   Nothing -> Text
jName
                         Text
p <- if (Scope
scope Scope -> Scope -> Bool
forall a. Eq a => a -> a -> Bool
== Scope
ScopeTypeAsync)
                           then do Text
ft <- TypeRep -> Text
typeShow (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
<$> Type -> CodeGen TypeRep
foreignType (Arg -> Type
argType Arg
arg)
                                   Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
ptrName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " <- callocMem :: IO (Ptr (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ft Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "))"
                                   Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
parenthesize (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ "Just " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ptrName
                           else Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Nothing"

                         Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
jName' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " <- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
maker Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " "
                                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
parenthesize (Text
wrapper Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " "
                                                   Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dropped)
                         Bool -> BaseCodeGen e () -> BaseCodeGen e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Scope
scope Scope -> Scope -> Bool
forall a. Eq a => a -> a -> Bool
== Scope
ScopeTypeAsync) (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$
                              Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "poke " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ptrName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
jName'
                         Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "return " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
jName'
              Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
maybeName)

prepareInoutArg :: Arg -> ExcCodeGen Text
prepareInoutArg :: Arg -> ExcCodeGen Text
prepareInoutArg arg :: Arg
arg = do
  Text
name' <- Arg -> ExcCodeGen Text
prepareInArg Arg
arg
  TypeRep
ft <- Type -> ExcCodeGen TypeRep
Type -> CodeGen TypeRep
foreignType (Type -> ExcCodeGen TypeRep) -> Type -> ExcCodeGen TypeRep
forall a b. (a -> b) -> a -> b
$ Arg -> Type
argType Arg
arg
  Maybe TypeAllocInfo
allocInfo <- Type -> CodeGen (Maybe TypeAllocInfo)
typeAllocInfo (Arg -> Type
argType Arg
arg)
  case Maybe TypeAllocInfo
allocInfo of
    Just (TypeAllocInfo isBoxed :: Bool
isBoxed n :: Int
n) -> do
         let allocator :: Text
allocator = if Bool
isBoxed
                         then "callocBoxedBytes"
                         else "callocBytes"
         Arg -> CodeGen Bool
wrapMaybe Arg
arg BaseCodeGen CGError Bool
-> (Bool -> ExcCodeGen Text) -> ExcCodeGen Text
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
            (do
              Text
name'' <- Text -> Converter -> CodeGen Text
genConversion (Text -> Text
prime 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
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                                    " :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeRep -> Text
typeShow (TypeRep -> TypeRep
io TypeRep
ft)
              Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "memcpy " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name'' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
n
              Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
name'')
             -- The semantics of this case are somewhat undefined.
            (Text -> ExcCodeGen Text
forall a. Text -> ExcCodeGen a
notImplementedError "Nullable inout structs not supported")
    Nothing -> do
      if Arg -> Bool
argCallerAllocates Arg
arg
      then Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
name'
      else do
        Text
name'' <- Text -> Converter -> CodeGen Text
genConversion (Text -> Text
prime 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
$ "allocMem :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeRep -> Text
typeShow (TypeRep -> TypeRep
io (TypeRep -> TypeRep) -> TypeRep -> TypeRep
forall a b. (a -> b) -> a -> b
$ TypeRep -> TypeRep
ptr TypeRep
ft)
        Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "poke " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name'' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name'
        Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
name''

prepareOutArg :: Arg -> ExcCodeGen Text
prepareOutArg :: Arg -> ExcCodeGen Text
prepareOutArg arg :: Arg
arg = do
  let name :: Text
name = Arg -> Text
escapedArgName Arg
arg
  TypeRep
ft <- Type -> ExcCodeGen TypeRep
Type -> CodeGen TypeRep
foreignType (Type -> ExcCodeGen TypeRep) -> Type -> ExcCodeGen TypeRep
forall a b. (a -> b) -> a -> b
$ Arg -> Type
argType Arg
arg
  if Arg -> Bool
argCallerAllocates Arg
arg
  then do
    Maybe TypeAllocInfo
allocInfo <- Type -> CodeGen (Maybe TypeAllocInfo)
typeAllocInfo (Arg -> Type
argType Arg
arg)
    case Maybe TypeAllocInfo
allocInfo of
      Just (TypeAllocInfo isBoxed :: Bool
isBoxed n :: Int
n) -> do
          let allocator :: Text
allocator = if Bool
isBoxed
                          then "callocBoxedBytes"
                          else "callocBytes"
          Text -> Converter -> CodeGen 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
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                            " :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeRep -> Text
typeShow (TypeRep -> TypeRep
io TypeRep
ft)
      Nothing ->
          Text -> ExcCodeGen Text
forall a. Text -> ExcCodeGen a
notImplementedError (Text -> ExcCodeGen Text) -> Text -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ ("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
<> "\" 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 Text -> Converter -> CodeGen 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
$ "allocMem :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeRep -> Text
typeShow (TypeRep -> TypeRep
io (TypeRep -> TypeRep) -> TypeRep -> TypeRep
forall a b. (a -> b) -> a -> b
$ TypeRep -> TypeRep
ptr TypeRep
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
callable t :: Type
t@(TCArray False fixed :: Int
fixed length :: Int
length _) aname :: Text
aname
                 nameMap :: Map Text Text
nameMap transfer :: Transfer
transfer primeLength :: Text -> Text
primeLength = do
  if Int
fixed Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> -1
  then do
    Text
unpacked <- Text -> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall e. Text -> BaseCodeGen e Converter -> BaseCodeGen e Text
convert Text
aname (BaseCodeGen CGError Converter -> ExcCodeGen Text)
-> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ Text -> Type -> Transfer -> BaseCodeGen 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
    Transfer -> Type -> Text -> Text -> BaseCodeGen CGError ()
freeContainerType Transfer
transfer Type
t Text
aname Text
forall a. HasCallStack => a
undefined
    Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
unpacked
  else do
    Bool -> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
length Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -1) (BaseCodeGen CGError () -> BaseCodeGen CGError ())
-> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$
         Text -> BaseCodeGen CGError ()
forall a. Text -> ExcCodeGen a
badIntroError (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "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
<> "\""
    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. [a] -> Int -> a
!!Int
length
    Text
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 n :: Text
n -> Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
n
                Nothing ->
                    Text -> ExcCodeGen Text
forall a. Text -> ExcCodeGen a
badIntroError (Text -> ExcCodeGen Text) -> Text -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ "Couldn't find out array length " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                                            Text
lname
    let lname'' :: Text
lname'' = Text -> Text
primeLength Text
lname'
    Text
unpacked <- Text -> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall e. Text -> BaseCodeGen e Converter -> BaseCodeGen e Text
convert Text
aname (BaseCodeGen CGError Converter -> ExcCodeGen Text)
-> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ Text -> Type -> Transfer -> BaseCodeGen CGError Converter
unpackCArray Text
lname'' Type
t Transfer
transfer
    -- Free the memory associated with the array
    Transfer -> Type -> Text -> Text -> BaseCodeGen CGError ()
freeContainerType Transfer
transfer Type
t Text
aname Text
lname''
    Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
unpacked

-- Remove the warning, this should never be reached.
convertOutCArray _ t :: Type
t _ _ _ _ =
    Text -> ExcCodeGen Text
forall a. Text -> a
terror (Text -> ExcCodeGen Text) -> Text -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ "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 -> BaseCodeGen CGError ()
readOutArrayLengths callable :: Callable
callable nameMap :: 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) -> BaseCodeGen CGError ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
lNames ((Text -> ExcCodeGen Text) -> BaseCodeGen CGError ())
-> (Text -> ExcCodeGen Text) -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ \lname :: Text
lname -> do
    Text
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 n :: Text
n -> Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
n
                   Nothing ->
                       Text -> ExcCodeGen Text
forall a. Text -> ExcCodeGen a
badIntroError (Text -> ExcCodeGen Text) -> Text -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ "Couldn't find out array length " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                                               Text
lname
    Text -> Converter -> CodeGen Text
genConversion Text
lname' (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 "peek"

-- Touch DirectionIn arguments so we are sure that they exist when the
-- C function was called.
touchInArg :: Arg -> ExcCodeGen ()
touchInArg :: Arg -> BaseCodeGen CGError ()
touchInArg arg :: Arg
arg = Bool -> BaseCodeGen CGError () -> BaseCodeGen 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) (BaseCodeGen CGError () -> BaseCodeGen CGError ())
-> BaseCodeGen CGError () -> BaseCodeGen 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 a :: Type
a -> do
      Bool
managed <- Type -> CodeGen Bool
isManaged Type
a
      Bool -> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
managed (BaseCodeGen CGError () -> BaseCodeGen CGError ())
-> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ Arg -> CodeGen Bool
wrapMaybe Arg
arg BaseCodeGen CGError Bool
-> (Bool -> BaseCodeGen CGError ()) -> BaseCodeGen CGError ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BaseCodeGen CGError ()
-> BaseCodeGen CGError () -> Bool -> BaseCodeGen CGError ()
forall a. a -> a -> Bool -> a
bool
              (Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "mapM_ touchManagedPtr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name)
              (Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "whenJust " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " (mapM_ touchManagedPtr)")
    Nothing -> do
      Bool
managed <- Type -> CodeGen Bool
isManaged (Arg -> Type
argType Arg
arg)
      Bool -> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
managed (BaseCodeGen CGError () -> BaseCodeGen CGError ())
-> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ Arg -> CodeGen Bool
wrapMaybe Arg
arg BaseCodeGen CGError Bool
-> (Bool -> BaseCodeGen CGError ()) -> BaseCodeGen CGError ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BaseCodeGen CGError ()
-> BaseCodeGen CGError () -> Bool -> BaseCodeGen CGError ()
forall a. a -> a -> Bool -> a
bool
           (Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "touchManagedPtr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name)
           (Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "whenJust " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " 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
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 (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. [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
/= -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 [] m :: Map Int Arg
m = Map Int Arg -> ExcCodeGen (Map Int Arg)
forall (m :: * -> *) a. Monad m => a -> m a
return Map Int Arg
m
          go (arg :: Arg
arg:as :: [Arg]
as) m :: 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
                  c :: 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 _ -> 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
$
                                "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
<> "\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)
                      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 -> BaseCodeGen CGError ()
prepareClosures callable :: Callable
callable nameMap :: Map Text Text
nameMap = do
  Map Int Arg
m <- Callable -> ExcCodeGen (Map Int Arg)
closureToCallbackMap Callable
callable
  let closures :: [Int]
closures = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= -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
  [Int] -> (Int -> BaseCodeGen CGError ()) -> BaseCodeGen CGError ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
closures ((Int -> BaseCodeGen CGError ()) -> BaseCodeGen CGError ())
-> (Int -> BaseCodeGen CGError ()) -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ \closure :: 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
        Nothing -> Text -> BaseCodeGen CGError ()
forall a. Text -> ExcCodeGen a
badIntroError (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "Closure not found! "
                                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
<> "\n" 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
<> "\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
closure
        Just cb :: 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. [a] -> Int -> a
!!Int
closure
              n :: Text
n = Arg -> Text
escapedArgName Arg
cb
          Text
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 n :: Text
n -> Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
n
                  Nothing -> Text -> ExcCodeGen Text
forall a. Text -> ExcCodeGen a
badIntroError (Text -> ExcCodeGen Text) -> Text -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ "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
<> "\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)
          case Arg -> Scope
argScope Arg
cb of
            ScopeTypeInvalid -> Text -> BaseCodeGen CGError ()
forall a. Text -> ExcCodeGen a
badIntroError (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "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)
            ScopeTypeNotified -> do
                Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "let " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
closureName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = castFunPtrToPtr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n'
                case Arg -> Int
argDestroy Arg
cb of
                  (-1) -> Text -> BaseCodeGen CGError ()
forall a. Text -> ExcCodeGen a
badIntroError (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$
                          "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)
                  k :: Int
k -> 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. [a] -> Int -> a
!!Int
k in
                       Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "let " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
destroyName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = safeFreeFunPtrPtr"
            ScopeTypeAsync ->
                Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "let " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
closureName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = nullPtr"
            ScopeTypeCall -> Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "let " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
closureName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = nullPtr"

freeCallCallbacks :: Callable -> Map.Map Text Text -> ExcCodeGen ()
freeCallCallbacks :: Callable -> Map Text Text -> BaseCodeGen CGError ()
freeCallCallbacks callable :: Callable
callable nameMap :: Map Text Text
nameMap =
    [Arg] -> (Arg -> BaseCodeGen CGError ()) -> BaseCodeGen CGError ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Callable -> [Arg]
args Callable
callable) ((Arg -> BaseCodeGen CGError ()) -> BaseCodeGen CGError ())
-> (Arg -> BaseCodeGen CGError ()) -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ \arg :: Arg
arg -> do
       let name :: Text
name = Arg -> Text
escapedArgName Arg
arg
       Text
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 n :: Text
n -> Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
n
                  Nothing -> Text -> ExcCodeGen Text
forall a. Text -> ExcCodeGen a
badIntroError (Text -> ExcCodeGen Text) -> Text -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ "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
<> " 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
<> "\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)
       Bool -> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Arg -> Scope
argScope Arg
arg Scope -> Scope -> Bool
forall a. Eq a => a -> a -> Bool
== Scope
ScopeTypeCall) (BaseCodeGen CGError () -> BaseCodeGen CGError ())
-> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$
            Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "safeFreeFunPtr $ castFunPtrToPtr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name'

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

-- | Name for the first argument in dynamic wrappers (the `FunPtr`).
funPtr :: Text
funPtr :: Text
funPtr = "__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
callable symbol :: ForeignSymbol
symbol expose :: ExposeClosures
expose = do
  let (hInArgs :: [Arg]
hInArgs, _) = Callable -> ExposeClosures -> ([Arg], [Arg])
callableHInArgs Callable
callable
                                    (case ForeignSymbol
symbol of
                                       KnownForeignSymbol _ -> ExposeClosures
WithoutClosures
                                       DynamicForeignSymbol _ -> ExposeClosures
WithClosures)
  (argConstraints :: [Text]
argConstraints, types :: [Text]
types) <- [Arg] -> ExposeClosures -> ExcCodeGen ([Text], [Text])
inArgInterfaces [Arg]
hInArgs ExposeClosures
expose
  let constraints :: [Text]
constraints = ("MonadIO m" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
argConstraints)
  TypeRep
outType <- Callable -> [Arg] -> ExcCodeGen TypeRep
hOutType Callable
callable (Callable -> [Arg]
callableHOutArgs Callable
callable)
  Signature -> ExcCodeGen Signature
forall (m :: * -> *) a. Monad m => a -> m a
return (Signature -> ExcCodeGen Signature)
-> Signature -> ExcCodeGen Signature
forall a b. (a -> b) -> a -> b
$ Signature :: Callable -> [Text] -> [(Maybe Arg, Text)] -> Text -> Signature
Signature {
      signatureCallable :: Callable
signatureCallable = Callable
callable,
      signatureConstraints :: [Text]
signatureConstraints = [Text]
constraints,
      signatureReturnType :: Text
signatureReturnType = TypeRep -> Text
typeShow ("m" Text -> [TypeRep] -> TypeRep
`con` [TypeRep
outType]),
      signatureArgTypes :: [(Maybe Arg, Text)]
signatureArgTypes = case ForeignSymbol
symbol of
          KnownForeignSymbol _ -> [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 w :: 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)
                                    ("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
callable expose :: 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. [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
/= -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. [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
/= -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
        omitted :: [Arg]
omitted = case ExposeClosures
expose of
                    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
                    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
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 n :: Name
n callable :: Callable
callable nameMap :: 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 (m :: * -> *) a. Monad m => a -> m a
return (String -> Text
forall a. HasCallStack => String -> a
error "convertResult: unreachable code reached, bug!")
    else do
      Bool
nullableReturnType <- BaseCodeGen CGError Bool
-> (Type -> BaseCodeGen CGError Bool)
-> Maybe Type
-> BaseCodeGen CGError Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> BaseCodeGen CGError Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) Type -> BaseCodeGen CGError Bool
Type -> CodeGen Bool
typeIsNullable (Callable -> Maybe Type
returnType Callable
callable)
      if Callable -> Bool
returnMayBeNull Callable
callable Bool -> Bool -> Bool
&& Bool
nullableReturnType
      then do
        Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "maybeResult <- convertIfNonNull result $ \\result' -> do"
        ExcCodeGen Text -> ExcCodeGen Text
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen Text -> ExcCodeGen Text)
-> ExcCodeGen Text -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ do
             Text
converted <- Text -> ExcCodeGen Text
unwrappedConvertResult "result'"
             Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "return " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
converted
             Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return "maybeResult"
      else do
        Bool -> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
nullableReturnType (BaseCodeGen CGError () -> BaseCodeGen CGError ())
-> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$
             Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "checkUnexpectedReturnNULL \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
lowerName Name
n
                      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" result"
        Text -> ExcCodeGen Text
unwrappedConvertResult "result"

    where
      unwrappedConvertResult :: Text -> ExcCodeGen Text
unwrappedConvertResult rname :: 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 False (-1) (-1) _)) ->
                Text -> ExcCodeGen Text
forall a. Text -> ExcCodeGen a
badIntroError ("`" 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
<>
                "' is an array type, but contains no length information,\n"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "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 False _ _ _)) ->
                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 t :: Type
t -> do
                Text
result <- Text -> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall e. Text -> BaseCodeGen e Converter -> BaseCodeGen e Text
convert Text
rname (BaseCodeGen CGError Converter -> ExcCodeGen Text)
-> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ Type -> Transfer -> BaseCodeGen CGError Converter
fToH Type
t (Callable -> Transfer
returnTransfer Callable
callable)
                Transfer -> Type -> Text -> Text -> BaseCodeGen CGError ()
freeContainerType (Callable -> Transfer
returnTransfer Callable
callable) Type
t Text
rname Text
forall a. HasCallStack => a
undefined
                Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
result
            Nothing -> Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Text
forall a. HasCallStack => String -> a
error "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
callable nameMap :: Map Text Text
nameMap arg :: Arg
arg = do
  let name :: Text
name = Arg -> Text
escapedArgName Arg
arg
  Text
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 name' :: Text
name' -> Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
name'
      Nothing -> Text -> ExcCodeGen Text
forall a. Text -> ExcCodeGen a
badIntroError (Text -> ExcCodeGen Text) -> Text -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ "Parameter " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " not found!"
  case Arg -> Type
argType Arg
arg of
      t :: Type
t@(TCArray False (-1) (-1) _) ->
          if Arg -> Bool
argCallerAllocates Arg
arg
          then Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
inName
          else  Text -> ExcCodeGen Text
forall a. Text -> ExcCodeGen a
badIntroError ("`" 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
<>
                "' is an array type, but contains no length information,\n"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "so it cannot be unpacked.")
      t :: Type
t@(TCArray False _ _ _) -> do
          Text
aname' <- if Arg -> Bool
argCallerAllocates Arg
arg
                    then Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
inName
                    else Text -> Converter -> CodeGen 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 "peek"
          let arrayLength :: Text -> Text
arrayLength = if Arg -> Bool
argCallerAllocates Arg
arg
                            then Text -> Text
forall a. a -> a
id
                            else Text -> Text
prime
              wrapArray :: Text -> ExcCodeGen Text
wrapArray a :: 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
          Arg -> CodeGen Bool
wrapMaybe Arg
arg BaseCodeGen CGError Bool
-> (Bool -> ExcCodeGen Text) -> ExcCodeGen Text
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 -> ExcCodeGen Text
wrapArray Text
aname')
                 (do Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "maybe" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
aname'
                         Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " <- convertIfNonNull " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
aname'
                         Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " $ \\" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
prime Text
aname' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " -> do"
                     BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen CGError () -> BaseCodeGen CGError ())
-> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ do
                         Text
wrapped <- Text -> ExcCodeGen Text
wrapArray (Text -> Text
prime Text
aname')
                         Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "return " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
wrapped
                     Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> ExcCodeGen Text) -> Text -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ "maybe" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
aname')
      t :: Type
t -> do
          Text
peeked <- if Arg -> Bool
argCallerAllocates Arg
arg
                   then Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
inName
                   else Text -> Converter -> CodeGen 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 "peek"
          -- If we alloc we always take control of the resulting
          -- memory, otherwise we may leak.
          let transfer' :: Transfer
transfer' = if Arg -> Bool
argCallerAllocates Arg
arg
                         then Transfer
TransferEverything
                         else Arg -> Transfer
transfer Arg
arg
          Text
result <- do
              let wrap :: Text -> ExcCodeGen Text
wrap ptr :: Text
ptr = Text -> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall e. Text -> BaseCodeGen e Converter -> BaseCodeGen e Text
convert Text
ptr (BaseCodeGen CGError Converter -> ExcCodeGen Text)
-> BaseCodeGen CGError Converter -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ Type -> Transfer -> BaseCodeGen CGError Converter
fToH (Arg -> Type
argType Arg
arg) Transfer
transfer'
              Arg -> CodeGen Bool
wrapMaybe Arg
arg BaseCodeGen CGError Bool
-> (Bool -> ExcCodeGen Text) -> ExcCodeGen Text
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 -> ExcCodeGen Text
wrap Text
peeked)
                  (do Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "maybe" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
peeked
                          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " <- convertIfNonNull " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
peeked
                          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " $ \\" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
prime Text
peeked Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " -> do"
                      BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen CGError () -> BaseCodeGen CGError ())
-> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ do
                          Text
wrapped <- Text -> ExcCodeGen Text
wrap (Text -> Text
prime Text
peeked)
                          Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "return " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
wrapped
                      Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> ExcCodeGen Text) -> Text -> ExcCodeGen Text
forall a b. (a -> b) -> a -> b
$ "maybe" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
ucFirst Text
peeked)
          -- Free the memory associated with the out argument
          Transfer -> Type -> Text -> Text -> BaseCodeGen CGError ()
freeContainerType Transfer
transfer' Type
t Text
peeked Text
forall a. HasCallStack => a
undefined
          Text -> ExcCodeGen Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
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
callable nameMap :: Map Text Text
nameMap hOutArgs :: [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 ()
invokeCFunction :: Callable -> ForeignSymbol -> [Text] -> CodeGen ()
invokeCFunction callable :: Callable
callable symbol :: ForeignSymbol
symbol argNames :: [Text]
argNames = do
  let returnBind :: Text
returnBind = case Callable -> Maybe Type
returnType Callable
callable of
                     Nothing -> ""
                     _       -> if Callable -> Bool
skipRetVal Callable
callable
                                then "_ <- "
                                else "result <- "
      maybeCatchGErrors :: Text
maybeCatchGErrors = if Callable -> Bool
callableThrows Callable
callable
                          then "propagateGError $ "
                          else ""
      call :: Text
call = case ForeignSymbol
symbol of
               KnownForeignSymbol s :: Text
s -> Text
s
               DynamicForeignSymbol w :: DynamicWrapper
w -> Text -> Text
parenthesize (DynamicWrapper -> Text
dynamicWrapper DynamicWrapper
w
                                                      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
funPtr)
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen 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
forall a. Semigroup a => a -> a -> a
<>)) [Text]
argNames

-- | Return the result of the call, possibly including out arguments.
returnResult :: Callable -> Text -> [Text] -> CodeGen ()
returnResult :: Callable -> Text -> [Text] -> CodeGen ()
returnResult callable :: Callable
callable result :: Text
result pps :: [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 ()
line "return ()"
        (pp :: Text
pp:[]) -> Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "return " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pp
        _       -> Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "return (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate ", " [Text]
pps Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"
    else case [Text]
pps of
        [] -> Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "return " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
result
        _  -> Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "return (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate ", " (Text
result Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
pps) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"

-- | Generate a Haskell wrapper for the given foreign function.
genHaskellWrapper :: Name -> ForeignSymbol -> Callable ->
                     ExposeClosures -> ExcCodeGen Text
genHaskellWrapper :: Name
-> ForeignSymbol -> Callable -> ExposeClosures -> ExcCodeGen Text
genHaskellWrapper n :: Name
n symbol :: ForeignSymbol
symbol callable :: Callable
callable expose :: ExposeClosures
expose = ExcCodeGen Text -> ExcCodeGen Text
forall e a. BaseCodeGen e a -> BaseCodeGen 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 _ -> Name -> Text
lowerName Name
n
                 DynamicForeignSymbol _ -> Text -> Text
callbackDynamicWrapper (Name -> Text
upperName Name
n)
        (hInArgs :: [Arg]
hInArgs, omitted :: [Arg]
omitted) = Callable -> ExposeClosures -> ([Arg], [Arg])
callableHInArgs Callable
callable ExposeClosures
expose
        hOutArgs :: [Arg]
hOutArgs = Callable -> [Arg]
callableHOutArgs Callable
callable

    Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " ::"
    Callable
-> ForeignSymbol -> ExposeClosures -> BaseCodeGen CGError ()
formatHSignature Callable
callable ForeignSymbol
symbol ExposeClosures
expose
    let argNames :: [Text]
argNames = case ForeignSymbol
symbol of
                     KnownForeignSymbol _ -> (Arg -> Text) -> [Arg] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Arg -> Text
escapedArgName [Arg]
hInArgs
                     DynamicForeignSymbol _ ->
                         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 -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate " " [Text]
argNames Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = liftIO $ do"
    BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (Name
-> ForeignSymbol
-> Callable
-> [Arg]
-> [Arg]
-> [Arg]
-> ExposeClosures
-> BaseCodeGen CGError ()
genWrapperBody Name
n ForeignSymbol
symbol Callable
callable [Arg]
hInArgs [Arg]
hOutArgs [Arg]
omitted ExposeClosures
expose)
    Text -> ExcCodeGen Text
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
-> BaseCodeGen CGError ()
genWrapperBody n :: Name
n symbol :: ForeignSymbol
symbol callable :: Callable
callable hInArgs :: [Arg]
hInArgs hOutArgs :: [Arg]
hOutArgs omitted :: [Arg]
omitted expose :: ExposeClosures
expose = do
    Name -> Callable -> [Arg] -> BaseCodeGen CGError ()
readInArrayLengths Name
n Callable
callable [Arg]
hInArgs
    [Text]
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] -> Arg -> ExposeClosures -> ExcCodeGen Text
prepareArgForCall [Arg]
omitted Arg
arg ExposeClosures
expose
    -- Map from argument names to names passed to the C function
    let nameMap :: Map Text Text
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
    Callable -> Map Text Text -> BaseCodeGen CGError ()
prepareClosures Callable
callable Map Text Text
nameMap
    if Callable -> Bool
callableThrows Callable
callable
    then do
        Text -> CodeGen ()
line "onException (do"
        BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen CGError () -> BaseCodeGen CGError ())
-> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ do
            Callable -> ForeignSymbol -> [Text] -> CodeGen ()
invokeCFunction Callable
callable ForeignSymbol
symbol [Text]
inArgNames
            Callable -> Map Text Text -> BaseCodeGen CGError ()
readOutArrayLengths Callable
callable Map Text Text
nameMap
            Text
result <- Name -> Callable -> Map Text Text -> ExcCodeGen Text
convertResult Name
n Callable
callable Map Text Text
nameMap
            [Text]
pps <- Callable -> Map Text Text -> [Arg] -> ExcCodeGen [Text]
convertOutArgs Callable
callable Map Text Text
nameMap [Arg]
hOutArgs
            Callable -> Map Text Text -> BaseCodeGen CGError ()
freeCallCallbacks Callable
callable Map Text Text
nameMap
            [Arg] -> (Arg -> BaseCodeGen CGError ()) -> BaseCodeGen CGError ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Callable -> [Arg]
args Callable
callable) Arg -> BaseCodeGen CGError ()
touchInArg
            (Text -> BaseCodeGen CGError ())
-> [Text] -> BaseCodeGen CGError ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line ([Text] -> BaseCodeGen CGError ())
-> ExcCodeGen [Text] -> BaseCodeGen CGError ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Callable -> Map Text Text -> ExcCodeGen [Text]
freeInArgs Callable
callable Map Text Text
nameMap
            Callable -> Text -> [Text] -> CodeGen ()
returnResult Callable
callable Text
result [Text]
pps
        Text -> CodeGen ()
line " ) (do"
        BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen CGError () -> BaseCodeGen CGError ())
-> BaseCodeGen CGError () -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ do
            Callable -> Map Text Text -> BaseCodeGen CGError ()
freeCallCallbacks Callable
callable Map Text Text
nameMap
            [Text]
actions <- Callable -> Map Text Text -> ExcCodeGen [Text]
freeInArgsOnError Callable
callable Map Text Text
nameMap
            case [Text]
actions of
                [] -> Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line (Text -> BaseCodeGen CGError ()) -> Text -> BaseCodeGen CGError ()
forall a b. (a -> b) -> a -> b
$ "return ()"
                _ -> (Text -> BaseCodeGen CGError ())
-> [Text] -> BaseCodeGen CGError ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line [Text]
actions
        Text -> CodeGen ()
line " )"
    else do
        Callable -> ForeignSymbol -> [Text] -> CodeGen ()
invokeCFunction Callable
callable ForeignSymbol
symbol [Text]
inArgNames
        Callable -> Map Text Text -> BaseCodeGen CGError ()
readOutArrayLengths Callable
callable Map Text Text
nameMap
        Text
result <- Name -> Callable -> Map Text Text -> ExcCodeGen Text
convertResult Name
n Callable
callable Map Text Text
nameMap
        [Text]
pps <- Callable -> Map Text Text -> [Arg] -> ExcCodeGen [Text]
convertOutArgs Callable
callable Map Text Text
nameMap [Arg]
hOutArgs
        Callable -> Map Text Text -> BaseCodeGen CGError ()
freeCallCallbacks Callable
callable Map Text Text
nameMap
        [Arg] -> (Arg -> BaseCodeGen CGError ()) -> BaseCodeGen CGError ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Callable -> [Arg]
args Callable
callable) Arg -> BaseCodeGen CGError ()
touchInArg
        (Text -> BaseCodeGen CGError ())
-> [Text] -> BaseCodeGen CGError ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> BaseCodeGen CGError ()
Text -> CodeGen ()
line ([Text] -> BaseCodeGen CGError ())
-> ExcCodeGen [Text] -> BaseCodeGen CGError ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Callable -> Map Text Text -> ExcCodeGen [Text]
freeInArgs Callable
callable Map Text Text
nameMap
        Callable -> Text -> [Text] -> CodeGen ()
returnResult Callable
callable Text
result [Text]
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 c :: Callable
c =
    Callable
c{args :: [Arg]
args = (Arg -> Arg) -> [Arg] -> [Arg]
forall a b. (a -> b) -> [a] -> [b]
map (Arg -> Arg
fixupLength (Arg -> Arg) -> (Arg -> Arg) -> Arg -> Arg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg -> Arg
fixupDir) (Callable -> [Arg]
args Callable
c)}
    where fixupDir :: Arg -> Arg
          fixupDir :: Arg -> Arg
fixupDir a :: Arg
a = case Arg -> Type
argType Arg
a of
                         TCArray _ _ l :: Int
l _ ->
                             if Arg -> Bool
argCallerAllocates Arg
a Bool -> Bool -> Bool
&& Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> -1
                             then Arg
a { direction :: Direction
direction = Direction
DirectionInout
                                    , transfer :: Transfer
transfer = Transfer
TransferEverything }
                             else Arg
a
                         _ -> 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 a :: 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
                            Nothing -> Arg
a
                            Just array :: Arg
array ->
                                if Arg -> Bool
argCallerAllocates Arg
array
                                then Arg
a {direction :: Direction
direction = 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 ()
genCallableDebugInfo :: Callable -> CodeGen ()
genCallableDebugInfo callable :: Callable
callable =
    BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> [Arg] -> CodeGen ()
forall a. Show a => Text -> a -> CodeGen ()
commentShow "Args" (Callable -> [Arg]
args Callable
callable)
      Text -> [Arg] -> CodeGen ()
forall a. Show a => Text -> a -> CodeGen ()
commentShow "Lengths" (Callable -> [Arg]
arrayLengths Callable
callable)
      Text -> Maybe Type -> CodeGen ()
forall a. Show a => Text -> a -> CodeGen ()
commentShow "returnType" (Callable -> Maybe Type
returnType Callable
callable)
      Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "-- 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 -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "-- 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 -> BaseCodeGen e () -> BaseCodeGen 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)) (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$
           do Text -> CodeGen ()
line "-- XXX return value ignored, but it is not a boolean."
              Text -> CodeGen ()
line "--     This may be a memory leak?"
  where commentShow :: Show a => Text -> a -> CodeGen ()
        commentShow :: Text -> a -> CodeGen ()
commentShow prefix :: Text
prefix s :: 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
+ 2) " "
              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
                         [] -> []
                         (f :: Text
f:rest :: [Text]
rest) -> "-- " 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
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
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)) ()
Text -> CodeGen ()
line [Text]
padded

-- | Generate a wrapper for a known C symbol.
genCCallableWrapper :: Name -> Text -> Callable -> ExcCodeGen ()
genCCallableWrapper :: Name -> Text -> Callable -> BaseCodeGen CGError ()
genCCallableWrapper n :: Name
n cSymbol :: Text
cSymbol callable :: Callable
callable = do
  Callable -> CodeGen ()
genCallableDebugInfo Callable
callable

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

  Text
hSymbol <- Text -> Callable -> CodeGen Text
mkForeignImport Text
cSymbol Callable
callable'

  BaseCodeGen CGError ()
CodeGen ()
blank

  Text -> Maybe DeprecationInfo -> CodeGen ()
deprecatedPragma (Name -> Text
lowerName Name
n) (Callable -> Maybe DeprecationInfo
callableDeprecated Callable
callable)
  RelativeDocPosition -> Documentation -> CodeGen ()
writeDocumentation RelativeDocPosition
DocBeforeSymbol (Callable -> Documentation
callableDocumentation Callable
callable)
  ExcCodeGen Text -> BaseCodeGen CGError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Name
-> ForeignSymbol -> Callable -> ExposeClosures -> ExcCodeGen Text
genHaskellWrapper Name
n (Text -> ForeignSymbol
KnownForeignSymbol Text
hSymbol) Callable
callable'
         ExposeClosures
WithoutClosures)

-- | For callbacks we do not need to keep track of which arguments are
-- closures.
forgetClosures :: Callable -> Callable
forgetClosures :: Callable -> Callable
forgetClosures c :: Callable
c = Callable
c {args :: [Arg]
args = (Arg -> Arg) -> [Arg] -> [Arg]
forall a b. (a -> b) -> [a] -> [b]
map Arg -> Arg
forgetClosure (Callable -> [Arg]
args Callable
c)}
    where forgetClosure :: Arg -> Arg
          forgetClosure :: Arg -> Arg
forgetClosure arg :: Arg
arg = Arg
arg {argClosure :: Int
argClosure = -1}

-- | 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 n :: Name
n typeSynonym :: Text
typeSynonym callable :: Callable
callable = do
  Callable -> CodeGen ()
genCallableDebugInfo Callable
callable

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

  Text
wrapper <- Text -> CodeGen Text
mkDynamicImport Text
typeSynonym

  BaseCodeGen CGError ()
CodeGen ()
blank

  RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol Text
dynamicDoc

  let dyn :: DynamicWrapper
dyn = DynamicWrapper :: Text -> Text -> DynamicWrapper
DynamicWrapper { dynamicWrapper :: Text
dynamicWrapper = Text
wrapper
                           , dynamicType :: Text
dynamicType    = Text
typeSynonym }
  Name
-> ForeignSymbol -> Callable -> ExposeClosures -> ExcCodeGen Text
genHaskellWrapper Name
n (DynamicWrapper -> ForeignSymbol
DynamicForeignSymbol DynamicWrapper
dyn) Callable
callable' ExposeClosures
WithClosures

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