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)
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,
                  genWrappedPtr)
import Data.GI.CodeGen.SymbolNaming (upperName, classConstraint, noName,
                                     submoduleLocation, lowerName, qualifiedAPI)
import Data.GI.CodeGen.Type
import Data.GI.CodeGen.Util (tshow)

-- | Standard derived instances for newtypes wrapping @ManagedPtr@s.
newtypeDeriving :: CodeGen ()
newtypeDeriving :: BaseCodeGen e ()
newtypeDeriving = BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "deriving (Eq)"

genFunction :: Name -> Function -> CodeGen ()
genFunction :: Name -> Function -> CodeGen ()
genFunction n :: Name
n (Function symbol :: Text
symbol fnMovedTo :: Maybe Text
fnMovedTo callable :: 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. BaseCodeGen e a -> BaseCodeGen 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)) ()
Text -> CodeGen ()
line (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ "-- function " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
symbol
        (CGError -> CodeGen ()) -> ExcCodeGen () -> CodeGen ()
forall a. (CGError -> CodeGen a) -> ExcCodeGen a -> CodeGen a
handleCGExc (\e :: CGError
e -> Text -> CodeGen ()
line ("-- XXX Could not generate function "
                           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
symbol
                           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n-- Error was : " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CGError -> Text
describeCGError CGError
e))
                        (do
                          Name -> Text -> Callable -> ExcCodeGen ()
genCCallableWrapper Name
n Text
symbol Callable
callable
                          HaddockSection -> Text -> CodeGen ()
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)
                        )

-- | Generate the GValue instances for the given GObject.
genBoxedGValueInstance :: Name -> Text -> CodeGen ()
genBoxedGValueInstance :: Name -> Text -> CodeGen ()
genBoxedGValueInstance n :: Name
n get_type_fn :: Text
get_type_fn = do
  let name' :: Text
name' = Name -> Text
upperName Name
n
      doc :: Text
doc = "Convert '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "' to and from 'Data.GI.Base.GValue.GValue' with 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'."

  RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol Text
doc

  BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
