module Data.GI.CodeGen.Properties
    ( genInterfaceProperties
    , genObjectProperties
    , genNamespacedPropLabels
    ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad (forM_, when, unless)
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Set as S

import Foreign.C.Types (CInt, CUInt)
import Foreign.Storable (sizeOf)

import Data.GI.CodeGen.API
import Data.GI.CodeGen.Conversions
import Data.GI.CodeGen.Code
import Data.GI.CodeGen.GObject
import Data.GI.CodeGen.Haddock (addSectionDocumentation, writeHaddock,
                                RelativeDocPosition(DocBeforeSymbol))
import Data.GI.CodeGen.Inheritance (fullObjectPropertyList, fullInterfacePropertyList)
import Data.GI.CodeGen.SymbolNaming (lowerName, upperName, classConstraint,
                                     hyphensToCamelCase, qualifiedSymbol,
                                     typeConstraint, callbackDynamicWrapper,
                                     callbackHaskellToForeign,
                                     callbackWrapperAllocator)
import Data.GI.CodeGen.Type
import Data.GI.CodeGen.Util

propTypeStr :: Type -> CodeGen Text
propTypeStr :: Type -> CodeGen Text
propTypeStr t :: Type
t = case Type
t of
   TBasicType TUTF8 -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "String"
   TBasicType TFileName -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "String"
   TBasicType TPtr -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Ptr"
   TByteArray -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "ByteArray"
   TGHash _ _ -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Hash"
   TVariant -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Variant"
   TParamSpec -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "ParamSpec"
   TGClosure _ -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Closure"
   TError -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "GError"
   TBasicType TInt -> case CInt -> Int
forall a. Storable a => a -> Int
sizeOf (0 :: CInt) of
                        4 -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Int32"
                        n :: Int
n -> [Char]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a. HasCallStack => [Char] -> a
error ("Unsupported `gint' type length: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                    Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n)
   TBasicType TUInt -> case CUInt -> Int
forall a. Storable a => a -> Int
sizeOf (0 :: CUInt) of
                        4 -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "UInt32"
                        n :: Int
n -> [Char]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a. HasCallStack => [Char] -> a
error ("Unsupported `guint' type length: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                    Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n)
   TBasicType TLong -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Long"
   TBasicType TULong -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "ULong"
   TBasicType TInt32 -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Int32"
   TBasicType TUInt32 -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "UInt32"
   TBasicType TInt64 -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Int64"
   TBasicType TUInt64 -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "UInt64"
   TBasicType TBoolean -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Bool"
   TBasicType TFloat -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Float"
   TBasicType TDouble -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Double"
   TBasicType TGType -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "GType"
   TCArray True _ _ (TBasicType TUTF8) -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "StringArray"
   TCArray True _ _ (TBasicType TFileName) -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "StringArray"
   TGList (TBasicType TPtr) -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "PtrGList"
   t :: Type
t@(TInterface n :: Name
n) -> do
     API
api <- Name -> CodeGen API
findAPIByName Name
n
     case API
api of
       APIEnum _ -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Enum"
       APIFlags _ -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Flags"
       APICallback _ -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Callback"
       APIStruct s :: Struct
s -> if Struct -> Bool
structIsBoxed Struct
s
                      then Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Boxed"
                      else [Char]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> [Char]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a b. (a -> b) -> a -> b
$ "Unboxed struct property : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
t
       APIUnion u :: Union
u -> if Union -> Bool
unionIsBoxed Union
u
                     then Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Boxed"
                     else [Char]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> [Char]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a b. (a -> b) -> a -> b
$ "Unboxed union property : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
t
       APIObject _ -> do
                Bool
isGO <- Type -> CodeGen Bool
isGObject Type
t
                if Bool
isGO
                then Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Object"
                else [Char]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> [Char]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a b. (a -> b) -> a -> b
$ "Non-GObject object property : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
t
       APIInterface _ -> do
                Bool
isGO <- Type -> CodeGen Bool
isGObject Type
t
                if Bool
isGO
                then Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Object"
                else [Char]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> [Char]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a b. (a -> b) -> a -> b
$ "Non-GObject interface property : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
t
       _ -> [Char]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> [Char]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a b. (a -> b) -> a -> b
$ "Unknown interface property of type : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
t
   _ -> [Char]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> [Char]
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a b. (a -> b) -> a -> b
$ "Don't know how to handle properties of type " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
t

-- | The constraint for setting the given type in properties.
propSetTypeConstraint :: Type -> CodeGen Text
propSetTypeConstraint :: Type -> CodeGen Text
propSetTypeConstraint (TGClosure Nothing) =
  Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a b. (a -> b) -> a -> b
$ "(~) " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
parenthesize (TypeRep -> Text
typeShow ("GClosure" Text -> [TypeRep] -> TypeRep
`con` [Text -> TypeRep
con0 "()"]))
propSetTypeConstraint t :: Type
t = do
  Bool
isGO <- Type -> CodeGen Bool
isGObject Type
t
  if Bool
isGO
    then Type -> CodeGen Text
typeConstraint Type
t
    else do
      Bool
isCallback <- Type -> CodeGen Bool
typeIsCallback Type
t
      Text
hInType <- if Bool
isCallback
                 then TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
foreignType Type
t
                 else TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
haskellType Type
t
      Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a b. (a -> b) -> a -> b
$ "(~) " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ') Text
hInType
                         then Text -> Text
parenthesize Text
hInType
                         else Text
hInType

-- | The constraint for transferring the given type into a property.
propTransferTypeConstraint :: Type -> CodeGen Text
propTransferTypeConstraint :: Type -> CodeGen Text
propTransferTypeConstraint t :: Type
t = do
  Bool
isGO <- Type -> CodeGen Bool
isGObject Type
t
  if Bool
isGO
    then Type -> CodeGen Text
typeConstraint Type
t
    else do
      Text
hInType <- TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) TypeRep
-> BaseCodeGen e Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
isoHaskellType Type
t
      Text -> BaseCodeGen e Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> BaseCodeGen e Text) -> Text -> BaseCodeGen e Text
forall a b. (a -> b) -> a -> b
$ "(~) " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ') Text
hInType
                         then Text -> Text
parenthesize Text
hInType
                         else Text
hInType

-- | The type of the return value of @attrTransfer@ for the given
-- type.
propTransferType :: Type -> CodeGen Text
propTransferType :: Type -> CodeGen Text
propTransferType (TGClosure Nothing) =
  Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a b. (a -> b) -> a -> b
$ TypeRep -> Text
typeShow ("GClosure" Text -> [TypeRep] -> TypeRep
`con` [Text -> TypeRep
con0 "()"])
propTransferType t :: Type
t = do
  Bool
isCallback <- Type -> CodeGen Bool
typeIsCallback Type
t
  if Bool
isCallback
             then TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
foreignType Type
t
             else TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
haskellType Type
t

-- | Given a value "v" of the given Haskell type, satisfying the
-- constraint generated by 'propTransferTypeConstraint', convert it
-- (allocating memory is necessary) to the type given by 'propTransferType'.
genPropTransfer :: Text -> Type -> CodeGen ()
genPropTransfer :: Text -> Type -> CodeGen ()
genPropTransfer var :: Text
var (TGClosure Nothing) = Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "return " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
var
genPropTransfer var :: Text
var t :: Type
t = do
  Bool
isGO <- Type -> CodeGen Bool
isGObject Type
t
  if Bool
isGO
    then do
      Text
ht <- TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) TypeRep
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
haskellType Type
t
      Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "unsafeCastTo " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ht Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
