diff --git a/Data/Gettext.hs b/Data/Gettext.hs new file mode 100644 --- /dev/null +++ b/Data/Gettext.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE RecordWildCards, OverloadedStrings #-} + +module Data.Gettext + ( -- * Data structures + GmoFile (..), + Catalog, + -- * Loading and using translations + loadCatalog, + lookup, + gettext, ngettext, ngettext', + assocs, + -- * Utilities for plural forms + getHeaders, + getPluralDefinition, + choosePluralForm, + -- * Utilities for custom parsers implementation + parseGmo, + unpackGmoFile + ) 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.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, + gmoChoosePlural :: Int -> Int, + gmoData :: Trie.Trie [T.Text] } + +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 + content <- L.readFile path + 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) + +-- | Get all translation pairs +assocs :: Catalog -> [(B.ByteString, [T.Text])] +assocs = Trie.toList . gmoData + +-- | Obtain headers of the catalog. +-- Headers are defined as a translation for empty string. +getHeaders :: Catalog -> Maybe Headers +getHeaders gmo = getHeaders' (gmoData gmo) + +getHeaders' :: Trie.Trie [T.Text] -> Maybe Headers +getHeaders' trie = + case Trie.lookup "" trie of + Nothing -> Nothing + Just texts -> either error Just $ parseHeaders (head texts) + +-- | Get plural forms selection definition. +getPluralDefinition :: Catalog -> Maybe (Int, Expr) +getPluralDefinition gmo = getPluralDefinition' (gmoData gmo) + +getPluralDefinition' :: Trie.Trie [T.Text] -> Maybe (Int, Expr) +getPluralDefinition' trie = + case getHeaders' trie of + Nothing -> Nothing + Just headers -> either error Just $ parsePlural headers + +-- | Translate a string. +-- Original message must be defined in @po@ file in @msgid@ line. +gettext :: Catalog -> B.ByteString -> T.Text +gettext gmo key = + case lookup key gmo of + Nothing -> TLE.decodeUtf8 $ L.fromStrict key + Just texts -> head texts + +-- | 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 + -> Int -- ^ Number + -> B.ByteString -- ^ Single form in original language + -> B.ByteString -- ^ Plural form in original language + -> T.Text +ngettext gmo n single plural = ngettext' gmo n $ single `B.append` "\0" `B.append` plural + +-- | 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 + -> T.Text +ngettext' gmo n key = + case lookup key gmo of + Nothing -> TLE.decodeUtf8 $ L.fromStrict key + Just texts -> + let plural = choosePluralForm gmo n + idx = if plural >= length texts + then 0 -- if there are not enough plural forms defined, always use the first, + -- it is probably the most correct + else plural + in texts !! idx + +-- | Choose plural form index by number +choosePluralForm :: Catalog -> Int -> Int +choosePluralForm gmo = gmoChoosePlural gmo + +choosePluralForm' :: Trie.Trie [T.Text] -> Int -> Int +choosePluralForm' trie n = + case getPluralDefinition' trie of + 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) + + 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/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,25 @@ +haskell-gettext README +====================== + +This package is pure Haskell implementation of GetText library runtime. +It allows you to: + +* Load GNU Gettext binary catalog files (`.mo`, `.gmo`). +* Execute lookups for messages in catalog (gettext and ngettext functions). + +Support for plural form selection expressions is fully implemented. + +This package is however relatively low-level and may be not very nice to +use in applications. So it can be used as a backend for some more user-friendly +"translation framework". + +This package has the following advantages comparing to hgettext: + +* It is easier to build it on different platforms, since it has no dependency on + C code; +* It does not depend on additional C libraries in runtime; +* And probably the most important: this library does not use global process-level + variables to store "current catalog" (current locale), the catalog should be + specified for each call of translation function. So it can be much simpler to + use this library for example in web applications. + 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/examples/gmodump.hs b/examples/gmodump.hs new file mode 100644 --- /dev/null +++ b/examples/gmodump.hs @@ -0,0 +1,22 @@ + +import Data.Gettext + +import Control.Monad +import qualified Data.Trie as T +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.Text.Lazy.IO as TLIO +import System.Environment + +main = do + [file] <- getArgs + catalog <- loadCatalog file + case getPluralDefinition catalog of + Nothing -> putStrLn "No plural forms selection expression provided." + Just (_,expr) -> putStrLn $ "Plural forms selection: " ++ show expr + forM_ (assocs catalog) $ \(orig,trans) -> do + putStr "Original: " + B8.putStrLn orig + forM_ (zip [0..] trans) $ \(i,tran) -> do + putStr $ "Translation #" ++ show i ++ ": " + TLIO.putStrLn tran diff --git a/examples/gmotest.hs b/examples/gmotest.hs new file mode 100644 --- /dev/null +++ b/examples/gmotest.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Control.Monad +import System.FilePath +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.IO as TLIO +import System.IO +import System.Environment +import Text.Printf + +import Data.Gettext + +main :: IO () +main = do + [file, ns] <- getArgs + let n = read ns + catalog <- loadCatalog file + let localizedTemplate = ngettext catalog n "There is %d file" "There are %d files" + TLIO.putStrLn localizedTemplate + printf (T.unpack localizedTemplate) n + diff --git a/haskell-gettext.cabal b/haskell-gettext.cabal new file mode 100644 --- /dev/null +++ b/haskell-gettext.cabal @@ -0,0 +1,67 @@ +name: haskell-gettext +version: 0.1.0.0 +synopsis: GetText runtime library implementation in pure Haskell +description: This package is pure Haskell implementation of GetText library runtime. + It allows you to: + . + * Load GNU Gettext binary catalog files (`.mo`, `.gmo`). + . + * Execute lookups for messages in catalog (gettext and ngettext functions). + . + Support for plural form selection expressions is fully implemented. + . + This package is however relatively low-level and may be not very nice to + use in applications. So it can be used as a backend for some more user-friendly + \"translation framework\". + . + This package has the following advantages comparing to hgettext: + . + * It is easier to build it on different platforms, since it has no dependency on + C code; + . + * It does not depend on additional C libraries in runtime; + . + * And probably the most important: this library does not use global process-level + variables to store "current catalog" (current locale), the catalog should be + specified for each call of translation function. So it can be much simpler to + use this library for example in web applications. + +license: BSD3 +license-file: LICENSE +author: IlyaPortnov +maintainer: portnov84@rambler.ru +-- copyright: +category: Text +build-type: Simple +cabal-version: >=1.8 + +extra-source-files: README.md + examples/gmodump.hs + examples/gmotest.hs + +library + exposed-modules: Data.Gettext + build-depends: base > 4 && < 5, + binary >=0.7, + bytestring >=0.10, + text >= 1.2, + bytestring-trie >=0.2, + containers >=0.5, + time >=1.4, + mtl >= 2.2.1, + transformers >=0.3, + parsec >= 3.1.11 + +executable hgettext + main-is: hgettext.hs + build-depends: base > 4 && < 5, + haskell-src-exts >= 1.19.1, + uniplate >= 1.6.12, + time >= 1.5.0, + old-locale >= 1.0, + filepath >= 1.4 + +source-repository head + type: git + location: https://github.com/portnov/haskell-gettext.git + diff --git a/hgettext.hs b/hgettext.hs new file mode 100644 --- /dev/null +++ b/hgettext.hs @@ -0,0 +1,112 @@ +-- (C) vasylp https://github.com/vasylp/hgettext/blob/master/src/hgettext.hs + +import qualified Language.Haskell.Exts as H + +import System.Environment +import System.Console.GetOpt +import Data.Time +import System.Locale hiding (defaultTimeLocale) + +import Data.Generics.Uniplate.Data + +-- import Distribution.Simple.PreProcess.Unlit + +import Data.List +import Data.Char +import Data.Ord +import Data.Function (on) +import System.FilePath + +import Data.Version (showVersion) +version = undefined +-- import Paths_haskell_gettext (version) + +data Options = Options { + outputFile :: String, + keywords :: [String], + printVersion :: Bool + } deriving Show + +options :: [OptDescr (Options->Options)] +options = + [ + Option ['o'] ["output"] + (ReqArg (\o opts -> opts {outputFile = o}) "FILE") + "write output to specified file", + Option ['d'] ["default-domain"] + (ReqArg (\d opts -> opts {outputFile = d ++ ".po"}) "NAME") + "use NAME.po instead of messages.po", + Option ['k'] ["keyword"] + (ReqArg (\d opts -> opts {keywords = d: keywords opts}) "WORD") + "function names, in which searched words are wrapped. Can be used multiple times, for multiple funcitons", + Option [] ["version"] + (NoArg (\opts -> opts {printVersion = True})) + "print version of hgettexts" + ] + + +defaultOptions = Options "messages.po" ["__", "lprintf"] False + +parseArgs :: [String] -> IO (Options, [String]) +parseArgs args = + case getOpt Permute options args of + (o, n, []) -> return (foldl (flip id) defaultOptions o, n) + (_, _, errs) -> ioError (userError (concat errs ++ usageInfo header options)) + where header = "Usage: hgettext [OPTION] [INPUTFILE] ..." + + +toTranslate :: [String] -> H.ParseResult (H.Module H.SrcSpanInfo) -> [(H.SrcSpanInfo, String)] +toTranslate f (H.ParseOk z) = nub [ (loc, s) | H.App _ (H.Var _ (H.UnQual _ (H.Ident _ x))) (H.Lit _ (H.String loc s _)) <- universeBi z, x `elem` f] +toTranslate _ _ = [] + +-- Create list of messages from a single file +formatMessages :: String -> [(H.SrcSpanInfo, String)] -> String +formatMessages path l = concat $ map potEntry $ nubBy ((==) `on` snd) $ sortBy (comparing snd) l + where potEntry (l, s) = unlines [ + "#: " ++ showSrc l, + "msgid " ++ (show s), + "msgstr \"\"", + "" + ] + showSrc l = path ++ ":" ++ show (H.srcSpanStartLine (H.srcInfoSpan l)) ++ ":" ++ show (H.srcSpanStartColumn (H.srcInfoSpan l)) + + +formatPotFile :: [String] -> IO String +formatPotFile lines = do + time <- getZonedTime + let timeStr = formatTime defaultTimeLocale "%F %R%z" time + let header = formatPotHeader timeStr + return $ concat $ header: lines + where + formatPotHeader timeStr = + unlines ["# Translation file", + "", + "msgid \"\"", + "msgstr \"\"", + "", + "\"Project-Id-Version: PACKAGE VERSION\\n\"", + "\"Report-Msgid-Bugs-To: \\n\"", + "\"POT-Creation-Date: " ++ timeStr ++ "\\n\"", + "\"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\\n\"", + "\"Last-Translator: FULL NAME \\n\"", + "\"Language-Team: LANGUAGE \\n\"", + "\"MIME-Version: 1.0\\n\"", + "\"Content-Type: text/plain; charset=UTF-8\\n\"", + "\"Content-Transfer-Encoding: 8bit\\n\"", + ""] + +process :: Options -> [String] -> IO () +process Options{printVersion = True} _ = + putStrLn $ "hgettext, version " ++ (showVersion version) + +process opts fl = do + t <- mapM read' fl + pot <- formatPotFile $ map (\(n,c) -> formatMessages n $ toTranslate (keywords opts) c) t + writeFile (outputFile opts) pot + where read' "-" = getContents >>= \c -> return ("-", H.parseFileContents c) + read' f = H.parseFile f >>= \m -> return (f, m) + +main = + getArgs >>= parseArgs >>= uncurry process + +