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.ModulePath (dotModulePath)
import Data.GI.CodeGen.SymbolNaming (lowerName, upperName, classConstraint,
                                     hyphensToCamelCase, qualifiedSymbol,
                                     typeConstraint, callbackDynamicWrapper,
                                     callbackHaskellToForeign,
                                     callbackWrapperAllocator, safeCast,
                                     hackageModuleLink, moduleLocation,
                                     haddockAttrAnchor)
import Data.GI.CodeGen.Type
import Data.GI.CodeGen.Util

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

-- | Some types need casting to a concrete type before we can set or
-- construct properties. For example, for non-GObject object
-- properties we accept any instance of @IsX@ for convenience, but
-- instance resolution of the IsGValueSetter requires a concrete
-- type. The following code implements the cast on the given variable,
-- if needed, and returns the name of the new variable of concrete
-- type.
castProp :: Type -> Text -> CodeGen e Text
castProp :: forall e. Type -> Text -> CodeGen e Text
castProp t :: Type
t@(TInterface Name
n) Text
val = do
  api <- Name -> CodeGen e API
forall e. HasCallStack => Name -> CodeGen e API
findAPIByName Name
n
  case api of
    APIObject Object
o -> do
      isGO <- Type -> CodeGen e Bool
forall e. Type -> CodeGen e Bool
isGObject Type
t
      if not isGO
        then case (objGetValueFunc o, objSetValueFunc o) of
               (Just Text
_, Just Text
_) -> do
                 let val' :: Text
val' = Text -> Text
prime Text
val
                 cast <- Name
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall e. Name -> CodeGen e Text
safeCast Name
n
                 line $ val' <> " <- " <> cast <> " " <> val
                 return val'
               (Maybe Text, Maybe Text)
_ -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
val
        else return val
    API
_ -> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
val
castProp Type
_ Text
val = Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
val

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

-- | The constraint for transferring the given type into a property.
propTransferTypeConstraint :: Type -> CodeGen e Text
propTransferTypeConstraint :: forall e. Type -> CodeGen e Text
propTransferTypeConstraint Type
t = do
  isGO <- Type -> CodeGen e Bool
forall e. Type -> CodeGen e Bool
isGObject Type
t
  if isGO
    then typeConstraint t
    else do
      hInType <- typeShow <$> isoHaskellType t
      return $ "(~) " <> if T.any (== ' ') hInType
                         then parenthesize hInType
                         else hInType

-- | The type of the return value of @attrTransfer@ for the given
-- type.
propTransferType :: Type -> CodeGen e Text
propTransferType :: forall e. Type -> CodeGen e Text
propTransferType (TGClosure Maybe Type
Nothing) =
  Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
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 (Text
"GClosure" Text -> [TypeRep] -> TypeRep
`con` [Text -> TypeRep
con0 Text
"()"])
propTransferType Type
t = do
  isCallback <- Type -> CodeGen e Bool
forall e. Type -> CodeGen e Bool
typeIsCallback Type
t
  if isCallback
             then typeShow <$> foreignType t
             else typeShow <$> haskellType 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 e ()
genPropTransfer :: forall e. Text -> Type -> CodeGen e ()
genPropTransfer Text
var (TGClosure Maybe Type
Nothing) = Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"return " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
var
genPropTransfer Text
var Type
t = do
  isGO <- Type -> CodeGen e Bool
forall e. Type -> CodeGen e Bool
isGObject Type
t
  if isGO
    then do
      ht <- typeShow <$> haskellType t
      line $ "unsafeCastTo " <> ht <> " " <> var
    else case t of
           TInterface tn :: Name
tn@(Name Text
_ Text
n) -> do
             isCallback <- Type -> CodeGen e Bool
forall e. Type -> CodeGen e Bool
typeIsCallback Type
t
             if not isCallback
               then line $ "return " <> var
               else do
               -- Callbacks need to be wrapped
               wrapper <- qualifiedSymbol (callbackHaskellToForeign n) tn
               maker <- qualifiedSymbol (callbackWrapperAllocator n) tn
               line $ maker <> " " <>
                 parenthesize (wrapper <> " Nothing " <> var)
           Type
_ -> Text -> CodeGen e ()
forall e. Text -> CodeGen e ()
line (Text -> CodeGen e ()) -> Text -> CodeGen e ()
forall a b. (a -> b) -> a -> b
$ Text
"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 e ([Text], Text)
attrType :: forall e. Property -> CodeGen e ([Text], Text)
attrType Property
prop = do
  CodeGen e ()
