module Distribution.Simple.I18N.GetText
(
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
gettextDefaultMain :: IO ()
gettextDefaultMain = defaultMainWithHooks $ installGetTextHooks simpleUserHooks
installGetTextHooks :: UserHooks
-> UserHooks
installGetTextHooks uh = uh{
confHook = \a b ->
(confHook uh) a b >>=
return . updateLocalBuildInfo,
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 [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"
createDirectoryIfMissing True targetDir
system $ "msgfmt --output-file=" ++
(targetDir </> dom <.> "mo") ++
" " ++ file
in do
filelist <- getPoFilesDefault sMap
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{extensions = updExts (extensions 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 = fromPackageName . packageName . localPkgDescr
where fromPackageName (PackageName s) = s
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
split' x = concatMap lines $ concatMap words $ unfoldr (\b -> fmap (const . (second $ drop 1) . break (==',') $ b) . listToMaybe $ b) x