-- | Marshalling of structs and unions.
module Data.GI.CodeGen.Struct ( genStructOrUnionFields
                              , genZeroStruct
                              , genZeroUnion
                              , extractCallbacksInStruct
                              , fixAPIStructs
                              , ignoreStruct
                              , genBoxed
                              , genWrappedPtr
                              ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad (forM, when)

import Data.Maybe (mapMaybe, isJust, catMaybes)
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import Data.Text (Text)
import qualified Data.Text as T

import Data.GI.CodeGen.API
import Data.GI.CodeGen.Conversions
import Data.GI.CodeGen.Code
import Data.GI.CodeGen.Haddock (addSectionDocumentation, writeHaddock,
                                RelativeDocPosition(DocBeforeSymbol))
import Data.GI.CodeGen.ModulePath (dotModulePath)
import Data.GI.CodeGen.SymbolNaming (upperName, lowerName,
                                     underscoresToCamelCase,
                                     qualifiedSymbol,
                                     callbackHaskellToForeign,
                                     callbackWrapperAllocator,
                                     haddockAttrAnchor, moduleLocation,
                                     hackageModuleLink,
                                     normalizedAPIName)

import Data.GI.CodeGen.Type
import Data.GI.CodeGen.Util

-- | Whether (not) to generate bindings for the given struct.
ignoreStruct :: Name -> Struct -> Bool
ignoreStruct :: Name -> Struct -> Bool
ignoreStruct (Name Text
_ Text
name) Struct
s = (forall a. Maybe a -> Bool
isJust (Struct -> Maybe Name
gtypeStructFor Struct
s) Bool -> Bool -> Bool
||
                               Text
"Private" Text -> Text -> Bool
`T.isSuffixOf` Text
name) Bool -> Bool -> Bool
&&
                               (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Struct -> Bool
structForceVisible Struct
s)

-- | Whether the given type corresponds to an ignored struct.
isIgnoredStructType :: Type -> CodeGen e Bool
isIgnoredStructType :: forall e. Type -> CodeGen e Bool
isIgnoredStructType Type
t =
  case Type
t of
    TInterface Name
n -> do
      API
api <- forall e. HasCallStack => Type -> CodeGen e API
getAPI Type
t
      case API
api of
        APIStruct Struct
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Struct -> Bool
ignoreStruct Name
n Struct
s)
        API
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Type
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | Canonical name for the type of a callback type embedded in a
-- struct field.
fieldCallbackType :: Text -> Field -> Text
fieldCallbackType :: Text -> Field -> Text
fieldCallbackType Text
structName Field
field =
    Text
structName forall a. Semigroup a => a -> a -> a
<> (Text -> Text
underscoresToCamelCase forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Text
fieldName) Field
field forall a. Semigroup a => a -> a -> a
<> Text
"FieldCallback"

-- | Fix the interface names of callback fields in the struct to
-- correspond to the ones that we are going to generate.
fixCallbackStructFields :: Name -> Struct -> Struct
fixCallbackStructFields :: Name -> Struct -> Struct
fixCallbackStructFields (Name Text
ns Text
structName) Struct
s = Struct
s {structFields :: [Field]
structFields = [Field]
fixedFields}
    where fixedFields :: [Field]
          fixedFields :: [Field]
fixedFields = forall a b. (a -> b) -> [a] -> [b]
map Field -> Field
fixField (Struct -> [Field]
structFields Struct
s)

          fixField :: Field -> Field
          fixField :: Field -> Field
fixField Field
field =
              case Field -> Maybe Callback
fieldCallback Field
field of
                Maybe Callback
Nothing -> Field
field
                Just Callback
_ -> let n' :: Text
n' = Text -> Field -> Text
fieldCallbackType Text
structName Field
field
                          in Field
field {fieldType :: Type
fieldType = Name -> Type
TInterface (Text -> Text -> Name
Name Text
ns Text
n')}

-- | Fix the interface names of callback fields in an APIStruct to
-- correspond to the ones that we are going to generate. If something
-- other than an APIStruct is passed in we don't touch it.
fixAPIStructs :: (Name, API) -> (Name, API)
fixAPIStructs :: (Name, API) -> (Name, API)
fixAPIStructs (Name
n, APIStruct Struct
s) = (Name
n, Struct -> API
APIStruct forall a b. (a -> b) -> a -> b
$ Name -> Struct -> Struct
fixCallbackStructFields Name
n Struct
s)
fixAPIStructs (Name, API)
api = (Name, API)
api

-- | Extract the callback types embedded in the fields of structs, and
-- at the same time fix the type of the corresponding fields. Returns
-- the list of APIs associated to this struct, not including the
-- struct itself.
extractCallbacksInStruct :: (Name, API) -> [(Name, API)]
extractCallbacksInStruct :: (Name, API) -> [(Name, API)]
extractCallbacksInStruct (n :: Name
n@(Name Text
ns Text
structName), APIStruct Struct
s)
    | Name -> Struct -> Bool
ignoreStruct Name
n Struct
s = []
    | Bool
otherwise =
        forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Field -> Maybe (Name, API)
callbackInField (Struct -> [Field]
structFields Struct
s)
            where callbackInField :: Field -> Maybe (Name, API)
                  callbackInField :: Field -> Maybe (Name, API)
callbackInField Field
field = do
                    Callback
callback <- Field -> Maybe Callback
fieldCallback Field
field
                    let n' :: Text
n' = Text -> Field -> Text
fieldCallbackType Text
structName Field
field
                    forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Text -> Name
Name Text
ns Text
n', Callback -> API
APICallback Callback
callback)
extractCallbacksInStruct (Name, API)
_ = []

-- | The name of the type encoding the information for a field in a
-- struct/union.
infoType :: Name -> Field -> CodeGen e Text
infoType :: forall e. Name -> Field -> CodeGen e Text
infoType Name
owner Field
field = do
  let name :: Text
name = Name -> Text
upperName Name
owner
  let fName :: Text
fName = (Text -> Text
underscoresToCamelCase forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Text
fieldName) Field
field
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
name forall a. Semigroup a => a -> a -> a
<> Text
fName forall a. Semigroup a => a -> a -> a
<> Text
"FieldInfo"

-- | Whether a given field is an embedded struct/union.
isEmbedded :: Field -> ExcCodeGen Bool
isEmbedded :: Field -> ExcCodeGen Bool
isEmbedded Field
field = do
  Maybe API
api <- forall e. HasCallStack => Type -> CodeGen e (Maybe API)
findAPI (Field -> Type
fieldType Field
field)
  case Maybe API
api of
    Just (APIStruct Struct
_) -> ExcCodeGen Bool
checkEmbedding
    Just (APIUnion Union
_) -> ExcCodeGen Bool
checkEmbedding
    Maybe API
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  where
    checkEmbedding :: ExcCodeGen Bool
    checkEmbedding :: ExcCodeGen Bool
checkEmbedding = case Field -> Maybe Bool
fieldIsPointer Field
field of
      Maybe Bool
Nothing -> forall a. Text -> ExcCodeGen a
badIntroError Text
"Cannot determine whether the field is embedded."
      Just Bool
isPtr -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not Bool
isPtr)

