-- | 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          (warn)
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                           (fromPackageName, matchFileGlob)

-- | Default main function, same as
--
-- > defaultMainWithHooks $ installGetTextHooks simpleUserHooks
--
gettextDefaultMain :: IO ()
gettextDefaultMain :: IO ()
gettextDefaultMain = UserHooks -> IO ()
UserHooks -> IO ()
defaultMainWithHooks (UserHooks -> IO ()) -> UserHooks -> IO ()
forall a b. (a -> b) -> a -> b
$ UserHooks -> UserHooks
installGetTextHooks UserHooks
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 :: UserHooks -> UserHooks
installGetTextHooks uh :: UserHooks
uh =
    UserHooks
uh { confHook :: (GenericPackageDescription, HookedBuildInfo)
-> ConfigFlags -> IO LocalBuildInfo
confHook = \a :: (GenericPackageDescription, HookedBuildInfo)
a b :: ConfigFlags
b -> do
           LocalBuildInfo
lbi <- (UserHooks
-> (GenericPackageDescription, HookedBuildInfo)
-> ConfigFlags
-> IO LocalBuildInfo
confHook UserHooks
uh) (GenericPackageDescription, HookedBuildInfo)
a ConfigFlags
b
           LocalBuildInfo -> IO LocalBuildInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalBuildInfo -> LocalBuildInfo
updateLocalBuildInfo LocalBuildInfo
lbi)

       , postInst :: Args
-> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO ()
postInst = \args :: Args
args iflags :: InstallFlags
iflags pd :: PackageDescription
pd lbi :: LocalBuildInfo
lbi -> do
           UserHooks
-> Args
-> InstallFlags
-> PackageDescription
-> LocalBuildInfo
-> IO ()
postInst UserHooks
uh Args
args InstallFlags
iflags PackageDescription
pd LocalBuildInfo
lbi
           Verbosity -> LocalBuildInfo -> IO ()
installPOFiles (Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
forall a. Bounded a => a
maxBound (InstallFlags -> Flag Verbosity
installVerbosity InstallFlags
iflags)) LocalBuildInfo
lbi

       , postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO ()
postCopy = \args :: Args
args cflags :: CopyFlags
cflags pd :: PackageDescription
pd lbi :: LocalBuildInfo
lbi -> do
           UserHooks
-> Args
-> CopyFlags
-> PackageDescription
-> LocalBuildInfo
-> IO ()
postCopy UserHooks
uh Args
args CopyFlags
cflags PackageDescription
pd LocalBuildInfo
lbi
           Verbosity -> LocalBuildInfo -> IO ()
installPOFiles (Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
forall a. Bounded a => a
maxBound (CopyFlags -> Flag Verbosity
copyVerbosity CopyFlags
cflags)) LocalBuildInfo
lbi
       }


updateLocalBuildInfo :: LocalBuildInfo -> LocalBuildInfo
updateLocalBuildInfo :: LocalBuildInfo -> LocalBuildInfo
updateLocalBuildInfo l :: LocalBuildInfo
l =
    let sMap :: [(String, String)]
sMap = LocalBuildInfo -> [(String, String)]
getCustomFields LocalBuildInfo
l
        [domDef :: String
domDef, catDef :: String
catDef] = (([(String, String)] -> String) -> String)
-> [[(String, String)] -> String] -> Args
forall a b. (a -> b) -> [a] -> [b]
map (([(String, String)] -> String) -> [(String, String)] -> String
forall a b. (a -> b) -> a -> b
$ [(String, String)]
sMap) [[(String, String)] -> String
getDomainDefine, [(String, String)] -> String
getMsgCatalogDefine]
        dom :: String
dom = [(String, String)] -> String -> String
getDomainNameDefault [(String, String)]
sMap (LocalBuildInfo -> String
getPackageName LocalBuildInfo
l)
        tar :: String