var
    else case Type
t of
           TInterface tn :: Name
tn@(Name _ n :: Text
n) -> do
             Bool
isCallback <- Type -> CodeGen Bool
typeIsCallback Type
t
             if Bool -> Bool
not Bool
isCallback
               then Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "return " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
var
               else do
               -- Callbacks need to be wrapped
               Text
wrapper <- Text -> Name -> CodeGen Text
qualifiedSymbol (Text -> Text
callbackHaskellToForeign Text
n) Name
tn
               Text
maker <- Text -> Name -> CodeGen Text
qualifiedSymbol (Text -> Text
callbackWrapperAllocator Text
n) Name
tn
               Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
maker Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                 Text -> Text
parenthesize (Text
wrapper Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " Nothing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
var)
           _ -> Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "return " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
var

-- | Given a property, return the set of constraints on the types, and
-- the type variables for the object and its value.
attrType :: Property -> CodeGen ([Text], Text)
attrType :: Property -> CodeGen ([Text], Text)
attrType prop :: Property
prop = do
  BaseCodeGen e ()
CodeGen ()
resetTypeVariableScope
  Bool
isCallback <- Type -> CodeGen Bool
typeIsCallback (Property -> Type
propType Property
prop)
  if Bool
isCallback
    then do
      TypeRep
ftype <- Type -> CodeGen TypeRep
foreignType (Property -> Type
propType Property
prop)
      ([Text], Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     ([Text], Text)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], TypeRep -> Text
typeShow TypeRep
ftype)
    else do
      (t :: Text
t,constraints :: [Text]
constraints) <- Type -> ExposeClosures -> CodeGen (Text, [Text])
argumentType (Property -> Type
propType Property
prop) ExposeClosures
WithoutClosures
      ([Text], Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except e))
     ([Text], Text)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text]
constraints, Text
t)

-- | Generate documentation for the given setter.
setterDoc :: Name -> Property -> Text
setterDoc :: Name -> Property -> Text
setterDoc n :: Name
n prop :: Property
prop = [Text] -> Text
T.unlines [
    "Set the value of the “@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Property -> Text
propName Property
prop Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "@” property."
  , "When <https://github.com/haskell-gi/haskell-gi/wiki/Overloading overloading> is enabled, this is equivalent to"
  , ""
  , "@"
  , "'Data.GI.Base.Attributes.set' " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
lowerName Name
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " [ #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Property -> Text
hPropName Property
prop
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " 'Data.GI.Base.Attributes.:=' value ]"
  , "@"]

