{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, DeriveDataTypeable, OverloadedStrings, RecordWildCards #-}
-- | This module contains definitions for loading translation catalogs.
module Text.Localize.Load
  ( -- * Data types
    LocatePolicy (..), Facet,
    -- * Main functions
    loadTranslations, locateTranslations,
    -- * Commonly used location policies
    linuxLocation, localLocation
  ) where

import Control.Monad
import Control.Monad.Trans
import Data.Default
import qualified Data.Map as M
import qualified Data.Text.Lazy as T
import qualified Data.Gettext as Gettext
import Data.Text.Format.Heavy
import System.Directory
import System.FilePath
import System.FilePath.Glob

import Text.Localize.Types

-- | Load translations when path to each translation file is known.
loadTranslations :: [(LanguageId, FilePath)] -> IO Translations
loadTranslations :: [(LanguageId, LanguageId)] -> IO Translations
loadTranslations [(LanguageId, LanguageId)]
pairs = do
  [(LanguageId, Catalog)]
res <- [(LanguageId, LanguageId)]
-> ((LanguageId, LanguageId) -> IO (LanguageId, Catalog))
-> IO [(LanguageId, Catalog)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(LanguageId, LanguageId)]
pairs (((LanguageId, LanguageId) -> IO (LanguageId, Catalog))
 -> IO [(LanguageId, Catalog)])
-> ((LanguageId, LanguageId) -> IO (LanguageId, Catalog))
-> IO [(LanguageId, Catalog)]
forall a b. (a -> b) -> a -> b
$ \(LanguageId
lang, LanguageId
path) -> do
           Catalog
gmo <- LanguageId -> IO Catalog
Gettext.loadCatalog LanguageId
path
           (LanguageId, Catalog) -> IO (LanguageId, Catalog)
forall (m :: * -> *) a. Monad m => a -> m a
return (LanguageId
lang, Catalog
gmo)
  Translations -> IO Translations
forall (m :: * -> *) a. Monad m => a -> m a
return (Translations -> IO Translations)
-> Translations -> IO Translations
forall a b. (a -> b) -> a -> b
$ Map LanguageId Catalog -> Translations
Translations (Map LanguageId Catalog -> Translations)
-> Map LanguageId Catalog -> Translations
forall a b. (a -> b) -> a -> b
$ [(LanguageId, Catalog)] -> Map LanguageId Catalog
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(LanguageId, Catalog)]
res

-- | Locale facet (@LC_MESSAGES@ and siblings).
type Facet = String

-- | This data type defines where to search for catalog files (@.mo@ or @.gmo@) in the file system.
data LocatePolicy = LocatePolicy {
    LocatePolicy -> [LanguageId]
lcBasePaths :: [FilePath] -- ^ Paths to directory with translations, e.g. @"\/usr\/share\/locale"@. Defaults to @"locale"@.
  , LocatePolicy -> LanguageId
lcName :: String       -- ^ Catalog file name (in gettext this is also known as text domain). Defaults to @"messages"@.
  , LocatePolicy -> LanguageId
lcFacet :: Facet       -- ^ Locale facet. Defaults to @LC_MESSAGES@.
  , LocatePolicy -> Format
lcFormat :: Format     -- ^ File path format. The following variables can be used:
                           -- 
                           -- * @{base}@ - path to directory with translations;
                           -- * @{language}@ - language code;
                           -- * @{facet}@ - locale facet;
                           -- * @{name}@ - file name (text domain), without extension.
                           --
                           -- Please note: assumption is made that the @{language}@ variable is used only once.
                           --
                           --  Defaults to @"{base}\/{language}\/{facet}\/{name}.mo"@.
  }
  deriving (Int -> LocatePolicy -> ShowS
[LocatePolicy] -> ShowS
LocatePolicy -> LanguageId
(Int -> LocatePolicy -> ShowS)
-> (LocatePolicy -> LanguageId)
-> ([LocatePolicy] -> ShowS)
-> Show LocatePolicy
forall a.
(Int -> a -> ShowS)
-> (a -> LanguageId) -> ([a] -> ShowS) -> Show a
showList :: [LocatePolicy] -> ShowS
$cshowList :: [LocatePolicy] -> ShowS
show :: LocatePolicy -> LanguageId
$cshow :: LocatePolicy -> LanguageId
showsPrec :: Int -> LocatePolicy -> ShowS
$cshowsPrec :: Int -> LocatePolicy -> ShowS
Show)

