-- | 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 ()
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 UserHooks
uh =
    UserHooks
uh { confHook :: (GenericPackageDescription, HookedBuildInfo)
-> ConfigFlags -> IO LocalBuildInfo
confHook = \(GenericPackageDescription, HookedBuildInfo)
a 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 InstallFlags
iflags PackageDescription
pd 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 CopyFlags
cflags PackageDescription
pd 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 LocalBuildInfo
l =
    let sMap :: [(String, String)]
sMap = LocalBuildInfo -> [(String, String)]
getCustomFields LocalBuildInfo
l
        domDef :: String
domDef = [(String, String)] -> String
getDomainDefine [(String, String)]
sMap
        catDef :: String
catDef = [(String, String)] -> String
getMsgCatalogDefine [(String, String)]
sMap
        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 = String -> String -> String
forall a. Show a => String -> a -> String
formatMacro String
domDef String
dom
        domMS :: String
domMS = String -> String -> String
forall a. Show a => String -> a -> String
formatMacro String
catDef String
tar
    in Args -> LocalBuildInfo -> LocalBuildInfo
appendCPPOptions [String
domMS,String
catMS] (LocalBuildInfo -> LocalBuildInfo)
-> LocalBuildInfo -> LocalBuildInfo
forall a b. (a -> b) -> a -> b
$ [Extension] -> LocalBuildInfo -> LocalBuildInfo
appendExtension [KnownExtension -> Extension
EnableExtension KnownExtension
CPP] LocalBuildInfo
l

installPOFiles :: Verbosity -> LocalBuildInfo -> IO ()
installPOFiles :: Verbosity -> LocalBuildInfo -> IO ()
installPOFiles Verbosity
verb 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 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
</> 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 String
"msgfmt" [ String
"--output-file=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String
targetDir String -> String -> String
</> String
dom String -> 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
            ExitCode
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 Int
n -> Verbosity -> String -> IO ()
warn Verbosity
verb (String
"'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]
++ String
")")
    in do
      Args
filelist <- Verbosity -> LocalBuildInfo -> [(String, String)] -> IO Args
getPoFilesDefault Verbosity
verb LocalBuildInfo
l [(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 LocalBuildInfo
l BuildInfo -> BuildInfo
f =
    let a :: LocalBuildInfo
a = LocalBuildInfo
l{localPkgDescr :: PackageDescription
localPkgDescr = PackageDescription -> PackageDescription
updPkgDescr (LocalBuildInfo -> PackageDescription
localPkgDescr LocalBuildInfo
l)}
        updPkgDescr :: PackageDescription -> PackageDescription
updPkgDescr 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 Maybe Library
Nothing  = Maybe Library
forall a. Maybe a
Nothing
        updLibrary (Just 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 [Executable]
x = (Executable -> Executable) -> [Executable] -> [Executable]
forall a b. (a -> b) -> [a] -> [b]
map Executable -> Executable
updExec [Executable]
x
        updExec :: Executable -> Executable
updExec 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 [Extension]
exts LocalBuildInfo
l =
    LocalBuildInfo -> (BuildInfo -> BuildInfo) -> LocalBuildInfo
forBuildInfo LocalBuildInfo
l BuildInfo -> BuildInfo
updBuildInfo
    where updBuildInfo :: BuildInfo -> BuildInfo
updBuildInfo BuildInfo
x = BuildInfo
x{defaultExtensions :: [Extension]
defaultExtensions = [Extension] -> [Extension]
updExts (BuildInfo -> [Extension]
defaultExtensions BuildInfo
x)}
          updExts :: [Extension] -> [Extension]
updExts [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 Args
opts LocalBuildInfo
l =
    LocalBuildInfo -> (BuildInfo -> BuildInfo) -> LocalBuildInfo
forBuildInfo LocalBuildInfo
l BuildInfo -> BuildInfo
updBuildInfo
    where updBuildInfo :: BuildInfo -> BuildInfo
updBuildInfo BuildInfo
x = BuildInfo
x{cppOptions :: Args
cppOptions = Args -> Args
updOpts (BuildInfo -> Args
cppOptions BuildInfo
x)}
          updOpts :: Args -> Args
updOpts 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 => String -> a -> String
formatMacro :: String -> a -> String
formatMacro String
name a
value = String
"-D" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"=" 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 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]
++ String
"/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 [(String, String)]
al String
name 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 [(String, String)]
al String
d = [(String, String)] -> String -> String -> String
findInParametersDefault [(String, String)]
al String
"x-gettext-domain-name" String
d

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

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

getPoFilesDefault :: Verbosity -> LocalBuildInfo  -> [(String, String)] -> IO [String]
getPoFilesDefault :: Verbosity -> LocalBuildInfo -> [(String, String)] -> IO Args
getPoFilesDefault Verbosity
verb LocalBuildInfo
l [(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 String
"x-gettext-po-files" String
""
    where toFileList :: String -> IO Args
toFileList String
"" = Args -> IO Args
forall (m :: * -> *) a. Monad m => a -> m a
return []
          toFileList 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 (Verbosity -> PackageDescription -> String -> IO Args
matchFileGlob Verbosity
verb (LocalBuildInfo -> PackageDescription
localPkgDescr LocalBuildInfo
l)) (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' 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 (\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 Int
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
==Char
',') (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