genPropertySetter :: Text -> Name -> HaddockSection -> Property -> CodeGen ()
genPropertySetter :: Text -> Name -> HaddockSection -> Property -> CodeGen ()
genPropertySetter setter :: Text
setter n :: Name
n docSection :: HaddockSection
docSection prop :: Property
prop = 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
  (constraints :: [Text]
constraints, t :: Text
t) <- Property -> CodeGen ([Text], Text)
attrType Property
prop
  Bool
isNullable <- Type -> CodeGen Bool
typeIsNullable (Property -> Type
propType Property
prop)
  Bool
isCallback <- Type -> CodeGen Bool
typeIsCallback (Property -> Type
propType Property
prop)
  Text
cls <- Name -> CodeGen Text
classConstraint Name
n
  let constraints' :: [Text]
constraints' = "MonadIO m"Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:(Text
cls Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " o")Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
constraints
  Text
tStr <- Type -> BaseCodeGen e Text
Type -> CodeGen Text
propTypeStr (Type -> BaseCodeGen e Text) -> Type -> BaseCodeGen e Text
forall a b. (a -> b) -> a -> b
$ Property -> Type
propType Property
prop
  RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Name -> Property -> Text
setterDoc Name
n Property
prop)
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
setter 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]
constraints'
           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ") => o -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " -> m ()"
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
setter Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " obj val = liftIO $ B.Properties.setObjectProperty" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tStr
           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " obj \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Property -> Text
propName Property
prop
           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if Bool
isNullable Bool -> Bool -> Bool
&& (Bool -> Bool
not Bool
isCallback)
              then "\" (Just val)"
              else "\" val"
  HaddockSection -> Text -> CodeGen ()
export HaddockSection
docSection Text
setter

-- | Generate documentation for the given getter.
getterDoc :: Name -> Property -> Text
getterDoc :: Name -> Property -> Text
getterDoc n :: Name
n prop :: Property
prop = [Text] -> Text
T.unlines [
    "Get the value of the “@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Property -> Text
propName Property
prop Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "@” property."
  , "When <https://github.com/haskell-gi/haskell-gi/wiki/Overloading overloading> is enabled, this is equivalent to"
  , ""
  , "@"
  , "'Data.GI.Base.Attributes.get' " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
lowerName Name
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Property -> Text
hPropName Property
prop
  , "@"]

genPropertyGetter :: Text -> Name -> HaddockSection -> Property -> CodeGen ()
genPropertyGetter :: Text -> Name -> HaddockSection -> Property -> CodeGen ()
genPropertyGetter getter :: Text
getter n :: Name
n docSection :: HaddockSection
docSection prop :: Property
prop = 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
  Bool
isNullable <- Type -> CodeGen Bool
typeIsNullable (Property -> Type
propType Property
prop)
  let isMaybe :: Bool
isMaybe = Bool
isNullable Bool -> Bool -> Bool
&& Property -> Maybe Bool
propReadNullable Property
prop Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
  TypeRep
constructorType <- Type -> CodeGen TypeRep
isoHaskellType (Property -> Type
propType Property
prop)
  Text
tStr <- Type -> BaseCodeGen e Text
Type -> CodeGen Text
propTypeStr (Type -> BaseCodeGen e Text) -> Type -> BaseCodeGen e Text
forall a b. (a -> b) -> a -> b
$ Property -> Type
propType Property
prop
  Text
cls <- Name -> CodeGen Text
classConstraint Name
n
  let constraints :: Text
constraints = "(MonadIO m, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cls Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " o)"
      outType :: TypeRep
outType = if Bool
isMaybe
                then TypeRep -> TypeRep
maybeT TypeRep
constructorType
                else TypeRep
constructorType
      returnType :: Text
returnType = TypeRep -> Text
typeShow (TypeRep -> Text) -> TypeRep -> Text
forall a b. (a -> b) -> a -> b
$ "m" Text -> [TypeRep] -> TypeRep
`con` [TypeRep
outType]
      getProp :: Text
getProp = if Bool
isNullable Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isMaybe
                then "checkUnexpectedNothing \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
getter
                         Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" $ B.Properties.getObjectProperty" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tStr
                else "B.Properties.getObjectProperty" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tStr
  -- Some property getters require in addition a constructor, which
  -- will convert the foreign value to the wrapped Haskell one.
  Text
constructorArg <-
    if Text
tStr Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["Object", "Boxed"]
    then Text -> BaseCodeGen e Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> BaseCodeGen e Text) -> Text -> BaseCodeGen e Text
