1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
|
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)
-- | Qualified name for the info for a given method.
methodInfoName :: Name -> Method -> CodeGen e Text
methodInfoName n method =
let infoName = upperName n <> (ucFirst . lowerName . methodName) method
<> "MethodInfo"
in qualifiedSymbol infoName n
-- | Appropriate instances so overloaded labels are properly resolved.
genMethodResolver :: Text -> CodeGen e ()
genMethodResolver n = do
addLanguagePragma "TypeApplications"
group $ do
line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", "
<> "O.OverloadedMethod info " <> n <> " p) => OL.IsLabel t ("
<> n <> " -> p) where"
line $ "#if MIN_VERSION_base(4,10,0)"
indent $ line $ "fromLabel = O.overloadedMethod @info"
line $ "#else"
indent $ line $ "fromLabel _ = O.overloadedMethod @info"
line $ "#endif"
-- The circular instance trick is to avoid the liberal coverage
-- condition. We should be using DYSFUNCTIONAL pragmas instead, once
-- those are implemented:
-- https://github.com/ghc-proposals/ghc-proposals/pull/374
cppIf (CPPMinVersion "base" (4,13,0)) $ group $ do
line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", "
<> "O.OverloadedMethod info " <> n <> " p, "
<> "R.HasField t " <> n <> " p) => "
<> "R.HasField t " <> n <> " p where"
indent $ line $ "getField = O.overloadedMethod @info"
group $ do
line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", "
<> "O.OverloadedMethodInfo info " <> n <> ") => "
<> "OL.IsLabel t (O.MethodProxy info "
<> n <> ") where"
line $ "#if MIN_VERSION_base(4,10,0)"
indent $ line $ "fromLabel = O.MethodProxy"
line $ "#else"
indent $ line $ "fromLabel _ = O.MethodProxy"
line $ "#endif"
-- | Generate the `MethodList` instance given the list of methods for
-- the given named type. Returns a Haddock comment summarizing the
-- list of methods available.
genMethodList :: Name -> [(Name, Method)] -> CodeGen e ()
genMethodList n methods = do
let name = upperName n
let filteredMethods = filter isOrdinaryMethod methods
gets = filter isGet filteredMethods
sets = filter isSet filteredMethods
others = filter (\m -> not (isSet m || isGet m)) filteredMethods
orderedMethods = others ++ gets ++ sets
infos <- forM orderedMethods $ \(owner, method) ->
do mi <- methodInfoName owner method
return ((lowerName . methodName) method, mi)
group $ do
let resolver = "Resolve" <> name <> "Method"
export (Section MethodSection) resolver
line $ "type family " <> resolver <> " (t :: Symbol) (o :: DK.Type) :: DK.Type where"
indent $ forM_ infos $ \(label, info) -> do
line $ resolver <> " \"" <> label <> "\" o = " <> info
indent $ line $ resolver <> " l o = O.MethodResolutionFailed l o"
genMethodResolver name
docs <- methodListDocumentation others gets sets
prependSectionFormattedDocs (Section MethodSection) docs
where isOrdinaryMethod :: (Name, Method) -> Bool
isOrdinaryMethod (_, m) = methodType m == OrdinaryMethod
isGet :: (Name, Method) -> Bool
isGet (_, m) = "get_" `T.isPrefixOf` (name . methodName) m
isSet :: (Name, Method) -> Bool
isSet (_, m) = "set_" `T.isPrefixOf` (name . methodName) m
-- | Format a haddock comment with the information about available
-- methods.
methodListDocumentation :: [(Name, Method)] -> [(Name, Method)]
-> [(Name, Method)] -> CodeGen e Text
methodListDocumentation [] [] [] = return ""
methodListDocumentation ordinary getters setters = do
ordinaryFormatted <- formatMethods ordinary
gettersFormatted <- formatMethods getters
settersFormatted <- formatMethods setters
return $ "\n\n === __Click to display all available methods, including inherited ones__\n"
<> "==== Methods\n" <> ordinaryFormatted
<> "\n==== Getters\n" <> gettersFormatted
<> "\n==== Setters\n" <> settersFormatted
where formatMethods :: [(Name, Method)] -> CodeGen e Text
formatMethods [] = return "/None/.\n"
formatMethods methods = do
qualifiedMethods <- forM methods $ \(owner, m) -> do
api <- findAPIByName owner
let mn = lowerName (methodName m)
return $ "[" <> mn <>
"](\"" <> dotModulePath (moduleLocation owner api)
<> "#g:method:" <> mn <> "\")"
return $ T.intercalate ", " qualifiedMethods <> ".\n"
-- | Treat the instance argument of a method as non-null, even if the
-- introspection data may say otherwise. Returns the modified
-- callable, together with a boolean value indicating where the
-- nullability annotation has been erased.
nonNullableInstanceArg :: Callable -> (Callable, Bool)
nonNullableInstanceArg c = case args c of
inst:rest -> (c {args = inst {mayBeNull = False} : rest}, mayBeNull inst)
[] -> (c, False)
-- | Generate the `MethodInfo` type and instance for the given method.
genMethodInfo :: Name -> Method -> ExcCodeGen ()
genMethodInfo n m =
when (methodType m == OrdinaryMethod) $
group $ do
api <- findAPIByName n
infoName <- methodInfoName n m
let (callable, nullableInstance) =
nonNullableInstanceArg . fixupCallerAllocates $ methodCallable m
sig <- callableSignature callable (KnownForeignSymbol undefined) WithoutClosures
bline $ "data " <> infoName
let (obj, otherTypes) = case map snd (signatureArgTypes sig) of
-- This should not happen, since ordinary methods always
-- have the instance as first argument.
[] -> error $ "Internal error: too few parameters! " ++ show m
(obj':otherTypes') -> (obj', otherTypes')
sigConstraint = "signature ~ (" <> T.intercalate " -> "
(otherTypes ++ [signatureReturnType sig]) <> ")"
hackageLink <- hackageModuleLink n
let mn = methodName m
mangled = lowerName (mn {name = name n <> "_" <> name mn})
dbgInfo = dotModulePath (moduleLocation n api) <> "." <> mangled
group $ do
line $ "instance ("
<> T.intercalate ", " (sigConstraint : signatureConstraints sig)
<> ") => O.OverloadedMethod " <> infoName <> " " <> obj
<> " signature where"
if nullableInstance
then indent $ line $ "overloadedMethod i = " <> mangled <> " (Just i)"
else indent $ line $ "overloadedMethod = " <> mangled
group $ do
line $ "instance O.OverloadedMethodInfo " <> infoName <> " " <> obj
<> " where"
indent $ do
line $ "overloadedMethodInfo = P.Just (O.ResolvedSymbolInfo {"
indent $ do
line $ "O.resolvedSymbolName = \"" <> dbgInfo <> "\","
line $ "O.resolvedSymbolURL = \"" <>
hackageLink <> "#v:" <> mangled <> "\""
line $ "})"
export (NamedSubsection MethodSection $ lowerName mn) infoName
-- | Generate a method info that is not actually callable, but rather
-- gives a type error when trying to use it.
genUnsupportedMethodInfo :: Name -> Method -> CodeGen e ()
genUnsupportedMethodInfo n m = do
infoName <- methodInfoName n m
line $ "-- XXX: Dummy instance, since code generation failed.\n"
<> "-- Please file a bug at http://github.com/haskell-gi/haskell-gi."
bline $ "data " <> infoName
group $ do
line $ "instance (p ~ (), o ~ O.UnsupportedMethodError \""
<> lowerName (methodName m) <> "\" " <> name n
<> ") => O.OverloadedMethod " <> infoName <> " o p where"
indent $ line $ "overloadedMethod = undefined"
group $ do
line $ "instance (o ~ O.UnsupportedMethodError \""
<> lowerName (methodName m) <> "\" " <> name n
<> ") => O.OverloadedMethodInfo " <> infoName <> " o where"
indent $ line $ "overloadedMethodInfo = undefined"
export ToplevelSection infoName
|
