diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, IlyaPortnov + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of IlyaPortnov nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,29 @@ +localize README +=============== + +This package is more or less fully functional translation framework, +based on [haskell-gettext][1] package. The key features are: + +* Convinient functions for translation. +* Full support of gettext features, such as message contexts and plural forms. +* It is possible to detect language to use by process locale. But it is not + necessary, you for example may want to use `Accept-Language` HTTP header + instead. +* Easy integration with custom monadic stacks by implementing instance of + `Localized` type class. +* There are two simple implementations of `Localized` type class, for IO and + StateT-based monad transformer. Being mostly examples, these implementations + can be useful in relatively simple applications. +* Utility functions to locate catalog files by specified rules. Example rules + for locating catalog files under source directory and for locating them + under usual Linux locations are provided. +* Integration with [text-format-heavy][2] package. It may be more convinient + than use of some other formatting libraries (`printf`, for example), + since it supports named variable placeholders, much easier for translators + to understand. + +Please refer to Haddock documentation and to examples in `examples/` directory. + +[1]: https://hackage.haskell.org/package/haskell-gettext +[2]: https://hackage.haskell.org/package/text-format-heavy + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Text/Localize.hs b/Text/Localize.hs new file mode 100644 --- /dev/null +++ b/Text/Localize.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, DeriveDataTypeable #-} +-- | This is the main module of the @localize@ package. +-- It contains definitions of general use and reexport generally required internal modules. +module Text.Localize + ( + -- $description + -- + -- * Most used functions + __, __n, __f, + -- * Basic functions + translate, translateN, translateNFormat, + lookup, withTranslation, + -- * Reexports + module Text.Localize.Types, + module Text.Localize.Load, + module Text.Localize.Locale + ) where + +import Prelude hiding (lookup) +import Control.Applicative +import Control.Monad +import qualified Data.Map as M +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.Encoding as TLE +import qualified Data.Text.Encoding as TE +import Data.String +import Data.List hiding (lookup) +import Data.Monoid +import Data.Typeable +import qualified Data.Gettext as Gettext +import qualified Data.Text.Format.Heavy as F +import Data.Text.Format.Heavy.Parse (parseFormat) + +import Text.Localize.Types +import Text.Localize.Load +import Text.Localize.Locale + +-- $description +-- +-- This is the main module of the @localize@ package. In most cases, you have to import only +-- this module. In specific cases, you may also want to import Text.Localize.IO or Text.Localize.State. +-- +-- All functions exported by @localize@ package work with any instance of the +-- @Localized@ type class. There are two simple examples of this type class +-- implementation provided in separate modules (IO and State); however, in +-- complex applications it may be more convinient to implement @Localized@ +-- instance for the monadic stack you already have. +-- +-- Example of usage is: +-- +-- @ +-- import qualified Data.Text as T +-- import qualified Data.Text.Lazy.IO as TLIO +-- import Text.Localize +-- +-- newtype MyMonad a = MyMonad {unMyMonad :: ... } +-- deriving (Monad) +-- +-- instance Localized MyMonad where +-- ... +-- +-- runMyMonad :: Translations -> MyMonad a -> IO a +-- runMyMonad = ... +-- +-- hello :: T.Text -> MyMonad () +-- hello name = do +-- liftIO $ TLIO.putStrLn =<< __ "Your name: " +-- liftIO $ hFlush stdout +-- name <- liftIO $ TLIO.getLine +-- greeting <- __f "Hello, {}!" (Single name) +-- liftIO $ TLIO.putStrLn greeting +-- +-- main :: IO () +-- main = do +-- translations <- locateTranslations $ linuxLocation "hello" +-- runMyMonad translations hello +-- +-- @ +-- +-- See also working examples under @examples/@ directory. +-- + +-- | Look up for translation. Returns source string if translation not found. +lookup :: Translations -> LanguageId -> TranslationSource -> T.Text +lookup t lang bstr = + case M.lookup lang (tMap t) of + Nothing -> toText bstr + Just gmo -> Gettext.gettext gmo bstr + +-- | Execute function depending on current translation catalog and context. +withTranslation :: Localized m + => (b -> r) -- ^ Function to be executed if there is no + -- translation for current language loaded. + -> (Gettext.Catalog -> Maybe Context -> b -> r) -- ^ Function to be executed on current catalog. + -> (b -> m r) -- ^ Function lifted into @Localized@ monad. +withTranslation dflt fn b = do + t <- getTranslations + lang <- getLanguage + ctxt <- getContext + case M.lookup lang (tMap t) of + Nothing -> return $ dflt b + Just gmo -> return $ fn gmo ctxt b + +-- | Translate a string. +translate :: (Localized m) => TranslationSource -> m T.Text +translate orig = do + t <- getTranslations + lang <- getLanguage + mbContext <- getContext + case M.lookup lang (tMap t) of + Nothing -> return $ toText orig + Just gmo -> + case mbContext of + Nothing -> return $ Gettext.gettext gmo orig + Just ctxt -> return $ Gettext.cgettext gmo ctxt orig + +-- | Short alias for @translate@. +__ :: (Localized m) => TranslationSource -> m T.Text +__ = translate + +-- | Translate a string, taking plural forms into account. +translateN :: (Localized m) + => TranslationSource -- ^ Single form in original language + -> TranslationSource -- ^ Plural form in original language + -> Int -- ^ Number + -> m T.Text +translateN orig plural n = do + t <- getTranslations + lang <- getLanguage + mbContext <- getContext + case M.lookup lang (tMap t) of + Nothing -> return $ toText orig + Just gmo -> + case mbContext of + Nothing -> return $ Gettext.ngettext gmo orig plural n + Just ctxt -> return $ Gettext.cngettext gmo ctxt orig plural n + +-- | Translate a string and substitute variables into it. +-- Data.Text.Format.Heavy.format syntax is used. +translateFormat :: (Localized m, F.VarContainer vars) + => TranslationSource -- ^ Original formatting string + -> vars -- ^ Substitution variables + -> m T.Text +translateFormat orig vars = do + fmtStr <- translate orig + case parseFormat fmtStr of + Left err -> fail $ show err + Right fmt -> return $ F.format fmt vars + +-- | Short alias for @translateFormat@. +__f :: (Localized m, F.VarContainer c) => TranslationSource -> c -> m T.Text +__f = translateFormat + +-- | Translate a string, taking plural forms into account, +-- and substitute variables into it. +-- Data.Text.Format.Heavy.format syntax is used. +translateNFormat :: (Localized m, F.VarContainer vars) + => TranslationSource -- ^ Single form of formatting string in original language + -> TranslationSource -- ^ Plural form of formatting string in original language + -> Int -- ^ Number + -> vars -- ^ Substitution variables + -> m T.Text +translateNFormat orig plural n vars = do + fmtStr <- translateN orig plural n + case parseFormat fmtStr of + Left err -> fail $ show err + Right fmt -> return $ F.format fmt vars + +-- | Short alias for @translateNFormat@. +__n :: (Localized m, F.VarContainer c) => TranslationSource -> TranslationSource -> Int -> c -> m T.Text +__n = translateNFormat + diff --git a/Text/Localize/IO.hs b/Text/Localize/IO.hs new file mode 100644 --- /dev/null +++ b/Text/Localize/IO.hs @@ -0,0 +1,76 @@ +-- | This module is most near to be a drop-in replacement for @hgettext@ API. +-- It provides an @instance Localized IO@ by using process-level global variables (IORefs) for +-- storing current language and translations. +-- +-- Being mostly an example, this module can though be usable for relatively simple applications, +-- for which you do not need to change languages a lot. +module Text.Localize.IO + (setupTranslations, + setLanguage, withLanguage, + setContext, withContext + ) where + +import Data.IORef +import System.IO.Unsafe (unsafePerformIO) + +import Text.Localize.Types +import Text.Localize.Load +import Text.Localize.Locale + +currentContext :: IORef (Maybe Context) +currentContext = unsafePerformIO $ newIORef Nothing +{-# NOINLINE currentContext #-} + +currentLanguage :: IORef LanguageId +currentLanguage = unsafePerformIO $ do + language <- languageFromLocale + newIORef language +{-# NOINLINE currentLanguage #-} + +currentTranslations :: IORef Translations +currentTranslations = unsafePerformIO $ newIORef undefined +{-# NOINLINE currentTranslations #-} + +instance Localized IO where + getLanguage = readIORef currentLanguage + getTranslations = readIORef currentTranslations + getContext = readIORef currentContext + +-- | This function must be called before any translation function call, +-- otherwise you will get runtime error. +-- +-- Current language is selected from process locale at startup. You can +-- change it later by calling @setLanguage@ or @withLanguage@. +setupTranslations :: LocatePolicy -> IO () +setupTranslations p = do + translations <- locateTranslations p + writeIORef currentTranslations translations + +-- | Set current language. +setLanguage :: LanguageId -> IO () +setLanguage language = writeIORef currentLanguage language + +-- | Execute some actions with specific language, and +-- then return to previously used language. +withLanguage :: LanguageId -> IO a -> IO a +withLanguage language actions = do + oldLang <- getLanguage + setLanguage language + result <- actions + setLanguage oldLang + return result + +-- | Set current context. +setContext :: Maybe Context -> IO () +setContext mbContext = writeIORef currentContext mbContext + +-- | Execute some actions within specific context, +-- and then return to previously used context. +withContext :: Maybe Context -> IO a -> IO a +withContext ctxt actions = do + oldContext <- getContext + setContext ctxt + result <- actions + setContext oldContext + return result + diff --git a/Text/Localize/Load.hs b/Text/Localize/Load.hs new file mode 100644 --- /dev/null +++ b/Text/Localize/Load.hs @@ -0,0 +1,105 @@ +{-# 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 pairs = do + res <- forM pairs $ \(lang, path) -> do + gmo <- Gettext.loadCatalog path + return (lang, gmo) + return $ Translations $ M.fromList 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 { + lcBasePaths :: [FilePath] -- ^ Paths to directory with translations, e.g. @"\/usr\/share\/locale"@. Defaults to @"locale"@. + , lcName :: String -- ^ Catalog file name (in gettext this is also known as text domain). Defaults to @"messages"@. + , lcFacet :: Facet -- ^ Locale facet. Defaults to @LC_MESSAGES@. + , 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 (Show) + +instance Default LocatePolicy where + def = LocatePolicy { + lcBasePaths = ["locale"], + lcName = "messages", + lcFacet = "LC_MESSAGES", + lcFormat = "{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 name = def {lcBasePaths = ["/usr/share/locale", "/usr/local/share/locale"], lcName = name} + +-- | Simple translations location polciy, assuming all catalog files located at +-- @{base}\/{language}.mo@. +localLocation :: FilePath -- ^ Path to directory with translations + -> LocatePolicy +localLocation base = def {lcBasePaths = [base], lcFormat = "{base}/{language}.mo"} + +-- | Locate and load translations according to specified policy. +locateTranslations :: MonadIO m => LocatePolicy -> m Translations +locateTranslations (LocatePolicy {..}) = liftIO $ do + basePaths <- mapM makeAbsolute lcBasePaths + pairs <- forM basePaths $ \basePath -> do + let vars = M.fromList $ + [("base", basePath), + ("language", "*"), + ("facet", lcFacet), + ("name", lcName)] :: M.Map T.Text String + Format fmtItems = lcFormat + (fmtBase, fmtTail) = breakFormat fmtItems + pathGlob = T.unpack (format lcFormat vars) + pathBaseLen = fromIntegral $ T.length (format (Format fmtBase) vars) + pathTailLen = fromIntegral $ T.length (format (Format fmtTail) vars) + paths <- glob pathGlob + forM paths $ \path -> do + let pathWithoutBase = drop pathBaseLen path + languageLen = length pathWithoutBase - pathTailLen + language = take languageLen pathWithoutBase + return (language, path) + loadTranslations $ concat pairs + where + breakFormat items = + let (hd, tl) = break isLanguage items + in case tl of + [] -> (hd, []) + _ -> (hd, tail tl) + + isLanguage (FVariable name _) = name == "language" + isLanguage _ = False + diff --git a/Text/Localize/Locale.hs b/Text/Localize/Locale.hs new file mode 100644 --- /dev/null +++ b/Text/Localize/Locale.hs @@ -0,0 +1,17 @@ +-- | This module contains definitions related to +-- obtaining current localization settings from +-- process's locale. +module Text.Localize.Locale where + +import Data.Maybe +import System.Locale.SetLocale + +import Text.Localize.Types + +-- | Obtain language to be used from process's locale. +languageFromLocale :: IO LanguageId +languageFromLocale = do + mbLocale <- setLocale LC_MESSAGES (Just "") + let locale = fromMaybe "C" mbLocale + return $ takeWhile (/= '_') locale + diff --git a/Text/Localize/State.hs b/Text/Localize/State.hs new file mode 100644 --- /dev/null +++ b/Text/Localize/State.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE TypeSynonymInstances, GeneralizedNewtypeDeriving, OverloadedStrings #-} +-- | This module offers a simple implementation of @Localized@ class via @StateT@ transformer. +-- This implementation is usable if you have nothing against adding yet another transformer to +-- your already complicated monadic stack. Otherwise, it may be simpler for you to add necessary +-- fields to one of @StateT@s or @ReaderT@s in your stack. +module Text.Localize.State + (-- * Data types + LocState (..), + LocalizeT (..), + -- * Functions + runLocalizeT, + setLanguage, withLanguage, + setContext, withContext + ) where + +import Control.Applicative +import Control.Monad.State +import Control.Monad.Trans + +import Text.Localize.Types + +-- | Localization state +data LocState = LocState { + lsTranslations :: Translations, + lsLanguage :: LanguageId, + lsContext :: Maybe Context + } + deriving (Show) + +-- | Localization monad transformer +newtype LocalizeT m a = LocalizeT { + unLocalizeT :: StateT LocState m a + } + deriving (Functor, Applicative, Monad, MonadIO, MonadState LocState) + +instance Monad m => Localized (LocalizeT m) where + getTranslations = gets lsTranslations + getLanguage = gets lsLanguage + getContext = gets lsContext + +-- | Run a computation inside @LocalizeT@. +runLocalizeT :: Monad m => LocalizeT m a -> LocState -> m a +runLocalizeT actions st = evalStateT (unLocalizeT actions) st + +-- | Set current language +setLanguage :: Monad m => LanguageId -> LocalizeT m () +setLanguage lang = modify $ \st -> st {lsLanguage = lang} + +-- | Execute some actions with specified language. +withLanguage :: Monad m => LanguageId -> LocalizeT m a -> LocalizeT m a +withLanguage lang actions = do + oldLang <- gets lsLanguage + setLanguage lang + result <- actions + setLanguage oldLang + return result + +-- | Set current context. +setContext :: Monad m => Maybe Context -> LocalizeT m () +setContext ctxt = modify $ \st -> st {lsContext = ctxt} + +-- | Execute some actions within specific context. +withContext :: Monad m => Maybe Context -> LocalizeT m a -> LocalizeT m a +withContext ctxt actions = do + oldContext <- gets lsContext + setContext ctxt + result <- actions + setContext oldContext + return result + diff --git a/Text/Localize/Types.hs b/Text/Localize/Types.hs new file mode 100644 --- /dev/null +++ b/Text/Localize/Types.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, DeriveDataTypeable #-} +-- | This module contains data type definitions for the @localize@ package. +module Text.Localize.Types where + +import Control.Applicative +import qualified Data.Map as M +import qualified Data.ByteString as B +import qualified Data.Text.Lazy as T +import qualified Data.Text.Encoding as TE +import qualified Data.Gettext as Gettext + +-- | Language identifier +type LanguageId = String + +-- | Context name +type Context = B.ByteString + +-- | String to be translated +type TranslationSource = B.ByteString + +-- | Stores translation catalogs for all supported languages +data Translations = Translations { + tMap :: M.Map LanguageId Gettext.Catalog } + +instance Show Translations where + show t = "" + +-- | This is the main type class of the package. +-- All functions work with any instance of this type class. +-- +-- Note that this class only supports **getting** current language +-- and translation, not setting them. Though concrete implementation +-- can have its own ways to change language or context, these ways are +-- not required by the @localize@ package, and so are not declared in the +-- type class. +class (Monad m, Applicative m) => Localized m where + -- | Obtain currently selected language ID. + getLanguage :: m LanguageId + + -- | Obtain currently loaded translations. + getTranslations :: m Translations + + -- | Obtain currently selected localization context. + -- Nothing means no specific context. + getContext :: m (Maybe Context) + getContext = return Nothing + +-- | This assumes UTF-8 encoding. +toText :: TranslationSource -> T.Text +toText bstr = T.fromStrict $ TE.decodeUtf8 bstr + diff --git a/localize.cabal b/localize.cabal new file mode 100644 --- /dev/null +++ b/localize.cabal @@ -0,0 +1,44 @@ +name: localize +version: 0.2.0.0 +synopsis: GNU Gettext-based messages localization library +description: More or less fully functional translation framework, + based on @haskell-gettext@ and @text-format-heavy@ + packages. +license: BSD3 +license-file: LICENSE +author: IlyaPortnov +maintainer: portnov84@rambler.ru +-- copyright: +category: Text +build-type: Simple +extra-doc-files: README.md +cabal-version: >=1.18 + +library + exposed-modules: Text.Localize, + Text.Localize.Types, + Text.Localize.Load, + Text.Localize.State, + Text.Localize.IO, + Text.Localize.Locale + build-depends: base > 4 && < 5, + mtl >= 2.2.1, + binary >=0.7, + bytestring ==0.10.*, + text >= 1.2, + data-default >= 0.7, + containers >=0.5, + text-format-heavy >= 0.1.4.0, + haskell-gettext >= 0.1.1.0, + time >=1.4, + transformers >=0.3, + filepath >= 1.4, + directory >= 1.3, + Glob >= 0.7.14, + setlocale >= 1.0 + default-language: Haskell2010 + +Source-repository head + type: git + location: https://github.com/portnov/localize.git +