-- | 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 = (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 e Bool
isIgnoredStructType :: forall e. Type -> CodeGen e Bool
isIgnoredStructType Type
t =
  case Type
t of
    TInterface Name
n -> do
      api <- Type -> CodeGen e API
forall e. HasCallStack => Type -> CodeGen e API
getAPI Type
t
      case api of
        APIStruct Struct
s -> Bool -> CodeGen e Bool
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Struct -> Bool
ignoreStruct Name
n Struct
s)
        API
_ -> Bool -> CodeGen e Bool
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Type
_ -> Bool -> CodeGen e Bool
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | 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 = 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 = TInterface (Name ns 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 <- Field -> Maybe Callback
fieldCallback Field
field
                    let n' = Text -> Field -> Text
fieldCallbackType Text
structName Field
field
                    return (Name ns n', APICallback 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 (Text -> Text) -> (Field -> Text) -> Field -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Text
fieldName) Field
field
  Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
 -> 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
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
  api <- Type -> CodeGen CGError (Maybe API)
forall e. HasCallStack => Type -> CodeGen e (Maybe API)
findAPI (Field -> Type
fieldType Field
field)
  case api of
    Just (APIStruct Struct
_) -> ExcCodeGen Bool
checkEmbedding
    Just (APIUnion Union
_) -> ExcCodeGen Bool
checkEmbedding
    Maybe API
_ -> Bool -> ExcCodeGen Bool
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
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 a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
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. CodeGen e a -> CodeGen 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

  embedded <- Field -> ExcCodeGen Bool
isEmbedded Field
field
  nullConvert <- if embedded
                 then return Nothing
                 else maybeNullConvert (fieldType field)
  hType <- typeShow <$> if isJust nullConvert
                        then maybeT <$> isoHaskellType (fieldType field)
                        else isoHaskellType (fieldType field)
  fType <- typeShow <$> foreignType (fieldType field)

  writeHaddock DocBeforeSymbol (getterDoc n field)

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

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

  fType <- typeShow <$> foreignType (fieldType field)
  hType <- if isPtr
           then return fType
           else typeShow <$> haskellType (fieldType field)

  writeHaddock DocBeforeSymbol (setterDoc n field)

  line $ setter <> " :: MonadIO m => " <> name' <> " -> "
           <> hType <> " -> m ()"
  line $ setter <> " s val = liftIO $ withManagedPtr s $ \\ptr -> do"
  indent $ do
    converted <- if isPtr
                 then return "val"
                 else convert "val" $ hToF (fieldType field) TransferNothing
    line $ "poke (ptr `plusPtr` " <> tshow (fieldOffset field)
         <> ") (" <> converted <> " :: " <> fType <> ")"

-- | 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. CodeGen e a -> CodeGen 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

  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
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
forall e. Type -> CodeGen e TypeRep
foreignType (Field -> Type
fieldType Field
field)

  writeHaddock DocBeforeSymbol (clearDoc field)

  line $ clear <> " :: MonadIO m => " <> name' <> " -> m ()"
  line $ clear <> " s = liftIO $ withManagedPtr s $ \\ptr -> do"
  indent $
    line $ "poke (ptr `plusPtr` " <> tshow (fieldOffset field)
         <> ") ("  <> nullPtr <> " :: " <> fType <> ")"

-- | 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 <- Type -> CodeGen e API
forall e. HasCallStack => Type -> CodeGen e API
getAPI Type
t
  case api of
    APICallback callback :: Callback
callback@(Callback {cbCallable :: Callback -> Callable
cbCallable = Callable
callable}) ->
      if Callable -> Bool
callableThrows Callable
callable
      then Maybe Callback
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Callback)
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Callback
forall a. Maybe a
Nothing
      else Maybe Callback
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Callback)
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Callback -> Maybe Callback
forall a. a -> Maybe a
Just Callback
callback)
    API
_ -> Maybe Callback
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Callback)
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Callback
forall a. Maybe a
Nothing
isRegularCallback Type
_ = Maybe Callback
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Callback)
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Callback
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
  isPtr <- Type -> CodeGen e Bool
