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,
                               fixClosures, fixCallbackUserData)
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.
    Bool
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Text
forall a. Maybe a
Nothing Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
fnMovedTo) (ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$
      ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e a. CodeGen e a -> CodeGen e a
group (ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ do
        Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. Text -> CodeGen e ()
line (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ Text
"-- function " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
n
        (CGError
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ExcCodeGen ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e a. (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a
handleCGExc (\CGError
e -> do
                        Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. Text -> CodeGen e ()
line (Text
"-- XXX Could not generate function "
                              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
n
                              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n")
                        CGError
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. CGError -> CodeGen e ()
printCGError CGError
e)
                        (do
                          Name -> Text -> Callable -> ExcCodeGen ()
genCCallableWrapper Name
n Text
symbol Callable
callable
                          HaddockSection -> Text -> ExcCodeGen ()
forall e. HaddockSection -> Text -> CodeGen e ()
export (NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
MethodSection (Text -> HaddockSection) -> Text -> HaddockSection
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
  CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
group (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
bline (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"newtype " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (SP.ManagedPtr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
indent (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"deriving (Eq)"

  CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
group (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
bline (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"instance SP.ManagedPtrNewtype " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where"
    CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
indent (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"toManagedPtr (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
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 = Bool
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Name -> Struct -> Bool
ignoreStruct Name
n Struct
s) (ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ do
   let Name Text
_ Text
name' = API -> Name -> Name
normalizedAPIName (Struct -> API
APIStruct Struct
s) Name
n

   RelativeDocPosition
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Text
"Memory-managed wrapper type.")
   Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. Text -> CodeGen e ()
genNewtype Text
name'
   Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. Text -> CodeGen e ()
exportDecl (Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text
"(..)"))

   HaddockSection
-> Documentation
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. HaddockSection -> Documentation -> CodeGen e ()
addSectionDocumentation HaddockSection
ToplevelSection (Struct -> Documentation
structDocumentation Struct
s)

   if Struct -> Bool
structIsBoxed Struct
s
   then Name
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. Name -> Text -> CodeGen e ()
genBoxed Name
n (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Struct -> Maybe Text
structTypeInit Struct
s)
   else Name
-> AllocationInfo
-> Int
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
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.
   Name
-> Struct
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. Name -> Struct -> CodeGen e ()
genZeroStruct Name
n Struct
s

   -- Generate code for fields.
   Name
-> [Field]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. Name -> [Field] -> CodeGen e ()
genStructOrUnionFields Name
n (Struct -> [Field]
structFields Struct
s)

   -- Methods
   methods <- [Method]
-> (Method
    -> ReaderT
         CodeGenConfig
         (StateT (CGState, ModuleInfo) (Except e))
         (Maybe (Name, Method)))
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     [Maybe (Name, Method)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Struct -> [Method]
structMethods Struct
s) ((Method
  -> ReaderT
       CodeGenConfig
       (StateT (CGState, ModuleInfo) (Except e))
       (Maybe (Name, Method)))
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except e))
      [Maybe (Name, Method)])
-> (Method
    -> ReaderT
         CodeGenConfig
         (StateT (CGState, ModuleInfo) (Except e))
         (Maybe (Name, Method)))
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     [Maybe (Name, Method)]
forall a b. (a -> b) -> a -> b
$ \Method
f -> do
       let mn :: Name
mn = Method -> Name
methodName Method
f
       isFunction <- Text -> CodeGen e Bool
forall e. Text -> CodeGen e Bool
symbolFromFunction (Method -> Text
methodSymbol Method
f)
       if not isFunction
       then handleCGExc
               (\CGError
e -> do Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. Text -> CodeGen e ()
line (Text
"-- XXX Could not generate method "
                               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"::" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
mn)
                         CGError
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. CGError -> CodeGen e ()
printCGError CGError
e
                         Maybe (Name, Method)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe (Name, Method))
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Name, Method)
forall a. Maybe a
Nothing)
               (genMethod n f >> return (Just (n, f)))
       else return Nothing

   -- Overloaded methods
   cppIf CPPOverloading (genMethodList n (catMaybes 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

  RelativeDocPosition -> Text -> CodeGen e ()
forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Text
"Memory-managed wrapper type.")
  Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
genNewtype Text
name'
  Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
exportDecl (Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(..)")

  HaddockSection -> Documentation -> CodeGen e ()
forall e. HaddockSection -> Documentation -> CodeGen e ()
addSectionDocumentation HaddockSection
ToplevelSection (Union -> Documentation
unionDocumentation Union
u)

  if Union -> Bool
unionIsBoxed Union
u
  then Name -> Text -> CodeGen e ()
forall e. Name -> Text -> CodeGen e ()
genBoxed Name
n (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Union -> Maybe Text
unionTypeInit Union
u)
  else Name -> AllocationInfo -> Int -> CodeGen e ()
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.
  Name -> Union -> CodeGen e ()
forall e. Name -> Union -> CodeGen e ()
genZeroUnion Name
n Union
u

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

  -- Methods
  methods <- [Method]
-> (Method
    -> ReaderT
         CodeGenConfig
         (StateT (CGState, ModuleInfo) (Except e))
         (Maybe (Name, Method)))
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     [Maybe (Name, Method)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Union -> [Method]
unionMethods Union
u) ((Method
  -> ReaderT
       CodeGenConfig
       (StateT (CGState, ModuleInfo) (Except e))
       (Maybe (Name, Method)))
 -> ReaderT
      CodeGenConfig
      (StateT (CGState, ModuleInfo) (Except e))
      [Maybe (Name, Method)])
-> (Method
    -> ReaderT
         CodeGenConfig
         (StateT (CGState, ModuleInfo) (Except e))
         (Maybe (Name, Method)))
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     [Maybe (Name, Method)]
forall a b. (a -> b) -> a -> b
$ \Method
f -> do
      let mn :: Name
mn = Method -> Name
methodName Method
f
      isFunction <- Text -> CodeGen e Bool
forall e. Text -> CodeGen e Bool
symbolFromFunction (Method -> Text
methodSymbol Method
f)
      if not isFunction
      then handleCGExc
                (\CGError
e -> do Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text
"-- XXX Could not generate method "
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"::" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
mn)
                          CGError -> CodeGen e ()
forall e. CGError -> CodeGen e ()
printCGError CGError
e
                          Maybe (Name, Method)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe (Name, Method))
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Name, Method)
forall a. Maybe a
Nothing)
                (genMethod n f >> return (Just (n, f)))
      else return Nothing

  -- Overloaded methods
  cppIf CPPOverloading $ genMethodList n (catMaybes 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 = args'' , returnType = returnType' }
    where
      returnType' :: Maybe Type
returnType' = Maybe Type -> (Type -> Maybe Type) -> Maybe Type -> Maybe Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe Type
forall a. Maybe a
Nothing (Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> (Type -> Type) -> Type -> Maybe Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
fixCArrayLength) (Callable -> Maybe Type
returnType Callable
c)
      args' :: [Arg]
args' = (Arg -> Arg) -> [Arg] -> [Arg]
forall a b. (a -> b) -> [a] -> [b]
map (Arg -> Arg
fixDestroyers (Arg -> Arg) -> (Arg -> Arg) -> Arg -> Arg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg -> Arg
fixClosures (Arg -> Arg) -> (Arg -> Arg) -> Arg -> Arg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg -> Arg
fixLengthArg) (Callable -> [Arg]
args Callable
c)
      args'' :: [Arg]
args'' = case [Arg]
args' of
        Arg
inst:[Arg]
rest -> Arg -> Arg
fixInstanceDirection Arg
inst Arg -> [Arg] -> [Arg]
forall a. a -> [a] -> [a]
: [Arg]
rest
        [] -> []

      fixLengthArg :: Arg -> Arg
      fixLengthArg :: Arg -> Arg
fixLengthArg Arg
arg = Arg
arg { argType = fixCArrayLength (argType arg)}

      fixCArrayLength :: Type -> Type
      fixCArrayLength :: Type -> Type
fixCArrayLength (TCArray Bool
zt Int
fixed Int
length Type
t) =
          if Int
length Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> -Int
1
          then Bool -> Int -> Int -> Type -> Type
TCArray Bool
zt Int
fixed (Int
lengthInt -> Int -> Int
forall 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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> -Int
1
                          then Arg
arg {argDestroy = destroy + 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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> -Int
1
                        then Arg
arg {argClosure = closure + 1}
                        else Arg
arg

      -- We always treat the instance argument of a method as "in",
      -- even if the introspection data says otherwise (this is
      -- generally an erroneous annotation, meaning that the structure
      -- is modified).
      fixInstanceDirection :: Arg -> Arg
      fixInstanceDirection :: Arg -> Arg
fixInstanceDirection Arg
arg = Arg
arg { 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 = returnType' }
    where
      returnType' :: Maybe Type
returnType' = if Bool
returnsGObject then
                        Type -> Maybe Type
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
    returnsGObject <- ReaderT
  CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Bool
-> (Type
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Bool)
-> Maybe Type
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Bool
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) Type
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Bool
forall e. Type -> CodeGen e Bool
isGObject (Callable -> Maybe Type
returnType Callable
c)
    line $ "-- method " <> name' <> "::" <> name mn
    line $ "-- method type : " <> tshow t
    let -- Mangle the name to namespace it to the class.
        mn' = Name
mn { name = name cn <> "_" <> name mn }
    let c'  = if MethodType
Constructor MethodType -> MethodType -> Bool
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'' = if MethodType
OrdinaryMethod MethodType -> MethodType -> Bool
forall a. Eq a => a -> a -> Bool
== MethodType
t
              then Callable -> Callable
fixMethodArgs Callable
c'
              else Callable
c'
    genCCallableWrapper mn' sym c''
    export (NamedSubsection MethodSection $ lowerName mn) (lowerName mn')

    cppIf CPPOverloading $
      genMethodInfo cn (m {methodCallable = 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 = CodeGen e Text -> CodeGen e Text
forall e a. CodeGen e a -> CodeGen e a
group (CodeGen e Text -> CodeGen e Text)
-> CodeGen e Text -> CodeGen e Text
forall a b. (a -> b) -> a -> b
$ do
  let symb :: Text
symb = Text
"gv_get_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
get_value_fn
  Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"foreign import ccall \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
get_value_fn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
symb Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ::"
  CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
indent (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"FP.Ptr B.GValue.GValue -> IO (FP.Ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  Text -> CodeGen e Text
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
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 = CodeGen e Text -> CodeGen e Text
forall e a. CodeGen e a -> CodeGen e a
group (CodeGen e Text -> CodeGen e Text)
-> CodeGen e Text -> CodeGen e Text
forall a b. (a -> b) -> a -> b
$ do
  let symb :: Text
symb = Text
"gv_set_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
set_value_fn
  Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"foreign import ccall \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
set_value_fn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
symb Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ::"
  CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
indent (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"FP.Ptr B.GValue.GValue -> FP.Ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> IO ()"
  Text -> CodeGen e Text
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
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 t'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' to and from t'Data.GI.Base.GValue.GValue'. See 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'."

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

  CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
group (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
bline (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"instance B.GValue.IsGValue (Maybe " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") where"
    CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
indent (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
group (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"gvalueGType_ = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
get_type_fn
      Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"gvalueSet_ gv P.Nothing = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
set_value_fn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" gv (FP.nullPtr :: FP.Ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
      Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"gvalueSet_ gv (P.Just obj) = B.ManagedPtr.withManagedPtr obj (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
set_value_fn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" gv)"
      Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"gvalueGet_ gv = do"
      CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
indent (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ CodeGen e () -> CodeGen e ()
forall e a. CodeGen e a -> CodeGen e a
group (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"ptr <- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
get_value_fn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" gv :: IO (FP.Ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
        Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"if ptr /= FP.nullPtr"
        Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"then P.Just <$> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
newFn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ptr"
        Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"else return P.Nothing"

-- | 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
  isGO <- Type -> CodeGen e Bool
forall e. Type -> CodeGen e Bool
isGObject (Name -> Type
TInterface Name
n)
  let name' = Name -> Text
upperName Name
n

  get_type_fn <- do
    let cn_ = Text
"c_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ti
    group $ do
      line $ "foreign import ccall \"" <> ti <> "\""
      indent $ line $ cn_ <> " :: IO B.Types.GType"
    return cn_

  group $ do
    bline $ "instance B.Types.TypedObject " <> name' <> " where"
    indent $ do
      line $ "glibType = " <> get_type_fn

  when isGO $ group $ do
      bline $ "instance B.Types.GObject " <> name'

  className <- classConstraint n
  group $ do
    exportDecl className
    writeHaddock DocBeforeSymbol (classDoc 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 = if Bool
isGO
                      then Text
"(SP.GObject o, O.IsDescendantOf " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" o)"
                      else Text
"(SP.BoxedPtr o, SP.TypedObject o, O.IsDescendantOf " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" o)"
    bline $ "class " <> constraints <> " => " <> className <> " o"
    bline $ "instance " <> constraints <> " => " <> className <> " o"

    blank

    parentAPIs <- mapM (\Name
n -> Type
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) API
forall e. HasCallStack => Type -> CodeGen e API
getAPI (Name -> Type
TInterface Name
n)) parents
    qualifiedParents <- mapM (uncurry qualifiedAPI) (zip parentAPIs parents)
    bline $ "instance O.HasParentTypes " <> name'
    line $ "type instance O.ParentTypes " <> name' <> " = '["
      <> T.intercalate ", " qualifiedParents <> "]"

  -- Safe downcasting.
  group $ do
    cast <- safeCast n
    exportDecl cast
    writeHaddock DocBeforeSymbol (castDoc name')
    bline $ cast <> " :: (MIO.MonadIO m, " <> className <> " o) => o -> m " <> name'
    line $ cast <> " = MIO.liftIO . B.ManagedPtr.unsafeCastTo " <> name'

  return get_type_fn

  where castDoc :: Text -> Text
        castDoc :: Text -> Text
castDoc Text
name' = Text
"Cast to t'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                        Text
"', for types for which this is known to be safe. " Text -> Text -> Text
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 t'"
                         Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"', for instance with `to" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
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
  isGO <- Type -> CodeGen e Bool
forall e. Type -> CodeGen e Bool
isGObject Type
t

  writeHaddock DocBeforeSymbol ("Memory-managed wrapper type.")
  genNewtype name'
  exportDecl (name' <> "(..)")

  addSectionDocumentation ToplevelSection (objDocumentation o)

  -- Type safe casting to parent objects, and implemented interfaces.
  parents <- instanceTree n
  get_type_fn <- genCasts n (objTypeInit o) (parents <> objInterfaces o)

  if isGO
    then genGValueInstance n get_type_fn "B.ManagedPtr.newObject" "B.GValue.get_object" "B.GValue.set_object"
    else case (objGetValueFunc o, objSetValueFunc o) of
           (Just Text
get_value_fn, Just Text
set_value_fn) -> do
             getter <- Text -> Text -> CodeGen e Text
forall e. Text -> Text -> CodeGen e Text
genGValueGetter Text
name' Text
get_value_fn
             setter <- genGValueSetter name' set_value_fn
             genGValueInstance n get_type_fn "B.ManagedPtr.newPtr" getter setter
           (Maybe Text, Maybe Text)
_ -> Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"--- XXX Missing getter and/or setter, so no GValue instance could be generated."

  cppIf CPPOverloading $ fullObjectMethodList n o >>= genMethodList n

  if isGO
    then do
      forM_ (objSignals o) $ \Signal
s -> Signal -> Name -> CodeGen e ()
forall e. Signal -> Name -> CodeGen e ()
genSignal Signal
s Name
n

      genObjectProperties n o
      cppIf CPPOverloading $
        genNamespacedPropLabels n (objProperties o) (objMethods o)
      cppIf CPPOverloading $
        genObjectSignals n o
    else group $ do
      let 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
            }
      genWrappedPtr n allocInfo 0

  -- Methods
  forM_ (objMethods o) $ \Method
f -> do
    let mn :: Name
mn = Method -> Name
methodName Method
f
    (CGError -> CodeGen e ()) -> ExcCodeGen () -> CodeGen e ()
forall e a. (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a
handleCGExc (\CGError
e -> do Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text
"-- XXX Could not generate method "
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"::" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
mn)
                          CGError -> CodeGen e ()
forall e. CGError -> CodeGen e ()
printCGError CGError
e
                          CPPGuard -> CodeGen e () -> CodeGen e ()
forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf CPPGuard
CPPOverloading (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$
                            Name -> Method -> CodeGen e ()
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

  Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"-- interface " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
  RelativeDocPosition -> Text -> CodeGen e ()
forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Text
"Memory-managed wrapper type.")
  Text -> Maybe DeprecationInfo -> CodeGen e ()
forall e. Text -> Maybe DeprecationInfo -> CodeGen e ()
deprecatedPragma Text
name' (Maybe DeprecationInfo -> CodeGen e ())
-> Maybe DeprecationInfo -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Interface -> Maybe DeprecationInfo
ifDeprecated Interface
iface
  Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
genNewtype Text
name'
  Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
exportDecl (Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(..)")

  HaddockSection -> Documentation -> CodeGen e ()
forall e. HaddockSection -> Documentation -> CodeGen e ()
addSectionDocumentation HaddockSection
ToplevelSection (Interface -> Documentation
ifDocumentation Interface
iface)

  isGO <- Name -> API -> CodeGen e Bool
forall e. Name -> API -> CodeGen e Bool
apiIsGObject Name
n (Interface -> API
APIInterface Interface
iface)
  if isGO
  then do
    let cn_ = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (String -> Text
forall a. HasCallStack => String -> a
error String
"GObject derived interface without a type!") (Interface -> Maybe Text
ifTypeInit Interface
iface)
    gobjectPrereqs <- filterM nameIsGObject (ifPrerequisites iface)
    allParents <- forM gobjectPrereqs $ \Name
p -> (Name
p Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: ) ([Name] -> [Name])
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Name]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Name]
forall e. Name -> CodeGen e [Name]
instanceTree Name
p
    let uniqueParents = [Name] -> [Name]
forall a. Eq a => [a] -> [a]
nub ([[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Name]]
allParents)
    get_type_fn <- genCasts n cn_ uniqueParents
    genGValueInstance n get_type_fn "B.ManagedPtr.newObject" "B.GValue.get_object" "B.GValue.set_object"

    genInterfaceProperties n iface
    cppIf CPPOverloading $
       genNamespacedPropLabels n (ifProperties iface) (ifMethods iface)

  else group $ do
    cls <- classConstraint n
    exportDecl cls
    writeHaddock DocBeforeSymbol ("Type class for types which implement t'"
                                  <> name' <> "'.")

    -- 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
"(ManagedPtrNewtype o, O.IsDescendantOf " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" o)"
    bline $ "class " <> constraints <> " => " <> cls <> " o"
    bline $ "instance " <> constraints <> " => " <> cls <> " o"

    genWrappedPtr n (ifAllocationInfo iface) 0

    when (not . null . ifProperties $ iface) $ group $ do
       comment $ "XXX Skipping property generation for non-GObject interface"

  -- Methods
  cppIf CPPOverloading $ fullInterfaceMethodList n iface >>= genMethodList n

  forM_ (ifMethods iface) $ \Method
f -> do
      let mn :: Name
mn = Method -> Name
methodName Method
f
      isFunction <- Text -> CodeGen e Bool
forall e. Text -> CodeGen e Bool
symbolFromFunction (Method -> Text
methodSymbol Method
f)
      unless isFunction $
             handleCGExc
             (\CGError
e -> do Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
comment (Text
"XXX Could not generate method "
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"::" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
mn)
                       CGError -> CodeGen e ()
forall e. CGError -> CodeGen e ()
printCGError CGError
e
                       CPPGuard -> CodeGen e () -> CodeGen e ()
forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf CPPGuard
CPPOverloading (Name -> Method -> CodeGen e ()
forall e. Name -> Method -> CodeGen e ()
genUnsupportedMethodInfo Name
n Method
f))
             (genMethod n f)

  -- Signals
  forM_ (ifSignals iface) $ \Signal
s -> (CGError -> CodeGen e ()) -> ExcCodeGen () -> CodeGen e ()
forall e a. (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a
handleCGExc
     (\CGError
e -> do Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
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]
               CGError -> CodeGen e ()
forall e. CGError -> CodeGen e ()
printCGError CGError
e)
     (Signal -> Name -> ExcCodeGen ()
forall e. Signal -> Name -> CodeGen e ()
genSignal Signal
s Name
n)

  cppIf CPPOverloading $
     genInterfaceSignals n 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
    apis <- CodeGen e (Map Name API)
forall e. CodeGen e (Map Name API)
getAPIs
    return $ any (hasSymbol sym . snd) $ M.toList 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 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
sym2 Bool -> Bool -> Bool
&& Maybe Text
movedTo Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
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) = Name -> Constant -> CodeGen e ()
forall e. Name -> Constant -> CodeGen e ()
genConstant Name
n Constant
c
genAPI Name
n (APIFunction Function
f) = Name -> Function -> CodeGen e ()
forall e. Name -> Function -> CodeGen e ()
genFunction Name
n Function
f
genAPI Name
n (APIEnum Enumeration
e) = Name -> Enumeration -> CodeGen e ()
forall e. Name -> Enumeration -> CodeGen e ()
genEnum Name
n Enumeration
e
genAPI Name
n (APIFlags Flags
f) = Name -> Flags -> CodeGen e ()
forall e. Name -> Flags -> CodeGen e ()
genFlags Name
n Flags
f
genAPI Name
n (APICallback Callback
c) = Name -> Callback -> CodeGen e ()
forall e. Name -> Callback -> CodeGen e ()
genCallback Name
n Callback
c
genAPI Name
n (APIStruct Struct
s) = Name -> Struct -> CodeGen e ()
forall e. Name -> Struct -> CodeGen e ()
genStruct Name
n Struct
s
genAPI Name
n (APIUnion Union
u) = Name -> Union -> CodeGen e ()
forall e. Name -> Union -> CodeGen e ()
genUnion Name
n Union
u
genAPI Name
n (APIObject Object
o) = Name -> Object -> CodeGen e ()
forall e. Name -> Object -> CodeGen e ()
genObject Name
n Object
o
genAPI Name
n (APIInterface Interface
i) = Name -> Interface -> CodeGen e ()
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 = ModulePath -> CodeGen e () -> CodeGen e ()
forall e. ModulePath -> CodeGen e () -> CodeGen e ()
submodule (Name -> API -> ModulePath
submoduleLocation Name
n API
api) (CodeGen e () -> CodeGen e ()) -> CodeGen e () -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Name -> API -> CodeGen e ()
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
  ((Name, API)
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> [(Name, API)]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Name
 -> API
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> (Name, API)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name
-> API
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. Name -> API -> CodeGen e ()
genAPIModule)
    -- We provide these ourselves
    ([(Name, API)]
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> [(Name, API)]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ ((Name, API) -> Bool) -> [(Name, API)] -> [(Name, API)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ((Name, API) -> Bool) -> (Name, API) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, API) -> Bool
handWritten)
    -- Some callback types are defined inside structs
    ([(Name, API)] -> [(Name, API)]) -> [(Name, API)] -> [(Name, API)]
forall a b. (a -> b) -> a -> b
$ ((Name, API) -> (Name, API)) -> [(Name, API)] -> [(Name, API)]
forall a b. (a -> b) -> [a] -> [b]
map (Name, API) -> (Name, API)
fixAPIStructs
    -- Some APIs contain duplicated fields by mistake, drop
    -- the duplicates.
    ([(Name, API)] -> [(Name, API)]) -> [(Name, API)] -> [(Name, API)]
forall a b. (a -> b) -> a -> b
$ ((Name, API) -> (Name, API)) -> [(Name, API)] -> [(Name, API)]
forall a b. (a -> b) -> [a] -> [b]
map (Name, API) -> (Name, API)
dropDuplicatedFields
    ([(Name, API)] -> [(Name, API)]) -> [(Name, API)] -> [(Name, API)]
forall a b. (a -> b) -> a -> b
$ ((Name, API) -> Maybe (Name, API))
-> [(Name, API)] -> [(Name, API)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((API -> Maybe API) -> (Name, API) -> Maybe (Name, API)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (Name, a) -> f (Name, b)
traverse API -> Maybe API
dropMovedItems)
    ([(Name, API)] -> [(Name, API)]) -> [(Name, API)] -> [(Name, API)]
forall a b. (a -> b) -> a -> b
$ Map Name API -> [(Name, API)]
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.
  ModulePath
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. ModulePath -> CodeGen e () -> CodeGen e ()
submodule ModulePath
"Callbacks" (()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
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).
  Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line Text
"import Data.GI.Base"
  Text -> CodeGen e ()
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 (Map Name API -> Map Name API)
-> (Map Name API -> Map Name API) -> Map Name API -> Map Name API
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Name, API)] -> Map Name API
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
                     ([(Name, API)] -> Map Name API)
-> (Map Name API -> [(Name, API)]) -> Map Name API -> Map Name API
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, API) -> [(Name, API)]) -> [(Name, API)] -> [(Name, API)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name, API) -> [(Name, API)]
extractCallbacksInStruct
                     ([(Name, API)] -> [(Name, API)])
-> (Map Name API -> [(Name, API)]) -> Map Name API -> [(Name, API)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Name API -> [(Name, API)]
forall k a. Map k a -> [(k, a)]
M.toList) Map Name API
apis
  allAPIs <- CodeGen e (Map Name API)
forall e. CodeGen e (Map Name API)
getAPIs
  let contextAPIs = Map Name API -> Map Name API -> Map Name API
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 -> Map Name API -> Map Name API
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

  recurseWithAPIs contextAPIs (genModule' targetAPIs)

  where
    fixAPIs :: M.Map Name API -> M.Map Name API
    fixAPIs :: Map Name API -> Map Name API
fixAPIs Map Name API
apis = [(Name, API)] -> Map Name API
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.
      ([(Name, API)] -> Map Name API) -> [(Name, API)] -> Map Name API
forall a b. (a -> b) -> a -> b
$ ((Name, API) -> (Name, API)) -> [(Name, API)] -> [(Name, API)]
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.
      ([(Name, API)] -> [(Name, API)]) -> [(Name, API)] -> [(Name, API)]
forall a b. (a -> b) -> a -> b
$ ((Name, API) -> (Name, API)) -> [(Name, API)] -> [(Name, API)]
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.
      ([(Name, API)] -> [(Name, API)]) -> [(Name, API)] -> [(Name, API)]
forall a b. (a -> b) -> a -> b
$ ((Name, API) -> (Name, API)) -> [(Name, API)] -> [(Name, API)]
forall a b. (a -> b) -> [a] -> [b]
map (Name, API) -> (Name, API)
checkClosureDestructors
      -- Make sure that the argClosure argument refers to a callback,
      -- not to the user_data field.
      ([(Name, API)] -> [(Name, API)]) -> [(Name, API)] -> [(Name, API)]
forall a b. (a -> b) -> a -> b
$ ((Name, API) -> (Name, API)) -> [(Name, API)] -> [(Name, API)]
forall a b. (a -> b) -> [a] -> [b]
map (Name, API) -> (Name, API)
fixClosures
      -- Make sure that the user_data argument of callbacks is
      -- annotated as such.
      ([(Name, API)] -> [(Name, API)]) -> [(Name, API)] -> [(Name, API)]
forall a b. (a -> b) -> a -> b
$ ((Name, API) -> (Name, API)) -> [(Name, API)] -> [(Name, API)]
forall a b. (a -> b) -> [a] -> [b]
map (Name, API) -> (Name, API)
fixCallbackUserData
      -- Make sure that the symbols to be generated are valid
      -- Haskell identifiers, when necessary.
      ([(Name, API)] -> [(Name, API)]) -> [(Name, API)] -> [(Name, API)]
forall a b. (a -> b) -> a -> b
$ ((Name, API) -> (Name, API)) -> [(Name, API)] -> [(Name, API)]
forall a b. (a -> b) -> [a] -> [b]
map (Name, API) -> (Name, API)
fixSymbolNaming
      ([(Name, API)] -> [(Name, API)]) -> [(Name, API)] -> [(Name, API)]
forall a b. (a -> b) -> a -> b
$ Map Name API -> [(Name, API)]
forall k a. Map k a -> [(k, a)]
M.toList Map Name API
apis