forall a b. (a -> b) -> a -> b
$ " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeRep -> Text
typeShow TypeRep
constructorType
    else (if Text
tStr Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Callback"
          then do
             TypeRep
callbackType <- Type -> CodeGen TypeRep
haskellType (Property -> Type
propType Property
prop)
             Text -> BaseCodeGen e Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> BaseCodeGen e Text) -> Text -> BaseCodeGen e Text
forall a b. (a -> b) -> a -> b
$ " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
callbackDynamicWrapper (TypeRep -> Text
typeShow TypeRep
callbackType)
          else Text -> BaseCodeGen e Text
forall (m :: * -> *) a. Monad m => a -> m a
return "")

  RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Name -> Property -> Text
getterDoc Name
n Property
prop)
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
getter Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
constraints Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                " => o -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
returnType
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
getter Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " obj = liftIO $ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
getProp
           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " obj \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Property -> Text
propName Property
prop Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
constructorArg
  HaddockSection -> Text -> CodeGen ()
export HaddockSection
docSection Text
getter

-- | Generate documentation for the given constructor.
constructorDoc :: Property -> Text
constructorDoc :: Property -> Text
constructorDoc prop :: Property
prop = [Text] -> Text
T.unlines [
    "Construct a `GValueConstruct` with valid value for the “@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Property -> Text
propName Property
prop Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "@” property. This is rarely needed directly, but it is used by `Data.GI.Base.Constructible.new`."
    ]

genPropertyConstructor :: Text -> Name -> HaddockSection -> Property -> CodeGen ()
genPropertyConstructor :: Text -> Name -> HaddockSection -> Property -> CodeGen ()
genPropertyConstructor constructor :: Text
constructor n :: Name
n docSection :: HaddockSection
docSection prop :: Property
prop = 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
  (constraints :: [Text]
constraints, t :: Text
t) <- Property -> CodeGen ([Text], Text)
attrType Property
prop
  Text
tStr <- Type -> BaseCodeGen e Text
Type -> CodeGen Text
propTypeStr (Type -> BaseCodeGen e Text) -> Type -> BaseCodeGen e Text
forall a b. (a -> b) -> a -> b
$ Property -> Type
propType Property
prop
  Bool
isNullable <- Type -> CodeGen Bool
typeIsNullable (Property -> Type
propType Property
prop)
  Bool
isCallback <- Type -> CodeGen Bool
typeIsCallback (Property -> Type
propType Property
prop)
  Text
cls <- Name -> CodeGen Text
classConstraint Name
n
  let constraints' :: [Text]
constraints' = (Text
cls Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " o") Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
constraints
      pconstraints :: Text
pconstraints = Text -> Text
parenthesize (Text -> [Text] -> Text
T.intercalate ", " [Text]
constraints') Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " => "
  RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Property -> Text
constructorDoc Property
prop)
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
constructor Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pconstraints
           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " -> IO (GValueConstruct o)"
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
constructor Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " val = B.Properties.constructObjectProperty" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tStr
           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Property -> Text
propName Property
prop
           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if Bool
isNullable Bool -> Bool -> Bool
&& (Bool -> Bool
not Bool
isCallback)
              then "\" (Just val)"
              else "\" val"
  HaddockSection -> Text -> CodeGen ()
export HaddockSection
docSection Text
constructor

-- | Generate documentation for the given setter.
clearDoc :: Property -> Text
clearDoc :: Property -> Text
clearDoc prop :: Property
prop = [Text] -> Text
T.unlines [
    "Set the value of the “@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Property -> Text
propName Property
prop Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "@” property to `Nothing`."
  , "When <https://github.com/haskell-gi/haskell-gi/wiki/Overloading overloading> is enabled, this is equivalent to"
  , ""
  , "@"
  , "'Data.GI.Base.Attributes.clear'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Property -> Text
hPropName Property
prop
  , "@"]

genPropertyClear :: Text -> Name -> HaddockSection -> Property -> CodeGen ()
genPropertyClear :: Text -> Name -> HaddockSection -> Property -> CodeGen ()
genPropertyClear clear :: Text
clear n :: Name
n docSection :: HaddockSection
docSection prop :: Property
prop = 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
  let constraints :: [Text]
constraints = ["MonadIO m", Text
cls Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " o"]
  Text
tStr <- Type -> BaseCodeGen e Text
Type -> CodeGen Text
propTypeStr (Type -> BaseCodeGen e Text) -> Type -> BaseCodeGen e Text
forall a b. (a -> b) -> a -> b
$ Property -> Type
propType Property
prop
  RelativeDocPosition -> Text -> CodeGen ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Property -> Text
clearDoc Property
prop)
  Text
nothingType <- TypeRep -> Text
typeShow (TypeRep -> Text) -> (TypeRep -> TypeRep) -> TypeRep -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> TypeRep
maybeT (TypeRep -> Text)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) TypeRep
-> BaseCodeGen e Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
haskellType (Property -> Type
propType Property
prop)
  Bool
isCallback <- Type -> CodeGen Bool
typeIsCallback (Property -> Type
propType Property
prop)
  let nothing :: Text