-- | Name for the getter function
fieldGetter :: Name -> Field -> Text
fieldGetter :: Name -> Field -> Text
fieldGetter Name
name' Field
field = Text
"get" forall a. Semigroup a => a -> a -> a
<> Name -> Text
upperName Name
name' forall a. Semigroup a => a -> a -> a
<> Field -> Text
fName Field
field

-- | Generate documentation for the given getter.
getterDoc :: Name -> Field -> Text
getterDoc :: Name -> Field -> Text
getterDoc Name
n Field
field = [Text] -> Text
T.unlines [
    Text
"Get the value of the “@" forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldName Field
field forall a. Semigroup a => a -> a -> a
<> Text
"@” field."
  , Text
"When <https://github.com/haskell-gi/haskell-gi/wiki/Overloading overloading> is enabled, this is equivalent to"
  , Text
""
  , Text
"@"
  , Text
"'Data.GI.Base.Attributes.get' " forall a. Semigroup a => a -> a -> a
<> Name -> Text
lowerName Name
n forall a. Semigroup a => a -> a -> a
<> Text
" #" forall a. Semigroup a => a -> a -> a
<> Field -> Text
labelName Field
field
  , Text
"@"]

-- Notice that when reading the field we return a copy of any embedded
-- structs, so modifications of the returned struct will not affect
-- the original struct. This is on purpose, in order to increase
-- safety (otherwise the garbage collector may decide to free the
-- parent structure while we are modifying the embedded one, and havoc
-- will ensue).
-- | Extract a field from a struct.
buildFieldReader :: Name -> Field -> ExcCodeGen ()
buildFieldReader :: Name -> Field -> ExcCodeGen ()
buildFieldReader Name
n Field
field = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
  let name' :: Text
name' = Name -> Text
upperName Name
n
      getter :: Text
getter = Name -> Field -> Text
fieldGetter Name
n Field
field

  Bool
embedded <- Field -> ExcCodeGen Bool
isEmbedded Field
field
  Maybe Text
nullConvert <- if Bool
embedded
                 then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                 else forall e. Type -> CodeGen e (Maybe Text)
maybeNullConvert (Field -> Type
fieldType Field
field)
  Text
hType <- TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if forall a. Maybe a -> Bool
isJust Maybe Text
nullConvert
                        then TypeRep -> TypeRep
maybeT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
isoHaskellType (Field -> Type
fieldType Field
field)
                        else forall e. Type -> CodeGen e TypeRep
isoHaskellType (Field -> Type
fieldType Field
field)
  Text
fType <- TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
foreignType (Field -> Type
fieldType Field
field)

  forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Name -> Field -> Text
getterDoc Name
n Field
field)

  forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
getter forall a. Semigroup a => a -> a -> a
<> Text
" :: MonadIO m => " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" -> m " forall a. Semigroup a => a -> a -> a
<>
              if (Char -> Bool) -> Text -> Bool
T.any (forall a. Eq a => a -> a -> Bool
== Char
' ') Text
hType
              then Text -> Text
parenthesize Text
hType
              else Text
hType
  forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
getter forall a. Semigroup a => a -> a -> a
<> Text
" s = liftIO $ withManagedPtr s $ \\ptr -> do"
  forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
    let peekedType :: Text
peekedType = if (Char -> Bool) -> Text -> Bool
T.any (forall a. Eq a => a -> a -> Bool
== Char
' ') Text
fType
                     then Text -> Text
parenthesize Text
fType
                     else Text
fType
    if Bool
embedded
    then forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"let val = ptr `plusPtr` " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (Field -> Int
fieldOffset Field
field)
             forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> Text
peekedType
    else forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"val <- peek (ptr `plusPtr` " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (Field -> Int
fieldOffset Field
field)
             forall a. Semigroup a => a -> a -> a
<> Text
") :: IO " forall a. Semigroup a => a -> a -> a
<> Text
peekedType
    Text
result <- case Maybe Text
nullConvert of
              Maybe Text
Nothing -> forall e. Text -> CodeGen e Converter -> CodeGen e Text
convert Text
"val" forall a b. (a -> b) -> a -> b
$ Type -> Transfer -> ExcCodeGen Converter
fToH (Field -> Type
fieldType Field
field) Transfer
TransferNothing
              Just Text
