blob: 18afcaf519722c3c98134f16f4893b147e9c9da5 (
plain)
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
|
{-# OPTIONS_GHC -Wall #-}
import Data.Maybe (fromMaybe)
import System.FilePath ( (</>), (<.>) )
import Distribution.PackageDescription
import Distribution.Simple
import Distribution.Simple.BuildPaths ( autogenModulesDir )
import Distribution.Simple.InstallDirs as I
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Setup as S
import Distribution.Simple.Utils
import Distribution.Text ( display )
import Distribution.ModuleName (ModuleName)
import qualified Distribution.ModuleName as ModuleName
import qualified Distribution.Simple.I18N.GetText as GetText
main :: IO ()
main = defaultMainWithHooks $ installBustleHooks simpleUserHooks
-- Okay, so we want to use hgettext's install hook, but not the hook that
-- miraculously runs all our code through CPP just to add a couple of
-- constants. (cpp doesn't like multi-line Haskell strings, so this is not
-- purely an academic preference.)
--
-- Instead, we generate GetText_bustle.hs which contains the constants, in the
-- same way as Paths_bustle.hs gets generated by Cabal. Much neater.
--
-- TODO: upstream this to hgettext
installBustleHooks :: UserHooks
-> UserHooks
installBustleHooks uh = uh
{ postInst = postInst gtuh
, buildHook = \pkg lbi hooks flags -> do
writeGetTextConstantsFile pkg lbi flags
buildHook uh pkg lbi hooks flags
}
where
gtuh = GetText.installGetTextHooks uh
writeGetTextConstantsFile :: PackageDescription -> LocalBuildInfo -> BuildFlags -> IO ()
writeGetTextConstantsFile pkg lbi flags = do
let verbosity = fromFlag (buildVerbosity flags)
createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi)
let pathsModulePath = autogenModulesDir lbi
</> ModuleName.toFilePath (getTextConstantsModuleName pkg) <.> "hs"
rewriteFile pathsModulePath (generateModule pkg lbi)
getTextConstantsModuleName :: PackageDescription -> ModuleName
getTextConstantsModuleName pkg_descr =
ModuleName.fromString $
"GetText_" ++ map fixchar (display (packageName pkg_descr))
where fixchar '-' = '_'
fixchar c = c
generateModule :: PackageDescription -> LocalBuildInfo -> String
generateModule pkg lbi =
header ++ body
where
moduleName = getTextConstantsModuleName pkg
header =
"module " ++ display moduleName ++ " (\n"++
" getMessageCatalogDomain,\n" ++
" getMessageCatalogDir\n" ++
") where\n"++
"\n"
body =
"getMessageCatalogDomain :: IO String\n" ++
"getMessageCatalogDomain = return " ++ show dom ++ "\n" ++
"\n" ++
"getMessageCatalogDir :: IO FilePath\n" ++
"getMessageCatalogDir = return " ++ show tar ++ "\n"
sMap = customFieldsPD (localPkgDescr lbi)
dom = getDomainNameDefault sMap (getPackageName lbi)
tar = targetDataDir lbi
-- Cargo-culted from hgettext
findInParametersDefault :: [(String, String)] -> String -> String -> String
findInParametersDefault al name def = (fromMaybe def . lookup name) al
getPackageName :: LocalBuildInfo -> String
getPackageName = fromPackageName . packageName . localPkgDescr
where fromPackageName (PackageName s) = s
getDomainNameDefault :: [(String, String)] -> String -> String
getDomainNameDefault al d = findInParametersDefault al "x-gettext-domain-name" d
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"
|
