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 -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"String"
TBasicType BasicType
TFileName -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"String"
TBasicType BasicType
TPtr -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Ptr"
Type
TByteArray -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"ByteArray"
TGHash Type
_ Type
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Hash"
Type
TVariant -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Variant"
Type
TParamSpec -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"ParamSpec"
TGClosure Maybe Type
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Closure"
Type
TError -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"GError"
Type
TGValue -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"GValue"
TBasicType BasicType
TInt -> case forall a. Storable a => a -> Int
sizeOf (CInt
0 :: CInt) of
Int
4 -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Int32"
Int
n -> forall a. HasCallStack => [Char] -> a
error ([Char]
"Unsupported `gint' type length: " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> [Char]
show Int
n)
TBasicType BasicType
TUInt -> case forall a. Storable a => a -> Int
sizeOf (CUInt
0 :: CUInt) of
Int
4 -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"UInt32"
Int
n -> forall a. HasCallStack => [Char] -> a
error ([Char]
"Unsupported `guint' type length: " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> [Char]
show Int
n)
TBasicType BasicType
TLong -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Long"
TBasicType BasicType
TULong -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"ULong"
TBasicType BasicType
TInt32 -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Int32"
TBasicType BasicType
TUInt32 -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"UInt32"
TBasicType BasicType
TInt64 -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Int64"
TBasicType BasicType
TUInt64 -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"UInt64"
TBasicType BasicType
TBoolean -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Bool"
TBasicType BasicType
TFloat -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Float"
TBasicType BasicType
TDouble -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Double"
TBasicType BasicType
TGType -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"GType"
TCArray Bool
True Int
_ Int
_ (TBasicType BasicType
TUTF8) -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"StringArray"
TCArray Bool
True Int
_ Int
_ (TBasicType BasicType
TFileName) -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"StringArray"
TGList (TBasicType BasicType
TPtr) -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"PtrGList"
t :: Type
t@(TInterface Name
n) -> do
API
api <- forall e. HasCallStack => Name -> CodeGen e API
findAPIByName Name
n
case API
api of
APIEnum Enumeration
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Enum"
APIFlags Flags
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Flags"
APICallback Callback
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Callback"
APIStruct Struct
s -> if Struct -> Bool
structIsBoxed Struct
s
then forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Boxed"
else forall a. Text -> ExcCodeGen a
notImplementedError forall a b. (a -> b) -> a -> b
$ Text
"Unboxed struct property : " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Type
t
APIUnion Union
u -> if Union -> Bool
unionIsBoxed Union
u
then forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Boxed"
else forall a. Text -> ExcCodeGen a
notImplementedError forall a b. (a -> b) -> a -> b
$ Text
"Unboxed union property : " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Type
t
APIObject Object
o -> do
Bool
isGO <- forall e. Type -> CodeGen e Bool
isGObject Type
t
if Bool
isGO
then forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Object"
else case (Object -> Maybe Text
objGetValueFunc Object
o, Object -> Maybe Text
objSetValueFunc Object
o) of
(Just Text
_, Just Text
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"IsGValueInstance"
(Maybe Text, Maybe Text)
_ -> forall a. Text -> ExcCodeGen a
notImplementedError forall a b. (a -> b) -> a -> b
$ Text
"Non-GObject object property without known gvalue_set and/or gvalue_get: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Type
t
APIInterface Interface
_ -> do
Bool
isGO <- forall e. Type -> CodeGen e Bool
isGObject Type
t
if Bool
isGO
then forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Object"
else forall a. Text -> ExcCodeGen a
notImplementedError forall a b. (a -> b) -> a -> b
$ Text
"Non-GObject interface property : " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Type
t
API
_ -> forall a. Text -> ExcCodeGen a
notImplementedError forall a b. (a -> b) -> a -> b
$ Text
"Unknown interface property of type : " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Type
t
Type
_ -> forall a. Text -> ExcCodeGen a
notImplementedError forall a b. (a -> b) -> a -> b
$ Text
"Don't know how to handle properties of type " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Type
t
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
api <- forall e. HasCallStack => Name -> CodeGen e API
findAPIByName Name
n
case API
api of
APIObject Object
o -> do
Bool
isGO <- forall e. Type -> CodeGen e Bool
isGObject Type
t
if Bool -> Bool
not Bool
isGO
then case (Object -> Maybe Text
objGetValueFunc Object
o, Object -> Maybe Text
objSetValueFunc Object
o) of
(Just Text
_, Just Text
_) -> do
let val' :: Text
val' = Text -> Text
prime Text
val
Text
cast <- forall e. Name -> CodeGen e Text
safeCast Name
n
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
val' forall a. Semigroup a => a -> a -> a
<> Text
" <- " forall a. Semigroup a => a -> a -> a
<> Text
cast forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
val
forall (m :: * -> *) a. Monad m => a -> m a
return Text
val'
(Maybe Text, Maybe Text)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
val
else forall (m :: * -> *) a. Monad m => a -> m a
return Text
val
API
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
val
castProp Type
_ Text
val = forall (m :: * -> *) a. Monad m => a -> m a
return Text
val
propSetTypeConstraint :: Type -> CodeGen e Text
propSetTypeConstraint :: forall e. Type -> CodeGen e Text
propSetTypeConstraint (TGClosure Maybe Type
Nothing) =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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
Bool
isGO <- forall e. Type -> CodeGen e Bool
isGObject Type
t
if Bool
isGO
then forall e. Type -> CodeGen e Text
typeConstraint Type
t
else do
Bool
isCallback <- forall e. Type -> CodeGen e Bool
typeIsCallback Type
t
Text
hInType <- if Bool
isCallback
then TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
foreignType Type
t
else TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
haskellType Type
t
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"(~) " forall a. Semigroup a => a -> a -> a
<> if (Char -> Bool) -> Text -> Bool
T.any (forall a. Eq a => a -> a -> Bool
== Char
' ') Text
hInType
then Text -> Text
parenthesize Text
hInType
else Text
hInType
propTransferTypeConstraint :: Type -> CodeGen e Text
propTransferTypeConstraint :: forall e. Type -> CodeGen e Text
propTransferTypeConstraint Type
t = do
Bool
isGO <- forall e. Type -> CodeGen e Bool
isGObject Type
t
if Bool
isGO
then forall e. Type -> CodeGen e Text
typeConstraint Type
t
else do
Text
hInType <- TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
isoHaskellType Type
t
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"(~) " forall a. Semigroup a => a -> a -> a
<> if (Char -> Bool) -> Text -> Bool
T.any (forall a. Eq a => a -> a -> Bool
== Char
' ') Text
hInType
then Text -> Text
parenthesize Text
hInType
else Text
hInType
propTransferType :: Type -> CodeGen e Text
propTransferType :: forall e. Type -> CodeGen e Text
propTransferType (TGClosure Maybe Type
Nothing) =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TypeRep -> Text
typeShow (Text
"GClosure" Text -> [TypeRep] -> TypeRep
`con` [Text -> TypeRep
con0 Text
"()"])
propTransferType Type
t = do
Bool
isCallback <- forall e. Type -> CodeGen e Bool
typeIsCallback Type
t
if Bool
isCallback
then TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
foreignType Type
t
else TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
haskellType Type
t
genPropTransfer :: Text -> Type -> CodeGen e ()
genPropTransfer :: forall e. Text -> Type -> CodeGen e ()
genPropTransfer Text
var (TGClosure Maybe Type
Nothing) = forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"return " forall a. Semigroup a => a -> a -> a
<> Text
var
genPropTransfer Text
var Type
t = do
Bool
isGO <- forall e. Type -> CodeGen e Bool
isGObject Type
t
if Bool
isGO
then do
Text
ht <- TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
haskellType Type
t
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"unsafeCastTo " forall a. Semigroup a => a -> a -> a
<> Text
ht forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
var
else case Type
t of
TInterface tn :: Name
tn@(Name Text
_ Text
n) -> do
Bool
isCallback <- forall e. Type -> CodeGen e Bool
typeIsCallback Type
t
if Bool -> Bool
not Bool
isCallback
then forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"return " forall a. Semigroup a => a -> a -> a
<> Text
var
else do
Text
wrapper <- forall e. Text -> Name -> CodeGen e Text
qualifiedSymbol (Text -> Text
callbackHaskellToForeign Text
n) Name
tn
Text
maker <- forall e. Text -> Name -> CodeGen e Text
qualifiedSymbol (Text -> Text
callbackWrapperAllocator Text
n) Name
tn
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
maker forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<>
Text -> Text
parenthesize (Text
wrapper forall a. Semigroup a => a -> a -> a
<> Text
" Nothing " forall a. Semigroup a => a -> a -> a
<> Text
var)
Type
_ -> forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"return " forall a. Semigroup a => a -> a -> a
<> Text
var
attrType :: Property -> CodeGen e ([Text], Text)
attrType :: forall e. Property -> CodeGen e ([Text], Text)
attrType Property
prop = do
forall e. CodeGen e ()
resetTypeVariableScope
Bool
isCallback <- forall e. Type -> CodeGen e Bool
typeIsCallback (Property -> Type
propType Property
prop)
if Bool
isCallback
then do
TypeRep
ftype <- forall e. Type -> CodeGen e TypeRep
foreignType (Property -> Type
propType Property
prop)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], TypeRep -> Text
typeShow TypeRep
ftype)
else do
(Text
t,[Text]
constraints) <- forall e. Type -> ExposeClosures -> CodeGen e (Text, [Text])
argumentType (Property -> Type
propType Property
prop) ExposeClosures
WithoutClosures
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text]
constraints, Text
t)
setterDoc :: Name -> Property -> Text
setterDoc :: Name -> Property -> Text
setterDoc Name
n Property
prop = [Text] -> Text
T.unlines [
Text
"Set the value of the “@" forall a. Semigroup a => a -> a -> a
<> Property -> Text
propName Property
prop 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' " forall a. Semigroup a => a -> a -> a
<> Name -> Text
lowerName Name
n forall a. Semigroup a => a -> a -> a
<> Text
" [ #" forall a. Semigroup a => a -> a -> a
<> Property -> Text
hPropName Property
prop
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 = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
([Text]
constraints, Text
t) <- forall e. Property -> CodeGen e ([Text], Text)
attrType Property
prop
Bool
isNullable <- forall e. Type -> CodeGen e Bool
typeIsNullable (Property -> Type
propType Property
prop)
Bool
isCallback <- forall e. Type -> CodeGen e Bool
typeIsCallback (Property -> Type
propType Property
prop)
Text
cls <- forall e. Name -> CodeGen e Text
classConstraint Name
n
let constraints' :: [Text]
constraints' = Text
"MonadIO m"forall a. a -> [a] -> [a]
:(Text
cls forall a. Semigroup a => a -> a -> a
<> Text
" o")forall a. a -> [a] -> [a]
:[Text]
constraints
Text
tStr <- Type -> ExcCodeGen Text
propTypeStr forall a b. (a -> b) -> a -> b
$ Property -> Type
propType Property
prop
forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Name -> Property -> Text
setterDoc Name
n Property
prop)
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
setter forall a. Semigroup a => a -> a -> a
<> Text
" :: (" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
constraints'
forall a. Semigroup a => a -> a -> a
<> Text
") => o -> " forall a. Semigroup a => a -> a -> a
<> Text
t forall a. Semigroup a => a -> a -> a
<> Text
" -> m ()"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
setter forall a. Semigroup a => a -> a -> a
<> Text
" obj val = MIO.liftIO $ do"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
Text
val' <- forall e. Type -> Text -> CodeGen e Text
castProp (Property -> Type
propType Property
prop) Text
"val"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"B.Properties.setObjectProperty" forall a. Semigroup a => a -> a -> a
<> Text
tStr
forall a. Semigroup a => a -> a -> a
<> Text
" obj \"" forall a. Semigroup a => a -> a -> a
<> Property -> Text
propName Property
prop
forall a. Semigroup a => a -> a -> a
<> if Bool
isNullable Bool -> Bool -> Bool
&& (Bool -> Bool
not Bool
isCallback)
then Text
"\" (Just " forall a. Semigroup a => a -> a -> a
<> Text
val' forall a. Semigroup a => a -> a -> a
<> Text
")"
else Text
"\" " forall a. Semigroup a => a -> a -> a
<> Text
val'
forall e. HaddockSection -> Text -> CodeGen e ()
export HaddockSection
docSection Text
setter
getterDoc :: Name -> Property -> Text
getterDoc :: Name -> Property -> Text
getterDoc Name
n Property
prop = [Text] -> Text
T.unlines [
Text
"Get the value of the “@" forall a. Semigroup a => a -> a -> a
<> Property -> Text
propName Property
prop 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' " forall a. Semigroup a => a -> a -> a
<> Name -> Text
lowerName Name
n forall a. Semigroup a => a -> a -> a
<> 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 = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
Bool
isNullable <- forall e. Type -> CodeGen e Bool
typeIsNullable (Property -> Type
propType Property
prop)
let isMaybe :: Bool
isMaybe = Bool
isNullable Bool -> Bool -> Bool
&& Property -> Maybe Bool
propReadNullable Property
prop forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Bool
False
TypeRep
constructorType <- forall e. Type -> CodeGen e TypeRep
isoHaskellType (Property -> Type
propType Property
prop)
Text
tStr <- Type -> ExcCodeGen Text
propTypeStr forall a b. (a -> b) -> a -> b
$ Property -> Type
propType Property
prop
Text
cls <- forall e. Name -> CodeGen e Text
classConstraint Name
n
let constraints :: Text
constraints = Text
"(MonadIO m, " forall a. Semigroup a => a -> a -> a
<> Text
cls forall a. Semigroup a => a -> a -> a
<> Text
" o)"
outType :: TypeRep
outType = if Bool
isMaybe
then TypeRep -> TypeRep
maybeT TypeRep
constructorType
else TypeRep
constructorType
returnType :: Text
returnType = TypeRep -> Text
typeShow forall a b. (a -> b) -> a -> b
$ Text
"m" Text -> [TypeRep] -> TypeRep
`con` [TypeRep
outType]
getProp :: Text
getProp = if Bool
isNullable Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isMaybe
then Text
"checkUnexpectedNothing \"" forall a. Semigroup a => a -> a -> a
<> Text
getter
forall a. Semigroup a => a -> a -> a
<> Text
"\" $ B.Properties.getObjectProperty" forall a. Semigroup a => a -> a -> a
<> Text
tStr
else Text
"B.Properties.getObjectProperty" forall a. Semigroup a => a -> a -> a
<> Text
tStr
Text
constructorArg <-
if Text
tStr forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"Object", Text
"Boxed"]
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
" " forall a. Semigroup a => a -> a -> a
<> TypeRep -> Text
typeShow TypeRep
constructorType
else (if Text
tStr forall a. Eq a => a -> a -> Bool
== Text
"Callback"
then do
TypeRep
callbackType <- forall e. Type -> CodeGen e TypeRep
haskellType (Property -> Type
propType Property
prop)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
" " forall a. Semigroup a => a -> a -> a
<> Text -> Text
callbackDynamicWrapper (TypeRep -> Text
typeShow TypeRep
callbackType)
else forall (m :: * -> *) a. Monad m => a -> m a
return Text
"")
forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Name -> Property -> Text
getterDoc Name
n Property
prop)
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
getter forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> Text
constraints forall a. Semigroup a => a -> a -> a
<>
Text
" => o -> " forall a. Semigroup a => a -> a -> a
<> Text
returnType
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
getter forall a. Semigroup a => a -> a -> a
<> Text
" obj = MIO.liftIO $ " forall a. Semigroup a => a -> a -> a
<> Text
getProp
forall a. Semigroup a => a -> a -> a
<> Text
" obj \"" forall a. Semigroup a => a -> a -> a
<> Property -> Text
propName Property
prop forall a. Semigroup a => a -> a -> a
<> Text
"\"" forall a. Semigroup a => a -> a -> a
<> Text
constructorArg
forall e. HaddockSection -> Text -> CodeGen e ()
export HaddockSection
docSection Text
getter
constructorDoc :: Property -> Text
constructorDoc :: Property -> Text
constructorDoc Property
prop = [Text] -> Text
T.unlines [
Text
"Construct a `GValueConstruct` with valid value for the “@" forall a. Semigroup a => a -> a -> a
<> Property -> Text
propName Property
prop 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 = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
([Text]
constraints, Text
t) <- forall e. Property -> CodeGen e ([Text], Text)
attrType Property
prop
Text
tStr <- Type -> ExcCodeGen Text
propTypeStr forall a b. (a -> b) -> a -> b
$ Property -> Type
propType Property
prop
Bool
isNullable <- forall e. Type -> CodeGen e Bool
typeIsNullable (Property -> Type
propType Property
prop)
Bool
isCallback <- forall e. Type -> CodeGen e Bool
typeIsCallback (Property -> Type
propType Property
prop)
Text
cls <- forall e. Name -> CodeGen e Text
classConstraint Name
n
let constraints' :: [Text]
constraints' = (Text
cls forall a. Semigroup a => a -> a -> a
<> Text
" o") forall a. a -> [a] -> [a]
: Text
"MIO.MonadIO m" forall a. a -> [a] -> [a]
: [Text]
constraints
pconstraints :: Text
pconstraints = Text -> Text
parenthesize (Text -> [Text] -> Text
T.intercalate Text
", " [Text]
constraints') forall a. Semigroup a => a -> a -> a
<> Text
" => "
forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Property -> Text
constructorDoc Property
prop)
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
constructor forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> Text
pconstraints
forall a. Semigroup a => a -> a -> a
<> Text
t forall a. Semigroup a => a -> a -> a
<> Text
" -> m (GValueConstruct o)"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
constructor forall a. Semigroup a => a -> a -> a
<> Text
" val = MIO.liftIO $ do"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
Text
val' <- forall e. Type -> Text -> CodeGen e Text
castProp (Property -> Type
propType Property
prop) Text
"val"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"MIO.liftIO $ B.Properties.constructObjectProperty" forall a. Semigroup a => a -> a -> a
<> Text
tStr
forall a. Semigroup a => a -> a -> a
<> Text
" \"" forall a. Semigroup a => a -> a -> a
<> Property -> Text
propName Property
prop
forall a. Semigroup a => a -> a -> a
<> if Bool
isNullable Bool -> Bool -> Bool
&& (Bool -> Bool
not Bool
isCallback)
then Text
"\" (P.Just " forall a. Semigroup a => a -> a -> a
<> Text
val' forall a. Semigroup a => a -> a -> a
<> Text
")"
else Text
"\" " forall a. Semigroup a => a -> a -> a
<> Text
val'
forall e. HaddockSection -> Text -> CodeGen e ()
export HaddockSection
docSection Text
constructor
clearDoc :: Property -> Text
clearDoc :: Property -> Text
clearDoc Property
prop = [Text] -> Text
T.unlines [
Text
"Set the value of the “@" forall a. Semigroup a => a -> a -> a
<> Property -> Text
propName Property
prop 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'" forall a. Semigroup a => a -> a -> a
<> 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 = forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
Text
cls <- forall e. Name -> CodeGen e Text
classConstraint Name
n
let constraints :: [Text]
constraints = [Text
"MonadIO m", Text
cls forall a. Semigroup a => a -> a -> a
<> Text
" o"]
Text
tStr <- Type -> ExcCodeGen Text
propTypeStr forall a b. (a -> b) -> a -> b
$ Property -> Type
propType Property
prop
forall e. RelativeDocPosition -> Text -> CodeGen e ()
writeHaddock RelativeDocPosition
DocBeforeSymbol (Property -> Text
clearDoc Property
prop)
Text
nothingType <- TypeRep -> Text
typeShow forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> TypeRep
maybeT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
haskellType (Property -> Type
propType Property
prop)
Bool
isCallback <- forall e. Type -> CodeGen e Bool
typeIsCallback (Property -> Type
propType Property
prop)
let nothing :: Text
nothing = if Bool
isCallback
then Text
"FP.nullFunPtr"
else Text
"(Nothing :: " forall a. Semigroup a => a -> a -> a
<> Text
nothingType forall a. Semigroup a => a -> a -> a
<> Text
")"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
clear forall a. Semigroup a => a -> a -> a
<> Text
" :: (" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
constraints
forall a. Semigroup a => a -> a -> a
<> Text
") => o -> m ()"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
clear forall a. Semigroup a => a -> a -> a
<> Text
" obj = liftIO $ B.Properties.setObjectProperty" forall a. Semigroup a => a -> a -> a
<> Text
tStr
forall a. Semigroup a => a -> a -> a
<> Text
" obj \"" forall a. Semigroup a => a -> a -> a
<> Property -> Text
propName Property
prop forall a. Semigroup a => a -> a -> a
<> Text
"\" " forall a. Semigroup a => a -> a -> a
<> Text
nothing
forall e. HaddockSection -> Text -> CodeGen e ()
export HaddockSection
docSection Text
clear
hPropName :: Property -> Text
hPropName :: Property -> Text
hPropName = Text -> Text
lcFirst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
hyphensToCamelCase 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
Bool
isGO <- forall e. Name -> API -> CodeGen e Bool
apiIsGObject Name
n (Object -> API
APIObject Object
o)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isGO forall a b. (a -> b) -> a -> b
$ do
[Text]
allProps <- forall e. Name -> Object -> CodeGen e [(Name, Property)]
fullObjectPropertyList Name
n Object
o forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Name
owner, Property
prop) -> do
Text
pi <- forall e. Name -> Property -> CodeGen e Text
infoType Name
owner Property
prop
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"'(\"" forall a. Semigroup a => a -> a -> a
<> Property -> Text
hPropName Property
prop
forall a. Semigroup a => a -> a -> a
<> Text
"\", " forall a. Semigroup a => a -> a -> a
<> Text
pi forall a. Semigroup a => a -> a -> a
<> Text
")")
forall e. Name -> [Property] -> [Text] -> CodeGen e ()
genProperties Name
n (Object -> [Property]
objProperties Object
o) [Text]
allProps
genInterfaceProperties :: Name -> Interface -> CodeGen e ()
genInterfaceProperties :: forall e. Name -> Interface -> CodeGen e ()
genInterfaceProperties Name
n Interface
iface = do
[Text]
allProps <- forall e. Name -> Interface -> CodeGen e [(Name, Property)]
fullInterfacePropertyList Name
n Interface
iface forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Name
owner, Property
prop) -> do
Text
pi <- forall e. Name -> Property -> CodeGen e Text
infoType Name
owner Property
prop
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"'(\"" forall a. Semigroup a => a -> a -> a
<> Property -> Text
hPropName Property
prop
forall a. Semigroup a => a -> a -> a
<> Text
"\", " forall a. Semigroup a => a -> a -> a
<> Text
pi forall a. Semigroup a => a -> a -> a
<> Text
")")
forall e. Name -> [Property] -> [Text] -> CodeGen e ()
genProperties Name
n (Interface -> [Property]
ifProperties Interface
iface) [Text]
allProps
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 forall (m :: * -> *) a. Monad m => a -> m a
return Text
"undefined"
else forall e. Text -> Name -> CodeGen e Text
qualifiedSymbol (Text
accessor forall a. Semigroup a => a -> a -> a
<> Text
on forall a. Semigroup a => a -> a -> a
<> Text
cName) Name
owner
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 forall a. Semigroup a => a -> a -> a
<> (Text -> Text
hyphensToCamelCase forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Text
propName) Property
prop
forall a. Semigroup a => a -> a -> a
<> Text
"PropertyInfo"
in 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 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 forall a. Semigroup a => a -> a -> a
<> Text
cName
flags :: [PropertyFlag]
flags = Property -> [PropertyFlag]
propFlags Property
prop
writable :: Bool
writable = PropertyFlag
PropertyWritable forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PropertyFlag]
flags Bool -> Bool -> Bool
&&
(PropertyFlag
PropertyConstructOnly forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [PropertyFlag]
flags)
readable :: Bool
readable = PropertyFlag
PropertyReadable forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PropertyFlag]
flags
constructOnly :: Bool
constructOnly = PropertyFlag
PropertyConstructOnly forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PropertyFlag]
flags
forall e. HaddockSection -> Documentation -> CodeGen e ()
addSectionDocumentation HaddockSection
docSection (Property -> Documentation
propDoc Property
prop)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Property -> Transfer
propTransfer Property
prop forall a. Eq a => a -> a -> Bool
/= Transfer
TransferNothing) forall a b. (a -> b) -> a -> b
$
forall a. Text -> ExcCodeGen a
notImplementedError forall a b. (a -> b) -> a -> b
$ Text
"Property " forall a. Semigroup a => a -> a -> a
<> Text
pName
forall a. Semigroup a => a -> a -> a
<> Text
" has unsupported transfer type "
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (Property -> Transfer
propTransfer Property
prop)
Bool
isNullable <- forall e. Type -> CodeGen e Bool
typeIsNullable (Property -> Type
propType Property
prop)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
readable Bool -> Bool -> Bool
|| Bool
writable Bool -> Bool -> Bool
|| Bool
constructOnly) forall a b. (a -> b) -> a -> b
$
forall a. Text -> ExcCodeGen a
notImplementedError forall a b. (a -> b) -> a -> b
$ Text
"Property is not readable, writable, or constructible: "
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Text
pName
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"-- VVV Prop \"" forall a. Semigroup a => a -> a -> a
<> Property -> Text
propName Property
prop forall a. Semigroup a => a -> a -> a
<> Text
"\""
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
" -- Type: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (Property -> Type
propType Property
prop)
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
" -- Flags: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (Property -> [PropertyFlag]
propFlags Property
prop)
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
" -- Nullable: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (Property -> Maybe Bool
propReadNullable Property
prop,
Property -> Maybe Bool
propWriteNullable Property
prop)
Text
getter <- forall e. Bool -> Text -> Name -> Text -> CodeGen e Text
accessorOrUndefined Bool
readable Text
"get" Name
owner Text
cName
Text
setter <- forall e. Bool -> Text -> Name -> Text -> CodeGen e Text
accessorOrUndefined Bool
writable Text
"set" Name
owner Text
cName
Text
constructor <- forall e. Bool -> Text -> Name -> Text -> CodeGen e Text
accessorOrUndefined (Bool
writable Bool -> Bool -> Bool
|| Bool
constructOnly)
Text
"construct" Name
owner Text
cName
Text
clear <- forall e. Bool -> Text -> Name -> Text -> CodeGen e Text
accessorOrUndefined (Bool
isNullable Bool -> Bool -> Bool
&& Bool
writable Bool -> Bool -> Bool
&&
Property -> Maybe Bool
propWriteNullable Property
prop forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Bool
False)
Text
"clear" Name
owner Text
cName
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
getter forall a. Eq a => a -> a -> Bool
/= Text
"undefined") forall a b. (a -> b) -> a -> b
$ Text -> Name -> HaddockSection -> Property -> ExcCodeGen ()
genPropertyGetter Text
getter Name
owner HaddockSection
docSection Property
prop
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
setter forall a. Eq a => a -> a -> Bool
/= Text
"undefined") forall a b. (a -> b) -> a -> b
$ Text -> Name -> HaddockSection -> Property -> ExcCodeGen ()
genPropertySetter Text
setter Name
owner HaddockSection
docSection Property
prop
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
constructor forall a. Eq a => a -> a -> Bool
/= Text
"undefined") forall a b. (a -> b) -> a -> b
$
Text -> Name -> HaddockSection -> Property -> ExcCodeGen ()
genPropertyConstructor Text
constructor Name
owner HaddockSection
docSection Property
prop
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
clear forall a. Eq a => a -> a -> Bool
/= Text
"undefined") forall a b. (a -> b) -> a -> b
$ Text -> Name -> HaddockSection -> Property -> ExcCodeGen ()
genPropertyClear Text
clear Name
owner HaddockSection
docSection Property
prop
Text
outType <- if Bool -> Bool
not Bool
readable
then forall (m :: * -> *) a. Monad m => a -> m a
return Text
"()"
else do
Text
sOutType <- if Bool
isNullable Bool -> Bool -> Bool
&& Property -> Maybe Bool
propReadNullable Property
prop forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Bool
False
then TypeRep -> Text
typeShow forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> TypeRep
maybeT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
isoHaskellType (Property -> Type
propType Property
prop)
else TypeRep -> Text
typeShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Type -> CodeGen e TypeRep
isoHaskellType (Property -> Type
propType Property
prop)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if (Char -> Bool) -> Text -> Bool
T.any (forall a. Eq a => a -> a -> Bool
== Char
' ') Text
sOutType
then Text -> Text
parenthesize Text
sOutType
else Text
sOutType
forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf CPPGuard
CPPOverloading forall a b. (a -> b) -> a -> b
$ do
Text
cls <- forall e. Name -> CodeGen e Text
classConstraint Name
owner
Text
inConstraint <- if Bool
writable Bool -> Bool -> Bool
|| Bool
constructOnly
then forall e. Type -> CodeGen e Text
propSetTypeConstraint (Property -> Type
propType Property
prop)
else forall (m :: * -> *) a. Monad m => a -> m a
return Text
"(~) ()"
Text
transferConstraint <- if Bool
writable Bool -> Bool -> Bool
|| Bool
constructOnly
then forall e. Type -> CodeGen e Text
propTransferTypeConstraint (Property -> Type
propType Property
prop)
else forall (m :: * -> *) a. Monad m => a -> m a
return Text
"(~) ()"
Text
transferType <- if Bool
writable Bool -> Bool -> Bool
|| Bool
constructOnly
then forall e. Type -> CodeGen e Text
propTransferType (Property -> Type
propType Property
prop)
else forall (m :: * -> *) a. Monad m => a -> m a
return Text
"()"
let allowedOps :: [Text]
allowedOps = (if Bool
writable
then [Text
"'AttrSet", Text
"'AttrConstruct"]
else [])
forall a. Semigroup a => a -> a -> a
<> (if Bool
constructOnly
then [Text
"'AttrConstruct"]
else [])
forall a. Semigroup a => a -> a -> a
<> (if Bool
readable
then [Text
"'AttrGet"]
else [])
forall a. Semigroup a => a -> a -> a
<> (if Bool
isNullable Bool -> Bool -> Bool
&& Property -> Maybe Bool
propWriteNullable Property
prop forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Bool
False
then [Text
"'AttrClear"]
else [])
Text
it <- forall e. Name -> Property -> CodeGen e Text
infoType Name
owner Property
prop
forall e. HaddockSection -> Text -> CodeGen e ()
export HaddockSection
docSection Text
it
API
api <- forall e. HasCallStack => Name -> CodeGen e API
findAPIByName Name
owner
Text
hackageLink <- forall e. Name -> CodeGen e Text
hackageModuleLink Name
owner
let qualifiedAttrName :: Text
qualifiedAttrName = ModulePath -> Text
dotModulePath (Name -> API -> ModulePath
moduleLocation Name
owner API
api)
forall a. Semigroup a => a -> a -> a
<> Text
"." forall a. Semigroup a => a -> a -> a
<> Text
lcAttr
attrInfoURL :: Text
attrInfoURL = Text
hackageLink forall a. Semigroup a => a -> a -> a
<> Text
"#" forall a. Semigroup a => a -> a -> a
<> Text
haddockAttrAnchor forall a. Semigroup a => a -> a -> a
<> Text
lcAttr
forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"data " forall a. Semigroup a => a -> a -> a
<> Text
it
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"instance AttrInfo " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" where"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrAllowedOps " forall a. Semigroup a => a -> a -> a
<> Text
it
forall a. Semigroup a => a -> a -> a
<> Text
" = '[ " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
allowedOps forall a. Semigroup a => a -> a -> a
<> Text
"]"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrBaseTypeConstraint " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
cls
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrSetTypeConstraint " forall a. Semigroup a => a -> a -> a
<> Text
it
forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
inConstraint
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrTransferTypeConstraint " forall a. Semigroup a => a -> a -> a
<> Text
it
forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
transferConstraint
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrTransferType " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
transferType
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrGetType " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
outType
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrLabel " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = \"" forall a. Semigroup a => a -> a -> a
<> Property -> Text
propName Property
prop forall a. Semigroup a => a -> a -> a
<> Text
"\""
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrOrigin " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
name
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"attrGet = " forall a. Semigroup a => a -> a -> a
<> Text
getter
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"attrSet = " forall a. Semigroup a => a -> a -> a
<> Text
setter
if Bool
writable Bool -> Bool -> Bool
|| Bool
constructOnly
then do forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"attrTransfer _ v = do"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e. Text -> Type -> CodeGen e ()
genPropTransfer Text
"v" (Property -> Type
propType Property
prop)
else forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"attrTransfer _ = undefined"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"attrConstruct = " forall a. Semigroup a => a -> a -> a
<> Text
constructor
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"attrClear = " forall a. Semigroup a => a -> a -> a
<> Text
clear
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"dbgAttrInfo = P.Just (O.ResolvedSymbolInfo {"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"O.resolvedSymbolName = \"" forall a. Semigroup a => a -> a -> a
<> Text
qualifiedAttrName forall a. Semigroup a => a -> a -> a
<> Text
"\""
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
", O.resolvedSymbolURL = \"" forall a. Semigroup a => a -> a -> a
<> Text
attrInfoURL forall a. Semigroup a => a -> a -> a
<> Text
"\""
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"})"
genPlaceholderProperty :: Name -> Property -> CodeGen e ()
genPlaceholderProperty :: forall e. Name -> Property -> CodeGen e ()
genPlaceholderProperty Name
owner Property
prop = do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"-- XXX Placeholder"
Text
it <- forall e. Name -> Property -> CodeGen e Text
infoType Name
owner Property
prop
let cName :: Text
cName = (Text -> Text
hyphensToCamelCase 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)
forall e. HaddockSection -> Text -> CodeGen e ()
export HaddockSection
docSection Text
it
forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"data " forall a. Semigroup a => a -> a -> a
<> Text
it
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"instance AttrInfo " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" where"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrAllowedOps " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = '[]"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrSetTypeConstraint " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = (~) ()"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrTransferTypeConstraint " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = (~) ()"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrTransferType " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = ()"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrBaseTypeConstraint " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = (~) ()"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrGetType " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = ()"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrLabel " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = \"\""
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type AttrOrigin " forall a. Semigroup a => a -> a -> a
<> Text
it forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Name -> Text
upperName Name
owner
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"attrGet = undefined"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"attrSet = undefined"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"attrConstruct = undefined"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"attrClear = undefined"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"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
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Property]
ownedProps forall a b. (a -> b) -> a -> b
$ \Property
prop -> do
forall e a. (CGError -> CodeGen e a) -> ExcCodeGen a -> CodeGen e a
handleCGExc (\CGError
err -> do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"-- XXX Generation of property \""
forall a. Semigroup a => a -> a -> a
<> Property -> Text
propName Property
prop forall a. Semigroup a => a -> a -> a
<> Text
"\" of object \""
forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"\" failed."
forall e. CGError -> CodeGen e ()
printCGError CGError
err
forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf CPPGuard
CPPOverloading (forall e. Name -> Property -> CodeGen e ()
genPlaceholderProperty Name
n Property
prop))
(Name -> Property -> ExcCodeGen ()
genOneProperty Name
n Property
prop)
forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf CPPGuard
CPPOverloading forall a b. (a -> b) -> a -> b
$ do
let propListType :: Text
propListType = Text
name forall a. Semigroup a => a -> a -> a
<> Text
"AttributeList"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"instance O.HasAttributeList " forall a. Semigroup a => a -> a -> a
<> Text
name
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type instance O.AttributeList " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
propListType
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type " forall a. Semigroup a => a -> a -> a
<> Text
propListType forall a. Semigroup a => a -> a -> a
<> Text
" = ('[ "
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
allProps forall a. Semigroup a => a -> a -> a
<> Text
"] :: [(Symbol, *)])"
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
hyphensToCamelCase forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Text
propName
in forall e. Name -> [Text] -> [Method] -> CodeGen e ()
genNamespacedAttrLabels Name
owner (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 = forall a. Ord a => [a] -> Set a
S.fromList (forall a b. (a -> b) -> [a] -> [b]
map (Name -> Text
lowerName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Name
methodName) [Method]
methods)
filteredAttrs :: [Text]
filteredAttrs = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set Text
methodNames) [Text]
attrNames
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
filteredAttrs forall a b. (a -> b) -> a -> b
$ \Text
attr -> forall e a. CodeGen e a -> CodeGen e a
group 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 forall a. Semigroup a => a -> a -> a
<> Text
cName
docSection :: HaddockSection
docSection = NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
PropertySection (Text -> Text
lcFirst Text
cName)
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
labelProxy forall a. Semigroup a => a -> a -> a
<> Text
" :: AttrLabelProxy \"" forall a. Semigroup a => a -> a -> a
<> Text -> Text
lcFirst Text
cName forall a. Semigroup a => a -> a -> a
<> Text
"\""
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
labelProxy forall a. Semigroup a => a -> a -> a
<> Text
" = AttrLabelProxy"
forall e. HaddockSection -> Text -> CodeGen e ()
export HaddockSection
docSection Text
labelProxy