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
|
{-# LANGUAGE CPP #-}
-- | Convenience hooks for writing custom @Setup.hs@ files for
-- bindings.
module Data.GI.CodeGen.CabalHooks
( setupBinding
, configureDryRun
, TaggedOverride(..)
) where
import qualified Distribution.ModuleName as MN
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Setup
import Distribution.Simple (UserHooks(..), simpleUserHooks,
defaultMainWithHooks, OptimisationLevel(..))
import Distribution.PackageDescription
import Data.GI.CodeGen.API (loadGIRInfo)
import Data.GI.CodeGen.Code (genCode, writeModuleTree, listModuleTree,
ModuleInfo, transitiveModuleDeps)
import Data.GI.CodeGen.CodeGen (genModule)
import Data.GI.CodeGen.Config (Config(..))
import Data.GI.CodeGen.LibGIRepository (setupTypelibSearchPath)
import Data.GI.CodeGen.ModulePath (toModulePath)
import Data.GI.CodeGen.Overrides (parseOverrides, girFixups,
filterAPIsAndDeps)
import Data.GI.CodeGen.Util (utf8ReadFile, utf8WriteFile, ucFirst)
import System.Directory (createDirectoryIfMissing)
import System.FilePath (joinPath, takeDirectory)
import Control.Monad (void, forM)
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.Map as M
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
#ifndef EXTRA_GIR_SEARCH_PATH
#define EXTRA_GIR_SEARCH_PATH
#endif
type ConfHook = (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags
-> IO LocalBuildInfo
-- | Included overrides file.
data TaggedOverride =
TaggedOverride { overrideTag :: Text
-- ^ Tag for the override, for error reporting purposes.
, overrideText :: Text
}
-- | Generate the code for the given module.
genModuleCode :: Text -- ^ name
-> Text -- ^ version
-> Text -- ^ pkgName
-> Text -- ^ pkgVersion
-> Bool -- ^ verbose
-> [TaggedOverride] -- ^ Explicit overrides
-> IO ModuleInfo
genModuleCode name version pkgName pkgVersion verbosity overrides = do
setupTypelibSearchPath []
parsed <- forM overrides $ \(TaggedOverride tag ovText) -> do
parseOverrides ovText >>= \case
Left err -> error $ "Error when parsing overrides file \""
<> T.unpack tag <> "\":"
<> T.unpack err
Right ovs -> return ovs
let ovs = mconcat parsed
(gir, girDeps) <- loadGIRInfo verbosity name (Just version) [EXTRA_GIR_SEARCH_PATH] (girFixups ovs)
let (apis, deps) = filterAPIsAndDeps ovs gir girDeps
allAPIs = M.union apis deps
cfg = Config {modName = name,
modVersion = version,
ghcPkgName = pkgName,
ghcPkgVersion = pkgVersion,
verbose = verbosity,
overrides = ovs}
return $ genCode cfg allAPIs (toModulePath name) (genModule apis)
-- | Write a module containing information about the configuration for
-- the package.
genConfigModule :: Maybe FilePath -> Text -> Maybe TaggedOverride -> IO ()
genConfigModule outputDir modName maybeGiven = do
let fname = joinPath [ fromMaybe "" outputDir
, "GI"
, T.unpack (ucFirst modName)
, "Config.hs" ]
dirname = takeDirectory fname
createDirectoryIfMissing True dirname
utf8WriteFile fname $ T.unlines
[ "{-# LANGUAGE OverloadedStrings #-}"
, "-- | Build time configuration used during code generation."
, "module GI." <> ucFirst modName <> ".Config ( overrides ) where"
, ""
, "import qualified Data.Text as T"
, "import Data.Text (Text)"
, ""
, "-- | Overrides used when generating these bindings."
, "overrides :: Text"
, "overrides = T.unlines"
, " [ " <> T.intercalate "\n , " (quoteOverrides maybeGiven) <> "]"
]
where quoteOverrides :: Maybe TaggedOverride -> [Text]
quoteOverrides Nothing = []
quoteOverrides (Just (TaggedOverride _ ovText)) =
map (T.pack . show) (T.lines ovText)
-- | A convenience helper for `confHook`, such that bindings for the
-- given module are generated in the @configure@ step of @cabal@.
confCodeGenHook :: Text -- ^ name
-> Text -- ^ version
-> Text -- ^ pkgName
-> Text -- ^ pkgVersion
-> Bool -- ^ verbose
-> Maybe FilePath -- ^ overrides file
-> [TaggedOverride] -- ^ other overrides
-> Maybe FilePath -- ^ output dir
-> ConfHook -- ^ previous `confHook`
-> ConfHook
confCodeGenHook name version pkgName pkgVersion verbosity
overridesFile inheritedOverrides outputDir
defaultConfHook (gpd, hbi) flags = do
givenOvs <- traverse (\fname -> TaggedOverride (T.pack fname) <$> utf8ReadFile fname) overridesFile
let ovs = maybe inheritedOverrides (:inheritedOverrides) givenOvs
m <- genModuleCode name version pkgName pkgVersion verbosity ovs
let buildInfo = MN.fromString . T.unpack $ "GI." <> ucFirst name <> ".Config"
em' = buildInfo : map (MN.fromString . T.unpack) (listModuleTree m)
lib = ((condTreeData . fromJust . condLibrary) gpd)
bi = libBuildInfo lib
#if MIN_VERSION_base(4,11,0)
bi' = bi {autogenModules = em'}
#else
bi' = bi
#endif
lib' = lib {exposedModules = em', libBuildInfo = bi'}
cL' = ((fromJust . condLibrary) gpd) {condTreeData = lib'}
gpd' = gpd {condLibrary = Just cL'}
void $ writeModuleTree verbosity outputDir m
genConfigModule outputDir name givenOvs
lbi <- defaultConfHook (gpd', hbi) flags
return (lbi {withOptimization = NoOptimisation})
-- | The entry point for @Setup.hs@ files in bindings.
setupBinding :: Text -- ^ name
-> Text -- ^ version
-> Text -- ^ pkgName
-> Text -- ^ pkgVersion
-> Bool -- ^ verbose
-> Maybe FilePath -- ^ overrides file
-> [TaggedOverride] -- ^ Explicit overrides
-> Maybe FilePath -- ^ output dir
-> IO ()
setupBinding name version pkgName pkgVersion verbose overridesFile overrides outputDir =
defaultMainWithHooks (simpleUserHooks {
confHook = confCodeGenHook name version
pkgName pkgVersion
verbose
overridesFile overrides outputDir
(confHook simpleUserHooks)
})
-- | Return the list of modules that `setupHaskellGIBinding` would
-- create, together with the set of dependencies loaded while
-- generating the code.
configureDryRun :: Text -- ^ name
-> Text -- ^ version
-> Text -- ^ pkgName
-> Text -- ^ pkgVersion
-> Maybe FilePath -- ^ Overrides file
-> [TaggedOverride] -- ^ Other overrides to load
-> IO ([Text], S.Set Text)
configureDryRun name version pkgName pkgVersion overridesFile inheritedOverrides = do
givenOvs <- traverse (\fname -> TaggedOverride (T.pack fname) <$> utf8ReadFile fname) overridesFile
let ovs = maybe inheritedOverrides (:inheritedOverrides) givenOvs
m <- genModuleCode name version pkgName pkgVersion False ovs
return (("GI." <> ucFirst name <> ".Config") : listModuleTree m,
transitiveModuleDeps m)
|