nullConverter -> do
                forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"result <- " forall a. Semigroup a => a -> a -> a
<> Text
nullConverter forall a. Semigroup a => a -> a -> a
<> Text
" val $ \\val' -> do"
                forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
                  Text
val' <- forall e. Text -> CodeGen e Converter -> CodeGen e Text
convert Text
"val'" forall a b. (a -> b) -> a -> b
$ Type -> Transfer -> ExcCodeGen Converter
fToH (Field -> Type
fieldType Field
field) Transfer
TransferNothing
                  forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"return " forall a. Semigroup a => a -> a -> a
<> Text
val'
                forall (m :: * -> *) a. Monad m => a -> m a
return Text
"result"
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"return " forall a. Semigroup a => a -> a -> a
<> Text
result

-- | Name for the setter function
fieldSetter :: Name -> Field -> Text
fieldSetter :: Name -> Field -> Text
fieldSetter Name
name' Field
field = Text
"set" forall a. Semigroup a => a -> a -> a
<> Name -> Text
upperName Name
name' forall a. Semigroup a => a -> a -> a
<> Field -> Text
fName Field
field

-- | Generate documentation for the given setter.
setterDoc :: Name -> Field -> Text
setterDoc :: Name -> Field -> Text
setterDoc Name
n Field
field = [Text] -> Text
T.unlines [
    Text
"Set the value of the “@" forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldName Field
field forall a. Semigroup a => a -> a -> a
<> Text
"@” field."
  , Text
"When <https://github.com/haskell-gi/haskell-gi/wiki/Overloading overloading> is enabled, this is equivalent to"
  , Text
""
  , Text
"@"
  , Text
"'Data.GI.Base.Attributes.set' " forall a. Semigroup a => a -> a -> a
<> Name -> Text
lowerName Name
n forall a. Semigroup a => a -> a -> a
<> Text
" [ #" forall a. Semigroup a => a -> a -> a
<> Field -> Text
labelName Field
field
    forall a. Semigroup a => a -> a -> a
<> Text
" 'Data.GI.Base.Attributes.:=' value ]"
  , Text
"@"]

-- | Write a field into a struct. Note that, since we cannot know for
-- sure who will be deallocating the fields in the struct, we leave
-- any conversions that involve pointers to the caller. What this
-- means in practice is that scalar fields will get marshalled to/from
-- Haskell, while anything that involves pointers will be returned in
-- the C representation.
buildFieldWriter :: Name -> Field -> ExcCodeGen ()
buildFieldWriter :: Name -> Field -> ExcCodeGen ()
buildFieldWriter Name
n Field
field = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
  let name' :: Text
name' = Name -> Text
upperName Name
n
  let setter :: Text
setter = Name -> Field -> Text
fieldSetter Name
n Field
field

  Bool
isPtr <- forall e. Type -> CodeGen e Bool
typeIsPtr (Field -> Type
fieldType Field
field)

  Text
fType <- TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
foreignType (Field -> Type
fieldType Field
field)
  Text
hType <- if Bool
isPtr
           then forall (m :: * -> *) a. Monad m => a -> m a
return Text
fType
           else TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
haskellType (Field -> Type
fieldType Field
field)

  forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Name -> Field -> Text
setterDoc Name
n Field
field)

  forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
setter forall a. Semigroup a => a -> a -> a
<> Text
" :: MonadIO m => " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" -> "
           forall a. Semigroup a => a -> a -> a
<> Text
hType forall a. Semigroup a => a -> a -> a
<> Text
" -> m ()"
  forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
setter forall a. Semigroup a => a -> a -> a
<> Text
" s val = liftIO $ withManagedPtr s $ \\ptr -> do"
  forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
    Text
converted <- if Bool
isPtr
                 then forall (m :: * -> *) a. Monad m => a -> m a
return Text
"val"
                 else forall e. Text -> CodeGen e Converter -> CodeGen e Text
convert Text
"val" forall a b. (a -> b) -> a -> b
$ Type -> Transfer -> ExcCodeGen Converter
hToF (Field -> Type
fieldType Field
field) Transfer
TransferNothing
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"poke (ptr `plusPtr` " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (Field -> Int
fieldOffset Field
field)
         forall a. Semigroup a => a -> a -> a
<> Text
") (" forall a. Semigroup a => a -> a -> a
<> Text
converted forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> Text
fType forall a. Semigroup a => a -> a -> a
<> Text
")"

-- | Name for the clear function
fieldClear :: Name -> Field -> Text
fieldClear :: Name -> Field -> Text
fieldClear Name
name' Field
field = Text
"clear" forall a. Semigroup a => a -> a -> a
<> Name -> Text
upperName Name
name' forall a. Semigroup a => a -> a -> a
<> Field -> Text
fName Field
field

-- | Documentation for the @clear@ method.
clearDoc :: Field -> Text
clearDoc :: Field -> Text
clearDoc Field
field = [Text] -> Text
T.unlines [
  Text
"Set the value of the “@" forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldName Field
field forall a. Semigroup a => a -> a -> a
<> Text
"@” field to `Nothing`."
  , Text
"When <https://github.com/haskell-gi/haskell-gi/wiki/Overloading overloading> is enabled, this is equivalent to"
  , Text
""
  , Text
"@"
  , Text
"'Data.GI.Base.Attributes.clear'" forall a. Semigroup a => a -> a -> a
<> Text
" #" forall a. Semigroup a => a -> a -> a
<> Field -> Text
labelName Field
field
  , Text
"@"]

