diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,5 @@ +i18n is written by Eugene Grigoriev. + +Permission is hereby granted, free of charge, to any person obtaining this work (the "i18n" haskell module), to deal in the Work without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Work, and to permit persons to whom the Work is furnished to do so. + +THE WORK IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE WORK OR THE USE OR OTHER DEALINGS IN THE WORK. 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/I18n.hs b/Text/I18n.hs new file mode 100644 --- /dev/null +++ b/Text/I18n.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Text.I18n +-- Copyright : (c) Eugene Grigoriev, 2008 +-- License : BSD-style +-- +-- Maintainer : eugene.grigoriev@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Internationalization support for Haskell based on GNU gettext +-- (). +-- Use Text.I18n.Po module. +-- +-- Plural forms are not yet implemented. +-- +----------------------------------------------------------------------------- +module Text.I18n ( + -- * Type Declarations + Msgid(..), Msgstr, L10nMode(..), Locale(..), Context, I18n, L10n, + -- * Internationalization Monad Functions + gettext, localize, withContext, withLocale, localize' + ) where + +import Control.Monad.Reader +import Control.Monad.Trans +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) + +-- | Localization mode. 'L10nMust' will throw an exception if unable to +-- translate whereas 'L10nMay' will just return the original 'Msgid' String. +-- 'L10nMay' is used by 'localize'. +data L10nMode = L10nMust | L10nMay + +type Context = String + +-- | The Internationalization monad allows the use of IO through 'liftIO'. +type I18n a = ReaderT (Locale, L10n, L10nMode, Maybe Context) IO 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 qualified System.IO.UTF8 as Utf8 + > + > main = do + > (l10n,errors) <- getL10n "dir/to/po" + > localize l10n (Locale "en") impl +-} +localize :: L10n -- ^ Structure containing localization data + -> Locale -- ^ Locale to use + -> I18n a -- ^ Inernationalized action + -> IO a -- ^ Localized action +localize = flip localize' L10nMay + +{-| + The top level localization function with a mode parameter. + + > main2 = localize' (Text.I18n.Po.getL10n "dir/to/po") + > L10nMust + > (Locale "en") + > impl +-} +localize' :: L10n -- ^ Structure containing localization data + -> L10nMode -- ^ Localization mode + -> Locale -- ^ Locale to use + -> I18n a -- ^ Inernationalized action + -> IO a -- ^ Localized action +localize' l10n mode loc action = runReaderT action (loc,l10n,mode,Nothing) + +{-| + The heart of I18n monad. Based on 'Text.Printf.printf'. + + > impl = do + > hello <- gettext "Hello, %s!" + > liftIO (Utf8.putStrLn (hello "Joe")) +-} +gettext :: PrintfType a => String -> I18n a +gettext msgid = do + (loc, l10n, mode, 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 -> case mode of + L10nMay -> return (printf msgid) + L10nMust -> fail + ("Undefined localization: " ++ + show ((Msgid msgid),loc) ) + +{-| + Sets a local 'Context' for an internationalized action. + If there is no translation, then no context version is tried. + + > impl2 = withContext (Just "test") impl +-} +withContext :: Maybe Context -- ^ Context to use + -> I18n a -- ^ Internationalized action + -> I18n a -- ^ New internationalized action +withContext ctxt action = do + (lang, l10n, mode, _) <- ask + local (const (lang, l10n, mode, ctxt)) + action + +{-| + Sets a local 'Locale' for an internationalized action. + + > impl3 = withLocale (Locale "ru") impl2 +-} +withLocale :: Locale -- ^ Locale to use + -> I18n a -- ^ Internationalized action + -> I18n a -- ^ New internationalized action. + -- Note: while this action is localy localized already, it is to be a part + -- of another internationalized action. + -- Therefore the final type is internationalized. +withLocale loc action = do + (_, l10n, mode, ctxt) <- ask + local (const (loc, l10n, mode, ctxt)) + action + +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 new file mode 100644 --- /dev/null +++ b/Text/I18n/Po.hs @@ -0,0 +1,186 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.I18n.Po +-- Copyright : (c) Eugene Grigoriev, 2008 +-- License : BSD-style +-- +-- Maintainer : eugene.grigoriev@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Internationalization support for Haskell based on GNU gettext +-- (). This module contains +-- PO parser. PO files are assumed to be in UTF-8 encoding. +-- +-- Plural forms are not yet implemented. +-- +-- Text.I18n and Control.Monad.Trans are exported for convenience. +-- +-- Use System.IO.UTF8 whenever you need to output a localized string. +-- +----------------------------------------------------------------------------- +module Text.I18n.Po ( + -- * Type Declarations + Msgid(..), Msgstr, L10nMode(..), Locale(..), Context, I18n, L10n, + -- * PO parsing + getL10n, + -- * I18n Monad Functions + localize, gettext, withContext, withLocale, localize', + 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 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 new file mode 100644 --- /dev/null +++ b/Text/I18n/Printf.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- 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 + +#ifndef __NHC__ +instance PrintfArg Word where + toUPrintf = uInteger +#endif + +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 new file mode 100644 --- /dev/null +++ b/i18n.cabal @@ -0,0 +1,17 @@ +Name: i18n +Version: 0.1 +Cabal-Version: >= 1.2 +Synopsis: Internationalization for Haskell +Category: Text +License: GPL +License-file: LICENSE +Copyright: (c) 2008 Eugene Grigoriev +Author: "Eugene Grigoriev" +Maintainer: "Eugene Grigoriev" +Stability: experimential +Description: Internationalization for Haskell based on GNU gettext. + +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