bline (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "instance B.GValue.IsGValue " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " where"
    BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "toGValue o = do"
      BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "gtype <- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
get_type_fn
        Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "B.ManagedPtr.withManagedPtr o (B.GValue.buildGValue gtype B.GValue.set_boxed)"
      Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "fromGValue gv = do"
      BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "ptr <- B.GValue.get_boxed gv :: IO (Ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"
        Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "B.ManagedPtr.newBoxed " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " ptr"

genBoxedObject :: Name -> Text -> CodeGen ()
genBoxedObject :: Name -> Text -> CodeGen ()
genBoxedObject n :: Name
n typeInit :: Text
typeInit = do
  let name' :: Text
name' = Name -> Text
upperName Name
n
      get_type_fn :: Text
get_type_fn = "c_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
typeInit

  BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "foreign import ccall \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
typeInit Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
            Text
get_type_fn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: "
    BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> CodeGen ()
line "IO GType"
  BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
       Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "instance BoxedObject " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " where"
       BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "boxedType _ = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
get_type_fn

  Name -> Text -> CodeGen ()
genBoxedGValueInstance Name
n Text
get_type_fn

  BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
hsBoot (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "instance BoxedObject " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " where"

-- | Generate wrapper for structures.
genStruct :: Name -> Struct -> CodeGen ()
genStruct :: Name -> Struct -> CodeGen ()
genStruct n :: Name
n s :: 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
name' = Name -> Text
upperName Name
n

   RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol ("Memory-managed wrapper type.")
   let decl :: BaseCodeGen e ()
decl = Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "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
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " (ManagedPtr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"
   ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
hsBoot ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
CodeGen ()
decl
   ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
CodeGen ()
decl
   ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
CodeGen ()
newtypeDeriving

   HaddockSection -> Documentation -> CodeGen ()
addSectionDocumentation HaddockSection
ToplevelSection (Struct -> Documentation
structDocumentation Struct
s)

   if Struct -> Bool
structIsBoxed Struct
s
   then Name -> Text -> CodeGen ()
genBoxedObject 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 -> CodeGen ()
genWrappedPtr Name
n (Struct -> AllocationInfo
structAllocationInfo Struct
s) (Struct -> Int
structSize Struct
s)

   Text -> CodeGen ()
exportDecl (Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ("(..)"))

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

   Text -> CodeGen ()
noName Text
name'

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

   -- Methods
   [Maybe (Name, Method)]
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
$ \f :: Method
f -> do
       let mn :: Name
mn = Method -> Name
methodName Method
f
       Bool
isFunction <- Text -> CodeGen Bool
symbolFromFunction (Method -> Text
methodSymbol Method
f)
       if Bool -> Bool
not Bool
isFunction
       then (CGError -> CodeGen (Maybe (Name, Method)))
-> ExcCodeGen (Maybe (Name, Method))
-> CodeGen (Maybe (Name, Method))
forall a. (CGError -> CodeGen a) -> ExcCodeGen a -> CodeGen a
handleCGExc
               (\e :: CGError
e -> Text -> CodeGen ()
line ("-- 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
forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
mn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n"
                            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "-- Error was : " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CGError -> Text
describeCGError CGError
e) BaseCodeGen e ()
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe (Name, Method))
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe (Name, Method))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                Maybe (Name, Method)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe (Name, Method))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Name, Method)
forall a. Maybe a
Nothing)
               (Name -> Method -> ExcCodeGen ()
genMethod Name
n Method
f ExcCodeGen ()
-> ExcCodeGen (Maybe (Name, Method))
-> ExcCodeGen (Maybe (Name, Method))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Name, Method) -> ExcCodeGen (Maybe (Name, Method))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name, Method) -> Maybe (Name, Method)
forall a. a -> Maybe a
Just (Name
n, Method
f)))
       else Maybe (Name, Method)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe (Name, Method))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Name, Method)
forall a. Maybe a
Nothing

   -- Overloaded methods
   CPPGuard
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e a. CPPGuard -> BaseCodeGen e a -> BaseCodeGen e a
cppIf CPPGuard
CPPOverloading (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
$
        Name -> [(Name, Method)] -> CodeGen ()
genMethodList Name
n ([Maybe (Name, Method)] -> [(Name, Method)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Name, Method)]
methods)

-- | Generated wrapper for unions.
genUnion :: Name -> Union -> CodeGen ()
genUnion :: Name -> Union -> CodeGen ()
genUnion n :: Name
n u :: Union
u = do
  let name' :: Text
name' = Name -> Text
upperName Name
n

  RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol ("Memory-managed wrapper type.")
  let decl :: BaseCodeGen e ()
decl = Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "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
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " (ManagedPtr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"
  BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
hsBoot BaseCodeGen e ()
CodeGen ()
decl
  BaseCodeGen e ()
CodeGen ()
decl
  BaseCodeGen e ()
CodeGen ()
newtypeDeriving

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

  if Union -> Bool
unionIsBoxed Union
u
  then Name -> Text -> CodeGen ()
genBoxedObject 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 ()
genWrappedPtr Name
n (Union -> AllocationInfo
unionAllocationInfo Union
u) (Union -> Int
unionSize Union
u)

  Text -> CodeGen ()
exportDecl (Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "(..)")

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

  Text -> CodeGen ()
noName Text
name'

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

  -- Methods
  [Maybe (Name, Method)]
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
$ \f :: Method
f -> do
      let mn :: Name
mn = Method -> Name
methodName Method
f
      Bool
isFunction <- Text -> CodeGen Bool
symbolFromFunction (Method -> Text
methodSymbol Method
f)
      if Bool -> Bool
not Bool
isFunction
      then (CGError -> CodeGen (Maybe (Name, Method)))