-- | Write a @NULL@ into a field of a struct of type `Ptr`.
buildFieldClear :: Name -> Field -> Text -> ExcCodeGen ()
buildFieldClear :: Name -> Field -> Text -> ExcCodeGen ()
buildFieldClear Name
n Field
field Text
nullPtr = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
  let name' :: Text
name' = Name -> Text
upperName Name
n
  let clear :: Text
clear = Name -> Field -> Text
fieldClear Name
n Field
field

  Text
fType <- TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
foreignType (Field -> Type
fieldType Field
field)

  forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Field -> Text
clearDoc Field
field)

  forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
clear forall a. Semigroup a => a -> a -> a
<> Text
" :: MonadIO m => " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" -> m ()"
  forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
clear forall a. Semigroup a => a -> a -> a
<> Text
" s = liftIO $ withManagedPtr s $ \\ptr -> do"
  forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"poke (ptr `plusPtr` " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (Field -> Int
fieldOffset Field
field)
         forall a. Semigroup a => a -> a -> a
<> Text
") ("  forall a. Semigroup a => a -> a -> a
<> Text
nullPtr forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> Text
fType forall a. Semigroup a => a -> a -> a
<> Text
")"

-- | Return whether the given type corresponds to a callback that does
-- not throw exceptions. If it is, return the callback itself. See
-- [Note: Callables that throw] for the reason why we do not try to
-- wrap callbacks that throw exceptions.
isRegularCallback :: Type -> CodeGen e (Maybe Callback)
isRegularCallback :: forall e. Type -> CodeGen e (Maybe Callback)
isRegularCallback t :: Type
t@(TInterface Name
_) = do
  API
api <- forall e. HasCallStack => Type -> CodeGen e API
getAPI Type
t
  case API
api of
    APICallback callback :: Callback
callback@(Callback {cbCallable :: Callback -> Callable
cbCallable = Callable
callable}) ->
      if Callable -> Bool
callableThrows Callable
callable
      then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Callback
callback)
    API
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
isRegularCallback Type
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- | The types accepted by the allocating set function
-- 'Data.GI.Base.Attributes.(:&=)'.
fieldTransferTypeConstraint :: Type -> CodeGen e Text
fieldTransferTypeConstraint :: forall e. Type -> CodeGen e Text
fieldTransferTypeConstraint Type
t = do
  Bool
isPtr <- forall e. Type -> CodeGen e Bool
typeIsPtr Type
t
  Maybe Callback
maybeRegularCallback <- forall e. Type -> CodeGen e (Maybe Callback)
isRegularCallback Type
t
  Text
inType <- if Bool
isPtr Bool -> Bool -> Bool
&& Bool -> Bool
not (forall a. Maybe a -> Bool
isJust Maybe Callback
maybeRegularCallback)
            then TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
foreignType Type
t
            else TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
isoHaskellType Type
t
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"(~)" forall a. Semigroup a => a -> a -> a
<> if (Char -> Bool) -> Text -> Bool
T.any (forall a. Eq a => a -> a -> Bool
== Char
' ') Text
inType
                    then Text -> Text
parenthesize Text
inType
                    else Text
inType

-- | The type generated by 'Data.GI.Base.attrTransfer' for this
-- field. This type should satisfy the
-- 'Data.GI.Base.Attributes.AttrSetTypeConstraint' for the type.
fieldTransferType :: Type -> CodeGen e Text
fieldTransferType :: forall e. Type -> CodeGen e Text
fieldTransferType Type
t = do
  Bool
isPtr <- forall e. Type -> CodeGen e Bool
typeIsPtr Type
t
  Text
inType <- if Bool
isPtr
            then TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
foreignType Type
t
            else TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
haskellType Type
t
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if (Char -> Bool) -> Text -> Bool
T.any (forall a. Eq a => a -> a -> Bool
== Char
' ') Text
inType
           then Text -> Text
parenthesize Text
inType
           else Text
inType

-- | Generate the field transfer function, which marshals Haskell
-- values to types that we can set, even if we need to allocate memory.
genFieldTransfer :: Text -> Type -> CodeGen e ()
genFieldTransfer :: forall e. Text -> Type -> CodeGen e ()
genFieldTransfer Text
var t :: Type
t@(TInterface Name
tn) = do
  Maybe Callback
maybeRegularCallback <- forall e. Type -> CodeGen e (Maybe Callback)
isRegularCallback Type
t
  case Maybe Callback
maybeRegularCallback of
    Just Callback
callback -> do
      let Name Text
_ Text
name' = API -> Name -> Name
normalizedAPIName (Callback -> API
APICallback Callback
callback) Name
tn
      Text
