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 or more
--  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.
--

module Distribution.Simple.I18N.GetText
    ( installGetTextHooks
    , gettextDefaultMain
    ) where

import           Distribution.PackageDescription
import           Distribution.Simple
import           Distribution.Simple.InstallDirs    as I
import           Distribution.Simple.LocalBuildInfo
import           Distribution.Simple.Setup
import           Distribution.Simple.Utils
import           Distribution.Verbosity

import           Control.Arrow                      (second)
import           Control.Monad
import           Data.List                          (nub, unfoldr)
import           Data.Maybe                         (fromMaybe, listToMaybe)
import           System.Directory
import           System.Exit
import           System.FilePath
import           System.Process

import           Internal

-- | 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.
--
-- Pre-existing hook handlers are executed before the GetText
-- handlers.
--
installGetTextHooks :: UserHooks -- ^ initial user hooks
                    -> UserHooks -- ^ patched user hooks
installGetTextHooks uh =
    uh { confHook = \a b -> do
           lbi <- (confHook uh) a b
           return (updateLocalBuildInfo lbi)

       , postInst = \args iflags pd lbi -> do
           postInst uh args iflags pd lbi
           installPOFiles (fromFlagOrDefault maxBound (installVerbosity iflags)) lbi

       , postCopy = \args cflags pd lbi -> do
           postCopy uh args cflags pd lbi
           installPOFiles (fromFlagOrDefault maxBound (copyVerbosity cflags)) lbi
       }


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 :: Verbosity -> LocalBuildInfo -> IO ()
installPOFiles verb 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
          ph <- runProcess "msgfmt" [ "--output-file=" ++ (targetDir </> dom <.> "mo"), file ]
                           Nothing Nothing Nothing Nothing Nothing
          ec <- waitForProcess ph
          case ec of
            ExitSuccess   -> return ()
            -- only warn for now, as the package may still be usable even if the msg catalogs are missing
            ExitFailure n -> warn verb ("'msgfmt' exited with non-zero status (rc = " ++ show n ++ ")")
    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 x = map updExec x
        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 :: Show a => [Char] -> a -> [Char]
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 = fromPackageName . 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 d = findInParametersDefault al "x-gettext-domain-name" d

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  = liftM 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