bustle-0.7.2: GetText.hs
-- | 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