wrapper <- forall e. Text -> Name -> CodeGen e Text
qualifiedSymbol (Text -> Text
callbackHaskellToForeign Text
name') Name
tn
      Text
maker <- forall e. Text -> Name -> CodeGen e Text
qualifiedSymbol (Text -> Text
callbackWrapperAllocator Text
name') Name
tn
      forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
maker forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<>
        Text -> Text
parenthesize (Text
wrapper forall a. Semigroup a => a -> a -> a
<> Text
" Nothing " forall a. Semigroup a => a -> a -> a
<> Text
var)
    Maybe Callback
Nothing -> forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"return " forall a. Semigroup a => a -> a -> a
<> Text
var
genFieldTransfer Text
var Type
_ = forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"return " forall a. Semigroup a => a -> a -> a
<> Text
var

-- | Haskell name for the field
fName :: Field -> Text
fName :: Field -> Text
fName = Text -> Text
underscoresToCamelCase forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Text
fieldName

-- | Label associated to the field.
labelName :: Field -> Text
labelName :: Field -> Text
labelName = Text -> Text
lcFirst  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Text
fName

-- | Support for modifying fields as attributes. Returns a tuple with
-- the name of the overloaded label to be used for the field, and the
-- associated info type.
genAttrInfo :: Name -> Field -> ExcCodeGen Text
genAttrInfo :: Name
-> Field
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
genAttrInfo Name
owner Field
field = do
  Text
it <- forall e. Name -> Field -> CodeGen e Text
infoType Name
owner Field
field
  let on :: Text
on = Name -> Text
upperName Name
owner

  Bool
isPtr <- forall e. Type -> CodeGen e Bool
typeIsPtr (Field -> Type
fieldType Field
field)

  Bool
embedded <- Field -> ExcCodeGen Bool
isEmbedded Field
field
  Bool
isNullable <- forall e. Type -> CodeGen e Bool
typeIsNullable (Field -> Type
fieldType Field
field)
  Text
outType <- TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if Bool -> Bool
not Bool
embedded Bool -> Bool -> Bool
&& Bool
isNullable
                          then TypeRep -> TypeRep
maybeT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
isoHaskellType (Field -> Type
fieldType Field
field)
                          else forall e. Type -> CodeGen e TypeRep
isoHaskellType (Field -> Type
fieldType Field
field)
  Text
inType <- if Bool
isPtr
            then TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
foreignType (Field -> Type
fieldType Field
field)
            else TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
haskellType (Field -> Type
fieldType Field
field)
  Text
transferType <- forall e. Type -> CodeGen e Text
fieldTransferType (Field -> Type
fieldType Field
field)
  Text
transferConstraint <- forall e. Type -> CodeGen e Text
fieldTransferTypeConstraint (Field -> Type
fieldType Field
field)

  API
api <- forall e. HasCallStack => Name -> CodeGen e API
findAPIByName Name
owner
  Text
hackageLink <- forall e. Name -> CodeGen e Text
hackageModuleLink Name
owner
  let qualifiedAttrName :: Text
qualifiedAttrName = ModulePath -> Text
dotModulePath (Name -> API -> ModulePath
moduleLocation Name
owner API
api)
                          forall a. Semigroup a => a -> a -> a
<> Text
"." forall a. Semigroup a => a -> a -> a
<> Field -> Text
labelName Field
field
      attrInfoURL :: Text
attrInfoURL = Text
hackageLink forall a. Semigroup a => a -> a -> a
<> Text
"#" forall a. Semigroup a => a -> a -> a
<> Text
haddockAttrAnchor forall a. Semigroup a => a -> a -> a
<> Field -> Text
labelName Field
field

  forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"data " forall a. Semigroup a => a -> a -> a
<> Text
it
  forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"instance AttrInfo " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" where"
  forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrBaseTypeConstraint " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = (~) " forall a. Semigroup a => a -> a -> a
<> Text
on
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrAllowedOps " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<>
             if Bool
embedded
             then Text
" = '[ 'AttrGet]"
             else if Bool
isPtr
                  then Text
" = '[ 'AttrSet, 'AttrGet, 'AttrClear]"
                  else Text
" = '[ 'AttrSet, 'AttrGet]"
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrSetTypeConstraint " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = (~) "
             forall a. Semigroup a => a -> a -> a
<> if (Char -> Bool) -> Text -> Bool
T.any (forall a. Eq a => a -> a -> Bool
== Char
' ') Text
inType
                then Text -> Text
parenthesize Text
inType
                else Text
inType
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrTransferTypeConstraint " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
transferConstraint
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrTransferType " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
transferType
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrGetType " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
outType
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrLabel " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = \"" forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldName Field
field forall a. Semigroup a => a -> a -> a
<> Text
"\""
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrOrigin " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
on
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"attrGet = " forall a. Semigroup a => a -> a -> a
<> Name -> Field -> Text
fieldGetter Name
owner Field
field
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"attrSet = " forall a. Semigroup a => a -> a -> a
<> if Bool -> Bool
not Bool
embedded
                             then Name -> Field -> Text
fieldSetter Name
owner Field
field
                             else Text
"undefined"
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"attrConstruct = undefined"
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"attrClear = " forall a. Semigroup a => a -> a -> a
<> if Bool -> Bool
not Bool
embedded Bool -> Bool -> Bool
&& Bool
isPtr
                               then Name -> Field -> Text
fieldClear Name
owner Field
field
                               else Text
"undefined"
    if Bool -> Bool
not Bool
embedded
      then do
          forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"attrTransfer _ v = do"
          forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e. Text -> Type -> CodeGen e ()
genFieldTransfer Text
"v" (Field -> Type
fieldType Field
field)
      else forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"attrTransfer = undefined"
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"dbgAttrInfo = P.Just (O.ResolvedSymbolInfo {"
    forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
      forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"O.resolvedSymbolName = \"" forall a. Semigroup a => a -> a -> a
<> Text
qualifiedAttrName forall a. Semigroup a => a -> a -> a
<> Text
"\""
      forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
", O.resolvedSymbolURL = \"" forall a. Semigroup a => a -> a -> a
<> Text
attrInfoURL forall a. Semigroup a => a -> a -> a
<> Text
"\""
      forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"})"

  forall e. CodeGen e ()
blank

  forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
    let labelProxy :: Text
labelProxy = Text -> Text
lcFirst Text
on forall a. Semigroup a => a -> a -> a
<> Text
"_" forall a. Semigroup a => a -> a -> a
<> Text -> Text
lcFirst (Field -> Text
fName Field
field)
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
labelProxy forall a. Semigroup a => a -> a -> a
<> Text
" :: AttrLabelProxy \"" forall a. Semigroup a => a -> a -> a
<> Text -> Text
lcFirst (Field -> Text
fName Field
field) forall a. Semigroup a => a -> a -> a
<> Text
"\""
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
labelProxy forall a. Semigroup a => a -> a -> a
<> Text
" = AttrLabelProxy"

    forall e. HaddockSection -> Text -> CodeGen e ()
export (NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
PropertySection forall a b. (a -> b) -> a -> b
$ Text -> Text
lcFirst forall a b. (a -> b) -> a -> b
$ Field -> Text
fName Field
field) Text
labelProxy

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"'(\"" forall a. Semigroup a => a -> a -> a
<> Field -> Text
labelName Field
field forall a. Semigroup a => a -> a -> a
<> Text
"\", " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
")"

-- | Build code for a single field.
buildFieldAttributes :: Name -> Field -> ExcCodeGen (Maybe Text)
buildFieldAttributes :: Name -> Field -> ExcCodeGen (Maybe Text)
buildFieldAttributes Name
n Field
field
    | Bool -> Bool
not (Field -> Bool
fieldVisible Field
field) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    | Type -> Bool
privateType (Field -> Type
fieldType Field
field) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    | Bool
otherwise = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do

     -- We don't generate bindings for private and class structs, so
     -- do not generate bindings for fields pointing to class structs
     -- either.
     Bool
ignored <- forall e. Type -> CodeGen e Bool
isIgnoredStructType (Field -> Type
fieldType Field
field)
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ignored forall a b. (a -> b) -> a -> b
$
      forall a. Text -> ExcCodeGen a
notImplementedError Text
"Field type is an unsupported struct type"

     Maybe Text
nullPtr <- forall e. Type -> CodeGen e (Maybe Text)
nullPtrForType (Field -> Type
fieldType Field
field)

     Bool
embedded <- Field -> ExcCodeGen Bool
isEmbedded Field
field

     forall e. HaddockSection -> Documentation -> CodeGen e ()
addSectionDocumentation HaddockSection
docSection (Field -> Documentation
fieldDocumentation Field
field)

     Name -> Field -> ExcCodeGen ()
buildFieldReader Name
n Field
field
     forall e. HaddockSection -> Text -> CodeGen e ()
export HaddockSection
docSection (Name -> Field -> Text
fieldGetter Name
n Field
field)

     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
embedded) forall a b. (a -> b) -> a -> b
$ do
         Name -> Field -> ExcCodeGen ()
buildFieldWriter Name
n Field
field
         forall e. HaddockSection -> Text -> CodeGen e ()
export HaddockSection
docSection (Name -> Field -> Text
fieldSetter Name
n Field
field)

         case Maybe Text
nullPtr of
           Just Text
null -> do
              Name -> Field -> Text -> ExcCodeGen ()
buildFieldClear Name
n Field
field Text
null
              forall e. HaddockSection -> Text -> CodeGen e ()
export HaddockSection
docSection (Name -> Field -> Text
fieldClear Name
n Field
field)
           Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

     forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf CPPGuard
CPPOverloading (Name
-> Field
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
genAttrInfo Name
n Field
field)

    where privateType :: Type -> Bool
          privateType :: Type -> Bool
privateType (TInterface Name
n) = Text
"Private" Text -> Text -> Bool
`T.isSuffixOf` Name -> Text
name Name
n
          privateType Type
_ = Bool
False

          docSection :: HaddockSection
docSection = NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
PropertySection forall a b. (a -> b) -> a -> b
$ Text -> Text
lcFirst forall a b. (a -> b) -> a -> b
$ Field -> Text
fName Field
field

-- | Generate code for the given list of fields.
genStructOrUnionFields :: Name -> [Field] -> CodeGen e ()
genStructOrUnionFields :: forall e. Name -> [Field] -> CodeGen e ()
genStructOrUnionFields Name
n [Field]
fields = do
  let name' :: Text
name' = Name -> Text
upperName Name
n

  [Maybe Text]
attrs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Field]
fields forall a b. (a -> b) -> a -> b
$ \Field
field ->
      forall e a. (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a
handleCGExc (\CGError
e -> do
                      forall e. Text -> CodeGen e ()
line (Text
"-- XXX Skipped attribute for \"" forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<>
                             Text
":" forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldName Field
field forall a. Semigroup a => a -> a -> a
<> Text
"\"")
                      forall e. CGError -> CodeGen e ()
printCGError CGError
e
                      forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
                  (Name -> Field -> ExcCodeGen (Maybe Text)
buildFieldAttributes Name
n Field
field)

  forall e. CodeGen e ()
blank

  forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf CPPGuard
CPPOverloading forall a b. (a -> b) -> a -> b
$ do
    let attrListName :: Text
attrListName = Text
name' forall a. Semigroup a => a -> a -> a
<> Text
"AttributeList"
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"instance O.HasAttributeList " forall a. Semigroup a => a -> a -> a
<> Text
name'
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type instance O.AttributeList " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
attrListName
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type " forall a. Semigroup a => a -> a -> a
<> Text
attrListName forall a. Semigroup a => a -> a -> a
<> Text
" = ('[ " forall a. Semigroup a => a -> a -> a
<>
         Text -> [Text] -> Text
T.intercalate Text
", " (forall a. [Maybe a] -> [a]
catMaybes [Maybe Text]
attrs) forall a. Semigroup a => a -> a -> a
<> Text
"] :: [(Symbol, DK.Type)])"

-- | Generate a constructor for a zero-filled struct/union of the given
-- type, using the boxed (or GLib, for unboxed types) allocator.
genZeroSU :: Name -> Int -> Bool -> CodeGen e ()
genZeroSU :: forall e. Name -> Int -> Bool -> CodeGen e ()
genZeroSU Name
n Int
size Bool
isBoxed = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
      let name :: Text
name = Name -> Text
upperName Name
n
      let builder :: Text
builder = Text
"newZero" forall a. Semigroup a => a -> a -> a
<> Text
name
          tsize :: Text
tsize = forall a. Show a => a -> Text
tshow Int
size

      forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Text
"Construct a `" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<>
                                     Text
"` struct initialized to zero.")

      forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
builder forall a. Semigroup a => a -> a -> a
<> Text
" :: MonadIO m => m " forall a. Semigroup a => a -> a -> a
<> Text
name
      forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
builder forall a. Semigroup a => a -> a -> a
<> Text
" = liftIO $ " forall a. Semigroup a => a -> a -> a
<>
           if Bool
isBoxed
           then Text
"callocBoxedBytes " forall a. Semigroup a => a -> a -> a
<> Text
tsize forall a. Semigroup a => a -> a -> a
<> Text
" >>= wrapBoxed " forall a. Semigroup a => a -> a -> a
<> Text
name
           else Text
"boxedPtrCalloc >>= wrapPtr " forall a. Semigroup a => a -> a -> a
<> Text
name
      forall e. Text -> CodeGen e ()
exportDecl Text
builder

      forall e. CodeGen e ()
blank

      -- Overloaded "new"
      forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
        forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"instance tag ~ 'AttrSet => Constructible " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" tag where"
        forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
           forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"new _ attrs = do"
           forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
              forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"o <- " forall a. Semigroup a => a -> a -> a
<> Text
builder
              forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"GI.Attributes.set o attrs"
              forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"return o"

-- | Specialization for structs of `genZeroSU`.
genZeroStruct :: Name -> Struct -> CodeGen e ()
genZeroStruct :: forall e. Name -> Struct -> CodeGen e ()
genZeroStruct Name
n Struct
s =
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AllocationInfo -> AllocationOp
allocCalloc (Struct -> AllocationInfo
structAllocationInfo Struct
s) forall a. Eq a => a -> a -> Bool
/= Text -> AllocationOp
AllocationOp Text
"none" Bool -> Bool -> Bool
&&
          Struct -> Int
structSize Struct
s forall a. Eq a => a -> a -> Bool
/= Int
0) forall a b. (a -> b) -> a -> b
$
    forall e. Name -> Int -> Bool -> CodeGen e ()
