diff --git a/Data/Gettext.hs b/Data/Gettext.hs --- a/Data/Gettext.hs +++ b/Data/Gettext.hs @@ -1,13 +1,39 @@ {-# LANGUAGE RecordWildCards, OverloadedStrings #-} - +-- | This is the main module of @haskell-gettext@ package. +-- For most cases, it is enough to import only this module. +-- Other modules of the package might be useful for other libraries +-- working with gettext's files. +-- +-- Simple example of usage of this module is: +-- +-- @ +-- {-\# LANGUAGE OverloadedStrings #\-} +-- module Main where +-- +-- import qualified Data.Text.Lazy as T +-- import qualified Text.Lazy.IO as TLIO +-- import Text.Printf +-- +-- import Data.Gettext +-- +-- main :: IO () +-- main = do +-- catalog <- loadCatalog "locale\/ru\/messages.mo" +-- TLIO.putStrLn $ gettext catalog "Simple translated message" +-- let n = 78 +-- let template = ngettext catalog "There is %d file" "There are %d files" n +-- printf (T.unpack template) n +-- @ +-- module Data.Gettext ( -- * Data structures - GmoFile (..), Catalog, -- * Loading and using translations loadCatalog, lookup, - gettext, ngettext, ngettext', + gettext, cgettext, + ngettext, cngettext, + ngettext', assocs, -- * Utilities for plural forms getHeaders, @@ -19,42 +45,19 @@ ) where import Prelude hiding (lookup) -import Control.Monad -import Data.Either import Data.Binary import Data.Binary.Get import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.Text.Lazy as T -import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy.Encoding as TLE import qualified Data.Trie as Trie -import Data.Word import Text.Printf +import Data.Gettext.GmoFile import Data.Gettext.Plural import Data.Gettext.Parsers --- import Debug.Trace - --- | This structure describes the binary structure of Gettext @.mo/.gmo@ file. -data GmoFile = GmoFile { - fMagic :: Word32 -- ^ Magic number (must be @0x950412de@ or @0xde120495@) - , fRevision :: Word32 -- ^ File revision - , fSize :: Word32 -- ^ Number of text pairs in the file - , fOriginalOffset :: Word32 -- ^ Offset of original strings - , fTranslationOffset :: Word32 -- ^ Offset of translations - , fHashtableSize :: Word32 -- ^ Size of hash table - , fHashtableOffset :: Word32 -- ^ Offset of hash table - , fOriginals :: [(Word32, Word32)] -- ^ Original strings - sizes and offsets - , fTranslations :: [(Word32, Word32)] -- ^ Translations - sizes and offsets - , fData :: L.ByteString -- ^ All file data - used to access strings by offsets - } - deriving (Eq) - -instance Show GmoFile where - show f = printf "" (fSize f) - -- | This structure describes data in Gettext's @.mo/.gmo@ file in ready-to-use format. data Catalog = Catalog { gmoSize :: Word32, @@ -64,25 +67,6 @@ instance Show Catalog where show gmo = printf "" (gmoSize gmo) --- | Prepare the data parsed from file for lookups. -unpackGmoFile :: GmoFile -> Catalog -unpackGmoFile (GmoFile {..}) = Catalog fSize choose trie - where - getOrig (len,offs) = L.take (fromIntegral len) $ L.drop (fromIntegral offs) fData - - choose = choosePluralForm' trie - - getTrans (len,offs) = - let bstr = getOrig (len,offs) - in if L.null bstr - then [T.empty] - else map TLE.decodeUtf8 $ L.split 0 bstr - - originals = map L.toStrict $ map getOrig fOriginals - translations = map getTrans fTranslations - - trie = Trie.fromList $ zip originals translations - -- | Load gettext file loadCatalog :: FilePath -> IO Catalog loadCatalog path = do @@ -90,7 +74,6 @@ let gmoFile = (runGet parseGmo content) {fData = content} return $ unpackGmoFile gmoFile - -- | Look up for string translation lookup :: B.ByteString -> Catalog -> Maybe [T.Text] lookup key gmo = Trie.lookup key (gmoData gmo) @@ -122,29 +105,50 @@ -- | Translate a string. -- Original message must be defined in @po@ file in @msgid@ line. -gettext :: Catalog -> B.ByteString -> T.Text +gettext :: Catalog + -> B.ByteString -- ^ Original string + -> T.Text gettext gmo key = case lookup key gmo of Nothing -> TLE.decodeUtf8 $ L.fromStrict key Just texts -> head texts +-- | Translate a string within specific context. +cgettext :: Catalog + -> B.ByteString -- ^ Message context (@msgctxt@ line in @po@ file) + -> B.ByteString -- ^ Original string + -> T.Text +cgettext gmo context key = gettext gmo (context `B.append` "\4" `B.append` key) + -- | Translate a string and select correct plural form. -- Original single form must be defined in @po@ file in @msgid@ line. -- Original plural form must be defined in @po@ file in @msgid_plural@ line. ngettext :: Catalog + -> B.ByteString -- ^ Single form in original language + -> B.ByteString -- ^ Plural form in original language -> Int -- ^ Number + -> T.Text +ngettext gmo single plural n = ngettext' gmo (single `B.append` "\0" `B.append` plural) n + +-- | Translate a string and select correct plural form, within specific context +-- Original single form must be defined in @po@ file in @msgid@ line. +-- Original plural form must be defined in @po@ file in @msgid_plural@ line. +cngettext :: Catalog + -> B.ByteString -- ^ Message context (@msgctxt@ line in @po@ file) -> B.ByteString -- ^ Single form in original language -> B.ByteString -- ^ Plural form in original language + -> Int -- ^ Number -> T.Text -ngettext gmo n single plural = ngettext' gmo n $ single `B.append` "\0" `B.append` plural +cngettext gmo context single plural n = + ngettext' gmo (context `B.append` "\4" `B.append` single `B.append` "\0" `B.append` plural) n -- | Variant of @ngettext@ for case when for some reason there is only -- @msgid@ defined in @po@ file, and no @msgid_plural@, but there are some @msgstr[n]@. ngettext' :: Catalog - -> Int -- ^ Number -> B.ByteString -- ^ Single form in original language + -> Int -- ^ Number -> T.Text -ngettext' gmo n key = +ngettext' gmo key n = case lookup key gmo of Nothing -> TLE.decodeUtf8 $ L.fromStrict key Just texts -> @@ -165,45 +169,22 @@ Nothing -> if n == 1 then 0 else 1 -- from GNU gettext implementation, known as 'germanic plural form' Just (_, expr) -> eval expr n --- | Data.Binary parser for GmoFile structure -parseGmo :: Get GmoFile -parseGmo = do - magic <- getWord32host - getWord32 <- case magic of - 0x950412de -> return getWord32le - 0xde120495 -> return getWord32be - _ -> fail "Invalid magic number" - - let getPair :: Get (Word32, Word32) - getPair = do - x <- getWord32 - y <- getWord32 - return (x,y) +-- | Prepare the data parsed from file for lookups. +unpackGmoFile :: GmoFile -> Catalog +unpackGmoFile (GmoFile {..}) = Catalog fSize choose trie + where + getOrig (len,offs) = L.take (fromIntegral len) $ L.drop (fromIntegral offs) fData - revision <- getWord32 - size <- getWord32 - origOffs <- getWord32 - transOffs <- getWord32 - hashSz <- getWord32 - hashOffs <- getWord32 - origs <- replicateM (fromIntegral size) getPair - trans <- replicateM (fromIntegral size) getPair - return $ GmoFile { - fMagic = magic, - fRevision = revision, - fSize = size, - fOriginalOffset = origOffs, - fTranslationOffset = transOffs, - fHashtableSize = hashSz, - fHashtableOffset = hashOffs, - fOriginals = origs, - fTranslations = trans, - fData = undefined } + choose = choosePluralForm' trie + + getTrans (len,offs) = + let bstr = getOrig (len,offs) + in if L.null bstr + then [T.empty] + else map TLE.decodeUtf8 $ L.split 0 bstr -withGmoFile :: FilePath -> (GmoFile -> IO a) -> IO a -withGmoFile path go = do - content <- L.readFile path - let gmo = (runGet parseGmo content) {fData = content} - result <- go gmo - return result + originals = map L.toStrict $ map getOrig fOriginals + translations = map getTrans fTranslations + + trie = Trie.fromList $ zip originals translations diff --git a/Data/Gettext/GmoFile.hs b/Data/Gettext/GmoFile.hs new file mode 100644 --- /dev/null +++ b/Data/Gettext/GmoFile.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE RecordWildCards, OverloadedStrings #-} + +module Data.Gettext.GmoFile + ( -- * Data structures + GmoFile (..), + -- * Parsing + parseGmo + ) where + +import Control.Monad +import Data.Binary +import Data.Binary.Get +import qualified Data.ByteString.Lazy as L +import Text.Printf + +-- | This structure describes the binary structure of Gettext @.mo/.gmo@ file. +data GmoFile = GmoFile { + fMagic :: Word32 -- ^ Magic number (must be @0x950412de@ or @0xde120495@) + , fRevision :: Word32 -- ^ File revision + , fSize :: Word32 -- ^ Number of text pairs in the file + , fOriginalOffset :: Word32 -- ^ Offset of original strings + , fTranslationOffset :: Word32 -- ^ Offset of translations + , fHashtableSize :: Word32 -- ^ Size of hash table + , fHashtableOffset :: Word32 -- ^ Offset of hash table + , fOriginals :: [(Word32, Word32)] -- ^ Original strings - sizes and offsets + , fTranslations :: [(Word32, Word32)] -- ^ Translations - sizes and offsets + , fData :: L.ByteString -- ^ All file data - used to access strings by offsets + } + deriving (Eq) + +instance Show GmoFile where + show f = printf "" (fSize f) + +-- | Data.Binary parser for GmoFile structure +parseGmo :: Get GmoFile +parseGmo = do + magic <- getWord32host + getWord32 <- case magic of + 0x950412de -> return getWord32le + 0xde120495 -> return getWord32be + _ -> fail "Invalid magic number" + + let getPair :: Get (Word32, Word32) + getPair = do + x <- getWord32 + y <- getWord32 + return (x,y) + + revision <- getWord32 + size <- getWord32 + origOffs <- getWord32 + transOffs <- getWord32 + hashSz <- getWord32 + hashOffs <- getWord32 + origs <- replicateM (fromIntegral size) getPair + trans <- replicateM (fromIntegral size) getPair + return $ GmoFile { + fMagic = magic, + fRevision = revision, + fSize = size, + fOriginalOffset = origOffs, + fTranslationOffset = transOffs, + fHashtableSize = hashSz, + fHashtableOffset = hashOffs, + fOriginals = origs, + fTranslations = trans, + fData = undefined } + +withGmoFile :: FilePath -> (GmoFile -> IO a) -> IO a +withGmoFile path go = do + content <- L.readFile path + let gmo = (runGet parseGmo content) {fData = content} + result <- go gmo + return result + diff --git a/Data/Gettext/Parsers.hs b/Data/Gettext/Parsers.hs new file mode 100644 --- /dev/null +++ b/Data/Gettext/Parsers.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | This module contains parsers for: +-- +-- * Catalog headers (@Name: Value@ lines, that are specified as translation for empty string in @po@ file); +-- * Plural form selection expressions (specified in @Plural-Forms@ header). +-- +-- These parsers are already used by main module; but they can be useful for other libraries working with +-- gettext's files. +-- +module Data.Gettext.Parsers + ( -- * Types + Header, Headers, + -- * Parsing functions + parseHeaders, + parsePlural, + -- * Parsec parsers + pHeaders, + pExpr, + pPlural + ) where + +import Control.Monad +import Control.Monad.Identity +import qualified Data.Text.Lazy as T +import Text.Parsec +import Text.Parsec.Text.Lazy +import Text.Parsec.Language +import qualified Text.Parsec.Token as Token +import Text.Parsec.Expr + +import Data.Gettext.Plural + +-- | Catalog header, i.e. one @Name: Value@ line in @po@ file +type Header = (T.Text, T.Text) +-- | List of catalog headers +type Headers = [Header] + +pHeader :: Parser Header +pHeader = do + name <- (many1 $ alphaNum <|> char '-') "Header name" + char ':' + many $ oneOf " \t" + value <- many $ noneOf "\r\n" + return (T.pack name, T.pack value) + +-- | Parsec parser for catalog headers +pHeaders :: Parser Headers +pHeaders = pHeader `sepEndBy` newline + +-- | Parse catalog headers. +-- NB: for now this function does not use Parsec. +parseHeaders :: T.Text -> Either String Headers +parseHeaders t = do + let lines = filter (not . T.null) $ T.splitOn "\n" t + forM lines $ \line -> + case T.splitOn ": " line of + [name, value] -> return (name, value) + (name:values) -> return (name, T.intercalate ": " values) + _ -> Left $ "Invalid gettext file header: " ++ T.unpack line + +pSimpleExpr :: Parser Expr +pSimpleExpr = buildExpressionParser table term "simple expression" + where + term = parens pExpr <|> (symbol "n" >> return N) <|> (Literal `fmap` natural) + + table = + [ [prefix "-" Negate, prefix "!" Not], + [binary "*" Multiply AssocLeft, binary "/" Divide AssocLeft, binary "%" Mod AssocLeft], + [binary "+" Plus AssocLeft, binary "-" Minus AssocLeft], + [binary "==" Equals AssocLeft, binary "!=" NotEquals AssocLeft, + binary ">" Greater AssocLeft, binary "<=" NotGreater AssocLeft, + binary "<" Less AssocLeft, binary ">=" NotLess AssocLeft], + [binary "&&" And AssocLeft, binary "||" Or AssocLeft, binary "^" Xor AssocLeft] + ] + + binary name fun assoc = Infix (do{ reservedOp name; return (Binary fun) }) assoc + prefix name fun = Prefix (do{ reservedOp name; return fun }) + -- postfix name fun = Postfix (do{ reservedOp name; return fun }) + +-- | Parse plural form selection expression. +-- Note: this parses only part which goes after @plural=@. +pExpr :: Parser Expr +pExpr = do + expr <- pSimpleExpr + mbCont <- optionMaybe pTernary + case mbCont of + Nothing -> return expr + Just (true, false) -> return $ If expr true false + +pTernary :: Parser (Expr, Expr) +pTernary = do + reservedOp "?" + true <- pExpr + colon + false <- pExpr + return (true, false) + +-- | Parse plural form selection definition. +-- This parses the whole value of @Plural-Forms@ header, +-- starting from @nplurals=@. +pPlural :: Parser (Int, Expr) +pPlural = do + symbol "nplurals" + reservedOp "=" + n <- natural + semi + symbol "plural" + reservedOp "=" + expr <- pExpr + return (n, expr) + +cStyle :: GenLanguageDef T.Text () Identity +cStyle = Token.LanguageDef + { Token.commentStart = "/*" + , Token.commentEnd = "*/" + , Token.commentLine = "//" + , Token.nestedComments = True + , Token.identStart = letter + , Token.identLetter = alphaNum <|> oneOf "_'" + , Token.opStart = Token.opLetter cStyle + , Token.opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" + , Token.reservedNames = [] + , Token.reservedOpNames= [] + , Token.caseSensitive = True + } + +lexer :: Token.GenTokenParser T.Text () Identity +lexer = Token.makeTokenParser cStyle + +natural :: Parser Int +natural = fromIntegral `fmap` Token.natural lexer + +reservedOp :: String -> Parser () +reservedOp = Token.reservedOp lexer + +symbol :: String -> Parser String +symbol = Token.symbol lexer + +parens :: Parser a -> Parser a +parens = Token.parens lexer + +semi :: Parser String +semi = Token.semi lexer + +colon :: Parser String +colon = Token.colon lexer + +-- | Parse plural form selection definition. +-- Return value is (number of possible plural forms; selection expression). +parsePlural :: Headers -> Either String (Int, Expr) +parsePlural headers = + case lookup (T.pack "Plural-Forms") headers of + Nothing -> Left $ "Plural-Forms header not found: " ++ show headers + Just str -> either (Left . show) Right $ parse pPlural "" str + + diff --git a/Data/Gettext/Plural.hs b/Data/Gettext/Plural.hs new file mode 100644 --- /dev/null +++ b/Data/Gettext/Plural.hs @@ -0,0 +1,80 @@ +-- | This module contains definitions for plural form selection expressions AST, +-- and an evaluator function for such expressions. +-- +module Data.Gettext.Plural + ( + -- * Data types + BinOp (..), Expr (..), + -- * Expressions + eval + ) where + +import Data.Bits (xor) + +-- | Supported binary operations +data BinOp = + Equals + | NotEquals + | Greater + | NotGreater + | Less + | NotLess + | And + | Or + | Xor + | Mod + | Plus + | Minus + | Multiply + | Divide + deriving (Eq, Show) + +-- | Plural form selection expression AST +data Expr = + N -- ^ The @n@ variable + | Literal Int -- ^ Literal number + | If Expr Expr Expr -- ^ Ternary operator (... ? ... : ...) + | Negate Expr -- ^ Unary arithmetic negation (as in @-1@). + | Not Expr -- ^ Unary logic negation (as in @! (n == 1)@) + | Binary BinOp Expr Expr -- ^ Binary operation + deriving (Eq, Show) + +order :: (Int -> Int -> Bool) -> (Int -> Int -> Int) +order op x y = if op x y then 1 else 0 + +logic :: (Bool -> Bool -> Bool) -> (Int -> Int -> Int) +logic op x y = if op (x /= 0) (y /= 0) then 1 else 0 + +evalOp :: BinOp -> (Int -> Int -> Int) +evalOp Equals = order (==) +evalOp NotEquals = order (/=) +evalOp Greater = order (>) +evalOp NotGreater = order (<=) +evalOp Less = order (<) +evalOp NotLess = order (>=) +evalOp And = logic (&&) +evalOp Or = logic (||) +evalOp Xor = logic xor +evalOp Mod = mod +evalOp Plus = (+) +evalOp Minus = (-) +evalOp Multiply = (*) +evalOp Divide = \x y -> + if y == 0 + then error "Division by zero in plural form selection expression" + else x `div` y + +-- | Evaluate the expression +eval :: Expr -- ^ Expression + -> Int -- ^ Number + -> Int -- ^ Plural form index defined by expression +eval N n = n +eval (Literal x) _ = x +eval (If cond true false) n = + if eval cond n /= 0 + then eval true n + else eval false n +eval (Binary op x y) n = + evalOp op (eval x n) (eval y n) +eval (Negate x) n = negate $ eval x n + diff --git a/examples/gmotest.hs b/examples/gmotest.hs --- a/examples/gmotest.hs +++ b/examples/gmotest.hs @@ -15,7 +15,7 @@ [file, ns] <- getArgs let n = read ns catalog <- loadCatalog file - let localizedTemplate = ngettext catalog n "There is %d file" "There are %d files" + let localizedTemplate = ngettext catalog "There is %d file" "There are %d files" n TLIO.putStrLn localizedTemplate printf (T.unpack localizedTemplate) n diff --git a/haskell-gettext.cabal b/haskell-gettext.cabal --- a/haskell-gettext.cabal +++ b/haskell-gettext.cabal @@ -1,5 +1,5 @@ name: haskell-gettext -version: 0.1.0.0 +version: 0.1.1.0 synopsis: GetText runtime library implementation in pure Haskell description: This package is pure Haskell implementation of GetText library runtime. It allows you to: @@ -41,6 +41,9 @@ library exposed-modules: Data.Gettext + Data.Gettext.GmoFile + Data.Gettext.Parsers + Data.Gettext.Plural build-depends: base > 4 && < 5, binary >=0.7, bytestring >=0.10, @@ -51,11 +54,12 @@ mtl >= 2.2.1, transformers >=0.3, parsec >= 3.1.11 + ghc-options: -fwarn-unused-imports executable hgettext main-is: hgettext.hs build-depends: base > 4 && < 5, - haskell-src-exts >= 1.19.1, + haskell-src-exts >= 1.18, uniplate >= 1.6.12, time >= 1.5.0, old-locale >= 1.0,