-- | 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.SymbolNaming (upperName, lowerName,
                                     underscoresToCamelCase,
                                     qualifiedSymbol,
                                     callbackHaskellToForeign,
                                     callbackWrapperAllocator)

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 = (Maybe Name -> Bool
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Struct -> Bool
structForceVisible Struct
s)

-- | Whether the given type corresponds to an ignored struct.
isIgnoredStructType :: Type -> CodeGen Bool
isIgnoredStructType :: Type -> CodeGen Bool
isIgnoredStructType Type
t =
  case Type
t of
    TInterface Name
n -> do
      API
api <- HasCallStack => Type -> CodeGen API
Type -> CodeGen API
getAPI Type
t
      case API
api of
        APIStruct Struct
s -> Bool -> BaseCodeGen e Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Struct -> Bool
ignoreStruct Name
n Struct
s)
        API
_ -> Bool -> BaseCodeGen e Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Type
_ -> Bool -> BaseCodeGen e Bool
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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> Text
underscoresToCamelCase (Text -> Text) -> (Field -> Text) -> Field -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Text
fieldName) Field
field Text -> Text -> Text
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 = (Field -> Field) -> [Field] -> [Field]
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 (Struct -> API) -> Struct -> API
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 =
        (Field -> Maybe (Name, API)) -> [Field] -> [(Name, API)]
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
                    (Name, API) -> Maybe (Name, API)
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 Text
infoType :: Name -> Field -> CodeGen Text
infoType Name
owner Field
field = do
  let name :: Text
name = Name -> Text
upperName Name
owner
  let fName :: Text
fName = (Text -> Text
underscoresToCamelCase (Text -> Text) -> (Field -> Text) -> Field -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Text
fieldName) Field
field
  Text -> BaseCodeGen e Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> BaseCodeGen e Text) -> Text -> BaseCodeGen e Text