genZeroSU Name
n (Struct -> Int
structSize Struct
s) (Struct -> Bool
structIsBoxed Struct
s)

-- | Specialization for unions of `genZeroSU`.
genZeroUnion :: Name -> Union -> CodeGen e ()
genZeroUnion :: forall e. Name -> Union -> CodeGen e ()
genZeroUnion Name
n Union
u =
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AllocationInfo -> AllocationOp
allocCalloc (Union -> AllocationInfo
unionAllocationInfo Union
u ) forall a. Eq a => a -> a -> Bool
/= Text -> AllocationOp
AllocationOp Text
"none" Bool -> Bool -> Bool
&&
          Union -> Int
unionSize Union
u forall a. Eq a => a -> a -> Bool
/= Int
0) forall a b. (a -> b) -> a -> b
$
    forall e. Name -> Int -> Bool -> CodeGen e ()
genZeroSU Name
n (Union -> Int
unionSize Union
u) (Union -> Bool
unionIsBoxed Union
u)

-- | Construct a import with the given prefix.
prefixedForeignImport :: Text -> Text -> Text -> CodeGen e Text
prefixedForeignImport :: forall e. Text -> Text -> Text -> CodeGen e Text
prefixedForeignImport Text
prefix Text
symbol Text
prototype = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
  forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"foreign import ccall \"" forall a. Semigroup a => a -> a -> a