nothing = if Bool
isCallback
                then "FP.nullFunPtr"
                else "(Nothing :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nothingType 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
$ Text
clear 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]
constraints
           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ") => o -> m ()"
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
clear Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " obj = liftIO $ B.Properties.setObjectProperty" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tStr
           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " obj \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Property -> Text
propName Property
prop Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nothing
  HaddockSection -> Text -> CodeGen ()
export HaddockSection
docSection Text
clear

-- | The property name as a lexically valid Haskell identifier. Note
-- that this is not escaped, since it is assumed that it will be used
-- with a prefix, so if a property is named "class", for example, this
-- will return "class".
hPropName :: Property -> Text
hPropName :: Property -> Text
hPropName = Text -> Text
lcFirst (Text -> Text) -> (Property -> Text) -> Property -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
hyphensToCamelCase (Text -> Text) -> (Property -> Text) -> Property -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Text
propName

genObjectProperties :: Name -> Object -> CodeGen ()
genObjectProperties :: Name -> Object -> CodeGen ()
genObjectProperties n :: Name
n o :: Object
o = do
  Bool
isGO <- Name -> API -> CodeGen Bool
apiIsGObject Name
n (Object -> API
APIObject Object
o)
  -- We do not generate bindings for objects not descending from GObject.
  Bool
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isGO (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]
allProps <- Name -> Object -> CodeGen [(Name, Property)]
fullObjectPropertyList Name
n Object
o BaseCodeGen e [(Name, Property)]
-> ([(Name, Property)]
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Text])
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Text]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                ((Name, Property)
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> [(Name, Property)]
-> 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 (\(owner :: Name
owner, prop :: Property
prop) -> do
                        Text
pi <- Name -> Property -> CodeGen Text
infoType Name
owner Property
prop
                        Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a b. (a -> b) -> a -> b
$ "'(\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Property -> Text
hPropName Property
prop
                                   Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")")
    Name -> [Property] -> [Text] -> CodeGen ()
genProperties Name
n (Object -> [Property]
objProperties Object
o) [Text]
allProps

genInterfaceProperties :: Name -> Interface -> CodeGen ()
genInterfaceProperties :: Name -> Interface -> CodeGen ()
genInterfaceProperties n :: Name
n iface :: Interface
iface = do
  [Text]
allProps <- Name -> Interface -> CodeGen [(Name, Property)]
fullInterfacePropertyList Name
n Interface
iface BaseCodeGen e [(Name, Property)]
-> ([(Name, Property)]
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Text])
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Text]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                ((Name, Property)
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> [(Name, Property)]
-> 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 (\(owner :: Name
owner, prop :: Property
prop) -> do
                        Text
pi <- Name -> Property -> CodeGen Text
infoType Name
owner Property
prop
                        Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text)
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a b. (a -> b) -> a -> b
$ "'(\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Property -> Text
hPropName Property
prop
                                   Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")")
  Name -> [Property] -> [Text] -> CodeGen ()
genProperties Name
n (Interface -> [Property]
ifProperties Interface
iface) [Text]
allProps

-- If the given accesor is available (indicated by available == True),
-- generate a fully qualified accesor name, otherwise just return
-- "undefined". accessor is "get", "set" or "construct"
accessorOrUndefined :: Bool -> Text -> Name -> Text -> CodeGen Text
accessorOrUndefined :: Bool -> Text -> Name -> Text -> CodeGen Text
accessorOrUndefined available :: Bool
available accessor :: Text
accessor owner :: Name
owner@(Name _ on :: Text
on) cName :: Text
cName =
    if Bool -> Bool
not Bool
available
    then Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall (m :: * -> *) a. Monad m => a -> m a
return "undefined"
    else Text -> Name -> CodeGen Text
qualifiedSymbol (Text
accessor Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
on Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cName) Name
owner

-- | The name of the type encoding the information for the property of
-- the object.
infoType :: Name -> Property -> CodeGen Text
infoType :: Name -> Property -> CodeGen Text
infoType owner :: Name
owner prop :: Property
prop =
    let infoType :: Text
infoType = Name -> Text
upperName Name
owner Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> Text
hyphensToCamelCase (Text -> Text) -> (Property -> Text) -> Property -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Text
propName) Property
prop
                   Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "PropertyInfo"
    in Text -> Name -> CodeGen Text
qualifiedSymbol Text
infoType Name
owner

genOneProperty :: Name -> Property -> ExcCodeGen ()
genOneProperty :: Name -> Property -> ExcCodeGen ()
genOneProperty owner :: Name
owner prop :: Property
prop = do
  let name :: Text
name = Name -> Text
upperName Name
owner
      cName :: Text
cName = (Text -> Text
hyphensToCamelCase (Text -> Text) -> (Property -> Text) -> Property -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Text
propName) Property
prop
      docSection :: HaddockSection
docSection = NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
PropertySection (Text -> Text
lcFirst Text
cName)
      pName :: Text
pName = Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cName
      flags :: [PropertyFlag]