forall a b. (a -> b) -> a -> b
$ Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fName Text -> Text -> Text
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 <- HasCallStack => Type -> CodeGen (Maybe API)
Type -> CodeGen (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
_ -> Bool -> ExcCodeGen Bool
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 -> Text -> ExcCodeGen Bool
forall a. Text -> ExcCodeGen a
badIntroError Text
"Cannot determine whether the field is embedded."
      Just Bool
isPtr -> Bool -> ExcCodeGen Bool
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" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
upperName Name
name' Text -> Text -> Text
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 “@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldName Field
field Text -> Text -> Text
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' " 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
<> Text
" #" Text -> Text -> 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 = ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
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 Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
                 else Type -> CodeGen (Maybe Text)
maybeNullConvert (Field -> Type
fieldType Field
field)
  Text
hType <- TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
nullConvert
                        then TypeRep -> TypeRep
maybeT (TypeRep -> TypeRep)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
isoHaskellType (Field -> Type
fieldType Field
field)
                        else Type -> CodeGen TypeRep
isoHaskellType (Field -> Type
fieldType Field
field)
  Text
fType <- TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
foreignType (Field -> Type
fieldType Field
field)

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

  Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
getter Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: MonadIO m => " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> m " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
              if (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Text
hType
              then Text -> Text
parenthesize Text
hType
              else Text
hType
  Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
getter Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" s = liftIO $ withManagedPtr s $ \\ptr -> do"
  ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
    let peekedType :: Text
peekedType = if (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Text
fType
                     then Text -> Text
parenthesize Text
fType
                     else Text
fType
    if Bool
embedded
    then Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"let val = ptr `plusPtr` " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Field -> Int
fieldOffset Field
field)
             Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
peekedType
    else Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"val <- peek (ptr `plusPtr` " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Field -> Int
fieldOffset Field
field)
             Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") :: IO " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
peekedType
    Text
result <- case Maybe Text
nullConvert of
              Maybe Text
Nothing -> Text
-> BaseCodeGen CGError Converter
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall e. Text -> BaseCodeGen e Converter -> BaseCodeGen e Text
convert Text
"val" (BaseCodeGen CGError Converter
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text)
-> BaseCodeGen CGError Converter
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall a b. (a -> b) -> a -> b
$ Type -> Transfer -> BaseCodeGen CGError Converter
fToH (Field -> Type
fieldType Field
field) Transfer
TransferNothing
              Just Text
nullConverter -> do
                Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"result <- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nullConverter Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" val $ \\val' -> do"
                ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
                  Text
val' <- Text
-> BaseCodeGen CGError Converter
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall e. Text -> BaseCodeGen e Converter -> BaseCodeGen e Text
convert Text
"val'" (BaseCodeGen CGError Converter
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text)
-> BaseCodeGen CGError Converter
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall a b. (a -> b) -> a -> b
$ Type -> Transfer -> BaseCodeGen CGError Converter
fToH (Field -> Type
fieldType Field
field) Transfer
TransferNothing
                  Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"return " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
val'
                Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"result"
    Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"return " Text -> Text -> Text
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" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
upperName Name
name' Text -> Text -> Text
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 “@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldName Field
field Text -> Text -> Text
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' " 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
<> Text
" [ #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
labelName Field
field
    Text -> Text -> Text
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 = ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
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 <- Type -> CodeGen Bool
typeIsPtr (Field -> Type
fieldType Field
field)

  Text
fType <- TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
foreignType (Field -> Type
fieldType Field
field)
  Text
hType <- if Bool
isPtr
           then Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
fType
           else TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
haskellType (Field -> Type
fieldType Field
field)

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

  Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
setter Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: MonadIO m => " 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 -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> m ()"
  Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
setter Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" s val = liftIO $ withManagedPtr s $ \\ptr -> do"
  ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
    Text
converted <- if Bool
isPtr
                 then Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"val"
                 else Text
-> BaseCodeGen CGError Converter
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall e. Text -> BaseCodeGen e Converter -> BaseCodeGen e Text
convert Text
"val" (BaseCodeGen CGError Converter
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text)
-> BaseCodeGen CGError Converter
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall a b. (a -> b) -> a -> b
$ Type -> Transfer -> BaseCodeGen CGError Converter
hToF (Field -> Type
fieldType Field
field) Transfer
TransferNothing
    Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"poke (ptr `plusPtr` " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Field -> Int
fieldOffset Field
field)
         Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
converted Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fType Text -> Text -> Text
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" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
upperName Name
name' Text -> Text -> Text
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 “@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldName Field
field Text -> Text -> Text
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'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" #" Text -> Text -> 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 = ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
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 (TypeRep -> Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
foreignType (Field -> Type
fieldType Field
field)

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

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

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

-- | The types accepted by the allocating set function
-- 'Data.GI.Base.Attributes.(:&=)'.
fieldTransferTypeConstraint :: Type -> CodeGen Text
fieldTransferTypeConstraint :: Type -> CodeGen Text
fieldTransferTypeConstraint Type
t = do
  Bool
isPtr <- Type -> CodeGen Bool
typeIsPtr Type
t
  Bool
isRegularCallback <- Type -> CodeGen Bool
isRegularCallback Type
t
  Text
inType <- if Bool
isPtr Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isRegularCallback
            then TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) TypeRep
-> BaseCodeGen e Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
foreignType Type
t
            else TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) TypeRep
-> BaseCodeGen e Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
isoHaskellType Type
t
  Text -> BaseCodeGen e Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> BaseCodeGen e Text) -> Text -> BaseCodeGen e Text
forall a b. (a -> b) -> a -> b
$ Text
"(~)" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
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 Text
fieldTransferType :: Type -> CodeGen Text
fieldTransferType Type
t = do
  Bool
isPtr <- Type -> CodeGen Bool
typeIsPtr Type
t
  Text
inType <- if Bool
isPtr
            then TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) TypeRep
-> BaseCodeGen e Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
foreignType Type
t
            else TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) TypeRep