<> Text
symbol forall a. Semigroup a => a -> a -> a
<> Text
"\" " forall a. Semigroup a => a -> a -> a
<> Text
prefix forall a. Semigroup a => a -> a -> a
<> Text
symbol
           forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> Text
prototype
  forall (m :: * -> *) a. Monad m => a -> m a
return (Text
prefix forall a. Semigroup a => a -> a -> a
<> Text
symbol)

-- | Generate a GValue instance for @GBoxed@ objects.
genBoxedGValueInstance :: Name -> Text -> CodeGen e ()
genBoxedGValueInstance :: forall e. Name -> Text -> CodeGen e ()
genBoxedGValueInstance Name
n Text
get_type_fn = do
  let name' :: Text
name' = Name -> Text
upperName Name
n
      doc :: Text
doc = Text
"Convert '" forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
"' to and from 'Data.GI.Base.GValue.GValue'. See 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'."

  forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol Text
doc

  forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
    forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"instance B.GValue.IsGValue (Maybe " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
") where"
    forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
      forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"gvalueGType_ = " forall a. Semigroup a => a -> a -> a
<> Text
get_type_fn
      forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"gvalueSet_ gv P.Nothing = B.GValue.set_boxed gv (FP.nullPtr :: FP.Ptr " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
")"
      forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"gvalueSet_ gv (P.Just obj) = B.ManagedPtr.withManagedPtr obj (B.GValue.set_boxed gv)"
      forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"gvalueGet_ gv = do"
      forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
        forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"ptr <- B.GValue.get_boxed gv :: IO (Ptr " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
")"
        forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"if ptr /= FP.nullPtr"
        forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"then P.Just <$> B.ManagedPtr.newBoxed " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" ptr"
        forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"else return P.Nothing"

-- | Allocation and deallocation for types registered as `GBoxed` in
-- the GLib type system.
genBoxed :: Name -> Text -> CodeGen e ()
genBoxed :: forall e. Name -> Text -> CodeGen e ()
genBoxed Name
n Text
typeInit = do
  let name' :: Text