flags = Property -> [PropertyFlag]
propFlags Property
prop
      writable :: Bool
writable = PropertyFlag
PropertyWritable PropertyFlag -> [PropertyFlag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PropertyFlag]
flags Bool -> Bool -> Bool
&&
                 (PropertyFlag
PropertyConstructOnly PropertyFlag -> [PropertyFlag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [PropertyFlag]
flags)
      readable :: Bool
readable = PropertyFlag
PropertyReadable PropertyFlag -> [PropertyFlag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PropertyFlag]
flags
      constructOnly :: Bool
constructOnly = PropertyFlag
PropertyConstructOnly PropertyFlag -> [PropertyFlag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PropertyFlag]
flags

  HaddockSection -> Documentation -> CodeGen ()
addSectionDocumentation HaddockSection
docSection (Property -> Documentation
propDoc Property
prop)

  -- For properties the meaning of having transfer /= TransferNothing
  -- is not clear (what are the right semantics for GValue setters?),
  -- and the other possibilities are very uncommon, so let us just
  -- assume that TransferNothing is always the case.
  Bool -> ExcCodeGen () -> ExcCodeGen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Property -> Transfer
propTransfer Property
prop Transfer -> Transfer -> Bool
forall a. Eq a => a -> a -> Bool
/= Transfer
TransferNothing) (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$
       Text -> ExcCodeGen ()
forall a. Text -> ExcCodeGen a
notImplementedError (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "Property " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pName
                               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " has unsupported transfer type "
                               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Transfer -> Text
forall a. Show a => a -> Text
tshow (Property -> Transfer
propTransfer Property
prop)

  Bool
isNullable <- Type -> CodeGen Bool
typeIsNullable (Property -> Type
propType Property
prop)

  Bool -> ExcCodeGen () -> ExcCodeGen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
readable Bool -> Bool -> Bool
|| Bool
writable Bool -> Bool -> Bool
|| Bool
constructOnly) (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$
       Text -> ExcCodeGen ()
forall a. Text -> ExcCodeGen a
notImplementedError (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "Property is not readable, writable, or constructible: "
                               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
tshow Text
pName

  ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
group (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "-- VVV Prop \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Property -> Text
propName Property
prop Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\""
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "   -- Type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a. Show a => a -> Text
tshow (Property -> Type
propType Property
prop)
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "   -- Flags: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [PropertyFlag] -> Text
forall a. Show a => a -> Text
tshow (Property -> [PropertyFlag]
propFlags Property
prop)
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "   -- Nullable: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Maybe Bool, Maybe Bool) -> Text
forall a. Show a => a -> Text
tshow (Property -> Maybe Bool
propReadNullable Property
prop,
                                        Property -> Maybe Bool
propWriteNullable Property
prop)

  Text
getter <- Bool -> Text -> Name -> Text -> CodeGen Text
accessorOrUndefined Bool
readable "get" Name
owner Text
cName
  Text
setter <- Bool -> Text -> Name -> Text -> CodeGen Text
accessorOrUndefined Bool
writable "set" Name
owner Text
cName
  Text
constructor <- Bool -> Text -> Name -> Text -> CodeGen Text
accessorOrUndefined (Bool
writable Bool -> Bool -> Bool
|| Bool
constructOnly)
                 "construct" Name
owner Text
cName
  Text
clear <- Bool -> Text -> Name -> Text -> CodeGen Text
accessorOrUndefined (Bool
isNullable Bool -> Bool -> Bool
&& Bool
writable Bool -> Bool -> Bool
&&
                                Property -> Maybe Bool
propWriteNullable Property
prop Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)
           "clear" Name
owner Text
cName

  Bool -> ExcCodeGen () -> ExcCodeGen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
getter Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= "undefined") (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text -> Name -> HaddockSection -> Property -> CodeGen ()
genPropertyGetter Text
getter Name
owner HaddockSection
docSection Property
prop
  Bool -> ExcCodeGen () -> ExcCodeGen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
setter Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= "undefined") (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text -> Name -> HaddockSection -> Property -> CodeGen ()
genPropertySetter Text
setter Name
owner HaddockSection
docSection Property
prop
  Bool -> ExcCodeGen () -> ExcCodeGen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
constructor Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= "undefined") (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$
       Text -> Name -> HaddockSection -> Property -> CodeGen ()
genPropertyConstructor Text
constructor Name
owner HaddockSection
docSection Property
prop
  Bool -> ExcCodeGen () -> ExcCodeGen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
clear Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= "undefined") (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text -> Name -> HaddockSection -> Property -> CodeGen ()
genPropertyClear Text
clear Name
owner HaddockSection
docSection Property
prop

  Text
outType <- if Bool -> Bool
not Bool
readable
             then Text -> BaseCodeGen CGError Text
forall (m :: * -> *) a. Monad m => a -> m a
return "()"
             else do
               Text
sOutType <- if Bool
isNullable Bool -> Bool -> Bool
&& Property -> Maybe Bool
propReadNullable Property
prop Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
                           then TypeRep -> Text
typeShow (TypeRep -> Text) -> (TypeRep -> TypeRep) -> TypeRep -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> TypeRep
maybeT (TypeRep -> Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> BaseCodeGen CGError Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
isoHaskellType (Property -> Type
propType Property
prop)
                           else TypeRep -> Text
typeShow (TypeRep -> Text)
-> ReaderT
     CodeGenConfig
     (StateT (CGState, ModuleInfo) (Except CGError))
     TypeRep
-> BaseCodeGen CGError Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CodeGen TypeRep
isoHaskellType (Property -> Type
propType Property
prop)
               Text -> BaseCodeGen CGError Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> BaseCodeGen CGError Text)
-> Text -> BaseCodeGen CGError Text
forall a b. (a -> b) -> a -> b
$ if (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ') Text
sOutType
                        then Text -> Text
parenthesize Text
sOutType
                        else Text
sOutType

  -- Polymorphic #label style lens
  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
$ do
    Text
cls <- Name -> CodeGen Text
classConstraint Name
owner
    Text
inConstraint <- if Bool
writable Bool -> Bool -> Bool
|| Bool
constructOnly
                    then Type -> CodeGen Text
propSetTypeConstraint (Property -> Type
propType Property
prop)
                    else Text -> BaseCodeGen CGError Text
forall (m :: * -> *) a. Monad m => a -> m a
return "(~) ()"
    Text
transferConstraint <- if Bool
writable Bool -> Bool -> Bool
|| Bool
constructOnly
                          then Type -> CodeGen Text
propTransferTypeConstraint (Property -> Type
propType Property
prop)
                          else Text -> BaseCodeGen CGError Text
forall (m :: * -> *) a. Monad m => a -> m a
return "(~) ()"
    Text
transferType <- if Bool
writable Bool -> Bool -> Bool
|| Bool
constructOnly
                    then Type -> CodeGen Text
propTransferType (Property -> Type
propType Property
prop)
                    else Text -> BaseCodeGen CGError Text
forall (m :: * -> *) a. Monad m => a -> m a
return "()"
    let allowedOps :: [Text]
allowedOps = (if Bool
writable
                      then ["'AttrSet", "'AttrConstruct"]
                      else [])
                     [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (if Bool
constructOnly
                         then ["'AttrConstruct"]
                         else [])
                     [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (if Bool
readable
                         then ["'AttrGet"]
                         else [])
                     [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (if Bool
isNullable Bool -> Bool -> Bool
&& Property -> Maybe Bool
propWriteNullable Property
prop Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
                         then ["'AttrClear"]
                         else [])
    Text
it <- Name -> Property -> CodeGen Text
infoType Name
owner Property
prop
    HaddockSection -> Text -> CodeGen ()
export HaddockSection
docSection Text
it
    Text -> ExcCodeGen ()
Text -> CodeGen ()
bline (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "data " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it
    Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "instance AttrInfo " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " where"
    ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
            Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "type AttrAllowedOps " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it
                     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]
allowedOps Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "]"
            Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "type AttrBaseTypeConstraint " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cls
            Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "type AttrSetTypeConstraint " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it
                     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
inConstraint
            Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "type AttrTransferTypeConstraint " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it
                     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
transferConstraint
            Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "type AttrTransferType " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
transferType
            Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "type AttrGetType " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
outType
            Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "type AttrLabel " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Property -> Text
propName Property
prop Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\""
            Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "type AttrOrigin " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
            Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "attrGet = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
getter
            Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "attrSet = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
setter
            if Bool
writable Bool -> Bool -> Bool
|| Bool
constructOnly
              then do Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "attrTransfer _ v = do"
                      ExcCodeGen () -> ExcCodeGen ()
forall e a. BaseCodeGen e a -> BaseCodeGen e a
indent (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ Text -> Type -> CodeGen ()
genPropTransfer "v" (Property -> Type
propType Property
prop)
              else Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "attrTransfer _ = undefined"
            Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "attrConstruct = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
constructor
            Text -> ExcCodeGen ()
Text -> CodeGen ()
line (Text -> ExcCodeGen ()) -> Text -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ "attrClear = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
clear

-- | Generate a placeholder property for those cases in which code
-- generation failed.
genPlaceholderProperty :: Name -> Property -> CodeGen ()
genPlaceholderProperty :: Name -> Property -> CodeGen ()
genPlaceholderProperty owner :: Name
owner prop :: Property
prop = do
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "-- XXX Placeholder"
  Text
it <- Name -> Property -> CodeGen Text
infoType Name
owner Property
prop
  let cName :: Text
cName = (Text -> Text
hyphensToCamelCase (Text -> Text) -> (Property -> Text) -> Property -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Text
propName) Property
prop
      docSection :: HaddockSection
docSection = NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
PropertySection (Text -> Text
lcFirst Text
cName)
  HaddockSection -> Text -> CodeGen ()
export HaddockSection
docSection Text
it
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "data " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it
  Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "instance AttrInfo " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it 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
$ do
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "type AttrAllowedOps " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it 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
$ "type AttrSetTypeConstraint " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it 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
$ "type AttrTransferTypeConstraint " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it 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
$ "type AttrTransferType " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it 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
$ "type AttrBaseTypeConstraint " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it 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
$ "type AttrGetType " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it 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
$ "type AttrLabel " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it 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
$ "type AttrOrigin " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
it Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
upperName Name
owner
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "attrGet = undefined"
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "attrSet = undefined"
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "attrConstruct = undefined"
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "attrClear = undefined"
    Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "attrTransfer = undefined"

genProperties :: Name -> [Property] -> [Text] -> CodeGen ()
genProperties :: Name -> [Property] -> [Text] -> CodeGen ()
genProperties n :: Name
n ownedProps :: [Property]
ownedProps allProps :: [Text]
allProps = do
  let name :: Text
name = Name -> Text
upperName Name
n

  [Property]
-> (Property
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Property]
ownedProps ((Property
  -> ReaderT
       CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> (Property
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ \prop :: Property
prop -> do
      (CGError -> CodeGen ()) -> ExcCodeGen () -> CodeGen ()
forall a. (CGError -> CodeGen a) -> ExcCodeGen a -> CodeGen a
handleCGExc (\err :: CGError
err -> do
                     Text -> BaseCodeGen e ()
Text -> CodeGen ()
line (Text -> BaseCodeGen e ()) -> Text -> BaseCodeGen e ()
forall a b. (a -> b) -> a -> b
$ "-- XXX Generation of property \""
                              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Property -> Text
propName Property
prop Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" of object \""
                              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CGError -> Text
describeCGError CGError
err
                     CPPGuard -> BaseCodeGen e () -> BaseCodeGen e ()
forall e a. CPPGuard -> BaseCodeGen e a -> BaseCodeGen e a
cppIf CPPGuard
CPPOverloading (Name -> Property -> CodeGen ()
genPlaceholderProperty Name
n Property
prop))
                  (Name -> Property -> ExcCodeGen ()
genOneProperty Name
n Property
prop)

  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
$ do
    let propListType :: Text
propListType = Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "AttributeList"
    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
$ "instance O.HasAttributeList " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
    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
$ "type instance O.AttributeList " 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
propListType
    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
$ "type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
propListType 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]
allProps Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "] :: [(Symbol, *)])"

-- | Generate gtk2hs compatible attribute labels (to ease
-- porting). These are namespaced labels, for examples
-- `widgetSensitive`. We take the list of methods, since there may be
-- name clashes (an example is Auth::is_for_proxy method in libsoup,
-- and the corresponding Auth::is-for-proxy property). When there is a
-- clash we give priority to the method.
genNamespacedPropLabels :: Name -> [Property] -> [Method] -> CodeGen ()
genNamespacedPropLabels :: Name -> [Property] -> [Method] -> CodeGen ()
genNamespacedPropLabels owner :: Name
owner props :: [Property]
props methods :: [Method]
methods =
    let lName :: Property -> Text
lName = Text -> Text
lcFirst (Text -> Text) -> (Property -> Text) -> Property -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
hyphensToCamelCase (Text -> Text) -> (Property -> Text) -> Property -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Text
propName
    in Name -> [Text] -> [Method] -> CodeGen ()
genNamespacedAttrLabels Name
owner ((Property -> Text) -> [Property] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Property -> Text
lName [Property]
props) [Method]
methods

genNamespacedAttrLabels :: Name -> [Text] -> [Method] -> CodeGen ()
genNamespacedAttrLabels :: Name -> [Text] -> [Method] -> CodeGen ()
genNamespacedAttrLabels owner :: Name
owner attrNames :: [Text]
attrNames methods :: [Method]
methods = do
  let name :: Text
name = Name -> Text
upperName Name
owner

  let methodNames :: Set Text
methodNames = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList ((Method -> Text) -> [Method] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Text
lowerName (Name -> Text) -> (Method -> Name) -> Method -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Name
methodName) [Method]
methods)
      filteredAttrs :: [Text]
filteredAttrs = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set Text
methodNames) [Text]
attrNames

  [Text]
-> (Text
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
filteredAttrs ((Text
  -> ReaderT
       CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> (Text
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ \attr :: Text
attr -> 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
    let cName :: Text
cName = Text -> Text
ucFirst Text
attr
        labelProxy :: Text
labelProxy = Text -> Text
lcFirst Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cName
        docSection :: HaddockSection
docSection = NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
PropertySection (Text -> Text
lcFirst Text
cName)

    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
$ Text
labelProxy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: AttrLabelProxy \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
lcFirst Text
cName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\""
    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
$ Text
labelProxy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " = AttrLabelProxy"

    HaddockSection -> Text -> CodeGen ()
export HaddockSection
docSection Text
labelProxy