tar = LocalBuildInfo -> String
targetDataDir LocalBuildInfo
l
        [catMS :: String
catMS, domMS :: String
domMS] = ((String, String) -> String) -> [(String, String)] -> Args
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String -> String) -> (String, String) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> String -> String
forall a. Show a => String -> a -> String
formatMacro) [(String
domDef, String
dom), (String
catDef, String
tar)]
    in (Args -> LocalBuildInfo -> LocalBuildInfo
appendCPPOptions [String
domMS,String
catMS] (LocalBuildInfo -> LocalBuildInfo)
-> (LocalBuildInfo -> LocalBuildInfo)
-> LocalBuildInfo
-> LocalBuildInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Extension] -> LocalBuildInfo -> LocalBuildInfo
appendExtension [KnownExtension -> Extension
EnableExtension KnownExtension
CPP]) LocalBuildInfo
l

installPOFiles :: Verbosity -> LocalBuildInfo -> IO ()
installPOFiles :: Verbosity -> LocalBuildInfo -> IO ()
installPOFiles verb :: Verbosity
verb l :: LocalBuildInfo
l =
    let sMap :: [(String, String)]
sMap = LocalBuildInfo -> [(String, String)]
getCustomFields LocalBuildInfo
l
        destDir :: String
destDir = LocalBuildInfo -> String
targetDataDir LocalBuildInfo
l
        dom :: String
dom = [(String, String)] -> String -> String
getDomainNameDefault [(String, String)]
sMap (LocalBuildInfo -> String
getPackageName LocalBuildInfo
l)
        installFile :: String -> IO ()
installFile file :: String
file = do
          let fname :: String
fname = String -> String
takeFileName String
file
          let bname :: String
bname = String -> String
takeBaseName String
fname
          let targetDir :: String
targetDir = String
destDir String -> String -> String
</> String
bname String -> String -> String
</> "LC_MESSAGES"
          -- ensure we have directory destDir/{loc}/LC_MESSAGES
          Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
targetDir
          ProcessHandle