forall e. CodeGen e ()
resetTypeVariableScope
  isCallback <- Type -> CodeGen e Bool
forall e. Type -> CodeGen e Bool
typeIsCallback (Property -> Type
propType Property
prop)
  if isCallback
    then do
      ftype <- foreignType (propType prop)
      return ([], typeShow ftype)
    else do
      (t,constraints) <- argumentType (propType prop) WithoutClosures
      return (constraints, t)

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

genPropertySetter :: Text -> Name -> HaddockSection -> Property -> ExcCodeGen ()
genPropertySetter :: Text -> Name -> HaddockSection -> Property -> ExcCodeGen ()
genPropertySetter Text
setter Name
n HaddockSection
docSection Property
prop = ExcCodeGen () -> ExcCodeGen ()
forall e a. CodeGen e a -> CodeGen e a
group (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
  (constraints, t) <- Property -> CodeGen CGError ([Text], Text)
forall e. Property -> CodeGen e ([Text], Text)
attrType Property
prop
  isNullable <- typeIsNullable (propType prop)
  isCallback <- typeIsCallback (propType prop)
  cls <- classConstraint n
  let constraints' = Text
"MonadIO m"Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:(Text
cls Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" o")Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
constraints
  tStr <- propTypeStr $ propType prop
  writeHaddock DocBeforeSymbol (setterDoc n prop)
  line $ setter <> " :: (" <> T.intercalate ", " constraints'
           <> ") => o -> " <> t <> " -> m ()"
  line $ setter <> " obj val = MIO.liftIO $ do"
  indent $ do
    val' <- castProp (propType prop) "val"
    line $ "B.Properties.setObjectProperty" <> tStr
             <> " obj \"" <> propName prop
             <> if isNullable && (not isCallback)
                then "\" (Just " <> val' <> ")"
                else "\" " <> val'
  export docSection setter

-- | Generate documentation for the given getter.
getterDoc :: Name -> Property -> Text
getterDoc :: Name -> Property -> Text
getterDoc Name
n Property
prop = [Text] -> Text
T.unlines [
    Text
"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
<> Text
"@” property."
  , Text
"When <https://github.com/haskell-gi/haskell-gi/wiki/Overloading overloading> is enabled, this is equivalent to"
  , Text
""
  , Text
"@"
  , Text
"'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 -> Text
forall a. Semigroup a => a -> a -> a
<> Property -> Text
hPropName Property
prop
  , Text
"@"]

genPropertyGetter :: Text -> Name -> HaddockSection -> Property -> ExcCodeGen ()
genPropertyGetter :: Text -> Name -> HaddockSection -> Property -> ExcCodeGen ()
genPropertyGetter Text
getter Name
n HaddockSection
docSection Property
prop = ExcCodeGen () -> ExcCodeGen ()
forall e a. CodeGen e a -> CodeGen e a
group (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
  isNullable <- Type -> CodeGen CGError Bool
forall e. Type -> CodeGen e Bool
typeIsNullable (Property -> Type
propType Property
prop)
  let 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
  constructorType <- isoHaskellType (propType prop)
  tStr <- propTypeStr $ propType prop
  cls <- classConstraint n
  let constraints = Text
"(MonadIO m, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cls Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" o)"
      outType = if Bool
isMaybe
                then TypeRep -> TypeRep
maybeT TypeRep
constructorType
                else TypeRep
constructorType
      returnType = TypeRep -> Text
typeShow (TypeRep -> Text) -> TypeRep -> Text
forall a b. (a -> b) -> a -> b
$ Text
"m" Text -> [TypeRep] -> TypeRep
`con` [TypeRep
outType]
      getProp = if Bool
isNullable Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isMaybe
                then Text
"checkUnexpectedNothing \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
getter
                         Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" $ B.Properties.getObjectProperty" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tStr
                else Text
"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.
  constructorArg <-
    if tStr `elem` ["Object", "Boxed"]
    then return $ " " <> typeShow constructorType
    else (if tStr == "Callback"
          then do
             callbackType <- haskellType (propType prop)
             return $ " " <> callbackDynamicWrapper (typeShow callbackType)
          else return "")

  writeHaddock DocBeforeSymbol (getterDoc n prop)
  line $ getter <> " :: " <> constraints <>
                " => o -> " <> returnType
  line $ getter <> " obj = MIO.liftIO $ " <> getProp
           <> " obj \"" <> propName prop <> "\"" <> constructorArg
  export docSection getter

-- | Generate documentation for the given constructor.
constructorDoc :: Property -> Text
constructorDoc :: Property -> Text
constructorDoc Property
prop = [Text] -> Text
T.unlines [
    Text
"Construct a t'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
<> Text
"@” property. This is rarely needed directly, but it is used by `Data.GI.Base.Constructible.new`."
    ]

genPropertyConstructor :: Text -> Name -> HaddockSection -> Property -> ExcCodeGen ()
genPropertyConstructor :: Text -> Name -> HaddockSection -> Property -> ExcCodeGen ()
genPropertyConstructor Text
constructor Name
n HaddockSection
docSection Property
prop = ExcCodeGen () -> ExcCodeGen ()
forall e a. CodeGen e a -> CodeGen e a
group (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
  (constraints, t) <- Property -> CodeGen CGError ([Text], Text)
forall e. Property -> CodeGen e ([Text], Text)
attrType Property
prop
  tStr <- propTypeStr $ propType prop
  isNullable <- typeIsNullable (propType prop)
  isCallback <- typeIsCallback (propType prop)
  cls <- classConstraint n
  let constraints' = (Text
cls Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" o") Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
"MIO.MonadIO m" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
constraints
      pconstraints = Text -> Text
parenthesize (Text -> [Text] -> Text
T.intercalate Text
", " [Text]
constraints') Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" => "
  writeHaddock DocBeforeSymbol (constructorDoc prop)
  line $ constructor <> " :: " <> pconstraints
           <> t <> " -> m (GValueConstruct o)"
  line $ constructor <> " val = MIO.liftIO $ do"
  indent $ do
    val' <- castProp (propType prop) "val"
    line $ "MIO.liftIO $ B.Properties.constructObjectProperty" <> tStr
           <> " \"" <> propName prop
           <> if isNullable && (not isCallback)
              then "\" (P.Just " <> val' <> ")"
              else "\" " <> val'
  export docSection constructor

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

genPropertyClear :: Text -> Name -> HaddockSection -> Property -> ExcCodeGen ()
genPropertyClear :: Text -> Name -> HaddockSection -> Property -> ExcCodeGen ()
genPropertyClear Text
clear Name
n HaddockSection
docSection Property
prop = ExcCodeGen () -> ExcCodeGen ()
forall e a. CodeGen e a -> CodeGen e a
group (ExcCodeGen () -> ExcCodeGen ()) -> ExcCodeGen () -> ExcCodeGen ()
forall a b. (a -> b) -> a -> b
$ do
  cls <- Name -> ExcCodeGen Text
forall e. Name -> CodeGen e Text
classConstraint Name
n
  let constraints = [Text
"MonadIO m", Text
cls Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" o"]
  tStr <- propTypeStr $ propType prop
  writeHaddock DocBeforeSymbol (clearDoc prop)
  nothingType <- typeShow . maybeT <$> haskellType (propType prop)
  isCallback <- typeIsCallback (propType prop)
  let nothing = if Bool
isCallback
                then Text
"FP.nullFunPtr"
                else Text
"(Nothing :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nothingType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  line $ clear <> " :: (" <> T.intercalate ", " constraints
           <> ") => o -> m ()"
  line $ clear <> " obj = liftIO $ B.Properties.setObjectProperty" <> tStr
           <> " obj \"" <> propName prop <> "\" " <> nothing
  export docSection 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 e ()
genObjectProperties :: forall e. Name -> Object -> CodeGen e ()
genObjectProperties Name
n Object
o = do
  isGO <- Name -> API -> CodeGen e Bool
forall e. Name -> API -> CodeGen e Bool
apiIsGObject Name
n (Object -> API
APIObject Object
o)
  -- We do not generate bindings for objects not descending from GObject.
  when isGO $ do
    allProps <- fullObjectPropertyList n o >>=
                mapM (\(Name
owner, Property
prop) -> do
                        pi <- Name
-> Property
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall e. Name -> Property -> CodeGen e Text
infoType Name
owner Property
prop
                        return $ "'(\"" <> hPropName prop
                                   <> "\", " <> pi <> ")")
    genProperties n (objProperties o) allProps

genInterfaceProperties :: Name -> Interface -> CodeGen e ()
genInterfaceProperties :: forall e. Name -> Interface -> CodeGen e ()
genInterfaceProperties Name
n Interface
iface = do
  allProps <- Name -> Interface -> CodeGen e [(Name, Property)]
forall e. Name -> Interface -> CodeGen e [(Name, Property)]
fullInterfacePropertyList Name
n Interface
iface CodeGen e [(Name, Property)]
-> ([(Name, Property)]
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Text])
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) [Text]
forall a b.
ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
-> (a
    -> ReaderT
         CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) b)
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) b
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(Name
owner, Property
prop) -> do
                        pi <- Name