-> ExcCodeGen (Maybe (Name, Method))
-> CodeGen (Maybe (Name, Method))
forall a. (CGError -> CodeGen a) -> ExcCodeGen a -> CodeGen a
handleCGExc
                (\e :: CGError
e -> Text -> CodeGen ()
line ("-- 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
forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
mn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n"
                             Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "-- Error was : " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CGError -> Text
describeCGError CGError
e)
                BaseCodeGen e ()
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe (Name, Method))
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe (Name, Method))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Name, Method)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe (Name, Method))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Name, Method)
forall a. Maybe a
Nothing)
                (Name -> Method -> ExcCodeGen ()
genMethod Name
n Method
f ExcCodeGen ()
-> ExcCodeGen (Maybe (Name, Method))
-> ExcCodeGen (Maybe (Name, Method))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Name, Method) -> ExcCodeGen (Maybe (Name, Method))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name, Method) -> Maybe (Name, Method)
forall a. a -> Maybe a
Just (Name
n, Method
f)))
      else Maybe (Name, Method)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     (Maybe (Name, Method))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Name, Method)
forall a. Maybe a
Nothing

  -- Overloaded methods
  CPPGuard -> BaseCodeGen e () -> BaseCodeGen e ()
forall e a. CPPGuard -> BaseCodeGen e a -> BaseCodeGen e a
cppIf CPPGuard
CPPOverloading (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$
       Name -> [(Name, Method)] -> CodeGen ()
genMethodList Name
n ([Maybe (Name, Method)] -> [(Name, Method)]
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 c :: Callable
c = Callable
c {  args :: [Arg]
args = [Arg]
args'' , returnType :: Maybe Type
returnType = Maybe Type
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'' = Arg -> Arg
fixInstance ([Arg] -> Arg
forall a. [a] -> a
head [Arg]
args') Arg -> [Arg] -> [Arg]
forall a. a -> [a] -> [a]
: [Arg] -> [Arg]
forall a. [a] -> [a]
tail [Arg]
args'

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

      fixCArrayLength :: Type -> Type
      fixCArrayLength :: Type -> Type
fixCArrayLength (TCArray zt :: Bool
zt fixed :: Int
fixed length :: Int
length t :: Type
t) =
          if Int
length Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> -1
          then Bool -> Int -> Int -> Type -> Type
TCArray Bool
zt Int
fixed (Int
lengthInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Type
t
          else Bool -> Int -> Int -> Type -> Type
TCArray Bool
zt Int
fixed Int
length Type
t

      fixCArrayLength t :: Type
t = Type
t

      fixDestroyers :: Arg -> Arg
      fixDestroyers :: Arg -> Arg
fixDestroyers arg :: 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
> -1
                          then Arg
arg {argDestroy :: Int
argDestroy = Int
destroy Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1}
                          else Arg
arg

      fixClosures :: Arg -> Arg
      fixClosures :: Arg -> Arg
fixClosures arg :: 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
> -1
                        then Arg
arg {argClosure :: Int
argClosure = Int
closure Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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
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 returnsGObject :: Bool
returnsGObject cn :: Name
cn c :: Callable
c = Callable
c { returnType :: Maybe Type
returnType = Maybe Type
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 cn :: 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 <- 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 (m :: * -> *) a. Monad m => a -> m a
return Bool
False) Type
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except CGError)) Bool
Type -> CodeGen Bool
isGObject (Callable -> Maybe Type
returnType Callable
c)
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "-- 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
forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
mn
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "-- method type : " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MethodType -> Text
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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
mn }
    let c' :: Callable
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'' :: Callable
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'
    Name -> Text -> Callable -> ExcCodeGen ()
genCCallableWrapper Name
mn' Text
sym Callable
c''
    HaddockSection -> Text -> CodeGen ()
export (NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
MethodSection (Text -> HaddockSection) -> Text -> HaddockSection
forall a b. (a -> b) -> a -> b
$ Name -> Text
lowerName Name
mn) (Name -> Text
lowerName Name
mn')

    CPPGuard -> ExcCodeGen () -> ExcCodeGen ()
forall e a. CPPGuard -> BaseCodeGen e a -> BaseCodeGen e a
cppIf CPPGuard
CPPOverloading (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$
         Name -> Method -> ExcCodeGen ()
genMethodInfo Name
cn (Method
m {methodCallable :: Callable
methodCallable = Callable
c''})

-- | Generate the GValue instances for the given GObject.
genGObjectGValueInstance :: Name -> Text -> CodeGen ()
genGObjectGValueInstance :: Name -> Text -> CodeGen ()
genGObjectGValueInstance n :: Name
n get_type_fn :: Text
get_type_fn = do
  let name' :: Text
name' = Name -> Text
upperName Name
n
      doc :: Text
doc = "Convert '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "' to and from 'Data.GI.Base.GValue.GValue' with 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'."

  RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol Text
doc

  BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
bline (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "instance B.GValue.IsGValue " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " where"
    BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "toGValue o = do"
      BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "gtype <- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
get_type_fn
        Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "B.ManagedPtr.withManagedPtr o (B.GValue.buildGValue gtype B.GValue.set_object)"
      Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "fromGValue gv = do"
      BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "ptr <- B.GValue.get_object gv :: IO (Ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"
        Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "B.ManagedPtr.newObject " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " ptr"

-- Type casting with type checking
genGObjectCasts :: Name -> Text -> [Name] -> CodeGen ()
genGObjectCasts :: Name -> Text -> [Name] -> CodeGen ()
genGObjectCasts n :: Name
n cn_ :: Text
cn_ parents :: [Name]
parents = do
  let name' :: Text
name' = Name -> Text
upperName Name
n
      get_type_fn :: Text
get_type_fn = "c_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cn_

  BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "foreign import ccall \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cn_ Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\""
    BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
get_type_fn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: IO GType"

  BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
bline (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "instance GObject " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " where"
    BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
            Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "gobjectType = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
get_type_fn

  Name -> Text -> CodeGen ()
genGObjectGValueInstance Name
n Text
get_type_fn

  Text
className <- Name -> CodeGen Text
classConstraint Name
n
  BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> CodeGen ()
exportDecl Text
className
    RelativeDocPosition -> Text -> CodeGen ()
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 = "(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
<> " o)"
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
bline (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "class " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
constraints Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " => " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
className Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " o"
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
bline (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "instance " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
constraints Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " => " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
className Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " o"

    BaseCodeGen e ()
CodeGen ()
blank

    [Text]
qualifiedParents <- (Name -> BaseCodeGen e Text)
-> [Name]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> BaseCodeGen e Text
Name -> CodeGen Text
qualifiedAPI [Name]
parents
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
bline (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "instance O.HasParentTypes " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name'
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "type instance O.ParentTypes " 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
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate ", " [Text]
qualifiedParents Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "]"

  -- Safe downcasting.
  BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    let safeCast :: Text
safeCast = "to" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name'
    Text -> CodeGen ()
exportDecl Text
safeCast
    RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Text -> Text
castDoc Text
name')
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
safeCast Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: (MonadIO m, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
className Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " o) => o -> m " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name'
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
safeCast Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = liftIO . unsafeCastTo " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name'

  where castDoc :: Text -> Text
        castDoc :: Text -> Text
castDoc name' :: Text
name' = "Cast to `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                        "`, for types for which this is known to be safe. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                        "For general casts, use `Data.GI.Base.ManagedPtr.castTo`."

        classDoc :: Text -> Text
        classDoc :: Text -> Text
classDoc name' :: Text
name' = "Type class for types which can be safely cast to `"
                         Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "`, 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
<> "`."

-- | 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 ()
genObject :: Name -> Object -> CodeGen ()
genObject n :: Name
n o :: Object
o = do
  let name' :: Text
name' = Name -> Text
upperName Name
n
  let t :: Type
t = Name -> Type
TInterface Name
n
  Bool
isGO <- Type -> CodeGen Bool
isGObject Type
t

  if Bool -> Bool
not Bool
isGO
  then Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "-- APIObject \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                "\" does not descend from GObject, it will be ignored."
  else do
    RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol ("Memory-managed wrapper type.")
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
bline (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "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
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " (ManagedPtr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"
    BaseCodeGen e ()
CodeGen ()
newtypeDeriving
    Text -> CodeGen ()
exportDecl (Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "(..)")

    HaddockSection -> Documentation -> CodeGen ()
addSectionDocumentation HaddockSection
ToplevelSection (Object -> Documentation
objDocumentation Object
o)

    -- Type safe casting to parent objects, and implemented interfaces.
    [Name]
parents <- Name -> CodeGen [Name]
instanceTree Name
n
    Name -> Text -> [Name] -> CodeGen ()
genGObjectCasts Name
n (Object -> Text
objTypeInit Object
o) ([Name]
parents [Name] -> [Name] -> [Name]
forall a. Semigroup a => a -> a -> a
<> Object -> [Name]
objInterfaces Object
o)

    Text -> CodeGen ()
noName Text
name'

    CPPGuard -> BaseCodeGen e () -> BaseCodeGen e ()
forall e a. CPPGuard -> BaseCodeGen e a -> BaseCodeGen e a
cppIf CPPGuard
CPPOverloading (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$
         Name -> Object -> CodeGen [(Name, Method)]
fullObjectMethodList Name
n Object
o BaseCodeGen e [(Name, Method)]
-> ([(Name, Method)] -> BaseCodeGen e ()) -> BaseCodeGen e ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> [(Name, Method)] -> CodeGen ()
genMethodList Name
n

    [Signal] -> (Signal -> BaseCodeGen e ()) -> BaseCodeGen e ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Object -> [Signal]
objSignals Object
o) ((Signal -> BaseCodeGen e ()) -> BaseCodeGen e ())
-> (Signal -> BaseCodeGen e ()) -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ \s :: Signal
s -> Signal -> Name -> CodeGen ()
genSignal Signal
s Name
n

    Name -> Object -> CodeGen ()
genObjectProperties Name
n Object
o
    CPPGuard -> BaseCodeGen e () -> BaseCodeGen e ()
forall e a. CPPGuard -> BaseCodeGen e a -> BaseCodeGen e a
cppIf CPPGuard
CPPOverloading (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$
         Name -> [Property] -> [Method] -> CodeGen ()
genNamespacedPropLabels Name
n (Object -> [Property]
objProperties Object
o) (Object -> [Method]
objMethods Object
o)
    CPPGuard -> BaseCodeGen e () -> BaseCodeGen e ()
forall e a. CPPGuard -> BaseCodeGen e a -> BaseCodeGen e a
cppIf CPPGuard
CPPOverloading (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$
         Name -> Object -> CodeGen ()
genObjectSignals Name
n Object
o

    -- Methods
    [Method] -> (Method -> BaseCodeGen e ()) -> BaseCodeGen e ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Object -> [Method]
objMethods Object
o) ((Method -> BaseCodeGen e ()) -> BaseCodeGen e ())
-> (Method -> BaseCodeGen e ()) -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ \f :: Method
f -> do
      let mn :: Name
mn = Method -> Name
methodName Method
f
      (CGError -> CodeGen ()) -> ExcCodeGen () -> CodeGen ()
forall a. (CGError -> CodeGen a) -> ExcCodeGen a -> CodeGen a
handleCGExc (\e :: CGError
e -> Text -> CodeGen ()
line ("-- 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
forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
mn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n"
                              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "-- Error was : " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CGError -> Text
describeCGError CGError
e)
                  ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (CPPGuard
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e a. CPPGuard -> BaseCodeGen e a -> BaseCodeGen e a
cppIf CPPGuard
CPPOverloading (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
$
                           Name -> Method -> CodeGen ()
genUnsupportedMethodInfo Name
n Method
f))
                  (Name -> Method -> ExcCodeGen ()
genMethod Name
n Method
f)

genInterface :: Name -> Interface -> CodeGen ()
genInterface :: Name -> Interface -> CodeGen ()
genInterface n :: Name
n iface :: Interface
iface = do
  let name' :: Text
name' = Name -> Text
upperName Name
n

  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "-- interface " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " "
  RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol ("Memory-managed wrapper type.")
  Text -> Maybe DeprecationInfo -> CodeGen ()
deprecatedPragma Text
name' (Maybe DeprecationInfo -> BaseCodeGen e ())
-> Maybe DeprecationInfo -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Interface -> Maybe DeprecationInfo
ifDeprecated Interface
iface
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
bline (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "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
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " (ManagedPtr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"
  BaseCodeGen e ()
CodeGen ()
newtypeDeriving
  Text -> CodeGen ()
exportDecl (Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "(..)")

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

  Text -> CodeGen ()
noName Text
name'

  [Signal] -> (Signal -> BaseCodeGen e ()) -> BaseCodeGen e ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Interface -> [Signal]
ifSignals Interface
iface) ((Signal -> BaseCodeGen e ()) -> BaseCodeGen e ())
-> (Signal -> BaseCodeGen e ()) -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ \s :: Signal
s -> (CGError -> CodeGen ()) -> ExcCodeGen () -> CodeGen ()
forall a. (CGError -> CodeGen a) -> ExcCodeGen a -> CodeGen a
handleCGExc
     (Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ())
-> (CGError -> Text) -> CGError -> BaseCodeGen e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> Text
T.concat ["-- XXX Could not generate signal ", Text
name', "::"
                     , Signal -> Text
sigName Signal
s
                     , "\n", "-- Error was : "] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (CGError -> Text) -> CGError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CGError -> Text
describeCGError)
     (Signal -> Name -> CodeGen ()
genSignal Signal
s Name
n)

  CPPGuard -> BaseCodeGen e () -> BaseCodeGen e ()
forall e a. CPPGuard -> BaseCodeGen e a -> BaseCodeGen e a
cppIf CPPGuard
CPPOverloading (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$
     Name -> Interface -> CodeGen ()
genInterfaceSignals Name
n Interface
iface

  Bool
isGO <- Name -> API -> CodeGen Bool
apiIsGObject Name
n (Interface -> API
APIInterface Interface
iface)
  if Bool
isGO
  then do
    let cn_ :: Text
cn_ = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Text
forall a. HasCallStack => [Char] -> a
error "GObject derived interface without a type!") (Interface -> Maybe Text
ifTypeInit Interface
iface)
    [Name]
gobjectPrereqs <- (Name -> BaseCodeGen e Bool)
-> [Name]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Name]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Name -> BaseCodeGen e Bool
Name -> CodeGen Bool
nameIsGObject (Interface -> [Name]
ifPrerequisites Interface
iface)
    [[Name]]
allParents <- [Name]
-> (Name
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Name])
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [[Name]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
gobjectPrereqs ((Name
  -> ReaderT
       CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Name])
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [[Name]])
-> (Name
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Name])
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [[Name]]
forall a b. (a -> b) -> a -> b
$ \p :: 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 -> CodeGen [Name]
instanceTree Name
p
    let uniqueParents :: [Name]
uniqueParents = [Name] -> [Name]
forall a. Eq a => [a] -> [a]
nub ([[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Name]]
allParents)
    Name -> Text -> [Name] -> CodeGen ()
genGObjectCasts Name
n Text
cn_ [Name]
uniqueParents

    Name -> Interface -> CodeGen ()
genInterfaceProperties Name
n Interface
iface
    CPPGuard -> BaseCodeGen e () -> BaseCodeGen e ()
forall e a. CPPGuard -> BaseCodeGen e a -> BaseCodeGen e a
cppIf CPPGuard
CPPOverloading (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$
       Name -> [Property] -> [Method] -> CodeGen ()
genNamespacedPropLabels Name
n (Interface -> [Property]
ifProperties Interface
iface) (Interface -> [Method]
ifMethods Interface
iface)

  else BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
    Text
cls <- Name -> CodeGen Text
classConstraint Name
n
    Text -> CodeGen ()
exportDecl Text
cls
    RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol ("Type class for types which implement `"
                                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "`.")

    -- 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 = "(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
<> " o)"
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
bline (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "class " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
constraints Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " => " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cls Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " o"
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
bline (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "instance " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
constraints Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " => " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cls Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " o"

    Name -> AllocationInfo -> Int -> CodeGen ()
genWrappedPtr Name
n (Interface -> AllocationInfo
ifAllocationInfo Interface
iface) 0

    Bool -> BaseCodeGen e () -> BaseCodeGen e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> (Interface -> Bool) -> Interface -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Property] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Property] -> Bool)
-> (Interface -> [Property]) -> Interface -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface -> [Property]
ifProperties (Interface -> Bool) -> Interface -> Bool
forall a b. (a -> b) -> a -> b
$ Interface
iface) (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ BaseCodeGen e () -> BaseCodeGen e ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ do
       Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "-- XXX Skipping property generation for non-GObject interface"

  -- Methods
  CPPGuard -> BaseCodeGen e () -> BaseCodeGen e ()
forall e a. CPPGuard -> BaseCodeGen e a -> BaseCodeGen e a
cppIf CPPGuard
CPPOverloading (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$
       Name -> Interface -> CodeGen [(Name, Method)]
fullInterfaceMethodList Name
n Interface
iface BaseCodeGen e [(Name, Method)]
-> ([(Name, Method)] -> BaseCodeGen e ()) -> BaseCodeGen e ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> [(Name, Method)] -> CodeGen ()
genMethodList Name
n

  [Method] -> (Method -> BaseCodeGen e ()) -> BaseCodeGen e ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Interface -> [Method]
ifMethods Interface
iface) ((Method -> BaseCodeGen e ()) -> BaseCodeGen e ())
-> (Method -> BaseCodeGen e ()) -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ \f :: Method
f -> do
      let mn :: Name
mn = Method -> Name
methodName Method
f
      Bool
isFunction <- Text -> CodeGen Bool
symbolFromFunction (Method -> Text
methodSymbol Method
f)
      Bool -> BaseCodeGen e () -> BaseCodeGen e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isFunction (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$
             (CGError -> CodeGen ()) -> ExcCodeGen () -> CodeGen ()
forall a. (CGError -> CodeGen a) -> ExcCodeGen a -> CodeGen a
handleCGExc
             (\e :: CGError
e -> Text -> CodeGen ()
line ("-- 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
forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
mn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n"
                          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "-- Error was : " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CGError -> Text
describeCGError CGError
e)
             ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (CPPGuard
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e a. CPPGuard -> BaseCodeGen e a -> BaseCodeGen e a
cppIf CPPGuard
CPPOverloading (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
$
                      Name -> Method -> CodeGen ()
genUnsupportedMethodInfo Name
n Method
f))
             (Name -> Method -> ExcCodeGen ()
genMethod Name
n Method
f)

-- 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 Bool
symbolFromFunction :: Text -> CodeGen Bool
symbolFromFunction sym :: Text
sym = do
    Map Name API
apis <- BaseCodeGen e (Map Name API)
CodeGen (Map Name API)
getAPIs
    Bool
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Bool)
-> Bool
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Bool
forall a b. (a -> b) -> a -> b
$ ((Name, API) -> Bool) -> [(Name, API)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> API -> Bool
hasSymbol Text
sym (API -> Bool) -> ((Name, API) -> API) -> (Name, API) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, API) -> API
forall a b. (a, b) -> b
snd) ([(Name, API)] -> Bool) -> [(Name, API)] -> Bool
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
    where
        hasSymbol :: Text -> API -> Bool
hasSymbol sym1 :: 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 _ _ = Bool
False

genAPI :: Name -> API -> CodeGen ()
genAPI :: Name -> API -> CodeGen ()
genAPI n :: Name
n (APIConst c :: Constant
c) = Name -> Constant -> CodeGen ()
genConstant Name
n Constant
c
genAPI n :: Name
n (APIFunction f :: Function
f) = Name -> Function -> CodeGen ()
genFunction Name
n Function
f
genAPI n :: Name
n (APIEnum e :: Enumeration
e) = Name -> Enumeration -> CodeGen ()
genEnum Name
n Enumeration
e
genAPI n :: Name
n (APIFlags f :: Flags
f) = Name -> Flags -> CodeGen ()
genFlags Name
n Flags
f
genAPI n :: Name
n (APICallback c :: Callback
c) = Name -> Callback -> CodeGen ()
genCallback Name
n Callback
c
genAPI n :: Name
n (APIStruct s :: Struct
s) = Name -> Struct -> CodeGen ()
genStruct Name
n Struct
s
genAPI n :: Name
n (APIUnion u :: Union
u) = Name -> Union -> CodeGen ()
genUnion Name
n Union
u
genAPI n :: Name
n (APIObject o :: Object
o) = Name -> Object -> CodeGen ()
genObject Name
n Object
o
genAPI n :: Name
n (APIInterface i :: Interface
i) = Name -> Interface -> CodeGen ()
genInterface Name
n Interface
i

-- | Generate the code for a given API in the corresponding module.
genAPIModule :: Name -> API -> CodeGen ()
genAPIModule :: Name -> API -> CodeGen ()
genAPIModule n :: Name
n api :: API
api = ModulePath -> BaseCodeGen e () -> BaseCodeGen e ()
forall e. ModulePath -> BaseCodeGen e () -> BaseCodeGen e ()
submodule (Name -> API -> ModulePath
submoduleLocation Name
n API
api) (BaseCodeGen e () -> BaseCodeGen e ())
-> BaseCodeGen e () -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Name -> API -> CodeGen ()
genAPI Name
n API
api

genModule' :: M.Map Name API -> CodeGen ()
genModule' :: Map Name API -> CodeGen ()
genModule' apis :: 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)) ()
Name -> API -> CodeGen ()
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 ((Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ Text -> Text -> Name
Name "GLib" "Array"
                               , Text -> Text -> Name
Name "GLib" "Error"
                               , Text -> Text -> Name
Name "GLib" "HashTable"
                               , Text -> Text -> Name
Name "GLib" "List"
                               , Text -> Text -> Name
Name "GLib" "SList"
                               , Text -> Text -> Name
Name "GLib" "Variant"
                               , Text -> Text -> Name
Name "GObject" "Value"
                               , Text -> Text -> Name
Name "GObject" "Closure"]) (Name -> Bool) -> ((Name, API) -> Name) -> (Name, API) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, API) -> Name
forall a b. (a, b) -> a
fst)
          ([(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)
traverse API -> Maybe API
dropMovedItems)
            -- 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
            -- Try to guess nullability of properties when there is no
            -- nullability info in the GIR.
          ([(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)
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
            -- 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
            -- 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
          ([(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 -> [(Name, API)]) -> Map Name API -> [(Name, API)]
forall a b. (a -> b) -> a -> b
$ 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 -> BaseCodeGen e () -> BaseCodeGen e ()
submodule "Callbacks" (()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

genModule :: M.Map Name API -> CodeGen ()
genModule :: Map Name API -> CodeGen ()
genModule apis :: Map Name API
apis = do
  -- Reexport Data.GI.Base for convenience (so it does not need to be
  -- imported separately).
  Text -> CodeGen ()
line "import Data.GI.Base"
  Text -> CodeGen ()
exportModule "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 = ([(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
  Map Name API
allAPIs <- BaseCodeGen e (Map Name API)
CodeGen (Map Name API)
getAPIs
  Map Name API -> CodeGen () -> CodeGen ()
recurseWithAPIs (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
allAPIs Map Name API
embeddedAPIs)
       (Map Name API -> CodeGen ()
genModule' (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
apis Map Name API
embeddedAPIs))