hgettext-0.1.30/0000755000000000000000000000000012075753663011633 5ustar0000000000000000hgettext-0.1.30/Setup.hs0000644000000000000000000000005712075753663013271 0ustar0000000000000000 import Distribution.Simple main = defaultMain hgettext-0.1.30/hgettext.cabal0000644000000000000000000000216212075753663014454 0ustar0000000000000000Name: hgettext Version: 0.1.30 Cabal-Version: >= 1.6 License: BSD3 Author: Vasyl Pasternak Maintainer: vasyl.pasternak@gmail.com Copyright: 2009 Vasyl Pasternak Category: Text Homepage: https://github.com/vasylp/hgettext Synopsis: Bindings to libintl.h (gettext, bindtextdomain) Build-Type: Simple Library Exposed-Modules: Text.I18N.GetText, Distribution.Simple.I18N.GetText Extensions: ForeignFunctionInterface Hs-Source-Dirs: src Build-Depends: base>=3.0.3.0 && <5, process, directory, filepath, containers, Cabal>=1.10, setlocale Executable hgettext Main-Is: hgettext.hs Extensions: TemplateHaskell Hs-Source-Dirs: src Build-Depends: base>=3.0.3.0 && <5, uniplate, haskell-src-exts Other-Modules: Paths_hgettext hgettext-0.1.30/src/0000755000000000000000000000000012075753663012422 5ustar0000000000000000hgettext-0.1.30/src/hgettext.hs0000644000000000000000000000677412075753663014630 0ustar0000000000000000 import qualified Language.Haskell.Exts as H import System.Environment import System.Console.GetOpt import Data.Generics.Uniplate.Data import Distribution.Simple.PreProcess.Unlit import Data.List import Data.Char import System.FilePath import Paths_hgettext (version) import Data.Version (showVersion) data Options = Options { outputFile :: String, keyword :: 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 {keyword = d}) "WORD") "function name, in which wrapped searched words", Option [] ["version"] (NoArg (\opts -> opts {printVersion = True})) "print version of hgettexts" ] defaultOptions = Options "messages.po" "__" 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 -> [(Int, String)] toTranslate f (H.ParseOk z) = nub [ (0, s) | H.App (H.Var (H.UnQual (H.Ident x))) (H.Lit (H.String s)) <- universeBi z, x == f] toTranslate _ _ = [] -- Create list of messages from a single file formatMessages :: String -> [(Int, String)] -> String formatMessages src l = concat $ map potEntry l where potEntry (l, s) = unlines [ "#: " ++ src ++ ":" ++ (show l), "msgid " ++ (show s), "msgstr \"\"", "" ] writePOTFile :: [String] -> String writePOTFile l = concat $ [potHeader] ++ l where potHeader = unlines ["# Translation file", "", "msgid \"\"", "msgstr \"\"", "", "\"Project-Id-Version: PACKAGE VERSION\\n\"", "\"Report-Msgid-Bugs-To: \\n\"", "\"POT-Creation-Date: 2009-01-13 06:05-0800\\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 writeFile (outputFile opts) $ writePOTFile $ map (\(n,c) -> formatMessages n $ toTranslate (keyword opts) c) t where read' "-" = getContents >>= \c -> return ("-", H.parseFileContents c) read' f = H.parseFile f >>= \m -> return (f, m) main = getArgs >>= parseArgs >>= uncurry process hgettext-0.1.30/src/Distribution/0000755000000000000000000000000012075753663015101 5ustar0000000000000000hgettext-0.1.30/src/Distribution/Simple/0000755000000000000000000000000012075753663016332 5ustar0000000000000000hgettext-0.1.30/src/Distribution/Simple/I18N/0000755000000000000000000000000012075753663017011 5ustar0000000000000000hgettext-0.1.30/src/Distribution/Simple/I18N/GetText.hs0000644000000000000000000001760512075753663020742 0ustar0000000000000000-- | This library extends the Distribution with internationalization support. -- -- It performs two functions: -- -- * compiles and installs PO files to the specified directory -- -- * tells the application where files were installed to make it able -- to bind them to the code -- -- Each PO file will be placed to the -- @{datadir}\/locale\/{loc}\/LC_MESSAGES\/{domain}.mo@ where: -- -- [@datadir@] Usually @prefix/share@ but could be different, depends -- on system. -- -- [@loc@] Locale name (language code, two characters). This module -- supposes, that each PO file has a base name set to the proper -- locale, e.g. @de.po@ is the German translation of the program, so -- this file will be placed under @{datadir}\/locale\/de@ directory -- -- [@domain@] Program domain. A unique identifier of single -- translational unit (program). By default domain will be set to the -- package name, but its name could be configured in the @.cabal@ file. -- -- The module defines following @.cabal@ fields: -- -- [@x-gettext-domain-name@] Name of the domain. One ofmore -- alphanumeric characters separated by hyphens or underlines. When -- not set, package name will be used. -- -- [@x-gettext-po-files@] List of files with translations. Could be -- used a limited form of wildcards, e.g.: @x-gettext-po-files: -- po/*.po@ -- -- [@x-gettext-domain-def@] Name of the macro, in which domain name -- will be passed to the program. Default value is -- @__MESSAGE_CATALOG_DOMAIN__@ -- -- [@x-gettext-msg-cat-def@] Name of the macro, in which path to the -- message catalog will be passed to the program. Default value is -- @__MESSAGE_CATALOG_DIR__@ -- -- The last two parameters are used to send configuration data to the -- code during its compilation. The most common usage example is: -- -- -- > ... -- > prepareI18N = do -- > setLocale LC_ALL (Just "") -- > bindTextDomain __MESSAGE_CATALOG_DOMAIN__ (Just __MESSAGE_CATALOG_DIR__) -- > textDomain __MESSAGE_CATALOG_DOMAIN__ -- > -- > main = do -- > prepareI18N -- > ... -- > -- > ... -- -- -- /NOTE:/ files, passed in the @x-gettext-po-files@ are not -- automatically added to the source distribution, so they should be -- also added to the @extra-source-files@ parameter, along with -- translation template file (usually @message.pot@) -- -- /WARNING:/ sometimes, when only configuration targets changes, code -- will not recompile, thus you should execute @cabal clean@ to -- cleanup the build and restart it again from the configuration. This -- is temporary bug, it will be fixed in next releases. -- module Distribution.Simple.I18N.GetText ( installGetTextHooks, gettextDefaultMain ) where import Distribution.Simple import Distribution.Simple.Setup as S import Distribution.Simple.LocalBuildInfo import Distribution.PackageDescription import Distribution.Simple.Configure import Distribution.Simple.InstallDirs as I import Distribution.Simple.Utils import Language.Haskell.Extension import Control.Monad import Control.Arrow (second) import Data.Maybe (listToMaybe, maybeToList, fromMaybe) import Data.List (unfoldr,nub,null) import System.FilePath import System.Directory import System.Process -- | Default main function, same as -- -- > defaultMainWithHooks $ installGetTextHooks simpleUserHooks -- gettextDefaultMain :: IO () gettextDefaultMain = defaultMainWithHooks $ installGetTextHooks simpleUserHooks -- | Installs hooks, used by GetText module to install -- PO files to the system. Previous won't be disabled -- installGetTextHooks :: UserHooks -- ^ initial user hooks -> UserHooks -- ^ patched user hooks installGetTextHooks uh = uh{ confHook = \a b -> (confHook uh) a b >>= return . updateLocalBuildInfo, postInst = \a b c d -> (postInst uh) a b c d >> installPOFiles a b c d } updateLocalBuildInfo :: LocalBuildInfo -> LocalBuildInfo updateLocalBuildInfo l = let sMap = getCustomFields l [domDef, catDef] = map ($ sMap) [getDomainDefine, getMsgCatalogDefine] dom = getDomainNameDefault sMap (getPackageName l) tar = targetDataDir l [catMS, domMS] = map (uncurry formatMacro) [(domDef, dom), (catDef, tar)] in (appendCPPOptions [domMS,catMS] . appendExtension [EnableExtension CPP]) l installPOFiles :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO () installPOFiles _ _ _ l = let sMap = getCustomFields l destDir = targetDataDir l dom = getDomainNameDefault sMap (getPackageName l) installFile file = do let fname = takeFileName file let bname = takeBaseName fname let targetDir = destDir bname "LC_MESSAGES" -- ensure we have directory destDir/{loc}/LC_MESSAGES createDirectoryIfMissing True targetDir system $ "msgfmt --output-file=" ++ (targetDir dom <.> "mo") ++ " " ++ file in do filelist <- getPoFilesDefault sMap -- copy all whose name is in the form of dir/{loc}.po to the -- destDir/{loc}/LC_MESSAGES/dom.mo -- with the 'msgfmt' tool mapM_ installFile filelist forBuildInfo :: LocalBuildInfo -> (BuildInfo -> BuildInfo) -> LocalBuildInfo forBuildInfo l f = let a = l{localPkgDescr = updPkgDescr (localPkgDescr l)} updPkgDescr x = x{library = updLibrary (library x), executables = updExecs (executables x)} updLibrary Nothing = Nothing updLibrary (Just x) = Just $ x{libBuildInfo = f (libBuildInfo x)} updExecs x = map updExec x updExec x = x{buildInfo = f (buildInfo x)} in a appendExtension :: [Extension] -> LocalBuildInfo -> LocalBuildInfo appendExtension exts l = forBuildInfo l updBuildInfo where updBuildInfo x = x{defaultExtensions = updExts (defaultExtensions x)} updExts s = nub (s ++ exts) appendCPPOptions :: [String] -> LocalBuildInfo -> LocalBuildInfo appendCPPOptions opts l = forBuildInfo l updBuildInfo where updBuildInfo x = x{cppOptions = updOpts (cppOptions x)} updOpts s = nub (s ++ opts) formatMacro name value = "-D" ++ name ++ "=" ++ (show value) targetDataDir :: LocalBuildInfo -> FilePath targetDataDir l = let dirTmpls = installDirTemplates l prefix' = prefix dirTmpls data' = datadir dirTmpls dataEx = I.fromPathTemplate $ I.substPathTemplate [(PrefixVar, prefix')] data' in dataEx ++ "/locale" getPackageName :: LocalBuildInfo -> String getPackageName = fromPackageName . packageName . localPkgDescr where fromPackageName (PackageName s) = s getCustomFields :: LocalBuildInfo -> [(String, String)] getCustomFields = customFieldsPD . localPkgDescr findInParametersDefault :: [(String, String)] -> String -> String -> String findInParametersDefault al name def = (fromMaybe def . lookup name) al getDomainNameDefault :: [(String, String)] -> String -> String getDomainNameDefault al d = findInParametersDefault al "x-gettext-domain-name" d getDomainDefine :: [(String, String)] -> String getDomainDefine al = findInParametersDefault al "x-gettext-domain-def" "__MESSAGE_CATALOG_DOMAIN__" getMsgCatalogDefine :: [(String, String)] -> String getMsgCatalogDefine al = findInParametersDefault al "x-gettext-msg-cat-def" "__MESSAGE_CATALOG_DIR__" getPoFilesDefault :: [(String, String)] -> IO [String] getPoFilesDefault al = toFileList $ findInParametersDefault al "x-gettext-po-files" "" where toFileList "" = return [] toFileList x = liftM concat $ mapM matchFileGlob $ split' x -- from Blow your mind (HaskellWiki) -- splits string by newline, space and comma split' x = concatMap lines $ concatMap words $ unfoldr (\b -> fmap (const . (second $ drop 1) . break (==',') $ b) . listToMaybe $ b) x hgettext-0.1.30/src/Text/0000755000000000000000000000000012075753663013346 5ustar0000000000000000hgettext-0.1.30/src/Text/I18N/0000755000000000000000000000000012075753663014025 5ustar0000000000000000hgettext-0.1.30/src/Text/I18N/GetText.hs0000644000000000000000000001713112075753663015750 0ustar0000000000000000-- | This library provides basic internationalization capabilities module Text.I18N.GetText ( getText, nGetText, dGetText, dnGetText, dcGetText, dcnGetText, bindTextDomain, textDomain ) where import Foreign.C.Types import Foreign.C.String import Foreign.C.Error import Foreign.Ptr import Data.Maybe (fromMaybe) import System.Locale.SetLocale foreign import ccall unsafe "libintl.h gettext" c_gettext :: CString -> IO CString foreign import ccall unsafe "libintl.h dgettext" c_dgettext :: CString -> CString -> IO CString foreign import ccall unsafe "libintl.h dcgettext" c_dcgettext :: CString -> CString -> CInt -> IO CString foreign import ccall unsafe "libintl.h ngettext" c_ngettext :: CString -> CString -> CULong -> IO CString foreign import ccall unsafe "libintl.h dngettext" c_dngettext :: CString -> CString -> CString -> CULong -> IO CString foreign import ccall unsafe "libintl.h dcngettext" c_dcngettext :: CString -> CString -> CString -> CULong -> CInt -> IO CString foreign import ccall unsafe "libintl.h bindtextdomain" c_bindtextdomain :: CString -> CString -> IO CString foreign import ccall unsafe "libintl.h textdomain" c_textdomain :: CString -> IO CString fromCString :: CString -> IO (Maybe String) fromCString x | x == nullPtr = return Nothing | otherwise = peekCString x >>= return . Just fromCStringError :: String -> CString -> IO String fromCStringError err x | x == nullPtr = throwErrno err | otherwise = peekCString x fromCStringDefault :: String -> CString -> IO String fromCStringDefault d x = fromCString x >>= \r -> return (fromMaybe d r) fromCStringPluralDefault :: (Eq a, Num a) => String -> String -> a -> CString -> IO String fromCStringPluralDefault def def_plural n s | n == 1 = fromCStringDefault def s | otherwise = fromCStringDefault def_plural s withCStringMaybe :: Maybe String -> (CString -> IO a) -> IO a withCStringMaybe Nothing f = f nullPtr withCStringMaybe (Just str) f = withCString str f -- |getText wraps GNU gettext function. It returns translated string for the -- input messages. If translated string not found the input string will be -- returned. -- -- The most common usage of this function is to declare function __: -- -- > __ = unsafePerformIO . getText -- -- and wrap all text strings into this function, e.g. -- -- > printHello = putStrLn (__ "Hello") -- getText :: String -> IO String getText s = withCString s $ \s' -> c_gettext s' >>= fromCStringDefault s -- |dGetText wraps GNU dgettext function. It works similar to 'getText' -- but also could take domain name. -- dGetText :: Maybe String -- ^ domain name, if 'Nothing' --- -- default domain will be used -> String -- ^ message id -> IO String -- ^ return value dGetText domainname msgid = withCStringMaybe domainname $ \dn' -> withCString msgid $ \msg' -> c_dgettext dn' msg' >>= fromCStringDefault msgid -- |dcGetText wraps GNU dcgettext function. It works similar to 'dGetText' -- but also takes category id dcGetText :: Maybe String -- ^ domain name, if 'Nothing' --- -- default domain will be used -> Category -- ^ locale facet -> String -- ^ message id -> IO String -- ^ return value dcGetText domainname cat msgid = withCStringMaybe domainname $ \dn' -> withCString msgid $ \msg' -> c_dcgettext dn' msg' (categoryToCInt cat) >>= fromCStringDefault msgid -- |nGetText wraps GNU ngettext function. It translates text string in the -- user's native language, by lookilng up the approppiate plural form of the -- message. -- nGetText :: String -- ^ msgid in singular form -> String -- ^ msgid in plural form -> Integer -- ^ number, used to choose appropriate form -> IO String -- ^ result string, by default if number is 1 than -- singular form of msgid is returned, otherwise --- -- plural nGetText msgid msgid_plural n = withCString msgid $ \msgid' -> withCString msgid_plural $ \msgid_plural' -> c_ngettext msgid' msgid_plural' (fromInteger n) >>= fromCStringPluralDefault msgid msgid_plural n -- |dnGetText wraps GNU dngettext function. It works similar to 'nGetText' but -- also takes domain name -- dnGetText :: Maybe String -- ^ domain name, if 'Nothing' --- -- default domain will be used -> String -- ^ msgid in singular form -> String -- ^ msgid in plural form -> Integer -- ^ number, used to choose appropriate form -> IO String -- ^ result string, by default if number is 1 than -- singular form of msgid is returned, otherwise --- -- plural dnGetText domainname msgid msgid_plural n = withCStringMaybe domainname $ \dn' -> withCString msgid $ \msgid' -> withCString msgid_plural $ \msgid_plural' -> c_dngettext dn' msgid' msgid_plural' (fromInteger n) >>= fromCStringPluralDefault msgid msgid_plural n -- |dcnGetText wraps GNU dcngettext function. It works similar to 'dnGetText' but -- also takes category id -- dcnGetText :: Maybe String -- ^ domain name, if 'Nothing' --- -- default domain will be used -> Category -- ^ locale facet -> String -- ^ msgid in singular form -> String -- ^ msgid in plural form -> Integer -- ^ number, used to choose appropriate form -> IO String -- ^ result string, by default if number is 1 than -- singular form of msgid is returned, otherwise --- -- plural dcnGetText domainname cat msgid msgid_plural n = withCStringMaybe domainname $ \dn' -> withCString msgid $ \msgid' -> withCString msgid_plural $ \msgid_plural' -> c_dcngettext dn' msgid' msgid_plural' (fromInteger n) (categoryToCInt cat) >>= fromCStringPluralDefault msgid msgid_plural n -- |bindTextDomain sets the base directory of the hierarchy -- containing message catalogs for a given message domain. -- -- Throws 'IOError' if fails -- bindTextDomain :: String -- ^ domain name -> Maybe String -- ^ path to the locale folder or 'Nothing' to return -- base directory for domain -> IO String -- ^ return value bindTextDomain domainname dirname = withCString domainname $ \domain -> withCStringMaybe dirname $ \dir -> c_bindtextdomain domain dir >>= fromCStringError "bindTextDomain fails" -- |textDomain sets domain for future 'getText' call -- -- Throws 'IOError' if fails -- textDomain :: Maybe String -- ^ domain name, if 'Nothing' than returns -- current domain name -> IO String -- ^ return value textDomain domainname = withCStringMaybe domainname $ \domain -> c_textdomain domain >>= fromCStringError "textDomain fails"