-> BaseCodeGen e Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
haskellType Type
t
  Text -> BaseCodeGen e Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> BaseCodeGen e Text) -> Text -> BaseCodeGen e Text
forall a b. (a -> b) -> a -> b
$ if (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
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 ()
genFieldTransfer :: Text -> Type -> CodeGen ()
genFieldTransfer Text
var t :: Type
t@(TInterface tn :: Name
tn@(Name Text
_ Text
n)) = do
  Bool
isRegularCallback <- Type -> CodeGen Bool
isRegularCallback Type
t
  if Bool
isRegularCallback
    then do
      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 -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
maker Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " 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
" Nothing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
var)
    else Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"return " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
var
genFieldTransfer Text
var Type
_ = Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"return " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
var

-- | Haskell name for the field
fName :: Field -> Text
fName :: Field -> Text
fName = Text -> Text
underscoresToCamelCase (Text -> Text) -> (Field -> Text) -> Field -> Text
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  (Text -> Text) -> (Field -> Text) -> Field -> Text
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 <- Name -> Field -> CodeGen Text
infoType Name
owner Field
field
  let on :: Text
on = Name -> Text
upperName Name
owner

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

  Bool
embedded <- Field -> ExcCodeGen Bool
isEmbedded Field
field
  Bool
isNullable <- Type -> CodeGen Bool
typeIsNullable (Field -> Type
fieldType Field
field)
  Text
outType <- TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
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 (TypeRep -> TypeRep)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
isoHaskellType (Field -> Type
fieldType Field
field)
                          else Type -> CodeGen TypeRep
isoHaskellType (Field -> Type
fieldType Field
field)
  Text
inType <- if Bool
isPtr
            then TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
foreignType (Field -> Type
fieldType Field
field)
            else TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
haskellType (Field -> Type
fieldType Field
field)
  Text
transferType <- Type -> CodeGen Text
fieldTransferType (Field -> Type
fieldType Field
field)
  Text
transferConstraint <- Type -> CodeGen Text
fieldTransferTypeConstraint (Field -> Type
fieldType Field
field)

  Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"data " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it
  Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"instance AttrInfo " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where"
  ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"type AttrBaseTypeConstraint " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = (~) " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
on
    Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"type AttrAllowedOps " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
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]"
    Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"type AttrSetTypeConstraint " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = (~) "
             Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Text
inType
                then Text -> Text
parenthesize Text
inType
                else Text
inType
    Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"type AttrTransferTypeConstraint " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
transferConstraint
    Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"type AttrTransferType " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
transferType
    Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"type AttrGetType " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
outType
    Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"type AttrLabel " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldName Field
field Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
    Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"type AttrOrigin " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
on
    Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"attrGet = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Field -> Text
fieldGetter Name
owner Field
field
    Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"attrSet = " Text -> Text -> Text
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"
    Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"attrConstruct = undefined"
    Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"attrClear = " Text -> Text -> Text
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
          Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"attrTransfer _ v = do"
          ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text -> Type -> CodeGen ()
genFieldTransfer Text
"v" (Field -> Type
fieldType Field
field)
      else Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"attrTransfer = undefined"

  ExcCodeGen ()
CodeGen ()
blank

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

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

  Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall a b. (a -> b) -> a -> b
$ Text
"'(\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
labelName Field
field Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

-- | Build code for a single field.
buildFieldAttributes :: Name -> Field -> ExcCodeGen (Maybe Text)
buildFieldAttributes :: Name
-> Field
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Text)
buildFieldAttributes Name
n Field
field
    | Bool -> Bool
not (Field -> Bool
fieldVisible Field
field) = Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
    | Type -> Bool
privateType (Field -> Type
fieldType Field
field) = Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
    | Bool