-> Property
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall e. Name -> Property -> CodeGen e Text
infoType Name
owner Property
prop
                        return $ "'(\"" <> hPropName prop
                                   <> "\", " <> pi <> ")")
  genProperties n (ifProperties iface) 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 e Text
accessorOrUndefined :: forall e. Bool -> Text -> Name -> Text -> CodeGen e Text
accessorOrUndefined Bool
available Text
accessor owner :: Name
owner@(Name Text
_ Text
on) Text
cName =
    if Bool -> Bool
not Bool
available
    then Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall a.
a
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"undefined"
    else Text
-> Name
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) Text
forall e. Text -> Name -> CodeGen e 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 e Text
infoType :: forall e. Name -> Property -> CodeGen e Text
infoType Name
owner 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
<> Text
"PropertyInfo"
    in Text -> Name -> CodeGen e Text
forall e. Text -> Name -> CodeGen e Text
qualifiedSymbol Text
infoType Name
owner

genOneProperty :: Name -> Property -> ExcCodeGen ()
genOneProperty :: Name -> Property -> ExcCodeGen ()
genOneProperty Name
owner 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
      lcAttr :: Text
lcAttr = Text -> Text
lcFirst Text
cName
      docSection :: HaddockSection
docSection = NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
PropertySection Text
lcAttr
      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 a. Eq a => a -> [a] -> 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 a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PropertyFlag]