name' = Name -> Text
upperName Name
n
      get_type_fn :: Text
get_type_fn = Text
"c_" forall a. Semigroup a => a -> a -> a
<> Text
typeInit

  forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"foreign import ccall \"" forall a. Semigroup a => a -> a -> a
<> Text
typeInit forall a. Semigroup a => a -> a -> a
<> Text
"\" " forall a. Semigroup a => a -> a -> a
<>
            Text
get_type_fn forall a. Semigroup a => a -> a -> a
<> Text
" :: "
    forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e. Text -> CodeGen e ()
line Text
"IO GType"

  forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
    forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type instance O.ParentTypes " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" = '[]"
    forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"instance O.HasParentTypes " forall a. Semigroup a => a -> a -> a
<> Text
name'

  forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
    forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"instance B.Types.TypedObject " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" where"
    forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"glibType = " forall a. Semigroup a => a -> a -> a
<> Text
get_type_fn

  forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
    forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"instance B.Types.GBoxed " forall a. Semigroup a => a -> a -> a
<> Text
name'

  forall e. Name -> Text -> CodeGen e ()
genBoxedGValueInstance Name
n Text
get_type_fn

-- | Generate the typeclass with information for how to
-- allocate/deallocate a given type which is not a `GBoxed`.
genWrappedPtr :: Name -> AllocationInfo -> Int -> CodeGen e ()
genWrappedPtr :: forall e. Name -> AllocationInfo -> Int -> CodeGen e ()
genWrappedPtr Name
n AllocationInfo
info Int
size = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
  let prefix :: Text -> Text
prefix = \Text
op -> Text
"_" forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
"_" forall a. Semigroup a => a -> a -> a
<> Text
op forall a. Semigroup a => a -> a -> a
<> Text
"_"

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
size forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& AllocationInfo -> AllocationOp
allocFree AllocationInfo
info forall a. Eq a => a -> a -> Bool
== AllocationOp
AllocationOpUnknown) forall a b. (a -> b) -> a -> b
$
       forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"-- XXX Wrapping a foreign struct/union with no known destructor or size, leak?"

  Text
copy <- case AllocationInfo -> AllocationOp
allocCopy AllocationInfo
info of
            AllocationOp Text
op -> do
                Text
copy <- forall e. Text -> Text -> Text -> CodeGen e Text
prefixedForeignImport (Text -> Text
prefix Text
"copy") Text
op Text
"Ptr a -> IO (Ptr a)"
                forall (m :: * -> *) a. Monad m => a -> m a
return (Text
"\\p -> B.ManagedPtr.withManagedPtr p (" forall a. Semigroup a => a -> a -> a
<> Text
copy forall a. Semigroup a => a -> a -> a
<>
                        Text
" >=> B.ManagedPtr.wrapPtr " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
")")
            AllocationOp
AllocationOpUnknown ->
                if Int
size forall a. Ord a => a -> a -> Bool
> Int
0
                then forall (m :: * -> *) a. Monad m => a -> m a
return (Text
"\\p -> B.ManagedPtr.withManagedPtr p (copyBytes "
                              forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Int
size forall a. Semigroup a => a -> a -> a
<>
                              Text
" >=> B.ManagedPtr.wrapPtr " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
")")
                else forall (m :: * -> *) a. Monad m => a -> m a
return Text
"return"

  Text
free <- case AllocationInfo -> AllocationOp
allocFree AllocationInfo
info of
            AllocationOp Text
op -> do
              Text
free <- forall e. Text -> Text -> Text -> CodeGen e Text
prefixedForeignImport (Text -> Text
prefix Text
"free") Text
op Text
"Ptr a -> IO ()"
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"\\p -> B.ManagedPtr.withManagedPtr p " forall a. Semigroup a => a -> a -> a
<> Text
free
            AllocationOp
AllocationOpUnknown ->
                if Int
size forall a. Ord a => a -> a -> Bool
> Int
0
                then forall (m :: * -> *) a. Monad m => a -> m a
return Text
"\\x -> SP.withManagedPtr x SP.freeMem"
                else forall (m :: * -> *) a. Monad m => a -> m a
return Text
"\\_x -> return ()"

  forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"instance BoxedPtr " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" where"
  forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
      forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"boxedPtrCopy = " forall a. Semigroup a => a -> a -> a
<> Text
copy
      forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"boxedPtrFree = " forall a. Semigroup a => a -> a -> a
<> Text
free

  case AllocationInfo -> AllocationOp
allocCalloc AllocationInfo
info of
    AllocationOp Text
"none" -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    AllocationOp Text
op -> do
      Text
calloc <- forall e. Text -> Text -> Text -> CodeGen e Text
prefixedForeignImport (Text -> Text
prefix Text
"calloc") Text
op Text
"IO (Ptr a)"
      forall e. Text -> CodeGen e ()
callocInstance Text
calloc
    AllocationOp
AllocationOpUnknown ->
      if Int
size forall a. Ord a => a -> a -> Bool
> Int
0
      then do
        let calloc :: Text
calloc = Text
"callocBytes " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Int
size
        forall e. Text -> CodeGen e ()
callocInstance Text
calloc
      else forall (m :: * -> *) a. Monad m => a -> m a
return ()

  where name' :: Text
name' = Name -> Text
upperName Name
n

        callocInstance :: Text -> CodeGen e ()
        callocInstance :: forall e. Text -> CodeGen e ()
callocInstance Text
calloc = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
          forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"instance CallocPtr " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" where"
          forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
            forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"boxedPtrCalloc = " forall a. Semigroup a => a -> a -> a
<> Text
calloc