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)
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 Bool
isRegularCallback :: forall e. Type -> CodeGen e Bool
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 {cbCallable :: Callback -> Callable
cbCallable = Callable
callable}) ->
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Callable -> Bool
callableThrows Callable
callable)
API
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isRegularCallback Type
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
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
Bool
isRegularCallback <- forall e. Type -> CodeGen e Bool
isRegularCallback Type
t
Text
inType <- if Bool
isPtr Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isRegularCallback
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 tn :: Name
tn@(Name Text
_ Text
n)) = do
Bool
isRegularCallback <- forall e. Type -> CodeGen e Bool
isRegularCallback Type
t
if Bool
isRegularCallback
then do
Text
wrapper <- forall e. Text -> Name -> CodeGen e Text
qualifiedSymbol (Text -> Text
callbackHaskellToForeign Text
n) Name
tn
Text
maker <- forall e. Text -> Name -> CodeGen e Text
qualifiedSymbol (Text -> Text
callbackWrapperAllocator Text
n) 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)
else 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, *)])"
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