instance Default LocatePolicy where
  def :: LocatePolicy
def = LocatePolicy :: [LanguageId] -> LanguageId -> LanguageId -> Format -> LocatePolicy
LocatePolicy {
          lcBasePaths :: [LanguageId]
lcBasePaths = [LanguageId
"locale"],
          lcName :: LanguageId
lcName = LanguageId
"messages",
          lcFacet :: LanguageId
lcFacet = LanguageId
"LC_MESSAGES",
          lcFormat :: Format
lcFormat = Format
"{base}/{language}/{facet}/{name}.mo"
        }

-- | Usual Linux translations location policy.
-- Catalog files are found under @\/usr\/[local\/]share\/locale\/{language}\/LC_MESSAGES\/{name}.mo@.
linuxLocation :: String        -- ^ Catalog file name (text domain)
              -> LocatePolicy
linuxLocation :: LanguageId -> LocatePolicy
linuxLocation LanguageId
name = LocatePolicy
forall a. Default a => a
def {lcBasePaths :: [LanguageId]
lcBasePaths = [LanguageId
"/usr/share/locale", LanguageId
"/usr/local/share/locale"], lcName :: LanguageId
lcName = LanguageId
name}

-- | Simple translations location polciy, assuming all catalog files located at
-- @{base}\/{language}.mo@.
localLocation :: FilePath      -- ^ Path to directory with translations
              -> LocatePolicy
localLocation :: LanguageId -> LocatePolicy
localLocation LanguageId
base = LocatePolicy
forall a. Default a => a
def {lcBasePaths :: [LanguageId]
lcBasePaths = [LanguageId
base], lcFormat :: Format
lcFormat = Format
"{base}/{language}.mo"}

-- | Locate and load translations according to specified policy.
locateTranslations :: MonadIO m => LocatePolicy -> m Translations
locateTranslations :: LocatePolicy -> m Translations
locateTranslations (LocatePolicy {LanguageId
[LanguageId]
Format
lcFormat :: Format
lcFacet :: LanguageId
lcName :: LanguageId
lcBasePaths :: [LanguageId]
lcFormat :: LocatePolicy -> Format
lcFacet :: LocatePolicy -> LanguageId
lcName :: LocatePolicy -> LanguageId
lcBasePaths :: LocatePolicy -> [LanguageId]
..}) = IO Translations -> m Translations
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Translations -> m Translations)
-> IO Translations -> m Translations
forall a b. (a -> b) -> a -> b
$ do
    [LanguageId]
basePaths <- (LanguageId -> IO LanguageId) -> [LanguageId] -> IO [LanguageId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LanguageId -> IO LanguageId
makeAbsolute [LanguageId]
lcBasePaths
    [[(LanguageId, LanguageId)]]
pairs <- [LanguageId]
-> (LanguageId -> IO [(LanguageId, LanguageId)])
-> IO [[(LanguageId, LanguageId)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [LanguageId]
basePaths ((LanguageId -> IO [(LanguageId, LanguageId)])
 -> IO [[(LanguageId, LanguageId)]])
-> (LanguageId -> IO [(LanguageId, LanguageId)])
-> IO [[(LanguageId, LanguageId)]]
forall a b. (a -> b) -> a -> b
$ \LanguageId
basePath -> do
        let vars :: Map Text LanguageId
vars = [(Text, LanguageId)] -> Map Text LanguageId
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, LanguageId)] -> Map Text LanguageId)
-> [(Text, LanguageId)] -> Map Text LanguageId
forall a b. (a -> b) -> a -> b
$
                     [(Text
"base", LanguageId
basePath),
                      (Text
"language", LanguageId
"*"),
                      (Text
"facet", LanguageId
lcFacet),
                      (Text
"name", LanguageId
lcName)] :: M.Map T.Text String
            Format [FormatItem]