otherwise = ReaderT
  CodeGenConfig
  (StateT (CGState, ModuleInfo) (Except CGError))
  (Maybe Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Text)
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (ReaderT
   CodeGenConfig
   (StateT (CGState, ModuleInfo) (Except CGError))
   (Maybe Text)
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except CGError))
      (Maybe Text))
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Text)
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 <- Type -> CodeGen Bool
isIgnoredStructType (Field -> Type
fieldType Field
field)
     Bool -> ExcCodeGen () -> ExcCodeGen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ignored (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$
      Text -> ExcCodeGen ()
forall a. Text -> ExcCodeGen a
notImplementedError Text
"Field type is an unsupported struct type"

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

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

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

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

     Bool -> ExcCodeGen () -> ExcCodeGen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
embedded) (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
         Name -> Field -> ExcCodeGen ()
buildFieldWriter Name
n Field
field
         HaddockSection -> Text -> CodeGen ()
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
              HaddockSection -> Text -> CodeGen ()
export HaddockSection
docSection (Name -> Field -> Text
fieldClear Name
n Field
field)
           Maybe Text
Nothing -> () -> ExcCodeGen ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

     Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CPPGuard
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall e a. CPPGuard -> BaseCodeGen e a -> BaseCodeGen 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 (Text -> HaddockSection) -> Text -> HaddockSection
forall a b. (a -> b) -> a -> b
$ Text -> Text
lcFirst (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Field -> Text
fName Field
field

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

  [Maybe Text]
attrs <- [Field]
-> (Field
    -> ReaderT
         CodeGenConfig
         (StateT (CGState, ModuleInfo) (Except e))
         (Maybe Text))
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     [Maybe Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Field]
fields ((Field
  -> ReaderT
       CodeGenConfig
       (StateT (CGState, ModuleInfo) (Except e))
       (Maybe Text))
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except e))
      [Maybe Text])
-> (Field
    -> ReaderT
         CodeGenConfig
         (StateT (CGState, ModuleInfo) (Except e))
         (Maybe Text))
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     [Maybe Text]
forall a b. (a -> b) -> a -> b
$ \Field
field ->
      (CGError -> CodeGen (Maybe Text))
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Text)
-> CodeGen (Maybe Text)
forall a. (CGError -> CodeGen a) -> ExcCodeGen a -> CodeGen a
handleCGExc (\CGError
e -> do
                      Text -> CodeGen ()
line (Text
"-- XXX Skipped attribute for \"" 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 -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldName Field
field Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"")
                      CGError -> CodeGen ()
printCGError CGError
e
                      Maybe Text -> BaseCodeGen e (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing)
                  (Name
-> Field
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Text)
buildFieldAttributes Name
n Field
field)

  BaseCodeGen e ()
CodeGen ()
blank

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

-- | 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 ()
genZeroSU :: Name -> Int -> Bool -> CodeGen ()
genZeroSU Name
n Int
size Bool
isBoxed = 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
      let name :: Text
name = Name -> Text
upperName Name
n
      let builder :: Text
builder = Text
"newZero" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
          tsize :: Text
tsize = Int -> Text
forall a. Show a => a -> Text
tshow Int
size

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

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

      BaseCodeGen e ()
CodeGen ()
blank

      -- Overloaded "new"
      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 -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"instance tag ~ 'AttrSet => Constructible " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" tag where"
        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 -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"new _ attrs = 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
              Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"o <- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
builder
              Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"GI.Attributes.set o attrs"
              Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"return o"

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

-- | Specialization for unions of `genZeroSU`.
genZeroUnion :: Name -> Union -> CodeGen ()
genZeroUnion :: Name -> Union -> CodeGen ()
genZeroUnion Name
n Union
u =
    Bool
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AllocationInfo -> AllocationOp
allocCalloc (Union -> AllocationInfo
unionAllocationInfo Union
u ) AllocationOp -> AllocationOp -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> AllocationOp
AllocationOp Text
"none" Bool -> Bool -> Bool
&&
          Union -> Int
