diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2008, Eugene Grigoriev +Copyright (c) 2016, Eugene Grigoriev All rights reserved. diff --git a/Text/I18n.hs b/Text/I18n.hs deleted file mode 100644 --- a/Text/I18n.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Text.I18n --- Copyright : (c) Eugene Grigoriev, 2008 --- License : BSD3 --- --- Maintainer : eugene.grigoriev@gmail.com --- Stability : experimental --- Portability : portable --- --- Internationalization support for Haskell. --- Use Text.I18n.Po module. --- --- Plural forms are not yet implemented. --- ------------------------------------------------------------------------------ -module Text.I18n ( - -- * Type Declarations - Msgid(..), Msgstr, Locale(..), Context, I18n, L10n, - -- * Internationalization Monad Functions - gettext, localize, withContext, withLocale - ) where - -import Control.Monad.Reader -import Control.Monad.Trans -import Control.Monad.Identity -import Data.Maybe -import Text.I18n.Printf -import qualified Data.Map as Map - -------------------------------------------------------------------------------- --- Type declarations -------------------------------------------------------------------------------- -newtype Msgid = Msgid String deriving (Show,Eq,Ord) - -type Msgstr = String - -newtype Locale = Locale String deriving (Show,Eq,Ord) - -type Context = String - --- | The Internationalization monad built using monad transformers. -type I18n a = ReaderT (Locale, L10n, Maybe Context) Identity a - --- | The Localization structure. -type L10n = Map.Map Locale - (Map.Map (Maybe Context) - (Map.Map Msgid - [Msgstr])) - -instance PrintfType (I18n String) where - spr fmts args = return (uprintf fmts (reverse args)) - -------------------------------------------------------------------------------- --- I18N Monad functions -------------------------------------------------------------------------------- -{-| - The top level localization function. - - > import Text.I18n.Po - > import Prelude hiding (putStr,putStrLn) - > - > main = do - > (l10n,errors) <- getL10n "dir/to/po" -- directory containing PO files - > putStrLn $ localize l10n (Locale "en") (example "Joe") --} -localize :: L10n -- ^ Structure containing localization data - -> Locale -- ^ Locale to use - -> I18n a -- ^ Inernationalized expression - -> a -- ^ Localized expression -localize l10n loc expression = runIdentity $ runReaderT expression (loc,l10n,Nothing) - -{-| - The heart of I18n monad. Based on 'Text.Printf.printf'. - - > example :: String -> I18n String - > example name = do - > hello <- gettext "Hello, %s!" - > return (hello name) --} -gettext :: PrintfType a => String -> I18n a -gettext msgid = do - (loc, l10n, ctxt) <- ask - case localizeMsgid l10n loc ctxt (Msgid msgid) of - Just msgstr -> return (printf msgstr) - Nothing -> case ctxt of - Just _ -> withContext Nothing (gettext msgid) - Nothing -> return (printf msgid) - -{-| - Sets a local 'Context' for an internationalized expression. - If there is no translation, then no context version is tried. - - > example2 :: String -> I18n String - > example2 = withContext (Just "test") . example --} -withContext :: Maybe Context -- ^ Context to use - -> I18n a -- ^ Internationalized expression - -> I18n a -- ^ New internationalized expression -withContext ctxt expression = do - (lang, l10n, _) <- ask - local (const (lang, l10n, ctxt)) - expression - -{-| - Sets a local 'Locale' for an internationalized expression. - - > example3 :: String -> I18n String - > example3 = withLocale (Locale "ru") . example2 --} -withLocale :: Locale -- ^ Locale to use - -> I18n a -- ^ Internationalized expression - -> I18n a -- ^ New internationalized expression. - -- Note: while this expression is localy localized already, it is to be a - -- part of another internationalized expression. - -- Therefore the final type is internationalized. -withLocale loc expression = do - (_, l10n, ctxt) <- ask - local (const (loc, l10n, ctxt)) - expression - -localizeMsgid :: L10n -> Locale -> Maybe Context -> Msgid -> Maybe String -localizeMsgid l10n loc ctxt msgid = do - local <- Map.lookup loc l10n - contextual <- Map.lookup ctxt local - msgstrs <- Map.lookup msgid contextual - listToMaybe msgstrs diff --git a/Text/I18n/Po.hs b/Text/I18n/Po.hs deleted file mode 100644 --- a/Text/I18n/Po.hs +++ /dev/null @@ -1,188 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.I18n.Po --- Copyright : (c) Eugene Grigoriev, 2008 --- License : BSD3 --- --- Maintainer : eugene.grigoriev@gmail.com --- Stability : experimental --- Portability : portable --- --- Internationalization support for Haskell. This module contains --- PO parser. PO files are assumed to be in UTF-8 encoding. --- --- Plural forms are not yet implemented. --- --- modules Text.I18n, Control.Monad.Trans, and function putStrLn and putStr --- from System.IO.UTF8 are exported for convenience. --- --- > import Prelude hiding (putStr,putStrLn) --- ------------------------------------------------------------------------------ -module Text.I18n.Po ( - -- * Type Declarations - Msgid(..), Msgstr, Locale(..), Context, I18n, L10n, - -- * PO parsing - getL10n, - -- * I18n Monad Functions - localize, gettext, withContext, withLocale, - -- * UTF-8 Output Functions - Utf8.putStrLn, Utf8.putStr, - module Control.Monad.Trans - ) where - -import Text.I18n -import Text.ParserCombinators.Parsec -import qualified Text.ParserCombinators.Parsec.Token as P -import Text.ParserCombinators.Parsec.Language -import Data.List -import qualified Data.Map as Map -import Data.Monoid -import Control.Monad.Trans -import Control.Arrow -import System.Directory -import System.FilePath -import qualified System.IO.UTF8 as Utf8 - -------------------------------------------------------------------------------- --- Type declarations -------------------------------------------------------------------------------- -data MsgDec = MsgDec (Maybe Context) Msgid [Msgstr] - -------------------------------------------------------------------------------- --- Interface -------------------------------------------------------------------------------- --- | Builds 'L10n' structure by parsing / .po / files contained in a given --- directory. 'L10n' structure is to be passed to 'localize' function. --- 'L10n' structure is used internaly by the 'I18n' monad. -getL10n :: FilePath -- ^ Directory containing PO files. - -> IO (L10n, [ParseError]) -- ^ Localization structure - -- and a list of parse errors. -getL10n dir = do - poFiles <- poFiles dir - locs <- processPos (map (second parsePo) poFiles) - (es,locs) <- return (separateEithers locs) - return (Map.fromList locs, es) - -------------------------------------------------------------------------------- --- Internal -------------------------------------------------------------------------------- -processPos :: [(Locale, IO (Either ParseError [MsgDec]))] - -> IO [Either ParseError - (Locale, Map.Map (Maybe Context) - (Map.Map Msgid - [Msgstr]))] -processPos rs = do - rs <- mapM (\(a,m) -> m >>= \b -> return (a,b)) rs - return $ map f rs - where f (l, (Right msgdecs)) = Right (l, mkMsgs msgdecs) - f (_, (Left e)) = Left e - -mkMsgs :: [MsgDec] -> Map.Map (Maybe Context) (Map.Map Msgid [Msgstr]) -mkMsgs = foldl' f mempty - where f m (MsgDec ctxt msgid msgstrs) = case Map.lookup ctxt m of - Nothing -> f (Map.insert ctxt mempty m) (MsgDec ctxt msgid msgstrs) - Just c -> Map.insert ctxt (Map.insert msgid msgstrs c) m - -poFiles :: FilePath -> IO [(Locale,FilePath)] -poFiles dir = do - files <- getDirectoryContents dir - return $ (map ((&&&) (Locale . (subtract 3 . length >>= take)) - (intercalate [pathSeparator] . (dir :) . return)) - . filter (flip any [".po",".Po",".PO"] . flip isSuffixOf)) - files - -parsePo :: FilePath -> IO (Either ParseError [MsgDec]) -parsePo n = do - contents <- Utf8.readFile n - return $ parse po n contents - -------------------------------------------------------------------------------- --- .po Parser -------------------------------------------------------------------------------- -{- EBNF - PO ::= msg* - msg ::= [msg-context] (msg-singular | msg-plural) - msg-context ::= "msgctxt" string* - msg-singular ::= msgid msgstr - msg-plural ::= msgid msgid-plural msgstr-plural* - msgid ::= "msgid" string* - msgid-plural ::= "msgid_plural" string* - msgstr ::= "msgstr" string* - msgstr-plural ::= "msgstr" form string* - form ::= "[" number "]" - number ::= (0-9)* | "N" - string ::= "\"" (char | escaped-char)* "\"" - escaped-char ::= "\\" char - char ::= (any UTF8 character) --} -lexer = P.makeTokenParser (emptyDef { - commentLine = "#", - reservedNames = ["msgctxt","msgid","msgid_plural","msgstr"] }) - -whiteSpace = P.whiteSpace lexer -lexeme = P.lexeme lexer -reserved = P.reserved lexer - -po = do whiteSpace - msgs <- many msg - eof - return msgs - -msg = do ctxt <- msg_context - (id,strs) <- try msg_singular <|> msg_plural - return (MsgDec ctxt id strs) - -msg_context = try $ option Nothing $ do - lexeme (reserved "msgctxt") - strs <- many1 str - return (Just (concat strs)) - -msg_singular = do id <- lexeme msgid - str <- lexeme msgstr - return (Msgid id, [str]) - -msg_plural = do id <- lexeme msgid - idp <- lexeme msgid_plural - strps <- lexeme (many1 msgstr_plural) - return (Msgid id, strps) - -msgid = do lexeme (reserved "msgid") - strs <- many1 str - return (concat strs) - -msgid_plural = do lexeme (reserved "msgid_plural") - strs <- many1 str - return (concat strs) - -msgstr = do lexeme (reserved "msgstr") - strs <- many1 str - return (concat strs) - -msgstr_plural = do lexeme (reserved "msgstr") - char '[' - try (do c <- oneOf ['n','N'] - return [c]) - <|> many1 (oneOf ['0'..'9']) - char ']' - whiteSpace - strs <- many1 str - return (concat strs) - -str = lexeme $ do char '"' - chs <- many ch - char '"' - return chs - -ch = try escaped_ch <|> noneOf ['"'] - -escaped_ch = do e <- char '\\' - c <- anyChar - case reads ['\'',e,c,'\''] :: [(Char,String)] of - (c,s):[] -> return c - _ -> return c - -------------------------------------------------------------------------------- --- Utilities -------------------------------------------------------------------------------- -separateEithers = foldr (either (first . (:)) (second . (:))) ([],[]) diff --git a/Text/I18n/Printf.hs b/Text/I18n/Printf.hs deleted file mode 100644 --- a/Text/I18n/Printf.hs +++ /dev/null @@ -1,243 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.I18n.Printf --- Copyright : (c) Eugene Grigoriev, 2008 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : eugene.grigoriev@gmail.com --- Stability : provisional --- Portability : portable --- --- A slightly modified version of Text.Printf module. (with permission) --- --- This module is internal to Text.I18n. --- ------------------------------------------------------------------------------ -module Text.I18n.Printf( - printf, hPrintf, - PrintfType, HPrintfType, PrintfArg, IsChar, - spr, uprintf -) where - -import Prelude -import Data.Char -import Data.Int -import Data.Word -import Numeric(showEFloat, showFFloat, showGFloat) -import System.IO - -printf :: (PrintfType r) => String -> r -printf fmts = spr fmts [] - -hPrintf :: (HPrintfType r) => Handle -> String -> r -hPrintf hdl fmts = hspr hdl fmts [] - -class PrintfType t where - spr :: String -> [UPrintf] -> t - -class HPrintfType t where - hspr :: Handle -> String -> [UPrintf] -> t - -instance (IsChar c) => PrintfType [c] where - spr fmts args = map fromChar (uprintf fmts (reverse args)) - -instance PrintfType (IO a) where - spr fmts args = do - putStr (uprintf fmts (reverse args)) - return undefined - -instance HPrintfType (IO a) where - hspr hdl fmts args = do - hPutStr hdl (uprintf fmts (reverse args)) - return undefined - -instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) where - spr fmts args = \ a -> spr fmts (toUPrintf a : args) - -instance (PrintfArg a, HPrintfType r) => HPrintfType (a -> r) where - hspr hdl fmts args = \ a -> hspr hdl fmts (toUPrintf a : args) - -class PrintfArg a where - toUPrintf :: a -> UPrintf - -instance PrintfArg Char where - toUPrintf c = UChar c - -instance (IsChar c) => PrintfArg [c] where - toUPrintf = UString . map toChar - -instance PrintfArg Int where - toUPrintf = uInteger - -instance PrintfArg Int8 where - toUPrintf = uInteger - -instance PrintfArg Int16 where - toUPrintf = uInteger - -instance PrintfArg Int32 where - toUPrintf = uInteger - -instance PrintfArg Int64 where - toUPrintf = uInteger - --- if on NHC, exclure this declaration using CPP -instance PrintfArg Word where - toUPrintf = uInteger - -instance PrintfArg Word8 where - toUPrintf = uInteger - -instance PrintfArg Word16 where - toUPrintf = uInteger - -instance PrintfArg Word32 where - toUPrintf = uInteger - -instance PrintfArg Word64 where - toUPrintf = uInteger - -instance PrintfArg Integer where - toUPrintf = UInteger 0 - -instance PrintfArg Float where - toUPrintf = UFloat - -instance PrintfArg Double where - toUPrintf = UDouble - -uInteger :: (Integral a, Bounded a) => a -> UPrintf -uInteger x = UInteger (toInteger $ minBound `asTypeOf` x) (toInteger x) - -class IsChar c where - toChar :: c -> Char - fromChar :: Char -> c - -instance IsChar Char where - toChar c = c - fromChar c = c - -------------------- - -data UPrintf = UChar Char | UString String | UInteger Integer Integer | UFloat Float | UDouble Double - -uprintf :: String -> [UPrintf] -> String -uprintf "" [] = "" -uprintf "" (_:_) = fmterr -uprintf ('%':'%':cs) us = '%':uprintf cs us -uprintf ('%':_) [] = argerr -uprintf ('%':cs) us@(_:_) = fmt cs us -uprintf (c:cs) us = c:uprintf cs us - -fmt :: String -> [UPrintf] -> String -fmt cs us = - let (width, prec, ladj, zero, plus, cs', us') = getSpecs False False False cs us - adjust (pre, str) = - let lstr = length str - lpre = length pre - fill = if lstr+lpre < width then take (width-(lstr+lpre)) (repeat (if zero then '0' else ' ')) else "" - in if ladj then pre ++ str ++ fill else if zero then pre ++ fill ++ str else fill ++ pre ++ str - adjust' ("", str) | plus = adjust ("+", str) - adjust' ps = adjust ps - in case cs' of - [] -> fmterr - c:cs'' -> case us' of - [] -> argerr - u:us'' -> (case c of - 'c' -> adjust ("", [toEnum (toint u)]) - 'd' -> adjust' (fmti u) - 'i' -> adjust' (fmti u) - 'x' -> adjust ("", fmtu 16 u) - 'X' -> adjust ("", map toUpper $ fmtu 16 u) - 'o' -> adjust ("", fmtu 8 u) - 'u' -> adjust ("", fmtu 10 u) - 'e' -> adjust' (dfmt' c prec u) - 'E' -> adjust' (dfmt' c prec u) - 'f' -> adjust' (dfmt' c prec u) - 'g' -> adjust' (dfmt' c prec u) - 'G' -> adjust' (dfmt' c prec u) - 's' -> adjust ("", tostr u) - _ -> perror ("bad formatting char " ++ [c]) - ) ++ uprintf cs'' us'' - -fmti :: UPrintf -> (String, String) -fmti (UInteger _ i) = if i < 0 then ("-", show (-i)) else ("", show i) -fmti (UChar c) = fmti (uInteger (fromEnum c)) -fmti _ = baderr - -fmtu :: Integer -> UPrintf -> String -fmtu b (UInteger l i) = itosb b (if i < 0 then -2*l + i else i) -fmtu b (UChar c) = itosb b (toInteger (fromEnum c)) -fmtu _ _ = baderr - -toint :: UPrintf -> Int -toint (UInteger _ i) = fromInteger i -toint (UChar c) = fromEnum c -toint _ = baderr - -tostr :: UPrintf -> String -tostr (UString s) = s -tostr _ = baderr - -itosb :: Integer -> Integer -> String -itosb b n = - if n < b then - [intToDigit $ fromInteger n] - else - let (q, r) = quotRem n b in - itosb b q ++ [intToDigit $ fromInteger r] - -stoi :: Int -> String -> (Int, String) -stoi a (c:cs) | isDigit c = stoi (a*10 + digitToInt c) cs -stoi a cs = (a, cs) - -getSpecs :: Bool -> Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, Bool, String, [UPrintf]) -getSpecs _ z s ('-':cs) us = getSpecs True z s cs us -getSpecs l z _ ('+':cs) us = getSpecs l z True cs us -getSpecs l _ s ('0':cs) us = getSpecs l True s cs us -getSpecs l z s ('*':cs) us = - case us of - [] -> argerr - nu : us' -> - let n = toint nu - (p, cs'', us'') = - case cs of - '.':'*':r -> case us' of { [] -> argerr; pu:us''' -> (toint pu, r, us''') } - '.':r -> let (n', cs') = stoi 0 r in (n', cs', us') - _ -> (-1, cs, us') - in (n, p, l, z, s, cs'', us'') -getSpecs l z s ('.':cs) us = - let (p, cs') = stoi 0 cs - in (0, p, l, z, s, cs', us) -getSpecs l z s cs@(c:_) us | isDigit c = - let (n, cs') = stoi 0 cs - (p, cs'') = case cs' of - '.':r -> stoi 0 r - _ -> (-1, cs') - in (n, p, l, z, s, cs'', us) -getSpecs l z s cs us = (0, -1, l, z, s, cs, us) - -dfmt' :: Char -> Int -> UPrintf -> (String, String) -dfmt' c p (UDouble d) = dfmt c p d -dfmt' c p (UFloat f) = dfmt c p f -dfmt' _ _ _ = baderr - -dfmt :: (RealFloat a) => Char -> Int -> a -> (String, String) -dfmt c p d = - case (if isUpper c then map toUpper else id) $ - (case toLower c of - 'e' -> showEFloat - 'f' -> showFFloat - 'g' -> showGFloat - _ -> error "Printf.dfmt: impossible" - ) - (if p < 0 then Nothing else Just p) d "" of - '-':cs -> ("-", cs) - cs -> ("" , cs) - -perror :: String -> a -perror s = error ("Printf.printf: "++s) -fmterr, argerr, baderr :: a -fmterr = perror "formatting string ended prematurely" -argerr = perror "argument list ended prematurely" -baderr = perror "bad argument" diff --git a/i18n.cabal b/i18n.cabal --- a/i18n.cabal +++ b/i18n.cabal @@ -1,18 +1,49 @@ -Name: i18n -Version: 0.3 -Cabal-Version: >= 1.2 +name: i18n +version: 0.4.0.0 +description: Internationalisation for Haskell +license-file: LICENSE +license: BSD3 + +author: Eugene Grigoriev +bug-reports: https://github.com/filib/i18n/issues build-type: Simple -Synopsis: Internationalization for Haskell -Category: Text -License: BSD3 -License-file: LICENSE -Copyright: (c) 2008 Eugene Grigoriev -Author: Eugene Grigoriev -Maintainer: Eugene Grigoriev -Stability: experimental -Description: Internationalization for Haskell +cabal-version: >=1.10 +category: Text +copyright: (c) 2008-2016 Eugene Grigoriev +homepage: https://github.com/filib/i18n +maintainer: Philip Cunningham +stability: experimental +synopsis: Internationalization for Haskell -Library - Build-Depends: base, array, containers, old-locale, old-time, filepath, - directory, parsec, mtl, utf8-string - Exposed-Modules: Text.I18n, Text.I18n.Po, Text.I18n.Printf +Source-repository head + type: git + location: https://github.com/filib/i18n + +library + hs-source-dirs: src + exposed-modules: Data.Text.I18n + , Data.Text.I18n.Po + , Data.Text.I18n.Types + build-depends: base >= 4.7 && < 5 + , containers >= 0.5.6.2 + , filepath >= 1.4.0.0 + , directory >= 1.2.0.0 + , parsec >= 3.1.9 + , mtl >= 2.2.1 + , text >= 1.2.1.3 + , transformers >= 0.4.2.0 + default-language: Haskell2010 + +test-suite i18n-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , containers + , hspec + , i18n + , tasty + , tasty-hspec + , text + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + default-language: Haskell2010 diff --git a/src/Data/Text/I18n.hs b/src/Data/Text/I18n.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/I18n.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | +-- Module: Data.Text.I18n +-- Copyright: (c) 2011-2016 Eugene Grigoriev +-- License: BSD3 +-- Maintainer: Philip Cunningham +-- Stability: experimental +-- Portability: portable +-- +-- Internationalisation support for Haskell. + +module Data.Text.I18n ( + -- * Internationalisation Monad Functions + gettext, + localize, + withContext, + withLocale, + -- * Re-exports + module Data.Text.I18n.Types, + ) where + +import Control.Monad.Identity +import Control.Monad.Reader +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Text as T +import Data.Text.I18n.Types + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import qualified Data.Text.I18n as I18n +-- >>> import qualified Data.Text.I18n.Po as I18n +-- >>> let example = I18n.gettext "Like tears in rain." +-- >>> (l10n, _) <- I18n.getL10n "./test/locale" +-- +-- | The heart of I18n monad. +gettext :: T.Text -> I18n T.Text +gettext msgid = do + (loc, l10n, ctxt) <- ask + case localizeMsgid l10n loc ctxt (Msgid msgid) of + Just msgstr -> return msgstr + Nothing -> + case ctxt of + Just _ -> withContext Nothing (gettext msgid) + Nothing -> return msgid + +-- | Top level localization function. +-- +-- Examples: +-- +-- >>> I18n.localize l10n (I18n.Locale "cym") example +-- "Fel dagrau yn y glaw." +-- +-- When the translation doesn't exist: +-- +-- >>> I18n.localize l10n (I18n.Locale "ru") example +-- "Like tears in rain." +localize :: L10n -- ^ Structure containing localization data + -> Locale -- ^ Locale to use + -> I18n a -- ^ Inernationalized expression + -> a -- ^ Localized expression +localize l10n loc expression = runIdentity $ runReaderT expression (loc, l10n, Nothing) + +-- | Sets a local 'Context' for an internationalized expression. If there is no translation, then no +-- context version is tried. +-- +-- Examples: +-- +-- >>> let example2 = I18n.withContext (Just "Attack ships on fire off the shoulder of Orion.") example +-- >>> I18n.localize l10n (I18n.Locale "cym") example2 +-- "Fel dagrau yn y glaw." +withContext :: Maybe Context -- ^ Context to use + -> I18n a -- ^ Internationalized expression + -> I18n a -- ^ New internationalized expression +withContext ctxt expression = do + (lang, l10n, _) <- ask + local (const (lang, l10n, ctxt)) expression + +-- | Sets a local 'Locale' for an internationalized expression. +-- +-- Examples: +-- +-- >>> let example3 = I18n.withLocale (I18n.Locale "en") example +-- >>> I18n.localize l10n (I18n.Locale "cym") example3 +-- "Like tears in rain." +withLocale :: Locale -- ^ Locale to use + -> I18n a -- ^ Internationalized expression + -> I18n a -- ^ New internationalized expression. +withLocale loc expression = do + (_, l10n, ctxt) <- ask + local (const (loc, l10n, ctxt)) expression + +-- | Internal lookup function. +localizeMsgid :: L10n -> Locale -> Maybe Context -> Msgid -> Maybe T.Text +localizeMsgid l10n loc ctxt msgid = do + local' <- Map.lookup loc l10n + contextual <- Map.lookup ctxt local' + msgstrs <- Map.lookup msgid contextual + case listToMaybe msgstrs of + Nothing -> Nothing + Just "" -> Nothing + Just msgstr -> Just msgstr diff --git a/src/Data/Text/I18n/Po.hs b/src/Data/Text/I18n/Po.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/I18n/Po.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: Data.Text.I18n.Po +-- Copyright: (c) 2011-2016 Eugene Grigoriev +-- License: BSD3 +-- Maintainer: Philip Cunningham +-- Stability: experimental +-- Portability: portable +-- +-- This module contains the PO parser. PO files are assumed to be in UTF-8 +-- encoding. Plural forms are not yet implemented. + +module Data.Text.I18n.Po ( + -- * PO parsing + getL10n, + -- * I18n Monad Functions + localize, + gettext, + withContext, + withLocale, + -- * Parsing functions + parsePo, + ) where + +import Control.Applicative ((<$>)) +import Control.Arrow (second, (&&&)) +import Data.Either (partitionEithers) +import Data.Functor.Identity (Identity) +import Data.List (foldl', intercalate, isSuffixOf) +import qualified Data.Map as Map +import Data.Monoid (mconcat, mempty) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import System.Directory (getDirectoryContents) +import System.FilePath (pathSeparator) +import Text.Parsec +import Text.Parsec.Text +import Text.ParserCombinators.Parsec.Language +import qualified Text.ParserCombinators.Parsec.Token as P + +import Data.Text.I18n + +-- External functions + +-- | Builds 'L10n' structure by parsing / .po / files contained in a given +-- directory. 'L10n' structure is to be passed to 'localize' function. 'L10n' +-- structure is used internaly by the 'I18n' monad. +getL10n :: FilePath + -- ^ Directory containing PO files. + -> IO (L10n, [ParseError]) + -- ^ Localization structure and a list of parse errors. +getL10n dir = do + poFiles' <- poFiles dir + locs <- processPos (map (second parsePo) poFiles') + (es, locs') <- return $! partitionEithers locs + return (Map.fromList locs', es) + +-- Internal Fuctions + +processPos :: [(Locale, IO (Either ParseError [MsgDec]))] + -> IO [Either ParseError (Locale, CtxMap)] +processPos rs = do + rs' <- mapM (\(a, m) -> m >>= \b -> return (a, b)) rs + return $! map f rs' + + where + f :: (a, Either b [MsgDec]) -> Either b (a, CtxMap) + f (l, Right msgdecs) = Right (l, mkMsgs msgdecs) + f (_, Left e) = Left e + +mkMsgs :: [MsgDec] -> CtxMap +mkMsgs = foldl' f mempty + where + f :: CtxMap -> MsgDec -> CtxMap + f m (MsgDec ctxt msgid' msgstrs) = + case Map.lookup ctxt m of + Nothing -> f (Map.insert ctxt mempty m) (MsgDec ctxt msgid' msgstrs) + Just c -> Map.insert ctxt (Map.insert msgid' msgstrs c) m + +-- | Finds all .po files for a given directory. Works on the assumption that the characters before +-- the file extension are the locale name. +poFiles :: FilePath -> IO [(Locale, FilePath)] +poFiles dir = do + files <- getDirectoryContents dir + return $! fmap assocLocalesAndPaths <$> onlyPoFiles $ files + + where + toAbsolutePath :: FilePath -> FilePath + toAbsolutePath = intercalate [pathSeparator] . (dir :) . return + + isPoFile :: FilePath -> Bool + isPoFile = flip any [".po", ".Po", ".PO"] . flip isSuffixOf + + onlyPoFiles :: [FilePath] -> [FilePath] + onlyPoFiles = filter isPoFile + + assocLocalesAndPaths :: FilePath -> (Locale, FilePath) + assocLocalesAndPaths = stripLocale &&& toAbsolutePath + + stripLocale :: FilePath -> Locale + stripLocale path = + let n = subtract 3 . length $ path + in Locale . T.pack $! take n path + +parsePo :: FilePath -> IO (Either ParseError [MsgDec]) +parsePo path = do + contents <- T.readFile path + return $! parse po path contents + +{- EBNF + PO ::= msg* + msg ::= [msg-context] (msg-singular | msg-plural) + msg-context ::= "msgctxt" string* + msg-singular ::= msgid msgstr + msg-plural ::= msgid msgid-plural msgstr-plural* + msgid ::= "msgid" string* + msgid-plural ::= "msgid_plural" string* + msgstr ::= "msgstr" string* + msgstr-plural ::= "msgstr" form string* + form ::= "[" number "]" + number ::= (0-9)* | "N" + string ::= "\"" (char | escaped-char)* "\"" + escaped-char ::= "\\" char + char ::= (any UTF8 character) +-} +lexer :: P.GenTokenParser T.Text () Identity +lexer = P.makeTokenParser poLangDef + where + poLangDef :: GenLanguageDef T.Text st Identity + poLangDef = LanguageDef + { commentStart = "" + , commentEnd = "" + , commentLine = "#" + , nestedComments = True + , identStart = letter <|> char '_' + , identLetter = alphaNum <|> oneOf "_'" + , opStart = opLetter poLangDef + , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" + , reservedOpNames = [] + , reservedNames = ["msgctxt", "msgid", "msgid_plural", "msgstr"] + , caseSensitive = True + } + +whiteSpace :: Parser () +whiteSpace = P.whiteSpace lexer + +lexeme :: Parser a -> Parser a +lexeme = P.lexeme lexer + +reserved :: String -> Parser () +reserved = P.reserved lexer + +po :: Parser [MsgDec] +po = do + _ <- whiteSpace + msgs <- many msg + _ <- eof + return $! msgs + +msg :: Parser MsgDec +msg = do + ctxt <- msgContext + (id', strs) <- try msgSingular <|> msgPlural + return $! MsgDec ctxt id' strs + +msgContext :: Parser (Maybe Context) +msgContext = try $ option Nothing $ do + _ <- lexeme (reserved "msgctxt") + strs <- many1 str + return (Just $! mconcat strs) + +msgSingular :: Parser (Msgid, [Msgstr]) +msgSingular = do + id' <- lexeme msgid + str' <- lexeme msgstr + return (Msgid id', [str']) + +msgPlural :: Parser (Msgid, [Msgstr]) +msgPlural = do + id' <- lexeme msgid + _ <- lexeme msgidPlural + strps <- lexeme (many1 msgstrPlural) + return (Msgid id', strps) + +msgid :: Parser T.Text +msgid = do + _ <- lexeme (reserved "msgid") + strs <- many1 str + return $! mconcat strs + +msgidPlural :: Parser Msgstr +msgidPlural = do + _ <- lexeme (reserved "msgid_plural") + strs <- many1 str + return $! mconcat strs + +msgstr :: Parser Msgstr +msgstr = do + _ <- lexeme (reserved "msgstr") + strs <- many1 str + return $! mconcat strs + +msgstrPlural :: Parser Msgstr +msgstrPlural = do + _ <- lexeme (reserved "msgstr") + _ <- char '[' + _ <- try indice + _ <- char ']' + _ <- whiteSpace + strs <- many1 str + return $! mconcat strs + + where + caseN :: Parser String + caseN = do + c <- oneOf ['n', 'N'] + return [c] + + caseX :: Parser String + caseX = many1 $ oneOf ['0' .. '9'] + + indice :: Parser String + indice = caseN <|> caseX + +str :: Parser T.Text +str = lexeme $ do + _ <- char '"' + chs <- many char' + _ <- char '"' + return $! T.pack chs + +char' :: Parser Char +char' = try escapedChar <|> noneOf ['"'] + +escapedChar :: Parser Char +escapedChar = do + e <- char '\\' + c <- anyChar + case reads ['\'', e, c, '\''] :: [(Char, String)] of + [(c', _)] -> return $! c' + _ -> return $! c diff --git a/src/Data/Text/I18n/Types.hs b/src/Data/Text/I18n/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/I18n/Types.hs @@ -0,0 +1,62 @@ +-- | +-- Module: Data.Text.I18n.Po +-- Copyright: (c) 2011-2016 Eugene Grigoriev +-- License: BSD3 +-- Maintainer: Philip Cunningham +-- Stability: experimental +-- Portability: portable +-- +-- Internationalisation support for Haskell. + +module Data.Text.I18n.Types ( + -- * Type Declarations + Context, + CtxMap, + I18n, + L10n, + Locale(..), + MsgDec(..), + Msgid(..), + Msgstr, + ) where + +import Control.Monad.Identity (Identity) +import Control.Monad.Reader (ReaderT) +import qualified Data.Map.Strict as Map +import qualified Data.Text as T + +-- $setup +-- >>> :set -XOverloadedStrings +-- +-- | Local context. +type Context = T.Text + +-- | Mapping from a contexts to translation mappings. +type CtxMap = Map.Map (Maybe Context) TranslationMap + +-- | The Internationalization monad built using monad transformers. +type I18n a = ReaderT (Locale, L10n, Maybe Context) Identity a + +-- | The Localization structure. +type L10n = Map.Map Locale (Map.Map (Maybe Context) (Map.Map Msgid [Msgstr])) + +-- | Textual representation of a locale e.g. +-- >>> Locale "en_GB" +-- ... +newtype Locale = Locale T.Text + deriving (Show, Eq, Ord) + +-- | Message delcaration. +data MsgDec = MsgDec (Maybe Context) Msgid [Msgstr] + +-- | Untranslated string. +-- >>> Msgid "hello there" +-- ... +newtype Msgid = Msgid T.Text + deriving (Show, Eq, Ord) + +-- | Translated string. +type Msgstr = T.Text + +-- | Mapping from identifiers to translations. +type TranslationMap = Map.Map Msgid [Msgstr] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Data.Text.I18n +import Data.Text.I18n.Po +import Test.Tasty +import Test.Tasty.Hspec + +main :: IO () +main = do + a <- testSpec "Library Specs" librarySpecs + defaultMain (tests $ testGroup "All specs" [a]) + +tests :: TestTree -> TestTree +tests specs = testGroup "i18n Tests" [specs] + +librarySpecs :: Spec +librarySpecs = describe "localize" $ do + let localeDir = "test/locale" + + context "when the translation does not exist" $ do + it "should return the original" $ do + (l10n, _) <- getL10n localeDir + let subject = localize l10n (Locale "fr") (gettext "Like tears in rain.") + let result = "Like tears in rain." + subject `shouldBe` result + + it "should return the original" $ do + (l10n, _) <- getL10n localeDir + let subject = localize l10n (Locale "en") (gettext "Like tears in rain.") + let result = "Like tears in rain." + subject `shouldBe` result + + context "when the translation does exist" $ do + it "should return the translation" $ do + (l10n, _) <- getL10n localeDir + let subject = localize l10n (Locale "cym") (gettext "Like tears in rain.") + let result = "Fel dagrau yn y glaw." + subject `shouldBe` result + + context "but it is an empty string" $ do + it "should return the original" $ do + (l10n, _) <- getL10n localeDir + let subject = localize l10n (Locale "fr") (gettext "Like tears in rain.") + let result = "Like tears in rain." + subject `shouldBe` result