module Data.GI.CodeGen.OverloadedMethods
( genMethodList
, genMethodInfo
, genUnsupportedMethodInfo
) where
import Control.Monad (forM, forM_, when)
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import Data.Text (Text)
import qualified Data.Text as T
import Data.GI.CodeGen.API
import Data.GI.CodeGen.Conversions (ExposeClosures(..))
import Data.GI.CodeGen.Callable (callableSignature, Signature(..),
ForeignSymbol(..), fixupCallerAllocates)
import Data.GI.CodeGen.Code
import Data.GI.CodeGen.ModulePath (dotModulePath)
import Data.GI.CodeGen.SymbolNaming (lowerName, upperName, qualifiedSymbol,
moduleLocation, hackageModuleLink)
import Data.GI.CodeGen.Util (ucFirst)
methodInfoName :: Name -> Method -> CodeGen e Text
methodInfoName :: forall e. Name -> Method -> CodeGen e Text
methodInfoName Name
n Method
method =
let infoName :: Text
infoName = Name -> Text
upperName Name
n forall a. Semigroup a => a -> a -> a
<> (Text -> Text
ucFirst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
lowerName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Name
methodName) Method
method
forall a. Semigroup a => a -> a -> a
<> Text
"MethodInfo"
in forall e. Text -> Name -> CodeGen e Text
qualifiedSymbol Text
infoName Name
n
genMethodResolver :: Text -> CodeGen e ()
genMethodResolver :: forall e. Text -> CodeGen e ()
genMethodResolver Text
n = do
forall e. Text -> CodeGen e ()
addLanguagePragma Text
"TypeApplications"
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
"instance (info ~ Resolve" forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
"Method t " forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
", "
forall a. Semigroup a => a -> a -> a
<> Text
"O.OverloadedMethod info " forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
" p) => OL.IsLabel t ("
forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
" -> p) where"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"#if MIN_VERSION_base(4,10,0)"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"fromLabel = O.overloadedMethod @info"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"#else"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"fromLabel _ = O.overloadedMethod @info"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"#endif"
forall e a. CPPGuard -> CodeGen e a -> CodeGen e a
cppIf (Text -> (Integer, Integer, Integer) -> CPPGuard
CPPMinVersion Text
"base" (Integer
4,Integer
13,Integer
0)) forall a b. (a -> b) -> a -> b
$ 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
"instance (info ~ Resolve" forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
"Method t " forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
", "
forall a. Semigroup a => a -> a -> a
<> Text
"O.OverloadedMethod info " forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
" p, "
forall a. Semigroup a => a -> a -> a
<> Text
"R.HasField t " forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
" p) => "
forall a. Semigroup a => a -> a -> a
<> Text
"R.HasField t " forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
" p where"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"getField = O.overloadedMethod @info"
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
"instance (info ~ Resolve" forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
"Method t " forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
", "
forall a. Semigroup a => a -> a -> a
<> Text
"O.OverloadedMethodInfo info " forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
") => "
forall a. Semigroup a => a -> a -> a
<> Text
"OL.IsLabel t (O.MethodProxy info "
forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
") where"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"#if MIN_VERSION_base(4,10,0)"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"fromLabel = O.MethodProxy"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"#else"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"fromLabel _ = O.MethodProxy"
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"#endif"
genMethodList :: Name -> [(Name, Method)] -> CodeGen e ()
genMethodList :: forall e. Name -> [(Name, Method)] -> CodeGen e ()
genMethodList Name
n [(Name, Method)]
methods = do
let name :: Text
name = Name -> Text
upperName Name
n
let filteredMethods :: [(Name, Method)]
filteredMethods = forall a. (a -> Bool) -> [a] -> [a]
filter (Name, Method) -> Bool
isOrdinaryMethod [(Name, Method)]
methods
gets :: [(Name, Method)]
gets = forall a. (a -> Bool) -> [a] -> [a]
filter (Name, Method) -> Bool
isGet [(Name, Method)]
filteredMethods
sets :: [(Name, Method)]
sets = forall a. (a -> Bool) -> [a] -> [a]
filter (Name, Method) -> Bool
isSet [(Name, Method)]
filteredMethods
others :: [(Name, Method)]
others = forall a. (a -> Bool) -> [a] -> [a]
filter (\(Name, Method)
m -> Bool -> Bool
not ((Name, Method) -> Bool
isSet (Name, Method)
m Bool -> Bool -> Bool
|| (Name, Method) -> Bool
isGet (Name, Method)
m)) [(Name, Method)]
filteredMethods
orderedMethods :: [(Name, Method)]
orderedMethods = [(Name, Method)]
others forall a. [a] -> [a] -> [a]
++ [(Name, Method)]
gets forall a. [a] -> [a] -> [a]
++ [(Name, Method)]
sets
[(Text, Text)]
infos <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Name, Method)]
orderedMethods forall a b. (a -> b) -> a -> b
$ \(Name
owner, Method
method) ->
do Text
mi <- forall e. Name -> Method -> CodeGen e Text
methodInfoName Name
owner Method
method
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name -> Text
lowerName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Name
methodName) Method
method, Text
mi)
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
let resolver :: Text
resolver = Text
"Resolve" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"Method"
forall e. HaddockSection -> Text -> CodeGen e ()
export (NamedSection -> HaddockSection
Section NamedSection
MethodSection) Text
resolver
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"type family " forall a. Semigroup a => a -> a -> a
<> Text
resolver forall a. Semigroup a => a -> a -> a
<> Text
" (t :: Symbol) (o :: DK.Type) :: DK.Type where"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Text, Text)]
infos forall a b. (a -> b) -> a -> b
$ \(Text
label, Text
info) -> do
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
resolver forall a. Semigroup a => a -> a -> a
<> Text
" \"" forall a. Semigroup a => a -> a -> a
<> Text
label forall a. Semigroup a => a -> a -> a
<> Text
"\" o = " forall a. Semigroup a => a -> a -> a
<> Text
info
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
resolver forall a. Semigroup a => a -> a -> a
<> Text
" l o = O.MethodResolutionFailed l o"
forall e. Text -> CodeGen e ()
genMethodResolver Text
name
Text
docs <- forall e.
[(Name, Method)]
-> [(Name, Method)] -> [(Name, Method)] -> CodeGen e Text
methodListDocumentation [(Name, Method)]
others [(Name, Method)]
gets [(Name, Method)]
sets
forall e. HaddockSection -> Text -> CodeGen e ()
prependSectionFormattedDocs (NamedSection -> HaddockSection
Section NamedSection
MethodSection) Text
docs
where isOrdinaryMethod :: (Name, Method) -> Bool
isOrdinaryMethod :: (Name, Method) -> Bool
isOrdinaryMethod (Name
_, Method
m) = Method -> MethodType
methodType Method
m forall a. Eq a => a -> a -> Bool
== MethodType
OrdinaryMethod
isGet :: (Name, Method) -> Bool
isGet :: (Name, Method) -> Bool
isGet (Name
_, Method
m) = Text
"get_" Text -> Text -> Bool
`T.isPrefixOf` (Name -> Text
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Name
methodName) Method
m
isSet :: (Name, Method) -> Bool
isSet :: (Name, Method) -> Bool
isSet (Name
_, Method
m) = Text
"set_" Text -> Text -> Bool
`T.isPrefixOf` (Name -> Text
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Name
methodName) Method
m
methodListDocumentation :: [(Name, Method)] -> [(Name, Method)]
-> [(Name, Method)] -> CodeGen e Text
methodListDocumentation :: forall e.
[(Name, Method)]
-> [(Name, Method)] -> [(Name, Method)] -> CodeGen e Text
methodListDocumentation [] [] [] = forall (m :: * -> *) a. Monad m => a -> m a
return Text
""
methodListDocumentation [(Name, Method)]
ordinary [(Name, Method)]
getters [(Name, Method)]
setters = do
Text
ordinaryFormatted <- forall e. [(Name, Method)] -> CodeGen e Text
formatMethods [(Name, Method)]
ordinary
Text
gettersFormatted <- forall e. [(Name, Method)] -> CodeGen e Text
formatMethods [(Name, Method)]
getters
Text
settersFormatted <- forall e. [(Name, Method)] -> CodeGen e Text
formatMethods [(Name, Method)]
setters
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"\n\n === __Click to display all available methods, including inherited ones__\n"
forall a. Semigroup a => a -> a -> a
<> Text
"==== Methods\n" forall a. Semigroup a => a -> a -> a
<> Text
ordinaryFormatted
forall a. Semigroup a => a -> a -> a
<> Text
"\n==== Getters\n" forall a. Semigroup a => a -> a -> a
<> Text
gettersFormatted
forall a. Semigroup a => a -> a -> a
<> Text
"\n==== Setters\n" forall a. Semigroup a => a -> a -> a
<> Text
settersFormatted
where formatMethods :: [(Name, Method)] -> CodeGen e Text
formatMethods :: forall e. [(Name, Method)] -> CodeGen e Text
formatMethods [] = forall (m :: * -> *) a. Monad m => a -> m a
return Text
"/None/.\n"
formatMethods [(Name, Method)]
methods = do
[Text]
qualifiedMethods <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Name, Method)]
methods forall a b. (a -> b) -> a -> b
$ \(Name
owner, Method
m) -> do
API
api <- forall e. HasCallStack => Name -> CodeGen e API
findAPIByName Name
owner
let mn :: Text
mn = Name -> Text
lowerName (Method -> Name
methodName Method
m)
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
mn forall a. Semigroup a => a -> a -> a
<>
Text
"](\"" forall a. Semigroup a => a -> a -> a
<> ModulePath -> Text
dotModulePath (Name -> API -> ModulePath
moduleLocation Name
owner API
api)
forall a. Semigroup a => a -> a -> a
<> Text
"#g:method:" forall a. Semigroup a => a -> a -> a
<> Text
mn forall a. Semigroup a => a -> a -> a
<> Text
"\")"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
", " [Text]
qualifiedMethods forall a. Semigroup a => a -> a -> a
<> Text
".\n"
genMethodInfo :: Name -> Method -> ExcCodeGen ()
genMethodInfo :: Name -> Method -> ExcCodeGen ()
genMethodInfo Name
n Method
m =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Method -> MethodType
methodType Method
m forall a. Eq a => a -> a -> Bool
== MethodType
OrdinaryMethod) forall a b. (a -> b) -> a -> b
$
forall e a. CodeGen e a -> CodeGen e a
group forall a b. (a -> b) -> a -> b
$ do
API
api <- forall e. HasCallStack => Name -> CodeGen e API
findAPIByName Name
n
Text
infoName <- forall e. Name -> Method -> CodeGen e Text
methodInfoName Name
n Method
m
let callable :: Callable
callable = Callable -> Callable
fixupCallerAllocates (Method -> Callable
methodCallable Method
m)
Signature
sig <- Callable -> ForeignSymbol -> ExposeClosures -> ExcCodeGen Signature
callableSignature Callable
callable (Text -> ForeignSymbol
KnownForeignSymbol forall a. HasCallStack => a
undefined) ExposeClosures
WithoutClosures
forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"data " forall a. Semigroup a => a -> a -> a
<> Text
infoName
let (Text
obj, [Text]
otherTypes) = case forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (Signature -> [(Maybe Arg, Text)]
signatureArgTypes Signature
sig) of
[] -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Internal error: too few parameters! " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Method
m
(Text
obj':[Text]
otherTypes') -> (Text
obj', [Text]
otherTypes')
sigConstraint :: Text
sigConstraint = Text
"signature ~ (" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
" -> "
([Text]
otherTypes forall a. [a] -> [a] -> [a]
++ [Signature -> Text
signatureReturnType Signature
sig]) forall a. Semigroup a => a -> a -> a
<> Text
")"
Text
hackageLink <- forall e. Name -> CodeGen e Text
hackageModuleLink Name
n
let mn :: Name
mn = Method -> Name
methodName Method
m
mangled :: Text
mangled = Name -> Text
lowerName (Name
mn {name :: Text
name = Name -> Text
name Name
n forall a. Semigroup a => a -> a -> a
<> Text
"_" forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
mn})
dbgInfo :: Text
dbgInfo = ModulePath -> Text
dotModulePath (Name -> API -> ModulePath
moduleLocation Name
n API
api) forall a. Semigroup a => a -> a -> a
<> Text
"." forall a. Semigroup a => a -> a -> a
<> Text
mangled
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
"instance ("
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (Text
sigConstraint forall a. a -> [a] -> [a]
: Signature -> [Text]
signatureConstraints Signature
sig)
forall a. Semigroup a => a -> a -> a
<> Text
") => O.OverloadedMethod " forall a. Semigroup a => a -> a -> a
<> Text
infoName forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
obj
forall a. Semigroup a => a -> a -> a
<> Text
" signature where"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"overloadedMethod = " forall a. Semigroup a => a -> a -> a
<> Text
mangled
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
"instance O.OverloadedMethodInfo " forall a. Semigroup a => a -> a -> a
<> Text
infoName forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
obj
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
"overloadedMethodInfo = 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
dbgInfo 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
hackageLink forall a. Semigroup a => a -> a -> a
<> Text
"#v:" forall a. Semigroup a => a -> a -> a
<> Text
mangled forall a. Semigroup a => a -> a -> a
<> Text
"\""
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"})"
forall e. HaddockSection -> Text -> CodeGen e ()
export (NamedSection -> Text -> HaddockSection
NamedSubsection NamedSection
MethodSection forall a b. (a -> b) -> a -> b
$ Name -> Text
lowerName Name
mn) Text
infoName
genUnsupportedMethodInfo :: Name -> Method -> CodeGen e ()
genUnsupportedMethodInfo :: forall e. Name -> Method -> CodeGen e ()
genUnsupportedMethodInfo Name
n Method
m = do
Text
infoName <- forall e. Name -> Method -> CodeGen e Text
methodInfoName Name
n Method
m
forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"-- XXX: Dummy instance, since code generation failed.\n"
forall a. Semigroup a => a -> a -> a
<> Text
"-- Please file a bug at http://github.com/haskell-gi/haskell-gi."
forall e. Text -> CodeGen e ()
bline forall a b. (a -> b) -> a -> b
$ Text
"data " forall a. Semigroup a => a -> a -> a
<> Text
infoName
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
"instance (p ~ (), o ~ O.UnsupportedMethodError \""
forall a. Semigroup a => a -> a -> a
<> Name -> Text
lowerName (Method -> Name
methodName Method
m) forall a. Semigroup a => a -> a -> a
<> Text
"\" " forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
n
forall a. Semigroup a => a -> a -> a
<> Text
") => O.OverloadedMethod " forall a. Semigroup a => a -> a -> a
<> Text
infoName forall a. Semigroup a => a -> a -> a
<> Text
" o p where"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"overloadedMethod = undefined"
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
"instance (o ~ O.UnsupportedMethodError \""
forall a. Semigroup a => a -> a -> a
<> Name -> Text
lowerName (Method -> Name
methodName Method
m) forall a. Semigroup a => a -> a -> a
<> Text
"\" " forall a. Semigroup a => a -> a -> a
<> Name -> Text
name Name
n
forall a. Semigroup a => a -> a -> a
<> Text
") => O.OverloadedMethodInfo " forall a. Semigroup a => a -> a -> a
<> Text
infoName forall a. Semigroup a => a -> a -> a
<> Text
" o where"
forall e a. CodeGen e a -> CodeGen e a
indent forall a b. (a -> b) -> a -> b
$ forall e. Text -> CodeGen e ()
line forall a b. (a -> b) -> a -> b
$ Text
"overloadedMethodInfo = undefined"
forall e. HaddockSection -> Text -> CodeGen e ()
export HaddockSection
ToplevelSection Text
infoName