flags
      constructOnly :: Bool
constructOnly = PropertyFlag
PropertyConstructOnly PropertyFlag -> [PropertyFlag] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PropertyFlag]
flags

  HaddockSection -> Documentation -> ExcCodeGen ()
forall e. HaddockSection -> Documentation -> CodeGen e ()
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
$ Text
"Property " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pName
                               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" 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)

  isNullable <- Type -> CodeGen CGError Bool
forall e. Type -> CodeGen e Bool
typeIsNullable (Property -> Type
propType Property
prop)

  unless (readable || writable || constructOnly) $
       notImplementedError $ "Property is not readable, writable, or constructible: "
                               <> tshow pName

  group $ do
    line $ "-- VVV Prop \"" <> propName prop <> "\""
    line $ "   -- Type: " <> tshow (propType prop)
    line $ "   -- Flags: " <> tshow (propFlags prop)
    line $ "   -- Nullable: " <> tshow (propReadNullable prop,
                                        propWriteNullable prop)

  getter <- accessorOrUndefined readable "get" owner cName
  setter <- accessorOrUndefined writable "set" owner cName
  constructor <- accessorOrUndefined (writable || constructOnly)
                 "construct" owner cName
  clear <- accessorOrUndefined (isNullable && writable &&
                                propWriteNullable prop /= Just False)
           "clear" owner cName

  when (getter /= "undefined") $ genPropertyGetter getter owner docSection prop
  when (setter /= "undefined") $ genPropertySetter setter owner docSection prop
  when (constructor /= "undefined") $
       genPropertyConstructor constructor owner docSection prop
  when (clear /= "undefined") $ genPropertyClear clear owner docSection prop

  outType <- if not readable
             then return "()"
             else do
               sOutType <- if isNullable && propReadNullable prop /= Just False
                           then typeShow . maybeT <$> isoHaskellType (propType prop)
                           else typeShow <$> isoHaskellType (propType prop)
               return $ if T.any (== ' ') sOutType
                        then parenthesize sOutType
                        else sOutType

  -- Polymorphic #label style lens
  cppIf CPPOverloading $ do
    cls <- classConstraint owner
    inConstraint <- if writable || constructOnly
                    then propSetTypeConstraint (propType prop)
                    else return "(~) ()"
    transferConstraint <- if writable || constructOnly
                          then propTransferTypeConstraint (propType prop)
                          else return "(~) ()"
    transferType <- if writable || constructOnly
                    then propTransferType (propType prop)
                    else return "()"
    let allowedOps = (if Bool
writable
                      then [Text
"'AttrSet", Text
"'AttrConstruct"]
                      else [])
                     [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (if Bool
constructOnly
                         then [Text
"'AttrConstruct"]
                         else [])
                     [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (if Bool
readable
                         then [Text
"'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 [Text
"'AttrClear"]
                         else [])
    it <- infoType owner prop
    export docSection it
    api <- findAPIByName owner
    hackageLink <- hackageModuleLink owner
    let qualifiedAttrName = ModulePath -> Text
dotModulePath (Name -> API -> ModulePath
moduleLocation Name
owner API
api)
                            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
lcAttr
        attrInfoURL = Text
hackageLink Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
haddockAttrAnchor Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
lcAttr
    bline $ "data " <> it
    line $ "instance AttrInfo " <> it <> " where"
    indent $ do
            line $ "type AttrAllowedOps " <> it
                     <> " = '[ " <> T.intercalate ", " allowedOps <> "]"
            line $ "type AttrBaseTypeConstraint " <> it <> " = " <> cls
            line $ "type AttrSetTypeConstraint " <> it
                     <> " = " <> inConstraint
            line $ "type AttrTransferTypeConstraint " <> it
                     <> " = " <> transferConstraint
            line $ "type AttrTransferType " <> it <> " = " <> transferType
            line $ "type AttrGetType " <> it <> " = " <> outType
            line $ "type AttrLabel " <> it <> " = \"" <> propName prop <> "\""
            line $ "type AttrOrigin " <> it <> " = " <> name
            line $ "attrGet = " <> getter
            line $ "attrSet = " <> setter
            if writable || constructOnly
              then do line $ "attrTransfer _ v = do"
                      indent $ genPropTransfer "v" (propType prop)
              else line $ "attrTransfer _ = undefined"
            line $ "attrConstruct = " <> constructor
            line $ "attrClear = " <> clear
            line $ "dbgAttrInfo = P.Just (O.ResolvedSymbolInfo {"
            indent $ do
              line $ "O.resolvedSymbolName = \"" <> qualifiedAttrName <> "\""
              line $ ", O.resolvedSymbolURL = \"" <> attrInfoURL <> "\""
              line $ "})"

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

genProperties :: Name -> [Property] -> [Text] -> CodeGen e ()
genProperties :: forall e. Name -> [Property] -> [Text] -> CodeGen e ()
genProperties Name
n [Property]
ownedProps [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
$ \Property
prop -> do
      (CGError
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ExcCodeGen ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e a. (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a
handleCGExc (\CGError
err -> do
                     Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. Text -> CodeGen e ()
line (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ Text
"-- 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
<> Text
"\" of object \""
                              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" failed."
                     CGError
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. CGError -> CodeGen e ()
printCGError CGError
err
                     CPPGuard
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf CPPGuard
CPPOverloading (Name
-> Property
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. Name -> Property -> CodeGen e ()
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 -> CodeGen e a -> CodeGen 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
<> Text
"AttributeList"
    Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. Text -> CodeGen e ()
line (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ Text
"instance O.HasAttributeList " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
    Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. Text -> CodeGen e ()
line (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ Text
"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 -> Text
forall a. Semigroup a => a -> a -> a
<> Text
propListType
    Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. Text -> CodeGen e ()
line (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ Text
"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 -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
allProps Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"] :: [(Symbol, DK.Type)])"

-- | 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 e ()
genNamespacedPropLabels :: forall e. Name -> [Property] -> [Method] -> CodeGen e ()
genNamespacedPropLabels Name
owner [Property]
props [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 e ()
forall e. Name -> [Text] -> [Method] -> CodeGen e ()
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 e ()
genNamespacedAttrLabels :: forall e. Name -> [Text] -> [Method] -> CodeGen e ()
genNamespacedAttrLabels Name
owner [Text]
attrNames [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
$ \Text
attr -> ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e a. CodeGen e a -> CodeGen e a
group (ReaderT CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ do
    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)) ()
forall e. Text -> CodeGen e ()
line (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ Text
labelProxy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: 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
"\""
    Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. Text -> CodeGen e ()
line (Text
 -> ReaderT
      CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ())
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall a b. (a -> b) -> a -> b
$ Text
labelProxy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = AttrLabelProxy"

    HaddockSection
-> Text
-> ReaderT
     CodeGenConfig (StateT (CGState, ModuleInfo) (Except e)) ()
forall e. HaddockSection -> Text -> CodeGen e ()
export HaddockSection
docSection Text
labelProxy