forall e. Type -> CodeGen e Bool
typeIsPtr Type
t
  maybeRegularCallback <- isRegularCallback t
  inType <- if isPtr && not (isJust maybeRegularCallback)
            then typeShow <$> foreignType t
            else typeShow <$> isoHaskellType t
  return $ "(~)" <> if T.any (== ' ') inType
                    then parenthesize inType
                    else 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
  isPtr <- Type -> CodeGen e Bool
forall e. Type -> CodeGen e Bool
typeIsPtr Type
t
  inType <- if isPtr
            then typeShow <$> foreignType t
            else typeShow <$> haskellType t
  return $ if T.any (== ' ') inType
           then parenthesize inType
           else 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
  maybeRegularCallback <- Type -> CodeGen e (Maybe Callback)
forall e. Type -> CodeGen e (Maybe Callback)
isRegularCallback Type
t
  case maybeRegularCallback of
    Just Callback
callback -> do
      let Name Text
_ Text
name' = API -> Name -> Name
normalizedAPIName (Callback -> API
APICallback Callback
callback) Name
tn
      wrapper <- Text -> Name -> CodeGen e Text
forall e. Text -> Name -> CodeGen e Text
qualifiedSymbol (Text -> Text
callbackHaskellToForeign Text
name') Name
tn
      maker <- qualifiedSymbol (callbackWrapperAllocator name') tn
      line $ maker <> " " <>
        parenthesize (wrapper <> " Nothing " <> var)
    Maybe Callback
Nothing -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. Text -> CodeGen e ()
line (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
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
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. Text -> CodeGen e ()
line (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
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
  it <- Name
-> Field
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
forall e. Name -> Field -> CodeGen e Text
infoType Name
owner Field
field
  let on = Name -> Text
upperName Name
owner

  isPtr <- typeIsPtr (fieldType field)

  embedded <- isEmbedded field
  isNullable <- typeIsNullable (fieldType field)
  outType <- typeShow <$> if not embedded && isNullable
                          then maybeT <$> isoHaskellType (fieldType field)
                          else isoHaskellType (fieldType field)
  inType <- if isPtr
            then typeShow <$> foreignType (fieldType field)
            else typeShow <$> haskellType (fieldType field)
  transferType <- fieldTransferType (fieldType field)
  transferConstraint <- fieldTransferTypeConstraint (fieldType field)

  api <- findAPIByName owner
  hackageLink <- hackageModuleLink owner
  let qualifiedAttrName = ModulePath -> Text
dotModulePath (Name -> API -> ModulePath
moduleLocation Name
owner API
api)
                          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
      attrInfoURL = Text
hackageLink Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
haddockAttrAnchor Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Field -> Text
labelName Field
field

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

  blank

  group $ do
    let 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)
    line $ labelProxy <> " :: AttrLabelProxy \"" <> lcFirst (fName field) <> "\""
    line $ labelProxy <> " = AttrLabelProxy"

    export (NamedSubsection PropertySection $ lcFirst $ fName field) labelProxy

  return $ "'(\"" <> labelName field <> "\", " <> it <> ")"

-- | 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 a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
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 a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
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. CodeGen e a -> CodeGen 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.
     ignored <- Type -> ExcCodeGen Bool
forall e. Type -> CodeGen e Bool
isIgnoredStructType (Field -> Type
fieldType Field
field)
     when ignored $
      notImplementedError "Field type is an unsupported struct type"

     nullPtr <- nullPtrForType (fieldType field)

     embedded <- isEmbedded field

     addSectionDocumentation docSection (fieldDocumentation field)

     buildFieldReader n field
     export docSection (fieldGetter n field)

     when (not embedded) $ do
         buildFieldWriter n field
         export docSection (fieldSetter n field)

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

     Just <$> cppIf CPPOverloading (genAttrInfo n 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 e ()
genStructOrUnionFields :: forall e. Name -> [Field] -> CodeGen e ()
genStructOrUnionFields Name
n [Field]
fields = do
  let name' :: Text
name' = Name -> Text
upperName Name
n

  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
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except e))
      (Maybe Text))
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall e a. (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a
handleCGExc (\CGError
e -> do
                      Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
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 e ()
forall e. CGError -> CodeGen e ()
printCGError CGError
e
                      Maybe Text
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe Text)
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing)
                  (Name
-> Field
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     (Maybe Text)
buildFieldAttributes Name
n Field
field)

  blank

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

      CodeGen e ()
forall e. CodeGen e ()
blank

      -- Overloaded "new"
      CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
group (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
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"
        CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
indent (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
           Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"new _ attrs = do"
           CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
indent (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
              Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"o <- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
builder
              Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"GI.Attributes.set o attrs"
              Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
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 =
    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
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
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 =
    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
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
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 = CodeGen e Text -> CodeGen e Text
forall e a. CodeGen e a -> CodeGen e a
group (CodeGen e Text -> CodeGen e Text)
-> CodeGen e Text -> CodeGen e Text
forall a b. (a -> b) -> a -> b
$ do
  Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"foreign import ccall \"" 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 -> CodeGen e Text
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
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 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 '" 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'. See 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'."

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

  CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
group (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
bline (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"instance B.GValue.IsGValue (Maybe " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") where"
    CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
indent (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
group (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"gvalueGType_ = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
get_type_fn
      Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"gvalueSet_ gv P.Nothing = B.GValue.set_boxed gv (FP.nullPtr :: FP.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 e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"gvalueSet_ gv (P.Just obj) = B.ManagedPtr.withManagedPtr obj (B.GValue.set_boxed gv)"
      Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"gvalueGet_ gv = do"
      CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
indent (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
group (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
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 e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"if ptr /= FP.nullPtr"
        Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"then P.Just <$> 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"
        Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
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_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
typeInit

  CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
group (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"foreign import ccall \"" 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
" :: "
    CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
indent (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line Text
"IO GType"

  CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
group (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
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 e ()
forall e. Text -> CodeGen e ()
bline (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"instance O.HasParentTypes " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name'

  CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
group (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
bline (Text -> CodeGen e ()) -> Text -> CodeGen e ()
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"
    CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
indent (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"glibType = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
get_type_fn

  CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
group (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
bline (Text -> CodeGen e ()) -> Text -> CodeGen e ()
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 e ()
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 = CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
group (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
  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 -> CodeGen e () -> CodeGen 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) (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$
       Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"-- XXX Wrapping a foreign struct/union with no known destructor or size, leak?"

  copy <- case AllocationInfo -> AllocationOp
allocCopy AllocationInfo
info of
            AllocationOp Text
op -> do
                copy <- Text
-> Text
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall e. Text -> Text -> Text -> CodeGen e Text
prefixedForeignImport (Text -> Text
prefix Text
"copy") Text
op Text
"Ptr a -> IO (Ptr a)"
                return ("\\p -> B.ManagedPtr.withManagedPtr p (" <> copy <>
                        " >=> B.ManagedPtr.wrapPtr " <> name' <> ")")
            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 a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
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 a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"return"

  free <- case allocFree info of
            AllocationOp Text
op -> do
              free <- Text
-> Text
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall e. Text -> Text -> Text -> CodeGen e Text
prefixedForeignImport (Text -> Text
prefix Text
"free") Text
op Text
"Ptr a -> IO ()"
              return $ "\\p -> B.ManagedPtr.withManagedPtr p " <> 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 a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
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 a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"\\_x -> return ()"

  bline $ "instance BoxedPtr " <> name' <> " where"
  indent $ do
      line $ "boxedPtrCopy = " <> copy
      line $ "boxedPtrFree = " <> free

  case allocCalloc info of
    AllocationOp Text
"none" -> () -> CodeGen e ()
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    AllocationOp Text
op -> do
      calloc <- Text
-> Text
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall e. Text -> Text -> Text -> CodeGen e Text
prefixedForeignImport (Text -> Text
prefix Text
"calloc") Text
op Text
"IO (Ptr a)"
      callocInstance 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 e ()
forall e. Text -> CodeGen e ()
callocInstance Text
calloc
      else () -> CodeGen e ()
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
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 = CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
group (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
          Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
bline (Text -> CodeGen e ()) -> Text -> CodeGen e ()
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"
          CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
indent (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
            Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"boxedPtrCalloc = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
calloc