ph <- String
-> Args
-> Maybe String
-> Maybe [(String, String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
runProcess "msgfmt" [ "--output-file=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String
targetDir String -> String -> String
</> String
dom String -> String -> String
<.> "mo"), String
file ]
                           Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing
          ExitCode
ec <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
          case ExitCode
ec of
            ExitSuccess   -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            -- only warn for now, as the package may still be usable even if the msg catalogs are missing
            ExitFailure n :: Int
n -> Verbosity -> String -> IO ()
warn Verbosity
verb ("'msgfmt' exited with non-zero status (rc = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")")
    in do
      Args
filelist <- [(String, String)] -> IO Args
getPoFilesDefault [(String, String)]
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
      (String -> IO ()) -> Args -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
installFile Args
filelist

forBuildInfo :: LocalBuildInfo -> (BuildInfo -> BuildInfo) -> LocalBuildInfo
forBuildInfo :: LocalBuildInfo -> (BuildInfo -> BuildInfo) -> LocalBuildInfo
forBuildInfo l :: LocalBuildInfo
l f :: BuildInfo -> BuildInfo
f =
    let a :: LocalBuildInfo
a = LocalBuildInfo
l{localPkgDescr :: PackageDescription
localPkgDescr = PackageDescription -> PackageDescription
updPkgDescr (LocalBuildInfo -> PackageDescription
localPkgDescr LocalBuildInfo
l)}
        updPkgDescr :: PackageDescription -> PackageDescription
updPkgDescr x :: PackageDescription
x = PackageDescription
x{library :: Maybe Library
library = Maybe Library -> Maybe Library
updLibrary (PackageDescription -> Maybe Library
library PackageDescription
x),
                          executables :: [Executable]
executables = [Executable] -> [Executable]
updExecs (PackageDescription -> [Executable]
executables PackageDescription
x)}
        updLibrary :: Maybe Library -> Maybe Library
updLibrary Nothing  = Maybe Library
forall a. Maybe a
Nothing
        updLibrary (Just x :: Library
x) = Library -> Maybe Library
forall a. a -> Maybe a
Just (Library -> Maybe Library) -> Library -> Maybe Library
forall a b. (a -> b) -> a -> b
$ Library
x{libBuildInfo :: BuildInfo
libBuildInfo = BuildInfo -> BuildInfo
f (Library -> BuildInfo
libBuildInfo Library
x)}
        updExecs :: [Executable] -> [Executable]
updExecs x :: [Executable]
x = (Executable -> Executable) -> [Executable] -> [Executable]
forall a b. (a -> b) -> [a] -> [b]
map Executable -> Executable
updExec [Executable]
x
        updExec :: Executable -> Executable
updExec x :: Executable
x = Executable
x{buildInfo :: BuildInfo
buildInfo = BuildInfo -> BuildInfo
f (Executable -> BuildInfo
buildInfo Executable
x)}
    in LocalBuildInfo
a

appendExtension :: [Extension] -> LocalBuildInfo -> LocalBuildInfo
appendExtension :: [Extension] -> LocalBuildInfo -> LocalBuildInfo
appendExtension exts :: [Extension]
exts l :: LocalBuildInfo
l =
    LocalBuildInfo -> (BuildInfo -> BuildInfo) -> LocalBuildInfo
forBuildInfo LocalBuildInfo
l BuildInfo -> BuildInfo
updBuildInfo
    where updBuildInfo :: BuildInfo -> BuildInfo
updBuildInfo x :: BuildInfo
x = BuildInfo
x{defaultExtensions :: [Extension]
defaultExtensions = [Extension] -> [Extension]
updExts (BuildInfo -> [Extension]
defaultExtensions BuildInfo
x)}
          updExts :: [Extension] -> [Extension]
updExts s :: [Extension]
s = [Extension] -> [Extension]
forall a. Eq a => [a] -> [a]
nub ([Extension]
s [Extension] -> [Extension] -> [Extension]
forall a. [a] -> [a] -> [a]
++ [Extension]
exts)

appendCPPOptions :: [String] -> LocalBuildInfo -> LocalBuildInfo
appendCPPOptions :: Args -> LocalBuildInfo -> LocalBuildInfo
appendCPPOptions opts :: Args
opts l :: LocalBuildInfo
l =
    LocalBuildInfo -> (BuildInfo -> BuildInfo) -> LocalBuildInfo
forBuildInfo LocalBuildInfo
l BuildInfo -> BuildInfo
updBuildInfo
    where updBuildInfo :: BuildInfo -> BuildInfo
updBuildInfo x :: BuildInfo
x = BuildInfo
x{cppOptions :: Args
cppOptions = Args -> Args
updOpts (BuildInfo -> Args
cppOptions BuildInfo
x)}
          updOpts :: Args -> Args
updOpts s :: Args
s = Args -> Args
forall a. Eq a => [a] -> [a]
nub (Args
s Args -> Args -> Args
forall a. [a] -> [a] -> [a]
++ Args
opts)

formatMacro :: Show a => [Char] -> a -> [Char]
formatMacro :: String -> a -> String
formatMacro name :: String
name value :: a
value = "-D" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ "=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (a -> String
forall a. Show a => a -> String
show a
value)

targetDataDir :: LocalBuildInfo -> FilePath
targetDataDir :: LocalBuildInfo -> String
targetDataDir l :: LocalBuildInfo
l =
    let dirTmpls :: InstallDirTemplates
dirTmpls = LocalBuildInfo -> InstallDirTemplates
installDirTemplates LocalBuildInfo
l
        prefix' :: PathTemplate
prefix' = InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
prefix InstallDirTemplates
dirTmpls
        data' :: PathTemplate
data' = InstallDirTemplates -> PathTemplate
forall dir. InstallDirs dir -> dir
datadir InstallDirTemplates
dirTmpls
        dataEx :: String