fmtItems = Format
lcFormat
            ([FormatItem]
fmtBase, [FormatItem]
fmtTail) = [FormatItem] -> ([FormatItem], [FormatItem])
breakFormat [FormatItem]
fmtItems
            pathGlob :: LanguageId
pathGlob = Text -> LanguageId
T.unpack (Format -> Map Text LanguageId -> Text
forall vars. VarContainer vars => Format -> vars -> Text
format Format
lcFormat Map Text LanguageId
vars)
            pathBaseLen :: Int
pathBaseLen = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ Text -> Int64
T.length (Format -> Map Text LanguageId -> Text
forall vars. VarContainer vars => Format -> vars -> Text
format ([FormatItem] -> Format
Format [FormatItem]
fmtBase) Map Text LanguageId
vars)
            pathTailLen :: Int
pathTailLen = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ Text -> Int64
T.length (Format -> Map Text LanguageId -> Text
forall vars. VarContainer vars => Format -> vars -> Text
format ([FormatItem] -> Format
Format [FormatItem]
fmtTail) Map Text LanguageId
vars)
        [LanguageId]
paths <- LanguageId -> IO [LanguageId]
glob LanguageId
pathGlob
        [LanguageId]
-> (LanguageId -> IO (LanguageId, LanguageId))
-> IO [(LanguageId, LanguageId)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [LanguageId]
paths ((LanguageId -> IO (LanguageId, LanguageId))
 -> IO [(LanguageId, LanguageId)])
-> (LanguageId -> IO (LanguageId, LanguageId))
-> IO [(LanguageId, LanguageId)]
forall a b. (a -> b) -> a -> b
$ \LanguageId
path -> do
             let pathWithoutBase :: LanguageId
pathWithoutBase = Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
pathBaseLen LanguageId
path
                 languageLen :: Int
languageLen = LanguageId -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length LanguageId
pathWithoutBase Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
pathTailLen
                 language :: LanguageId
language = Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
languageLen LanguageId
pathWithoutBase
             (LanguageId, LanguageId) -> IO (LanguageId, LanguageId)
forall (m :: * -> *) a. Monad m => a -> m a
return (LanguageId
language, LanguageId
path)
    [(LanguageId, LanguageId)] -> IO Translations
loadTranslations ([(LanguageId, LanguageId)] -> IO Translations)
-> [(LanguageId, LanguageId)] -> IO Translations
forall a b. (a -> b) -> a -> b
$ [[(LanguageId, LanguageId)]] -> [(LanguageId, LanguageId)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(LanguageId, LanguageId)]]
pairs
  where
    breakFormat :: [FormatItem] -> ([FormatItem], [FormatItem])
breakFormat [FormatItem]
items =
      let ([FormatItem]
hd, [FormatItem]
tl) = (FormatItem -> Bool)
-> [FormatItem] -> ([FormatItem], [FormatItem])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break FormatItem -> Bool
isLanguage [FormatItem]
items
      in  case [FormatItem]
tl of
            [] -> ([FormatItem]
hd, [])
            [FormatItem]
_  -> ([FormatItem]
hd, [FormatItem] -> [FormatItem]
forall a. [a] -> [a]
tail [FormatItem]
tl)

    isLanguage :: FormatItem -> Bool
isLanguage (FVariable Text
name VarFormat
_) = Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"language"
    isLanguage FormatItem
_ = Bool
False