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) =
    -- Only generate the function if it has not been moved.
    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)
                        )

-- | Create the newtype wrapping the ManagedPtr for the given type.
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"

-- | Generate wrapper for structures.
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)

   -- Generate a builder for a structure filled with zeroes.
   forall e. Name -> Struct -> CodeGen e ()
genZeroStruct Name
n Struct
s

   -- Generate code for fields.
   forall e. Name -> [Field] -> CodeGen e ()
genStructOrUnionFields Name
n (Struct -> [Field]
structFields Struct
s)

   -- Methods
   [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

   -- Overloaded methods
   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))

-- | Generated wrapper for unions.
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)

  -- Generate a builder for a structure filled with zeroes.
  forall e. Name -> Union -> CodeGen e ()
genZeroUnion Name
n Union
u

  -- Generate code for fields.
  forall e. Name -> [Field] -> CodeGen e ()
genStructOrUnionFields Name
n (Union -> [Field]
unionFields Union
u)

  -- Methods
  [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

  -- Overloaded methods
  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)

-- | When parsing the GIR file we add the implicit object argument to
-- methods of an object.  Since we are prepending an argument we need
-- to adjust the offset of the length arguments of CArrays, and
-- closure and destroyer offsets.
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

      -- We always treat the instance argument of a method as non-null
      -- and "in", even if sometimes the introspection data may say
      -- otherwise.
      fixInstance :: Arg -> Arg
      fixInstance :: Arg -> Arg
fixInstance Arg
arg = Arg
arg { mayBeNull :: Bool
mayBeNull = Bool
False
                            , direction :: Direction
direction = Direction
DirectionIn}

-- For constructors we want to return the actual type of the object,
-- rather than a generic superclass (so Gtk.labelNew returns a
-- Gtk.Label, rather than a Gtk.Widget)
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 -- Mangle the name to namespace it to the class.
        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''})

-- | Generate an import for the gvalue getter for the given type. It
-- returns the name of the function on the Haskell side.
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

-- | Generate an import for the gvalue setter for the given type. It
-- returns the name of the function on the Haskell side.
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

-- | Generate the GValue instances for the given GObject.
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"

-- | Type casting with type checking, returns the function returning the
-- GType for the oject.
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')

    -- Create the IsX constraint. We cannot simply say
    --
    -- > type IsX o = (GObject o, ...)
    --
    -- since we sometimes need to refer to @IsX@ itself, without
    -- applying it. We instead use the trick of creating a class with
    -- a universal instance.
    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
"]"

  -- Safe downcasting.
  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
"`."

-- | Wrap a given Object. We enforce that every Object that we wrap is a
-- GObject. This is the case for everything except the ParamSpec* set
-- of objects, we deal with these separately.
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)

  -- Type safe casting to parent objects, and implemented interfaces.
  [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

  -- Methods
  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
"`.")

    -- Create the IsX constraint. We cannot simply say
    --
    -- > type IsX o = (ManagedPtrNewtype o, O.IsDescendantOf X o)
    --
    -- since we sometimes need to refer to @IsX@ itself, without
    -- applying it. We instead use the trick of creating a class with
    -- a universal instance.
    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"

  -- Methods
  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)

  -- Signals
  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

-- Some type libraries include spurious interface/struct methods,
-- where a method Mod.Foo::func also appears as an ordinary function
-- in the list of APIs. If we find a matching function (without the
-- "moved-to" annotation), we don't generate the method.
--
-- It may be more expedient to keep a map of symbol -> function.
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

-- | Generate the code for a given API in the corresponding module.
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)
    -- We provide these ourselves
    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)
    -- Some callback types are defined inside structs
    forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Name, API) -> (Name, API)
fixAPIStructs
    -- Some APIs contain duplicated fields by mistake, drop
    -- the duplicates.
    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

  -- Make sure we generate a "Callbacks" module, since it is imported
  -- by other modules. It is fine if it ends up empty.
  forall e. ModulePath -> CodeGen e () -> CodeGen e ()
submodule ModulePath
"Callbacks" (forall (m :: * -> *) a. Monad m => a -> m a
return ())
  where
    -- Whether we provide hand-written bindings for the given API,
    -- replacing the ones that would be autogenerated from the
    -- introspection data.
    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
  -- Reexport Data.GI.Base for convenience (so it does not need to be
  -- imported separately).
  forall e. Text -> CodeGen e ()
line Text
"import Data.GI.Base"
  forall e. Text -> CodeGen e ()
exportModule Text
"Data.GI.Base"

  -- Some API symbols are embedded into structures, extract these and
  -- inject them into the set of APIs loaded and being generated.
  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
      -- Try to guess nullability of properties when there is no
      -- nullability info in the GIR.
      forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Name, API) -> (Name, API)
guessPropertyNullability
      -- Not every interface providing signals or properties is
      -- correctly annotated as descending from GObject, fix this.
      forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Name, API) -> (Name, API)
detectGObject
      -- Make sure that every argument marked as being a
      -- destructor for a user_data argument has an associated
      -- user_data argument.
      forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Name, API) -> (Name, API)
checkClosureDestructors
      -- Make sure that the symbols to be generated are valid
      -- Haskell identifiers, when necessary.
      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