dataEx = PathTemplate -> String
I.fromPathTemplate (PathTemplate -> String) -> PathTemplate -> String
forall a b. (a -> b) -> a -> b
$ PathTemplateEnv -> PathTemplate -> PathTemplate
I.substPathTemplate [(PathTemplateVariable
PrefixVar, PathTemplate
prefix')] PathTemplate
data'
    in String
dataEx String -> String -> String
forall a. [a] -> [a] -> [a]
++ "/locale"

getPackageName :: LocalBuildInfo -> String
getPackageName :: LocalBuildInfo -> String
getPackageName = PackageName -> String
fromPackageName (PackageName -> String)
-> (LocalBuildInfo -> PackageName) -> LocalBuildInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageDescription -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName (PackageDescription -> PackageName)
-> (LocalBuildInfo -> PackageDescription)
-> LocalBuildInfo
-> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalBuildInfo -> PackageDescription
localPkgDescr

getCustomFields :: LocalBuildInfo -> [(String, String)]
getCustomFields :: LocalBuildInfo -> [(String, String)]
getCustomFields = PackageDescription -> [(String, String)]
customFieldsPD (PackageDescription -> [(String, String)])
-> (LocalBuildInfo -> PackageDescription)
-> LocalBuildInfo
-> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalBuildInfo -> PackageDescription
localPkgDescr

findInParametersDefault :: [(String, String)] -> String -> String -> String
findInParametersDefault :: [(String, String)] -> String -> String -> String
findInParametersDefault al :: [(String, String)]
al name :: String
name def :: String
def = (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
def (Maybe String -> String)
-> ([(String, String)] -> Maybe String)
-> [(String, String)]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name) [(String, String)]
al

getDomainNameDefault :: [(String, String)] -> String -> String
getDomainNameDefault :: [(String, String)] -> String -> String
getDomainNameDefault al :: [(String, String)]
al d :: String
d = [(String, String)] -> String -> String -> String
findInParametersDefault [(String, String)]
al "x-gettext-domain-name" String
d

getDomainDefine :: [(String, String)] -> String
getDomainDefine :: [(String, String)] -> String
getDomainDefine al :: [(String, String)]
al = [(String, String)] -> String -> String -> String
findInParametersDefault [(String, String)]
al "x-gettext-domain-def" "__MESSAGE_CATALOG_DOMAIN__"

getMsgCatalogDefine :: [(String, String)] -> String
getMsgCatalogDefine :: [(String, String)] -> String
getMsgCatalogDefine al :: [(String, String)]
al = [(String, String)] -> String -> String -> String
findInParametersDefault [(String, String)]
al "x-gettext-msg-cat-def" "__MESSAGE_CATALOG_DIR__"

getPoFilesDefault :: [(String, String)] -> IO [String]
getPoFilesDefault :: [(String, String)] -> IO Args
getPoFilesDefault al :: [(String, String)]
al = String -> IO Args
toFileList (String -> IO Args) -> String -> IO Args
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> String -> String -> String
findInParametersDefault [(String, String)]
al "x-gettext-po-files" ""
    where toFileList :: String -> IO Args
toFileList "" = Args -> IO Args
forall (m :: * -> *) a. Monad m => a -> m a
return []
          toFileList x :: String
x  = ([Args] -> Args) -> IO [Args] -> IO Args
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Args] -> Args
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [Args] -> IO Args) -> IO [Args] -> IO Args
forall a b. (a -> b) -> a -> b
$ (String -> IO Args) -> Args -> IO [Args]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO Args
matchFileGlob (Args -> IO [Args]) -> Args -> IO [Args]
forall a b. (a -> b) -> a -> b
$ String -> Args
split' String
x
          -- from Blow your mind (HaskellWiki)
          -- splits string by newline, space and comma
          split' :: String -> Args
split' x :: String
x = (String -> Args) -> Args -> Args
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> Args
lines (Args -> Args) -> Args -> Args
forall a b. (a -> b) -> a -> b
$ (String -> Args) -> Args -> Args
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> Args
words (Args -> Args) -> Args -> Args
forall a b. (a -> b) -> a -> b
$ (String -> Maybe (String, String)) -> String -> Args
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (\b :: String
b -> (Char -> (String, String)) -> Maybe Char -> Maybe (String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String, String) -> Char -> (String, String)
forall a b. a -> b -> a
const ((String, String) -> Char -> (String, String))
-> (String -> (String, String))
-> String
-> Char
-> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String -> String) -> (String, String) -> (String, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((String -> String) -> (String, String) -> (String, String))
-> (String -> String) -> (String, String) -> (String, String)
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop 1) ((String, String) -> (String, String))
-> (String -> (String, String)) -> String -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==',') (String -> Char -> (String, String))
-> String -> Char -> (String, String)
forall a b. (a -> b) -> a -> b
$ String
b) (Maybe Char -> Maybe (String, String))
-> (String -> Maybe Char) -> String -> Maybe (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Char
forall a. [a] -> Maybe a
listToMaybe (String -> Maybe (String, String))
-> String -> Maybe (String, String)
forall a b. (a -> b) -> a -> b
$ String
b) String
x