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
ignoreStruct :: Name -> Struct -> Bool
ignoreStruct :: Name -> Struct -> Bool
ignoreStruct (Name Text
_ Text
name) Struct
s = (forall a. Maybe a -> Bool
isJust (Struct -> Maybe Name
gtypeStructFor Struct
s) Bool -> Bool -> Bool
||
Text
"Private" Text -> Text -> Bool
`T.isSuffixOf` Text
name) Bool -> Bool -> Bool
&&
(Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Struct -> Bool
structForceVisible Struct
s)
isIgnoredStructType :: Type -> CodeGen e Bool
isIgnoredStructType :: forall e. Type -> CodeGen e Bool
isIgnoredStructType Type
t =
case Type
t of
TInterface Name
n -> do
API
api <- forall e. HasCallStack => Type -> CodeGen e API
getAPI Type
t
case API
api of
APIStruct Struct
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Struct -> Bool
ignoreStruct Name
n Struct
s)
API
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Type
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
fieldCallbackType :: Text -> Field -> Text
fieldCallbackType :: Text -> Field -> Text
fieldCallbackType Text
structName Field
field =
Text
structName forall a. Semigroup a => a -> a -> a
<> (Text -> Text
underscoresToCamelCase forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Text
fieldName) Field
field forall a. Semigroup a => a -> a -> a
<> Text
"FieldCallback"
fixCallbackStructFields :: Name -> Struct -> Struct
fixCallbackStructFields :: Name -> Struct -> Struct
fixCallbackStructFields (Name Text
ns Text
structName) Struct
s = Struct
s {structFields :: [Field]
structFields = [Field]
fixedFields}
where fixedFields :: [Field]
fixedFields :: [Field]
fixedFields = forall a b. (a -> b) -> [a] -> [b]
map Field -> Field
fixField (Struct -> [Field]
structFields Struct
s)
fixField :: Field -> Field
fixField :: Field -> Field
fixField Field
field =
case Field -> Maybe Callback
fieldCallback Field
field of
Maybe Callback
Nothing -> Field
field
Just Callback
_ -> let n' :: Text
n' = Text -> Field -> Text
fieldCallbackType Text
structName Field
field
in Field
field {fieldType :: Type
fieldType = Name -> Type
TInterface (Text -> Text -> Name
Name Text
ns Text
n')}
fixAPIStructs :: (Name, API) -> (Name, API)
fixAPIStructs :: (Name, API) -> (Name, API)
fixAPIStructs (Name
n, APIStruct Struct
s) = (Name
n, Struct -> API
APIStruct forall a b. (a -> b) -> a -> b
$ Name -> Struct -> Struct
fixCallbackStructFields Name
n Struct
s)
fixAPIStructs (Name, API)
api = (Name, API)
api
extractCallbacksInStruct :: (Name, API) -> [(Name, API)]
(n :: Name
n@(Name Text
ns Text
structName), APIStruct Struct
s)
| Name -> Struct -> Bool
ignoreStruct Name
n Struct
s = []
| Bool
otherwise =
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Field -> Maybe (Name, API)
callbackInField (Struct -> [Field]
structFields Struct
s)
where callbackInField :: Field -> Maybe (Name, API)
callbackInField :: Field -> Maybe (Name, API)
callbackInField Field
field = do
Callback
callback <- Field -> Maybe Callback
fieldCallback Field
field
let n' :: Text
n' = Text -> Field -> Text
fieldCallbackType Text
structName Field
field
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Text -> Name
Name Text
ns Text
n', Callback -> API
APICallback Callback
callback)
extractCallbacksInStruct (Name, API)
_ = []
infoType :: Name -> Field -> CodeGen e Text
infoType :: forall e. Name -> Field -> CodeGen e Text
infoType Name
owner Field
field = do
let name :: Text
name = Name -> Text
upperName Name
owner
let fName :: Text
fName = (Text -> Text
underscoresToCamelCase forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Text
fieldName) Field
field
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
name forall a. Semigroup a => a -> a -> a
<> Text
fName forall a. Semigroup a => a -> a -> a
<> Text
"FieldInfo"
isEmbedded :: Field -> ExcCodeGen Bool
isEmbedded :: Field -> ExcCodeGen Bool
isEmbedded Field
field = do
Maybe API
api <- forall e. HasCallStack => Type -> CodeGen e (Maybe API)
findAPI (Field -> Type
fieldType Field
field)
case Maybe API
api of
Just (APIStruct Struct
_) -> ExcCodeGen Bool
checkEmbedding
Just (APIUnion Union
_) -> ExcCodeGen Bool
checkEmbedding
Maybe API
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
where
checkEmbedding :: ExcCodeGen Bool
checkEmbedding :: ExcCodeGen Bool
checkEmbedding = case Field -> Maybe Bool
fieldIsPointer Field
field of
Maybe Bool
Nothing -> forall a. Text -> ExcCodeGen a
badIntroError Text
"Cannot determine whether the field is embedded."
Just Bool
isPtr -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not Bool
isPtr)
fieldGetter :: Name -> Field -> Text
fieldGetter :: Name -> Field -> Text
fieldGetter Name
name' Field
field = Text
"get" forall a. Semigroup a => a -> a -> a
<> Name -> Text
upperName Name
name' forall a. Semigroup a => a -> a -> a
<> Field -> Text
fName Field
field
getterDoc :: Name -> Field -> Text
getterDoc :: Name -> Field -> Text
getterDoc Name
n Field
field = [Text] -> Text
T.unlines [
Text
"Get the value of the “@" forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldName Field
field forall a. Semigroup a => a -> a -> a
<> Text
"@” field."
, Text
"When <https://github.com/haskell-gi/haskell-gi/wiki/Overloading overloading> is enabled, this is equivalent to"
, Text
""
, Text
"@"
, Text
"'Data.GI.Base.Attributes.get' " forall a. Semigroup a => a -> a -> a
<> Name -> Text
lowerName Name
n forall a. Semigroup a => a -> a -> a
<> Text
" #" forall a. Semigroup a => a -> a -> a
<> Field -> Text
labelName Field
field
, Text
"@"]
buildFieldReader :: Name -> Field -> ExcCodeGen ()
buildFieldReader :: Name -> Field -> ExcCodeGen ()
buildFieldReader Name
n Field
field = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
let name' :: Text
name' = Name -> Text
upperName Name
n
getter :: Text
getter = Name -> Field -> Text
fieldGetter Name
n Field
field
Bool
embedded <- Field -> ExcCodeGen Bool
isEmbedded Field
field
Maybe Text
nullConvert <- if Bool
embedded
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
else forall e. Type -> CodeGen e (Maybe Text)
maybeNullConvert (Field -> Type
fieldType Field
field)
Text
hType <- TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if forall a. Maybe a -> Bool
isJust Maybe Text
nullConvert
then TypeRep -> TypeRep
maybeT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
isoHaskellType (Field -> Type
fieldType Field
field)
else forall e. Type -> CodeGen e TypeRep
isoHaskellType (Field -> Type
fieldType Field
field)
Text
fType <- TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
foreignType (Field -> Type
fieldType Field
field)
forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Name -> Field -> Text
getterDoc Name
n Field
field)
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
getter forall a. Semigroup a => a -> a -> a
<> Text
" :: MonadIO m => " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" -> m " forall a. Semigroup a => a -> a -> a
<>
if (Char -> Bool) -> Text -> Bool
T.any (forall a. Eq a => a -> a -> Bool
== Char
' ') Text
hType
then Text -> Text
parenthesize Text
hType
else Text
hType
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
getter forall a. Semigroup a => a -> a -> a
<> Text
" s = liftIO $ withManagedPtr s $ \\ptr -> do"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
let peekedType :: Text
peekedType = if (Char -> Bool) -> Text -> Bool
T.any (forall a. Eq a => a -> a -> Bool
== Char
' ') Text
fType
then Text -> Text
parenthesize Text
fType
else Text
fType
if Bool
embedded
then forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"let val = ptr `plusPtr` " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (Field -> Int
fieldOffset Field
field)
forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> Text
peekedType
else forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"val <- peek (ptr `plusPtr` " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (Field -> Int
fieldOffset Field
field)
forall a. Semigroup a => a -> a -> a
<> Text
") :: IO " forall a. Semigroup a => a -> a -> a
<> Text
peekedType
Text
result <- case Maybe Text
nullConvert of
Maybe Text
Nothing -> forall e. Text -> CodeGen e Converter -> CodeGen e Text
convert Text
"val" forall a b. (a -> b) -> a -> b
$ Type -> Transfer -> ExcCodeGen Converter
fToH (Field -> Type
fieldType Field
field) Transfer
TransferNothing
Just Text
nullConverter -> do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"result <- " forall a. Semigroup a => a -> a -> a
<> Text
nullConverter forall a. Semigroup a => a -> a -> a
<> Text
" val $ \\val' -> do"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
Text
val' <- forall e. Text -> CodeGen e Converter -> CodeGen e Text
convert Text
"val'" forall a b. (a -> b) -> a -> b
$ Type -> Transfer -> ExcCodeGen Converter
fToH (Field -> Type
fieldType Field
field) Transfer
TransferNothing
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"return " forall a. Semigroup a => a -> a -> a
<> Text
val'
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"result"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"return " forall a. Semigroup a => a -> a -> a
<> Text
result
fieldSetter :: Name -> Field -> Text
fieldSetter :: Name -> Field -> Text
fieldSetter Name
name' Field
field = Text
"set" forall a. Semigroup a => a -> a -> a
<> Name -> Text
upperName Name
name' forall a. Semigroup a => a -> a -> a
<> Field -> Text
fName Field
field
setterDoc :: Name -> Field -> Text
setterDoc :: Name -> Field -> Text
setterDoc Name
n Field
field = [Text] -> Text
T.unlines [
Text
"Set the value of the “@" forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldName Field
field forall a. Semigroup a => a -> a -> a
<> Text
"@” field."
, Text
"When <https://github.com/haskell-gi/haskell-gi/wiki/Overloading overloading> is enabled, this is equivalent to"
, Text
""
, Text
"@"
, Text
"'Data.GI.Base.Attributes.set' " forall a. Semigroup a => a -> a -> a
<> Name -> Text
lowerName Name
n forall a. Semigroup a => a -> a -> a
<> Text
" [ #" forall a. Semigroup a => a -> a -> a
<> Field -> Text
labelName Field
field
forall a. Semigroup a => a -> a -> a
<> Text
" 'Data.GI.Base.Attributes.:=' value ]"
, Text
"@"]
buildFieldWriter :: Name -> Field -> ExcCodeGen ()
buildFieldWriter :: Name -> Field -> ExcCodeGen ()
buildFieldWriter Name
n Field
field = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
let name' :: Text
name' = Name -> Text
upperName Name
n
let setter :: Text
setter = Name -> Field -> Text
fieldSetter Name
n Field
field
Bool
isPtr <- forall e. Type -> CodeGen e Bool
typeIsPtr (Field -> Type
fieldType Field
field)
Text
fType <- TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
foreignType (Field -> Type
fieldType Field
field)
Text
hType <- if Bool
isPtr
then forall (m :: * -> *) a. Monad m => a -> m a
return Text
fType
else TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
haskellType (Field -> Type
fieldType Field
field)
forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Name -> Field -> Text
setterDoc Name
n Field
field)
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
setter forall a. Semigroup a => a -> a -> a
<> Text
" :: MonadIO m => " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" -> "
forall a. Semigroup a => a -> a -> a
<> Text
hType forall a. Semigroup a => a -> a -> a
<> Text
" -> m ()"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
setter forall a. Semigroup a => a -> a -> a
<> Text
" s val = liftIO $ withManagedPtr s $ \\ptr -> do"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
Text
converted <- if Bool
isPtr
then forall (m :: * -> *) a. Monad m => a -> m a
return Text
"val"
else forall e. Text -> CodeGen e Converter -> CodeGen e Text
convert Text
"val" forall a b. (a -> b) -> a -> b
$ Type -> Transfer -> ExcCodeGen Converter
hToF (Field -> Type
fieldType Field
field) Transfer
TransferNothing
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"poke (ptr `plusPtr` " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (Field -> Int
fieldOffset Field
field)
forall a. Semigroup a => a -> a -> a
<> Text
") (" forall a. Semigroup a => a -> a -> a
<> Text
converted forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> Text
fType forall a. Semigroup a => a -> a -> a
<> Text
")"
fieldClear :: Name -> Field -> Text
fieldClear :: Name -> Field -> Text
fieldClear Name
name' Field
field = Text
"clear" forall a. Semigroup a => a -> a -> a
<> Name -> Text
upperName Name
name' forall a. Semigroup a => a -> a -> a
<> Field -> Text
fName Field
field
clearDoc :: Field -> Text
clearDoc :: Field -> Text
clearDoc Field
field = [Text] -> Text
T.unlines [
Text
"Set the value of the “@" forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldName Field
field forall a. Semigroup a => a -> a -> a
<> Text
"@” field to `Nothing`."
, Text
"When <https://github.com/haskell-gi/haskell-gi/wiki/Overloading overloading> is enabled, this is equivalent to"
, Text
""
, Text
"@"
, Text
"'Data.GI.Base.Attributes.clear'" forall a. Semigroup a => a -> a -> a
<> Text
" #" forall a. Semigroup a => a -> a -> a
<> Field -> Text
labelName Field
field
, Text
"@"]
buildFieldClear :: Name -> Field -> Text -> ExcCodeGen ()
buildFieldClear :: Name -> Field -> Text -> ExcCodeGen ()
buildFieldClear Name
n Field
field Text
nullPtr = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
let name' :: Text
name' = Name -> Text
upperName Name
n
let clear :: Text
clear = Name -> Field -> Text
fieldClear Name
n Field
field
Text
fType <- TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
foreignType (Field -> Type
fieldType Field
field)
forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Field -> Text
clearDoc Field
field)
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
clear forall a. Semigroup a => a -> a -> a
<> Text
" :: MonadIO m => " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" -> m ()"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
clear forall a. Semigroup a => a -> a -> a
<> Text
" s = liftIO $ withManagedPtr s $ \\ptr -> do"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"poke (ptr `plusPtr` " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (Field -> Int
fieldOffset Field
field)
forall a. Semigroup a => a -> a -> a
<> Text
") (" forall a. Semigroup a => a -> a -> a
<> Text
nullPtr forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> Text
fType forall a. Semigroup a => a -> a -> a
<> Text
")"
isRegularCallback :: Type -> CodeGen e (Maybe Callback)
isRegularCallback :: forall e. Type -> CodeGen e (Maybe Callback)
isRegularCallback t :: Type
t@(TInterface Name
_) = do
API
api <- forall e. HasCallStack => Type -> CodeGen e API
getAPI Type
t
case API
api of
APICallback callback :: Callback
callback@(Callback {cbCallable :: Callback -> Callable
cbCallable = Callable
callable}) ->
if Callable -> Bool
callableThrows Callable
callable
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Callback
callback)
API
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
isRegularCallback Type
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
fieldTransferTypeConstraint :: Type -> CodeGen e Text
fieldTransferTypeConstraint :: forall e. Type -> CodeGen e Text
fieldTransferTypeConstraint Type
t = do
Bool
isPtr <- forall e. Type -> CodeGen e Bool
typeIsPtr Type
t
Maybe Callback
maybeRegularCallback <- forall e. Type -> CodeGen e (Maybe Callback)
isRegularCallback Type
t
Text
inType <- if Bool
isPtr Bool -> Bool -> Bool
&& Bool -> Bool
not (forall a. Maybe a -> Bool
isJust Maybe Callback
maybeRegularCallback)
then TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
foreignType Type
t
else TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
isoHaskellType Type
t
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"(~)" forall a. Semigroup a => a -> a -> a
<> if (Char -> Bool) -> Text -> Bool
T.any (forall a. Eq a => a -> a -> Bool
== Char
' ') Text
inType
then Text -> Text
parenthesize Text
inType
else Text
inType
fieldTransferType :: Type -> CodeGen e Text
fieldTransferType :: forall e. Type -> CodeGen e Text
fieldTransferType Type
t = do
Bool
isPtr <- forall e. Type -> CodeGen e Bool
typeIsPtr Type
t
Text
inType <- if Bool
isPtr
then TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
foreignType Type
t
else TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
haskellType Type
t
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if (Char -> Bool) -> Text -> Bool
T.any (forall a. Eq a => a -> a -> Bool
== Char
' ') Text
inType
then Text -> Text
parenthesize Text
inType
else Text
inType
genFieldTransfer :: Text -> Type -> CodeGen e ()
genFieldTransfer :: forall e. Text -> Type -> CodeGen e ()
genFieldTransfer Text
var t :: Type
t@(TInterface Name
tn) = do
Maybe Callback
maybeRegularCallback <- forall e. Type -> CodeGen e (Maybe Callback)
isRegularCallback Type
t
case Maybe Callback
maybeRegularCallback of
Just Callback
callback -> do
let Name Text
_ Text
name' = API -> Name -> Name
normalizedAPIName (Callback -> API
APICallback Callback
callback) Name
tn
Text
wrapper <- forall e. Text -> Name -> CodeGen e Text
qualifiedSymbol (Text -> Text
callbackHaskellToForeign Text
name') Name
tn
Text
maker <- forall e. Text -> Name -> CodeGen e Text
qualifiedSymbol (Text -> Text
callbackWrapperAllocator Text
name') Name
tn
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
maker forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<>
Text -> Text
parenthesize (Text
wrapper forall a. Semigroup a => a -> a -> a
<> Text
" Nothing " forall a. Semigroup a => a -> a -> a
<> Text
var)
Maybe Callback
Nothing -> forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"return " forall a. Semigroup a => a -> a -> a
<> Text
var
genFieldTransfer Text
var Type
_ = forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"return " forall a. Semigroup a => a -> a -> a
<> Text
var
fName :: Field -> Text
fName :: Field -> Text
fName = Text -> Text
underscoresToCamelCase forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Text
fieldName
labelName :: Field -> Text
labelName :: Field -> Text
labelName = Text -> Text
lcFirst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Text
fName
genAttrInfo :: Name -> Field -> ExcCodeGen Text
genAttrInfo :: Name
-> Field
-> ReaderT
CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
genAttrInfo Name
owner Field
field = do
Text
it <- forall e. Name -> Field -> CodeGen e Text
infoType Name
owner Field
field
let on :: Text
on = Name -> Text
upperName Name
owner
Bool
isPtr <- forall e. Type -> CodeGen e Bool
typeIsPtr (Field -> Type
fieldType Field
field)
Bool
embedded <- Field -> ExcCodeGen Bool
isEmbedded Field
field
Bool
isNullable <- forall e. Type -> CodeGen e Bool
typeIsNullable (Field -> Type
fieldType Field
field)
Text
outType <- TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if Bool -> Bool
not Bool
embedded Bool -> Bool -> Bool
&& Bool
isNullable
then TypeRep -> TypeRep
maybeT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
isoHaskellType (Field -> Type
fieldType Field
field)
else forall e. Type -> CodeGen e TypeRep
isoHaskellType (Field -> Type
fieldType Field
field)
Text
inType <- if Bool
isPtr
then TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
foreignType (Field -> Type
fieldType Field
field)
else TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
haskellType (Field -> Type
fieldType Field
field)
Text
transferType <- forall e. Type -> CodeGen e Text
fieldTransferType (Field -> Type
fieldType Field
field)
Text
transferConstraint <- forall e. Type -> CodeGen e Text
fieldTransferTypeConstraint (Field -> Type
fieldType Field
field)
API
api <- forall e. HasCallStack => Name -> CodeGen e API
findAPIByName Name
owner
Text
hackageLink <- forall e. Name -> CodeGen e Text
hackageModuleLink Name
owner
let qualifiedAttrName :: Text
qualifiedAttrName = ModulePath -> Text
dotModulePath (Name -> API -> ModulePath
moduleLocation Name
owner API
api)
forall a. Semigroup a => a -> a -> a
<> Text
"." forall a. Semigroup a => a -> a -> a
<> Field -> Text
labelName Field
field
attrInfoURL :: Text
attrInfoURL = Text
hackageLink forall a. Semigroup a => a -> a -> a
<> Text
"#" forall a. Semigroup a => a -> a -> a
<> Text
haddockAttrAnchor forall a. Semigroup a => a -> a -> a
<> Field -> Text
labelName Field
field
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"data " forall a. Semigroup a => a -> a -> a
<> Text
it
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"instance AttrInfo " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" where"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrBaseTypeConstraint " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = (~) " forall a. Semigroup a => a -> a -> a
<> Text
on
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrAllowedOps " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<>
if Bool
embedded
then Text
" = '[ 'AttrGet]"
else if Bool
isPtr
then Text
" = '[ 'AttrSet, 'AttrGet, 'AttrClear]"
else Text
" = '[ 'AttrSet, 'AttrGet]"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrSetTypeConstraint " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = (~) "
forall a. Semigroup a => a -> a -> a
<> if (Char -> Bool) -> Text -> Bool
T.any (forall a. Eq a => a -> a -> Bool
== Char
' ') Text
inType
then Text -> Text
parenthesize Text
inType
else Text
inType
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrTransferTypeConstraint " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
transferConstraint
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrTransferType " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
transferType
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrGetType " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
outType
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrLabel " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = \"" forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldName Field
field forall a. Semigroup a => a -> a -> a
<> Text
"\""
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrOrigin " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
on
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"attrGet = " forall a. Semigroup a => a -> a -> a
<> Name -> Field -> Text
fieldGetter Name
owner Field
field
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"attrSet = " forall a. Semigroup a => a -> a -> a
<> if Bool -> Bool
not Bool
embedded
then Name -> Field -> Text
fieldSetter Name
owner Field
field
else Text
"undefined"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"attrConstruct = undefined"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"attrClear = " forall a. Semigroup a => a -> a -> a
<> if Bool -> Bool
not Bool
embedded Bool -> Bool -> Bool
&& Bool
isPtr
then Name -> Field -> Text
fieldClear Name
owner Field
field
else Text
"undefined"
if Bool -> Bool
not Bool
embedded
then do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"attrTransfer _ v = do"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e. Text -> Type -> CodeGen e ()
genFieldTransfer Text
"v" (Field -> Type
fieldType Field
field)
else forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"attrTransfer = undefined"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"dbgAttrInfo = P.Just (O.ResolvedSymbolInfo {"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"O.resolvedSymbolName = \"" forall a. Semigroup a => a -> a -> a
<> Text
qualifiedAttrName forall a. Semigroup a => a -> a -> a
<> Text
"\""
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
", O.resolvedSymbolURL = \"" forall a. Semigroup a => a -> a -> a
<> Text
attrInfoURL forall a. Semigroup a => a -> a -> a
<> Text
"\""
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"})"
forall e. CodeGen e ()
blank
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
let labelProxy :: Text
labelProxy = Text -> Text
lcFirst Text
on forall a. Semigroup a => a -> a -> a
<> Text
"_" forall a. Semigroup a => a -> a -> a
<> Text -> Text
lcFirst (Field -> Text
fName Field
field)
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
labelProxy forall a. Semigroup a => a -> a -> a
<> Text
" :: AttrLabelProxy \"" forall a. Semigroup a => a -> a -> a
<> Text -> Text
lcFirst (Field -> Text
fName Field
field) forall a. Semigroup a => a -> a -> a
<> Text
"\""
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
labelProxy forall a. Semigroup a => a -> a -> a
<> Text
" = AttrLabelProxy"
forall e. HaddockSection -> Text -> CodeGen e ()
export (NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
PropertySection forall a b. (a -> b) -> a -> b
$ Text -> Text
lcFirst forall a b. (a -> b) -> a -> b
$ Field -> Text
fName Field
field) Text
labelProxy
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"'(\"" forall a. Semigroup a => a -> a -> a
<> Field -> Text
labelName Field
field forall a. Semigroup a => a -> a -> a
<> Text
"\", " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
")"
buildFieldAttributes :: Name -> Field -> ExcCodeGen (Maybe Text)
buildFieldAttributes :: Name -> Field -> ExcCodeGen (Maybe Text)
buildFieldAttributes Name
n Field
field
| Bool -> Bool
not (Field -> Bool
fieldVisible Field
field) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
| Type -> Bool
privateType (Field -> Type
fieldType Field
field) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
| Bool
otherwise = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
Bool
ignored <- forall e. Type -> CodeGen e Bool
isIgnoredStructType (Field -> Type
fieldType Field
field)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ignored forall a b. (a -> b) -> a -> b
$
forall a. Text -> ExcCodeGen a
notImplementedError Text
"Field type is an unsupported struct type"
Maybe Text
nullPtr <- forall e. Type -> CodeGen e (Maybe Text)
nullPtrForType (Field -> Type
fieldType Field
field)
Bool
embedded <- Field -> ExcCodeGen Bool
isEmbedded Field
field
forall e. HaddockSection -> Documentation -> CodeGen e ()
addSectionDocumentation HaddockSection
docSection (Field -> Documentation
fieldDocumentation Field
field)
Name -> Field -> ExcCodeGen ()
buildFieldReader Name
n Field
field
forall e. HaddockSection -> Text -> CodeGen e ()
export HaddockSection
docSection (Name -> Field -> Text
fieldGetter Name
n Field
field)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
embedded) forall a b. (a -> b) -> a -> b
$ do
Name -> Field -> ExcCodeGen ()
buildFieldWriter Name
n Field
field
forall e. HaddockSection -> Text -> CodeGen e ()
export HaddockSection
docSection (Name -> Field -> Text
fieldSetter Name
n Field
field)
case Maybe Text
nullPtr of
Just Text
null -> do
Name -> Field -> Text -> ExcCodeGen ()
buildFieldClear Name
n Field
field Text
null
forall e. HaddockSection -> Text -> CodeGen e ()
export HaddockSection
docSection (Name -> Field -> Text
fieldClear Name
n Field
field)
Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf CPPGuard
CPPOverloading (Name
-> Field
-> ReaderT
CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Text
genAttrInfo Name
n Field
field)
where privateType :: Type -> Bool
privateType :: Type -> Bool
privateType (TInterface Name
n) = Text
"Private" Text -> Text -> Bool
`T.isSuffixOf` Name -> Text
name Name
n
privateType Type
_ = Bool
False
docSection :: HaddockSection
docSection = NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
PropertySection forall a b. (a -> b) -> a -> b
$ Text -> Text
lcFirst forall a b. (a -> b) -> a -> b
$ Field -> Text
fName Field
field
genStructOrUnionFields :: Name -> [Field] -> CodeGen e ()
genStructOrUnionFields :: forall e. Name -> [Field] -> CodeGen e ()
genStructOrUnionFields Name
n [Field]
fields = do
let name' :: Text
name' = Name -> Text
upperName Name
n
[Maybe Text]
attrs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Field]
fields forall a b. (a -> b) -> a -> b
$ \Field
field ->
forall e a. (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a
handleCGExc (\CGError
e -> do
forall e. Text -> CodeGen e ()
line (Text
"-- XXX Skipped attribute for \"" forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<>
Text
":" forall a. Semigroup a => a -> a -> a
<> Field -> Text
fieldName Field
field forall a. Semigroup a => a -> a -> a
<> Text
"\"")
forall e. CGError -> CodeGen e ()
printCGError CGError
e
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
(Name -> Field -> ExcCodeGen (Maybe Text)
buildFieldAttributes Name
n Field
field)
forall e. CodeGen e ()
blank
forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf CPPGuard
CPPOverloading forall a b. (a -> b) -> a -> b
$ do
let attrListName :: Text
attrListName = Text
name' forall a. Semigroup a => a -> a -> a
<> Text
"AttributeList"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"instance O.HasAttributeList " forall a. Semigroup a => a -> a -> a
<> Text
name'
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type instance O.AttributeList " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
attrListName
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type " forall a. Semigroup a => a -> a -> a
<> Text
attrListName forall a. Semigroup a => a -> a -> a
<> Text
" = ('[ " forall a. Semigroup a => a -> a -> a
<>
Text -> [Text] -> Text
T.intercalate Text
", " (forall a. [Maybe a] -> [a]
catMaybes [Maybe Text]
attrs) forall a. Semigroup a => a -> a -> a
<> Text
"] :: [(Symbol, DK.Type)])"
genZeroSU :: Name -> Int -> Bool -> CodeGen e ()
genZeroSU :: forall e. Name -> Int -> Bool -> CodeGen e ()
genZeroSU Name
n Int
size Bool
isBoxed = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
let name :: Text
name = Name -> Text
upperName Name
n
let builder :: Text
builder = Text
"newZero" forall a. Semigroup a => a -> a -> a
<> Text
name
tsize :: Text
tsize = forall a. Show a => a -> Text
tshow Int
size
forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Text
"Construct a `" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<>
Text
"` struct initialized to zero.")
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
builder forall a. Semigroup a => a -> a -> a
<> Text
" :: MonadIO m => m " forall a. Semigroup a => a -> a -> a
<> Text
name
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
builder forall a. Semigroup a => a -> a -> a
<> Text
" = liftIO $ " forall a. Semigroup a => a -> a -> a
<>
if Bool
isBoxed
then Text
"callocBoxedBytes " forall a. Semigroup a => a -> a -> a
<> Text
tsize forall a. Semigroup a => a -> a -> a
<> Text
" >>= wrapBoxed " forall a. Semigroup a => a -> a -> a
<> Text
name
else Text
"boxedPtrCalloc >>= wrapPtr " forall a. Semigroup a => a -> a -> a
<> Text
name
forall e. Text -> CodeGen e ()
exportDecl Text
builder
forall e. CodeGen e ()
blank
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"instance tag ~ 'AttrSet => Constructible " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" tag where"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"new _ attrs = do"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"o <- " forall a. Semigroup a => a -> a -> a
<> Text
builder
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"GI.Attributes.set o attrs"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"return o"
genZeroStruct :: Name -> Struct -> CodeGen e ()
genZeroStruct :: forall e. Name -> Struct -> CodeGen e ()
genZeroStruct Name
n Struct
s =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AllocationInfo -> AllocationOp
allocCalloc (Struct -> AllocationInfo
structAllocationInfo Struct
s) forall a. Eq a => a -> a -> Bool
/= Text -> AllocationOp
AllocationOp Text
"none" Bool -> Bool -> Bool
&&
Struct -> Int
structSize Struct
s forall a. Eq a => a -> a -> Bool
/= Int
0) forall a b. (a -> b) -> a -> b
$
forall e. Name -> Int -> Bool -> CodeGen e ()
genZeroSU Name
n (Struct -> Int
structSize Struct
s) (Struct -> Bool
structIsBoxed Struct
s)
genZeroUnion :: Name -> Union -> CodeGen e ()
genZeroUnion :: forall e. Name -> Union -> CodeGen e ()
genZeroUnion Name
n Union
u =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AllocationInfo -> AllocationOp
allocCalloc (Union -> AllocationInfo
unionAllocationInfo Union
u ) forall a. Eq a => a -> a -> Bool
/= Text -> AllocationOp
AllocationOp Text
"none" Bool -> Bool -> Bool
&&
Union -> Int
unionSize Union
u forall a. Eq a => a -> a -> Bool
/= Int
0) forall a b. (a -> b) -> a -> b
$
forall e. Name -> Int -> Bool -> CodeGen e ()
genZeroSU Name
n (Union -> Int
unionSize Union
u) (Union -> Bool
unionIsBoxed Union
u)
prefixedForeignImport :: Text -> Text -> Text -> CodeGen e Text
prefixedForeignImport :: forall e. Text -> Text -> Text -> CodeGen e Text
prefixedForeignImport Text
prefix Text
symbol Text
prototype = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"foreign import ccall \"" forall a. Semigroup a => a -> a -> a
<> Text
symbol forall a. Semigroup a => a -> a -> a
<> Text
"\" " forall a. Semigroup a => a -> a -> a
<> Text
prefix forall a. Semigroup a => a -> a -> a
<> Text
symbol
forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> Text
prototype
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
prefix forall a. Semigroup a => a -> a -> a
<> Text
symbol)
genBoxedGValueInstance :: Name -> Text -> CodeGen e ()
genBoxedGValueInstance :: forall e. Name -> Text -> CodeGen e ()
genBoxedGValueInstance Name
n Text
get_type_fn = do
let name' :: Text
name' = Name -> Text
upperName Name
n
doc :: Text
doc = Text
"Convert '" forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
"' to and from 'Data.GI.Base.GValue.GValue'. See 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'."
forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol Text
doc
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"instance B.GValue.IsGValue (Maybe " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
") where"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"gvalueGType_ = " forall a. Semigroup a => a -> a -> a
<> Text
get_type_fn
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"gvalueSet_ gv P.Nothing = B.GValue.set_boxed gv (FP.nullPtr :: FP.Ptr " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
")"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"gvalueSet_ gv (P.Just obj) = B.ManagedPtr.withManagedPtr obj (B.GValue.set_boxed gv)"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"gvalueGet_ gv = do"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"ptr <- B.GValue.get_boxed gv :: IO (Ptr " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
")"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"if ptr /= FP.nullPtr"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"then P.Just <$> B.ManagedPtr.newBoxed " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" ptr"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"else return P.Nothing"
genBoxed :: Name -> Text -> CodeGen e ()
genBoxed :: forall e. Name -> Text -> CodeGen e ()
genBoxed Name
n Text
typeInit = do
let name' :: Text
name' = Name -> Text
upperName Name
n
get_type_fn :: Text
get_type_fn = Text
"c_" forall a. Semigroup a => a -> a -> a
<> Text
typeInit
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"foreign import ccall \"" forall a. Semigroup a => a -> a -> a
<> Text
typeInit forall a. Semigroup a => a -> a -> a
<> Text
"\" " forall a. Semigroup a => a -> a -> a
<>
Text
get_type_fn forall a. Semigroup a => a -> a -> a
<> Text
" :: "
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e. Text -> CodeGen e ()
line Text
"IO GType"
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type instance O.ParentTypes " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" = '[]"
forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"instance O.HasParentTypes " forall a. Semigroup a => a -> a -> a
<> Text
name'
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"instance B.Types.TypedObject " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" where"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"glibType = " forall a. Semigroup a => a -> a -> a
<> Text
get_type_fn
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"instance B.Types.GBoxed " forall a. Semigroup a => a -> a -> a
<> Text
name'
forall e. Name -> Text -> CodeGen e ()
genBoxedGValueInstance Name
n Text
get_type_fn
genWrappedPtr :: Name -> AllocationInfo -> Int -> CodeGen e ()
genWrappedPtr :: forall e. Name -> AllocationInfo -> Int -> CodeGen e ()
genWrappedPtr Name
n AllocationInfo
info Int
size = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
let prefix :: Text -> Text
prefix = \Text
op -> Text
"_" forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
"_" forall a. Semigroup a => a -> a -> a
<> Text
op forall a. Semigroup a => a -> a -> a
<> Text
"_"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
size forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& AllocationInfo -> AllocationOp
allocFree AllocationInfo
info forall a. Eq a => a -> a -> Bool
== AllocationOp
AllocationOpUnknown) forall a b. (a -> b) -> a -> b
$
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"-- XXX Wrapping a foreign struct/union with no known destructor or size, leak?"
Text
copy <- case AllocationInfo -> AllocationOp
allocCopy AllocationInfo
info of
AllocationOp Text
op -> do
Text
copy <- forall e. Text -> Text -> Text -> CodeGen e Text
prefixedForeignImport (Text -> Text
prefix Text
"copy") Text
op Text
"Ptr a -> IO (Ptr a)"
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
"\\p -> B.ManagedPtr.withManagedPtr p (" forall a. Semigroup a => a -> a -> a
<> Text
copy forall a. Semigroup a => a -> a -> a
<>
Text
" >=> B.ManagedPtr.wrapPtr " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
")")
AllocationOp
AllocationOpUnknown ->
if Int
size forall a. Ord a => a -> a -> Bool
> Int
0
then forall (m :: * -> *) a. Monad m => a -> m a
return (Text
"\\p -> B.ManagedPtr.withManagedPtr p (copyBytes "
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Int
size forall a. Semigroup a => a -> a -> a
<>
Text
" >=> B.ManagedPtr.wrapPtr " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
")")
else forall (m :: * -> *) a. Monad m => a -> m a
return Text
"return"
Text
free <- case AllocationInfo -> AllocationOp
allocFree AllocationInfo
info of
AllocationOp Text
op -> do
Text
free <- forall e. Text -> Text -> Text -> CodeGen e Text
prefixedForeignImport (Text -> Text
prefix Text
"free") Text
op Text
"Ptr a -> IO ()"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"\\p -> B.ManagedPtr.withManagedPtr p " forall a. Semigroup a => a -> a -> a
<> Text
free
AllocationOp
AllocationOpUnknown ->
if Int
size forall a. Ord a => a -> a -> Bool
> Int
0
then forall (m :: * -> *) a. Monad m => a -> m a
return Text
"\\x -> SP.withManagedPtr x SP.freeMem"
else forall (m :: * -> *) a. Monad m => a -> m a
return Text
"\\_x -> return ()"
forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"instance BoxedPtr " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" where"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"boxedPtrCopy = " forall a. Semigroup a => a -> a -> a
<> Text
copy
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"boxedPtrFree = " forall a. Semigroup a => a -> a -> a
<> Text
free
case AllocationInfo -> AllocationOp
allocCalloc AllocationInfo
info of
AllocationOp Text
"none" -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
AllocationOp Text
op -> do
Text
calloc <- forall e. Text -> Text -> Text -> CodeGen e Text
prefixedForeignImport (Text -> Text
prefix Text
"calloc") Text
op Text
"IO (Ptr a)"
forall e. Text -> CodeGen e ()
callocInstance Text
calloc
AllocationOp
AllocationOpUnknown ->
if Int
size forall a. Ord a => a -> a -> Bool
> Int
0
then do
let calloc :: Text
calloc = Text
"callocBytes " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Int
size
forall e. Text -> CodeGen e ()
callocInstance Text
calloc
else forall (m :: * -> *) a. Monad m => a -> m a
return ()
where name' :: Text
name' = Name -> Text
upperName Name
n
callocInstance :: Text -> CodeGen e ()
callocInstance :: forall e. Text -> CodeGen e ()
callocInstance Text
calloc = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"instance CallocPtr " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" where"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"boxedPtrCalloc = " forall a. Semigroup a => a -> a -> a
<> Text
calloc