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
205
206
207
208
209
210
211
212
213
214
215
216
217
218
|
-- | This library extends the Distribution with internationalization support.
--
-- It performs two functions:
--
-- * compiles and installs PO files to the specified directory
--
-- * tells the application where files were installed to make it able
-- to bind them to the code
--
-- Each PO file will be placed to the
-- @{datadir}\/locale\/{loc}\/LC_MESSAGES\/{domain}.mo@ where:
--
-- [@datadir@] Usually @prefix/share@ but could be different, depends
-- on system.
--
-- [@loc@] Locale name (language code, two characters). This module
-- supposes, that each PO file has a base name set to the proper
-- locale, e.g. @de.po@ is the German translation of the program, so
-- this file will be placed under @{datadir}\/locale\/de@ directory
--
-- [@domain@] Program domain. A unique identifier of single
-- translational unit (program). By default domain will be set to the
-- package name, but its name could be configured in the @.cabal@ file.
--
-- The module defines following @.cabal@ fields:
--
-- [@x-gettext-domain-name@] Name of the domain. One ofmore
-- alphanumeric characters separated by hyphens or underlines. When
-- not set, package name will be used.
--
-- [@x-gettext-po-files@] List of files with translations. Could be
-- used a limited form of wildcards, e.g.: @x-gettext-po-files:
-- po/*.po@
--
-- [@x-gettext-domain-def@] Name of the macro, in which domain name
-- will be passed to the program. Default value is
-- @__MESSAGE_CATALOG_DOMAIN__@
--
-- [@x-gettext-msg-cat-def@] Name of the macro, in which path to the
-- message catalog will be passed to the program. Default value is
-- @__MESSAGE_CATALOG_DIR__@
--
-- The last two parameters are used to send configuration data to the
-- code during its compilation. The most common usage example is:
--
--
-- > ...
-- > prepareI18N = do
-- > setLocale LC_ALL (Just "")
-- > bindTextDomain __MESSAGE_CATALOG_DOMAIN__ (Just __MESSAGE_CATALOG_DIR__)
-- > textDomain __MESSAGE_CATALOG_DOMAIN__
-- >
-- > main = do
-- > prepareI18N
-- > ...
-- >
-- > ...
--
--
-- /NOTE:/ files, passed in the @x-gettext-po-files@ are not
-- automatically added to the source distribution, so they should be
-- also added to the @extra-source-files@ parameter, along with
-- translation template file (usually @message.pot@)
--
-- /WARNING:/ sometimes, when only configuration targets changes, code
-- will not recompile, thus you should execute @cabal clean@ to
-- cleanup the build and restart it again from the configuration. This
-- is temporary bug, it will be fixed in next releases.
--
-- /TODO:/ this is lifted verbatim (modulo other /TODO/s) from hgettext's
-- Distribution.Simple.I18N.GetText partly to expose individual hooks and
-- partly to avoid the /cabal configure/-time dependency. For the latter,
-- see https://github.com/fpco/stackage/issues/746
--
module GetText
(
-- | /TODO:/ upstream exporting the individual hooks?
installPOFiles,
-- | /TODO:/ upstream generating GetText_foo.hs rather than exporting these?
getDomainNameDefault,
getPackageName,
targetDataDir,
installGetTextHooks,
gettextDefaultMain
) where
import Distribution.Simple
import Distribution.Simple.Setup as S
import Distribution.Simple.LocalBuildInfo
import Distribution.PackageDescription
import Distribution.Simple.Configure
import Distribution.Simple.InstallDirs as I
import Distribution.Simple.Utils
import Language.Haskell.Extension
import Control.Monad
import Control.Arrow (second)
import Data.Maybe (listToMaybe, maybeToList, fromMaybe)
import Data.List (unfoldr,nub,null)
import System.FilePath
import System.Directory
import System.Process
-- | Default main function, same as
--
-- > defaultMainWithHooks $ installGetTextHooks simpleUserHooks
--
gettextDefaultMain :: IO ()
gettextDefaultMain = defaultMainWithHooks $ installGetTextHooks simpleUserHooks
-- | Installs hooks, used by GetText module to install
-- PO files to the system. Previous won't be disabled
--
installGetTextHooks :: UserHooks -- ^ initial user hooks
-> UserHooks -- ^ patched user hooks
installGetTextHooks uh = uh{
confHook = \a b ->
updateLocalBuildInfo <$> confHook uh a b,
postInst = \a b c d ->
postInst uh a b c d >>
installPOFiles a b c d
}
updateLocalBuildInfo :: LocalBuildInfo -> LocalBuildInfo
updateLocalBuildInfo l =
let sMap = getCustomFields l
[domDef, catDef] = map ($ sMap) [getDomainDefine, getMsgCatalogDefine]
dom = getDomainNameDefault sMap (getPackageName l)
tar = targetDataDir l
[catMS, domMS] = map (uncurry formatMacro) [(domDef, dom), (catDef, tar)]
in (appendCPPOptions [domMS,catMS] . appendExtension [EnableExtension CPP]) l
installPOFiles :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO ()
installPOFiles _ _ _ l =
let sMap = getCustomFields l
destDir = targetDataDir l
dom = getDomainNameDefault sMap (getPackageName l)
installFile file = do
let fname = takeFileName file
let bname = takeBaseName fname
let targetDir = destDir </> bname </> "LC_MESSAGES"
-- ensure we have directory destDir/{loc}/LC_MESSAGES
createDirectoryIfMissing True targetDir
system $ "msgfmt --output-file=" ++
(targetDir </> dom <.> "mo") ++
" " ++ file
in do
filelist <- getPoFilesDefault sMap
-- copy all whose name is in the form of dir/{loc}.po to the
-- destDir/{loc}/LC_MESSAGES/dom.mo
-- with the 'msgfmt' tool
mapM_ installFile filelist
forBuildInfo :: LocalBuildInfo -> (BuildInfo -> BuildInfo) -> LocalBuildInfo
forBuildInfo l f =
let a = l{localPkgDescr = updPkgDescr (localPkgDescr l)}
updPkgDescr x = x{library = updLibrary (library x),
executables = updExecs (executables x)}
updLibrary Nothing = Nothing
updLibrary (Just x) = Just $ x{libBuildInfo = f (libBuildInfo x)}
updExecs = map updExec
updExec x = x{buildInfo = f (buildInfo x)}
in a
appendExtension :: [Extension] -> LocalBuildInfo -> LocalBuildInfo
appendExtension exts l =
forBuildInfo l updBuildInfo
where updBuildInfo x = x{defaultExtensions = updExts (defaultExtensions x)}
updExts s = nub (s ++ exts)
appendCPPOptions :: [String] -> LocalBuildInfo -> LocalBuildInfo
appendCPPOptions opts l =
forBuildInfo l updBuildInfo
where updBuildInfo x = x{cppOptions = updOpts (cppOptions x)}
updOpts s = nub (s ++ opts)
formatMacro name value = "-D" ++ name ++ "=" ++ show value
targetDataDir :: LocalBuildInfo -> FilePath
targetDataDir l =
let dirTmpls = installDirTemplates l
prefix' = prefix dirTmpls
data' = datadir dirTmpls
dataEx = I.fromPathTemplate $ I.substPathTemplate [(PrefixVar, prefix')] data'
in dataEx ++ "/locale"
getPackageName :: LocalBuildInfo -> String
getPackageName = unPackageName . packageName . localPkgDescr
getCustomFields :: LocalBuildInfo -> [(String, String)]
getCustomFields = customFieldsPD . localPkgDescr
findInParametersDefault :: [(String, String)] -> String -> String -> String
findInParametersDefault al name def = (fromMaybe def . lookup name) al
getDomainNameDefault :: [(String, String)] -> String -> String
getDomainNameDefault al = findInParametersDefault al "x-gettext-domain-name"
getDomainDefine :: [(String, String)] -> String
getDomainDefine al = findInParametersDefault al "x-gettext-domain-def" "__MESSAGE_CATALOG_DOMAIN__"
getMsgCatalogDefine :: [(String, String)] -> String
getMsgCatalogDefine al = findInParametersDefault al "x-gettext-msg-cat-def" "__MESSAGE_CATALOG_DIR__"
getPoFilesDefault :: [(String, String)] -> IO [String]
getPoFilesDefault al = toFileList $ findInParametersDefault al "x-gettext-po-files" ""
where toFileList "" = return []
toFileList x = fmap concat $ mapM matchFileGlob $ split' x
-- from Blow your mind (HaskellWiki)
-- splits string by newline, space and comma
split' x = concatMap lines $ concatMap words $ unfoldr (\b -> fmap (const . second (drop 1) . break (==',') $ b) . listToMaybe $ b) x
|
