module Data.GI.CodeGen.CodeGen
( genConstant
, genFunction
, genModule
) where
import Control.Monad (forM, forM_, when, unless, filterM)
import Data.List (nub)
import Data.Maybe (fromJust, fromMaybe, catMaybes, mapMaybe)
#if !MIN_VERSION_base(4,13,0)
import Data.Monoid ((<>))
#endif
import qualified Data.Map as M
import qualified Data.Text as T
import Data.Text (Text)
import Data.GI.CodeGen.API
import Data.GI.CodeGen.Callable (genCCallableWrapper)
import Data.GI.CodeGen.Constant (genConstant)
import Data.GI.CodeGen.Code
import Data.GI.CodeGen.EnumFlags (genEnum, genFlags)
import Data.GI.CodeGen.Fixups (dropMovedItems, guessPropertyNullability,
detectGObject, dropDuplicatedFields,
checkClosureDestructors, fixSymbolNaming)
import Data.GI.CodeGen.GObject
import Data.GI.CodeGen.Haddock (deprecatedPragma, addSectionDocumentation,
writeHaddock,
RelativeDocPosition(DocBeforeSymbol))
import Data.GI.CodeGen.Inheritance (instanceTree, fullObjectMethodList,
fullInterfaceMethodList)
import Data.GI.CodeGen.Properties (genInterfaceProperties, genObjectProperties,
genNamespacedPropLabels)
import Data.GI.CodeGen.OverloadedSignals (genInterfaceSignals, genObjectSignals)
import Data.GI.CodeGen.OverloadedMethods (genMethodList, genMethodInfo,
genUnsupportedMethodInfo)
import Data.GI.CodeGen.Signal (genSignal, genCallback)
import Data.GI.CodeGen.Struct (genStructOrUnionFields, extractCallbacksInStruct,
fixAPIStructs, ignoreStruct, genZeroStruct, genZeroUnion,
genBoxed, genWrappedPtr)
import Data.GI.CodeGen.SymbolNaming (upperName, classConstraint,
submoduleLocation, lowerName, qualifiedAPI,
normalizedAPIName, safeCast)
import Data.GI.CodeGen.Type
import Data.GI.CodeGen.Util (tshow)
genFunction :: Name -> Function -> CodeGen e ()
genFunction :: forall e. Name -> Function -> CodeGen e ()
genFunction Name
n (Function Text
symbol Maybe Text
fnMovedTo Callable
callable) =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a
Nothing forall a. Eq a => a -> a -> Bool
== Maybe Text
fnMovedTo) 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
"-- function " forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
n
forall e a. (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a
handleCGExc (\CGError
e -> do
forall e. Text -> CodeGen e ()
line (Text
"-- XXX Could not generate function "
forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
n
forall a. Semigroup a => a -> a -> a
<> Text
"\n")
forall e. CGError -> CodeGen e ()
printCGError CGError
e)
(do
Name -> Text -> Callable -> ExcCodeGen ()
genCCallableWrapper Name
n Text
symbol Callable
callable
forall e. HaddockSection -> Text -> CodeGen e ()
export (NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
MethodSection forall a b. (a -> b) -> a -> b
$ Name -> Text
lowerName Name
n) (Name -> Text
lowerName Name
n)
)
genNewtype :: Text -> CodeGen e ()
genNewtype :: forall e. Text -> CodeGen e ()
genNewtype Text
name' = do
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
"newtype " 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
name' forall a. Semigroup a => a -> a -> a
<> Text
" (SP.ManagedPtr " forall a. Semigroup a => a -> a -> a
<> Text
name' 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 forall a b. (a -> b) -> a -> b
$ Text
"deriving (Eq)"
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 SP.ManagedPtrNewtype " 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
"toManagedPtr (" forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" p) = p"
genStruct :: Name -> Struct -> CodeGen e ()
genStruct :: forall e. Name -> Struct -> CodeGen e ()
genStruct Name
n Struct
s = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Name -> Struct -> Bool
ignoreStruct Name
n Struct
s) forall a b. (a -> b) -> a -> b
$ do
let Name Text
_ Text
name' = API -> Name -> Name
normalizedAPIName (Struct -> API
APIStruct Struct
s) Name
n
forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Text
"Memory-managed wrapper type.")
forall e. Text -> CodeGen e ()
genNewtype Text
name'
forall e. Text -> CodeGen e ()
exportDecl (Text
name' forall a. Semigroup a => a -> a -> a
<> (Text
"(..)"))
forall e. HaddockSection -> Documentation -> CodeGen e ()
addSectionDocumentation HaddockSection
ToplevelSection (Struct -> Documentation
structDocumentation Struct
s)
if Struct -> Bool
structIsBoxed Struct
s
then forall e. Name -> Text -> CodeGen e ()
genBoxed Name
n (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ Struct -> Maybe Text
structTypeInit Struct
s)
else forall e. Name -> AllocationInfo -> Int -> CodeGen e ()
genWrappedPtr Name
n (Struct -> AllocationInfo
structAllocationInfo Struct
s) (Struct -> Int
structSize Struct
s)
forall e. Name -> Struct -> CodeGen e ()
genZeroStruct Name
n Struct
s
forall e. Name -> [Field] -> CodeGen e ()
genStructOrUnionFields Name
n (Struct -> [Field]
structFields Struct
s)
[Maybe (Name, Method)]
methods <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Struct -> [Method]
structMethods Struct
s) forall a b. (a -> b) -> a -> b
$ \Method
f -> do
let mn :: Name
mn = Method -> Name
methodName Method
f
Bool
isFunction <- forall e. Text -> CodeGen e Bool
symbolFromFunction (Method -> Text
methodSymbol Method
f)
if Bool -> Bool
not Bool
isFunction
then forall e a. (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a
handleCGExc
(\CGError
e -> do forall e. Text -> CodeGen e ()
line (Text
"-- XXX Could not generate method "
forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
"::" forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
mn)
forall e. CGError -> CodeGen e ()
printCGError CGError
e
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
(Name -> Method -> ExcCodeGen ()
genMethod Name
n Method
f forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Name
n, Method
f)))
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf CPPGuard
CPPOverloading (forall e. Name -> [(Name, Method)] -> CodeGen e ()
genMethodList Name
n (forall a. [Maybe a] -> [a]
catMaybes [Maybe (Name, Method)]
methods))
genUnion :: Name -> Union -> CodeGen e ()
genUnion :: forall e. Name -> Union -> CodeGen e ()
genUnion Name
n Union
u = do
let Name Text
_ Text
name' = API -> Name -> Name
normalizedAPIName (Union -> API
APIUnion Union
u) Name
n
forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Text
"Memory-managed wrapper type.")
forall e. Text -> CodeGen e ()
genNewtype Text
name'
forall e. Text -> CodeGen e ()
exportDecl (Text
name' forall a. Semigroup a => a -> a -> a
<> Text
"(..)")
forall e. HaddockSection -> Documentation -> CodeGen e ()
addSectionDocumentation HaddockSection
ToplevelSection (Union -> Documentation
unionDocumentation Union
u)
if Union -> Bool
unionIsBoxed Union
u
then forall e. Name -> Text -> CodeGen e ()
genBoxed Name
n (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ Union -> Maybe Text
unionTypeInit Union
u)
else forall e. Name -> AllocationInfo -> Int -> CodeGen e ()
genWrappedPtr Name
n (Union -> AllocationInfo
unionAllocationInfo Union
u) (Union -> Int
unionSize Union
u)
forall e. Name -> Union -> CodeGen e ()
genZeroUnion Name
n Union
u
forall e. Name -> [Field] -> CodeGen e ()
genStructOrUnionFields Name
n (Union -> [Field]
unionFields Union
u)
[Maybe (Name, Method)]
methods <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Union -> [Method]
unionMethods Union
u) forall a b. (a -> b) -> a -> b
$ \Method
f -> do
let mn :: Name
mn = Method -> Name
methodName Method
f
Bool
isFunction <- forall e. Text -> CodeGen e Bool
symbolFromFunction (Method -> Text
methodSymbol Method
f)
if Bool -> Bool
not Bool
isFunction
then forall e a. (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a
handleCGExc
(\CGError
e -> do forall e. Text -> CodeGen e ()
line (Text
"-- XXX Could not generate method "
forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
"::" forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
mn)
forall e. CGError -> CodeGen e ()
printCGError CGError
e
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
(Name -> Method -> ExcCodeGen ()
genMethod Name
n Method
f forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Name
n, Method
f)))
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf CPPGuard
CPPOverloading forall a b. (a -> b) -> a -> b
$ forall e. Name -> [(Name, Method)] -> CodeGen e ()
genMethodList Name
n (forall a. [Maybe a] -> [a]
catMaybes [Maybe (Name, Method)]
methods)
fixMethodArgs :: Callable -> Callable
fixMethodArgs :: Callable -> Callable
fixMethodArgs Callable
c = Callable
c { args :: [Arg]
args = [Arg]
args'' , returnType :: Maybe Type
returnType = Maybe Type
returnType' }
where
returnType' :: Maybe Type
returnType' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
fixCArrayLength) (Callable -> Maybe Type
returnType Callable
c)
args' :: [Arg]
args' = forall a b. (a -> b) -> [a] -> [b]
map (Arg -> Arg
fixDestroyers forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg -> Arg
fixClosures forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg -> Arg
fixLengthArg) (Callable -> [Arg]
args Callable
c)
args'' :: [Arg]
args'' = Arg -> Arg
fixInstance (forall a. [a] -> a
head [Arg]
args') forall a. a -> [a] -> [a]
: forall a. [a] -> [a]
tail [Arg]
args'
fixLengthArg :: Arg -> Arg
fixLengthArg :: Arg -> Arg
fixLengthArg Arg
arg = Arg
arg { argType :: Type
argType = Type -> Type
fixCArrayLength (Arg -> Type
argType Arg
arg)}
fixCArrayLength :: Type -> Type
fixCArrayLength :: Type -> Type
fixCArrayLength (TCArray Bool
zt Int
fixed Int
length Type
t) =
if Int
length forall a. Ord a => a -> a -> Bool
> -Int
1
then Bool -> Int -> Int -> Type -> Type
TCArray Bool
zt Int
fixed (Int
lengthforall a. Num a => a -> a -> a
+Int
1) Type
t
else Bool -> Int -> Int -> Type -> Type
TCArray Bool
zt Int
fixed Int
length Type
t
fixCArrayLength Type
t = Type
t
fixDestroyers :: Arg -> Arg
fixDestroyers :: Arg -> Arg
fixDestroyers Arg
arg = let destroy :: Int
destroy = Arg -> Int
argDestroy Arg
arg in
if Int
destroy forall a. Ord a => a -> a -> Bool
> -Int
1
then Arg
arg {argDestroy :: Int
argDestroy = Int
destroy forall a. Num a => a -> a -> a
+ Int
1}
else Arg
arg
fixClosures :: Arg -> Arg
fixClosures :: Arg -> Arg
fixClosures Arg
arg = let closure :: Int
closure = Arg -> Int
argClosure Arg
arg in
if Int
closure forall a. Ord a => a -> a -> Bool
> -Int
1
then Arg
arg {argClosure :: Int
argClosure = Int
closure forall a. Num a => a -> a -> a
+ Int
1}
else Arg
arg
fixInstance :: Arg -> Arg
fixInstance :: Arg -> Arg
fixInstance Arg
arg = Arg
arg { mayBeNull :: Bool
mayBeNull = Bool
False
, direction :: Direction
direction = Direction
DirectionIn}
fixConstructorReturnType :: Bool -> Name -> Callable -> Callable
fixConstructorReturnType :: Bool -> Name -> Callable -> Callable
fixConstructorReturnType Bool
returnsGObject Name
cn Callable
c = Callable
c { returnType :: Maybe Type
returnType = Maybe Type
returnType' }
where
returnType' :: Maybe Type
returnType' = if Bool
returnsGObject then
forall a. a -> Maybe a
Just (Name -> Type
TInterface Name
cn)
else
Callable -> Maybe Type
returnType Callable
c
genMethod :: Name -> Method -> ExcCodeGen ()
genMethod :: Name -> Method -> ExcCodeGen ()
genMethod Name
cn m :: Method
m@(Method {
methodName :: Method -> Name
methodName = Name
mn,
methodSymbol :: Method -> Text
methodSymbol = Text
sym,
methodCallable :: Method -> Callable
methodCallable = Callable
c,
methodType :: Method -> MethodType
methodType = MethodType
t
}) = do
let name' :: Text
name' = Name -> Text
upperName Name
cn
Bool
returnsGObject <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) forall e. Type -> CodeGen e Bool
isGObject (Callable -> Maybe Type
returnType Callable
c)
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"-- method " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
"::" forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
mn
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"-- method type : " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow MethodType
t
let
mn' :: Name
mn' = Name
mn { name :: Text
name = Name -> Text
name Name
cn forall a. Semigroup a => a -> a -> a
<> Text
"_" forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
mn }
let c' :: Callable
c' = if MethodType
Constructor forall a. Eq a => a -> a -> Bool
== MethodType
t
then Bool -> Name -> Callable -> Callable
fixConstructorReturnType Bool
returnsGObject Name
cn Callable
c
else Callable
c
c'' :: Callable
c'' = if MethodType
OrdinaryMethod forall a. Eq a => a -> a -> Bool
== MethodType
t
then Callable -> Callable
fixMethodArgs Callable
c'
else Callable
c'
Name -> Text -> Callable -> ExcCodeGen ()
genCCallableWrapper Name
mn' Text
sym Callable
c''
forall e. HaddockSection -> Text -> CodeGen e ()
export (NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
MethodSection forall a b. (a -> b) -> a -> b
$ Name -> Text
lowerName Name
mn) (Name -> Text
lowerName Name
mn')
forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf CPPGuard
CPPOverloading forall a b. (a -> b) -> a -> b
$
Name -> Method -> ExcCodeGen ()
genMethodInfo Name
cn (Method
m {methodCallable :: Callable
methodCallable = Callable
c''})
genGValueGetter :: Text -> Text -> CodeGen e Text
genGValueGetter :: forall e. Text -> Text -> CodeGen e Text
genGValueGetter Text
name' Text
get_value_fn = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
let symb :: Text
symb = Text
"gv_get_" forall a. Semigroup a => a -> a -> a
<> Text
get_value_fn
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
get_value_fn forall a. Semigroup a => a -> a -> a
<> Text
"\" " forall a. Semigroup a => a -> a -> a
<> Text
symb 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 forall a b. (a -> b) -> a -> b
$ Text
"FP.Ptr B.GValue.GValue -> IO (FP.Ptr " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
")"
forall (m :: * -> *) a. Monad m => a -> m a
return Text
symb
genGValueSetter :: Text -> Text -> CodeGen e Text
genGValueSetter :: forall e. Text -> Text -> CodeGen e Text
genGValueSetter Text
name' Text
set_value_fn = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
let symb :: Text
symb = Text
"gv_set_" forall a. Semigroup a => a -> a -> a
<> Text
set_value_fn
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
set_value_fn forall a. Semigroup a => a -> a -> a
<> Text
"\" " forall a. Semigroup a => a -> a -> a
<> Text
symb 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 forall a b. (a -> b) -> a -> b
$ Text
"FP.Ptr B.GValue.GValue -> FP.Ptr " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" -> IO ()"
forall (m :: * -> *) a. Monad m => a -> m a
return Text
symb
genGValueInstance :: Name -> Text -> Text -> Text -> Text -> CodeGen e ()
genGValueInstance :: forall e. Name -> Text -> Text -> Text -> Text -> CodeGen e ()
genGValueInstance Name
n Text
get_type_fn Text
newFn Text
get_value_fn Text
set_value_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 = " forall a. Semigroup a => a -> a -> a
<> Text
set_value_fn forall a. Semigroup a => a -> a -> a
<> Text
" 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 (" forall a. Semigroup a => a -> a -> a
<> Text
set_value_fn forall a. Semigroup a => a -> a -> a
<> Text
" 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 <- " forall a. Semigroup a => a -> a -> a
<> Text
get_value_fn forall a. Semigroup a => a -> a -> a
<> Text
" gv :: IO (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
"if ptr /= FP.nullPtr"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"then P.Just <$> " forall a. Semigroup a => a -> a -> a
<> Text
newFn forall a. Semigroup a => a -> a -> a
<> Text
" " 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"
genCasts :: Name -> Text -> [Name] -> CodeGen e Text
genCasts :: forall e. Name -> Text -> [Name] -> CodeGen e Text
genCasts Name
n Text
ti [Name]
parents = do
Bool
isGO <- forall e. Type -> CodeGen e Bool
isGObject (Name -> Type
TInterface Name
n)
let name' :: Text
name' = Name -> Text
upperName Name
n
Text
get_type_fn <- do
let cn_ :: Text
cn_ = Text
"c_" forall a. Semigroup a => a -> a -> a
<> Text
ti
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
ti 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 forall a b. (a -> b) -> a -> b
$ Text
cn_ forall a. Semigroup a => a -> a -> a
<> Text
" :: IO B.Types.GType"
forall (m :: * -> *) a. Monad m => a -> m a
return Text
cn_
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
$ do
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 (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isGO 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 ()
bline forall a b. (a -> b) -> a -> b
$ Text
"instance B.Types.GObject " forall a. Semigroup a => a -> a -> a
<> Text
name'
Text
className <- forall e. Name -> CodeGen e Text
classConstraint Name
n
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
exportDecl Text
className
forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Text -> Text
classDoc Text
name')
let constraints :: Text
constraints = if Bool
isGO
then Text
"(SP.GObject o, O.IsDescendantOf " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" o)"
else Text
"(SP.BoxedPtr o, SP.TypedObject o, O.IsDescendantOf " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" o)"
forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"class " forall a. Semigroup a => a -> a -> a
<> Text
constraints forall a. Semigroup a => a -> a -> a
<> Text
" => " forall a. Semigroup a => a -> a -> a
<> Text
className forall a. Semigroup a => a -> a -> a
<> Text
" o"
forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"instance " forall a. Semigroup a => a -> a -> a
<> Text
constraints forall a. Semigroup a => a -> a -> a
<> Text
" => " forall a. Semigroup a => a -> a -> a
<> Text
className forall a. Semigroup a => a -> a -> a
<> Text
" o"
forall e. CodeGen e ()
blank
[API]
parentAPIs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Name
n -> forall e. HasCallStack => Type -> CodeGen e API
getAPI (Name -> Type
TInterface Name
n)) [Name]
parents
[Text]
qualifiedParents <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall e. API -> Name -> CodeGen e Text
qualifiedAPI) (forall a b. [a] -> [b] -> [(a, b)]
zip [API]
parentAPIs [Name]
parents)
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. 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 a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
qualifiedParents forall a. Semigroup a => a -> a -> a
<> Text
"]"
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
Text
cast <- forall e. Name -> CodeGen e Text
safeCast Name
n
forall e. Text -> CodeGen e ()
exportDecl Text
cast
forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Text -> Text
castDoc Text
name')
forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
cast forall a. Semigroup a => a -> a -> a
<> Text
" :: (MIO.MonadIO m, " forall a. Semigroup a => a -> a -> a
<> Text
className forall a. Semigroup a => a -> a -> a
<> Text
" o) => o -> m " forall a. Semigroup a => a -> a -> a
<> Text
name'
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
cast forall a. Semigroup a => a -> a -> a
<> Text
" = MIO.liftIO . B.ManagedPtr.unsafeCastTo " forall a. Semigroup a => a -> a -> a
<> Text
name'
forall (m :: * -> *) a. Monad m => a -> m a
return Text
get_type_fn
where castDoc :: Text -> Text
castDoc :: Text -> Text
castDoc Text
name' = Text
"Cast to `" forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<>
Text
"`, for types for which this is known to be safe. " forall a. Semigroup a => a -> a -> a
<>
Text
"For general casts, use `Data.GI.Base.ManagedPtr.castTo`."
classDoc :: Text -> Text
classDoc :: Text -> Text
classDoc Text
name' = Text
"Type class for types which can be safely cast to `"
forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
"`, for instance with `to" forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
"`."
genObject :: Name -> Object -> CodeGen e ()
genObject :: forall e. Name -> Object -> CodeGen e ()
genObject Name
n Object
o = do
let Name Text
_ Text
name' = API -> Name -> Name
normalizedAPIName (Object -> API
APIObject Object
o) Name
n
let t :: Type
t = Name -> Type
TInterface Name
n
Bool
isGO <- forall e. Type -> CodeGen e Bool
isGObject Type
t
forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Text
"Memory-managed wrapper type.")
forall e. Text -> CodeGen e ()
genNewtype Text
name'
forall e. Text -> CodeGen e ()
exportDecl (Text
name' forall a. Semigroup a => a -> a -> a
<> Text
"(..)")
forall e. HaddockSection -> Documentation -> CodeGen e ()
addSectionDocumentation HaddockSection
ToplevelSection (Object -> Documentation
objDocumentation Object
o)
[Name]
parents <- forall e. Name -> CodeGen e [Name]
instanceTree Name
n
Text
get_type_fn <- forall e. Name -> Text -> [Name] -> CodeGen e Text
genCasts Name
n (Object -> Text
objTypeInit Object
o) ([Name]
parents forall a. Semigroup a => a -> a -> a
<> Object -> [Name]
objInterfaces Object
o)
if Bool
isGO
then forall e. Name -> Text -> Text -> Text -> Text -> CodeGen e ()
genGValueInstance Name
n Text
get_type_fn Text
"B.ManagedPtr.newObject" Text
"B.GValue.get_object" Text
"B.GValue.set_object"
else case (Object -> Maybe Text
objGetValueFunc Object
o, Object -> Maybe Text
objSetValueFunc Object
o) of
(Just Text
get_value_fn, Just Text
set_value_fn) -> do
Text
getter <- forall e. Text -> Text -> CodeGen e Text
genGValueGetter Text
name' Text
get_value_fn
Text
setter <- forall e. Text -> Text -> CodeGen e Text
genGValueSetter Text
name' Text
set_value_fn
forall e. Name -> Text -> Text -> Text -> Text -> CodeGen e ()
genGValueInstance Name
n Text
get_type_fn Text
"B.ManagedPtr.newPtr" Text
getter Text
setter
(Maybe Text, Maybe Text)
_ -> forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"--- XXX Missing getter and/or setter, so no GValue instance could be generated."
forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf CPPGuard
CPPOverloading forall a b. (a -> b) -> a -> b
$ forall e. Name -> Object -> CodeGen e [(Name, Method)]
fullObjectMethodList Name
n Object
o forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall e. Name -> [(Name, Method)] -> CodeGen e ()
genMethodList Name
n
if Bool
isGO
then do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Object -> [Signal]
objSignals Object
o) forall a b. (a -> b) -> a -> b
$ \Signal
s -> forall e. Signal -> Name -> CodeGen e ()
genSignal Signal
s Name
n
forall e. Name -> Object -> CodeGen e ()
genObjectProperties Name
n Object
o
forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf CPPGuard
CPPOverloading forall a b. (a -> b) -> a -> b
$
forall e. Name -> [Property] -> [Method] -> CodeGen e ()
genNamespacedPropLabels Name
n (Object -> [Property]
objProperties Object
o) (Object -> [Method]
objMethods Object
o)
forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf CPPGuard
CPPOverloading forall a b. (a -> b) -> a -> b
$
forall e. Name -> Object -> CodeGen e ()
genObjectSignals Name
n Object
o
else forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
let allocInfo :: AllocationInfo
allocInfo = AllocationInfo {
allocCalloc :: AllocationOp
allocCalloc = AllocationOp
AllocationOpUnknown,
allocCopy :: AllocationOp
allocCopy = case Object -> Maybe Text
objRefFunc Object
o of
Just Text
ref -> Text -> AllocationOp
AllocationOp Text
ref
Maybe Text
Nothing -> AllocationOp
AllocationOpUnknown,
allocFree :: AllocationOp
allocFree = case Object -> Maybe Text
objUnrefFunc Object
o of
Just Text
unref -> Text -> AllocationOp
AllocationOp Text
unref
Maybe Text
Nothing -> AllocationOp
AllocationOpUnknown
}
forall e. Name -> AllocationInfo -> Int -> CodeGen e ()
genWrappedPtr Name
n AllocationInfo
allocInfo Int
0
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Object -> [Method]
objMethods Object
o) forall a b. (a -> b) -> a -> b
$ \Method
f -> do
let mn :: Name
mn = Method -> Name
methodName Method
f
forall e a. (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a
handleCGExc (\CGError
e -> do forall e. Text -> CodeGen e ()
line (Text
"-- XXX Could not generate method "
forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
"::" forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
mn)
forall e. CGError -> CodeGen e ()
printCGError CGError
e
forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf CPPGuard
CPPOverloading forall a b. (a -> b) -> a -> b
$
forall e. Name -> Method -> CodeGen e ()
genUnsupportedMethodInfo Name
n Method
f)
(Name -> Method -> ExcCodeGen ()
genMethod Name
n Method
f)
genInterface :: Name -> Interface -> CodeGen e ()
genInterface :: forall e. Name -> Interface -> CodeGen e ()
genInterface Name
n Interface
iface = do
let Name Text
_ Text
name' = API -> Name -> Name
normalizedAPIName (Interface -> API
APIInterface Interface
iface) Name
n
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"-- interface " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" "
forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Text
"Memory-managed wrapper type.")
forall e. Text -> Maybe DeprecationInfo -> CodeGen e ()
deprecatedPragma Text
name' forall a b. (a -> b) -> a -> b
$ Interface -> Maybe DeprecationInfo
ifDeprecated Interface
iface
forall e. Text -> CodeGen e ()
genNewtype Text
name'
forall e. Text -> CodeGen e ()
exportDecl (Text
name' forall a. Semigroup a => a -> a -> a
<> Text
"(..)")
forall e. HaddockSection -> Documentation -> CodeGen e ()
addSectionDocumentation HaddockSection
ToplevelSection (Interface -> Documentation
ifDocumentation Interface
iface)
Bool
isGO <- forall e. Name -> API -> CodeGen e Bool
apiIsGObject Name
n (Interface -> API
APIInterface Interface
iface)
if Bool
isGO
then do
let cn_ :: Text
cn_ = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
"GObject derived interface without a type!") (Interface -> Maybe Text
ifTypeInit Interface
iface)
[Name]
gobjectPrereqs <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM forall e. Name -> CodeGen e Bool
nameIsGObject (Interface -> [Name]
ifPrerequisites Interface
iface)
[[Name]]
allParents <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
gobjectPrereqs forall a b. (a -> b) -> a -> b
$ \Name
p -> (Name
p forall a. a -> [a] -> [a]
: ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Name -> CodeGen e [Name]
instanceTree Name
p
let uniqueParents :: [Name]
uniqueParents = forall a. Eq a => [a] -> [a]
nub (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Name]]
allParents)
Text
get_type_fn <- forall e. Name -> Text -> [Name] -> CodeGen e Text
genCasts Name
n Text
cn_ [Name]
uniqueParents
forall e. Name -> Text -> Text -> Text -> Text -> CodeGen e ()
genGValueInstance Name
n Text
get_type_fn Text
"B.ManagedPtr.newObject" Text
"B.GValue.get_object" Text
"B.GValue.set_object"
forall e. Name -> Interface -> CodeGen e ()
genInterfaceProperties Name
n Interface
iface
forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf CPPGuard
CPPOverloading forall a b. (a -> b) -> a -> b
$
forall e. Name -> [Property] -> [Method] -> CodeGen e ()
genNamespacedPropLabels Name
n (Interface -> [Property]
ifProperties Interface
iface) (Interface -> [Method]
ifMethods Interface
iface)
else forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
Text
cls <- forall e. Name -> CodeGen e Text
classConstraint Name
n
forall e. Text -> CodeGen e ()
exportDecl Text
cls
forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Text
"Type class for types which implement `"
forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
"`.")
let constraints :: Text
constraints = Text
"(ManagedPtrNewtype o, O.IsDescendantOf " forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
" o)"
forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"class " forall a. Semigroup a => a -> a -> a
<> Text
constraints forall a. Semigroup a => a -> a -> a
<> Text
" => " forall a. Semigroup a => a -> a -> a
<> Text
cls forall a. Semigroup a => a -> a -> a
<> Text
" o"
forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"instance " forall a. Semigroup a => a -> a -> a
<> Text
constraints forall a. Semigroup a => a -> a -> a
<> Text
" => " forall a. Semigroup a => a -> a -> a
<> Text
cls forall a. Semigroup a => a -> a -> a
<> Text
" o"
forall e. Name -> AllocationInfo -> Int -> CodeGen e ()
genWrappedPtr Name
n (Interface -> AllocationInfo
ifAllocationInfo Interface
iface) Int
0
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface -> [Property]
ifProperties forall a b. (a -> b) -> a -> b
$ Interface
iface) 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 ()
comment forall a b. (a -> b) -> a -> b
$ Text
"XXX Skipping property generation for non-GObject interface"
forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf CPPGuard
CPPOverloading forall a b. (a -> b) -> a -> b
$ forall e. Name -> Interface -> CodeGen e [(Name, Method)]
fullInterfaceMethodList Name
n Interface
iface forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall e. Name -> [(Name, Method)] -> CodeGen e ()
genMethodList Name
n
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Interface -> [Method]
ifMethods Interface
iface) forall a b. (a -> b) -> a -> b
$ \Method
f -> do
let mn :: Name
mn = Method -> Name
methodName Method
f
Bool
isFunction <- forall e. Text -> CodeGen e Bool
symbolFromFunction (Method -> Text
methodSymbol Method
f)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isFunction forall a b. (a -> b) -> a -> b
$
forall e a. (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a
handleCGExc
(\CGError
e -> do forall e. Text -> CodeGen e ()
comment (Text
"XXX Could not generate method "
forall a. Semigroup a => a -> a -> a
<> Text
name' forall a. Semigroup a => a -> a -> a
<> Text
"::" forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
mn)
forall e. CGError -> CodeGen e ()
printCGError CGError
e
forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf CPPGuard
CPPOverloading (forall e. Name -> Method -> CodeGen e ()
genUnsupportedMethodInfo Name
n Method
f))
(Name -> Method -> ExcCodeGen ()
genMethod Name
n Method
f)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Interface -> [Signal]
ifSignals Interface
iface) forall a b. (a -> b) -> a -> b
$ \Signal
s -> forall e a. (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a
handleCGExc
(\CGError
e -> do forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"-- XXX Could not generate signal ", Text
name', Text
"::"
, Signal -> Text
sigName Signal
s]
forall e. CGError -> CodeGen e ()
printCGError CGError
e)
(forall e. Signal -> Name -> CodeGen e ()
genSignal Signal
s Name
n)
forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf CPPGuard
CPPOverloading forall a b. (a -> b) -> a -> b
$
forall e. Name -> Interface -> CodeGen e ()
genInterfaceSignals Name
n Interface
iface
symbolFromFunction :: Text -> CodeGen e Bool
symbolFromFunction :: forall e. Text -> CodeGen e Bool
symbolFromFunction Text
sym = do
Map Name API
apis <- forall e. CodeGen e (Map Name API)
getAPIs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> API -> Bool
hasSymbol Text
sym forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Map Name API
apis
where
hasSymbol :: Text -> API -> Bool
hasSymbol Text
sym1 (APIFunction (Function { fnSymbol :: Function -> Text
fnSymbol = Text
sym2,
fnMovedTo :: Function -> Maybe Text
fnMovedTo = Maybe Text
movedTo })) =
Text
sym1 forall a. Eq a => a -> a -> Bool
== Text
sym2 Bool -> Bool -> Bool
&& Maybe Text
movedTo forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing
hasSymbol Text
_ API
_ = Bool
False
genAPI :: Name -> API -> CodeGen e ()
genAPI :: forall e. Name -> API -> CodeGen e ()
genAPI Name
n (APIConst Constant
c) = forall e. Name -> Constant -> CodeGen e ()
genConstant Name
n Constant
c
genAPI Name
n (APIFunction Function
f) = forall e. Name -> Function -> CodeGen e ()
genFunction Name
n Function
f
genAPI Name
n (APIEnum Enumeration
e) = forall e. Name -> Enumeration -> CodeGen e ()
genEnum Name
n Enumeration
e
genAPI Name
n (APIFlags Flags
f) = forall e. Name -> Flags -> CodeGen e ()
genFlags Name
n Flags
f
genAPI Name
n (APICallback Callback
c) = forall e. Name -> Callback -> CodeGen e ()
genCallback Name
n Callback
c
genAPI Name
n (APIStruct Struct
s) = forall e. Name -> Struct -> CodeGen e ()
genStruct Name
n Struct
s
genAPI Name
n (APIUnion Union
u) = forall e. Name -> Union -> CodeGen e ()
genUnion Name
n Union
u
genAPI Name
n (APIObject Object
o) = forall e. Name -> Object -> CodeGen e ()
genObject Name
n Object
o
genAPI Name
n (APIInterface Interface
i) = forall e. Name -> Interface -> CodeGen e ()
genInterface Name
n Interface
i
genAPIModule :: Name -> API -> CodeGen e ()
genAPIModule :: forall e. Name -> API -> CodeGen e ()
genAPIModule Name
n API
api = forall e. ModulePath -> CodeGen e () -> CodeGen e ()
submodule (Name -> API -> ModulePath
submoduleLocation Name
n API
api) forall a b. (a -> b) -> a -> b
$ forall e. Name -> API -> CodeGen e ()
genAPI Name
n API
api
genModule' :: M.Map Name API -> CodeGen e ()
genModule' :: forall e. Map Name API -> CodeGen e ()
genModule' Map Name API
apis = do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall e. Name -> API -> CodeGen e ()
genAPIModule)
forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, API) -> Bool
handWritten)
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Name, API) -> (Name, API)
fixAPIStructs
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Name, API) -> (Name, API)
dropDuplicatedFields
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse API -> Maybe API
dropMovedItems)
forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Map Name API
apis
forall e. ModulePath -> CodeGen e () -> CodeGen e ()
submodule ModulePath
"Callbacks" (forall (m :: * -> *) a. Monad m => a -> m a
return ())
where
handWritten :: (Name, API) -> Bool
handWritten :: (Name, API) -> Bool
handWritten (Name Text
"GLib" Text
"Array", API
_) = Bool
True
handWritten (Name Text
"GLib" Text
"Error", API
_) = Bool
True
handWritten (Name Text
"GLib" Text
"HashTable", API
_) = Bool
True
handWritten (Name Text
"GLib" Text
"List", API
_) = Bool
True
handWritten (Name Text
"GLib" Text
"SList", API
_) = Bool
True
handWritten (Name Text
"GLib" Text
"Variant", API
_) = Bool
True
handWritten (Name Text
"GObject" Text
"Value", API
_) = Bool
True
handWritten (Name Text
"GObject" Text
"Closure", API
_) = Bool
True
handWritten (Name, API)
_ = Bool
False
genModule :: M.Map Name API -> CodeGen e ()
genModule :: forall e. Map Name API -> CodeGen e ()
genModule Map Name API
apis = do
forall e. Text -> CodeGen e ()
line Text
"import Data.GI.Base"
forall e. Text -> CodeGen e ()
exportModule Text
"Data.GI.Base"
let embeddedAPIs :: Map Name API
embeddedAPIs = (Map Name API -> Map Name API
fixAPIs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name, API) -> [(Name, API)]
extractCallbacksInStruct
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.toList) Map Name API
apis
Map Name API
allAPIs <- forall e. CodeGen e (Map Name API)
getAPIs
let contextAPIs :: Map Name API
contextAPIs = forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union (Map Name API -> Map Name API
fixAPIs Map Name API
allAPIs) Map Name API
embeddedAPIs
targetAPIs :: Map Name API
targetAPIs = forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union (Map Name API -> Map Name API
fixAPIs Map Name API
apis) Map Name API
embeddedAPIs
forall e. Map Name API -> CodeGen e () -> CodeGen e ()
recurseWithAPIs Map Name API
contextAPIs (forall e. Map Name API -> CodeGen e ()
genModule' Map Name API
targetAPIs)
where
fixAPIs :: M.Map Name API -> M.Map Name API
fixAPIs :: Map Name API -> Map Name API
fixAPIs Map Name API
apis = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Name, API) -> (Name, API)
guessPropertyNullability
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Name, API) -> (Name, API)
detectGObject
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Name, API) -> (Name, API)
checkClosureDestructors
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Name, API) -> (Name, API)
fixSymbolNaming
forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Map Name API
apis