unionSize Union
u Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$
    Name -> Int -> Bool -> CodeGen ()
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 Text
prefixedForeignImport :: Text -> Text -> Text -> CodeGen Text
prefixedForeignImport Text
prefix Text
symbol Text
prototype = BaseCodeGen e Text -> BaseCodeGen e Text
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e Text -> BaseCodeGen e Text)
-> BaseCodeGen e Text -> BaseCodeGen e Text
forall a b. (a -> b) -> a -> b
$ do
  Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"foreign import ccall \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
symbol Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
symbol
           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
prototype
  Text -> BaseCodeGen e Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
symbol)

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

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

  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 -> CodeGen ()
bline (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"instance B.GValue.IsGValue " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where"
    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
$ 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 -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"toGValue o = 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
$ 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 -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"gtype <- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
get_type_fn
        Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"B.ManagedPtr.withManagedPtr o (B.GValue.buildGValue gtype B.GValue.set_boxed)"
      Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"fromGValue gv = 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
$ 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 -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"ptr <- B.GValue.get_boxed gv :: IO (Ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
        Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"B.ManagedPtr.newBoxed " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ptr"

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

  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 -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"foreign import ccall \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
typeInit Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
            Text
get_type_fn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: "
    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
$ Text -> CodeGen ()
line Text
"IO GType"

  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 -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"type instance O.ParentTypes " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = '[]"
    Text -> CodeGen ()
bline (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"instance O.HasParentTypes " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name'

  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 -> CodeGen ()
bline (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"instance B.Types.TypedObject " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where"
    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
$ Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"glibType = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
get_type_fn

  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 -> CodeGen ()
bline (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"instance B.Types.GBoxed " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name'

  Name -> Text -> CodeGen ()
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 ()
genWrappedPtr :: Name -> AllocationInfo -> Int -> CodeGen ()
genWrappedPtr Name
n AllocationInfo
info Int
size = 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
  let prefix :: Text -> Text
prefix = \Text
op -> Text
"_" 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 -> Text
forall a. Semigroup a => a -> a -> a
<> Text
op Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_"

  Bool -> BaseCodeGen e () -> BaseCodeGen e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
size Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& AllocationInfo -> AllocationOp
allocFree AllocationInfo
info AllocationOp -> AllocationOp -> Bool
forall a. Eq a => a -> a -> Bool
== AllocationOp
AllocationOpUnknown) (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$
       Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
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 <- Text -> Text -> Text -> CodeGen Text
prefixedForeignImport (Text -> Text
prefix Text
"copy") Text
op Text
"Ptr a -> IO (Ptr a)"
                Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
"\\p -> B.ManagedPtr.withManagedPtr p (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
copy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                        Text
" >=> B.ManagedPtr.wrapPtr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
            AllocationOp
AllocationOpUnknown ->
                if Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                then Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
"\\p -> B.ManagedPtr.withManagedPtr p (copyBytes "
                              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
size Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                              Text
" >=> B.ManagedPtr.wrapPtr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
                else Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
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 <- Text -> Text -> Text -> CodeGen Text
prefixedForeignImport (Text -> Text
prefix Text
"free") Text
op Text
"Ptr a -> IO ()"
              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
"\\p -> B.ManagedPtr.withManagedPtr p " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
free
            AllocationOp
AllocationOpUnknown ->
                if Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                then Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"\\x -> SP.withManagedPtr x SP.freeMem"
                else Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"\\_x -> return ()"

  Text -> CodeGen ()
bline (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"instance BoxedPtr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where"
  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 -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"boxedPtrCopy = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
copy
      Text -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"boxedPtrFree = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
free

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

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

        callocInstance :: Text -> CodeGen()
        callocInstance :: Text -> CodeGen ()
callocInstance Text
calloc = 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 -> CodeGen ()
bline (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"instance CallocPtr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where"
          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 -> CodeGen ()
line (Text -> CodeGen ()) -> Text -> CodeGen ()
forall a b. (a -> b) -> a -> b
$ Text
"boxedPtrCalloc = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
calloc