diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2009, Vasyl Pasternak + +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 Vasyl Pasternak 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/hgettext.cabal b/hgettext.cabal --- a/hgettext.cabal +++ b/hgettext.cabal @@ -1,31 +1,67 @@ -Name: hgettext -Version: 0.1.30 -Cabal-Version: >= 1.6 +cabal-version: 1.14 +name: hgettext +version: 0.1.31.0 +build-type: Simple -License: BSD3 +license: BSD3 +license-file: LICENSE -Author: Vasyl Pasternak -Maintainer: vasyl.pasternak@gmail.com -Copyright: 2009 Vasyl Pasternak -Category: Text -Homepage: https://github.com/vasylp/hgettext +author: Vasyl Pasternak +maintainer: Herbert Valerio Riedel +copyright: 2009 Vasyl Pasternak +category: Text +bug-reports: https://github.com/hvr/hgettext/issues +synopsis: Bindings to libintl.h (gettext, bindtextdomain) +description: This package provides bindings to the @gettext@ internationalization and localization (i18n) library. + . + This package provides support for custom @Setup.hs@ scripts via the "Distribution.Simple.I18N.GetText" module. + . + A user-contributed tutorial can be found in the [Haskell Wiki](https://wiki.haskell.org/Internationalization_of_Haskell_programs_using_gettext). -Synopsis: Bindings to libintl.h (gettext, bindtextdomain) -Build-Type: Simple +tested-with: GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 -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 +source-repository head + type: git + location: https://github.com/hvr/hgettext.git -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 +library + default-language: Haskell2010 + exposed-modules: Text.I18N.GetText, + Distribution.Simple.I18N.GetText + other-modules: Internal + hs-source-dirs: src + build-depends: base >=4.5 && <4.11 + , Cabal >=1.14 && <1.25 || == 2.0.* + , containers >=0.4.2 && <0.6 + , directory >=1.1 && <1.4 + , filepath >=1.3 && <1.5 + , process >=1.1 && <1.7 + , setlocale >=0.0.3 && <1.1 + + ghc-options: -Wall + + -- temporary hack: https://github.com/haskell-hvr/hgettext/pull/3 + if os(windows) + extra-libraries: libintl + +executable hgettext + default-language: Haskell2010 + + main-is: hgettext.hs + other-modules: Paths_hgettext + + hs-source-dirs: src-exe + + -- constraints inherited from lib:hgettext + build-depends: hgettext + , base + , Cabal + , containers + , filepath + + build-depends: deepseq >=1.1 && <1.5 + , haskell-src-exts >=1.18 && <1.21 + , uniplate >=1.6.12 && <1.7 + + ghc-options: -Wall diff --git a/src-exe/hgettext.hs b/src-exe/hgettext.hs new file mode 100644 --- /dev/null +++ b/src-exe/hgettext.hs @@ -0,0 +1,118 @@ +module Main (main) where + +import Control.DeepSeq +import Control.Exception +import Control.Monad +import Data.Generics.Uniplate.Data +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Version (showVersion) +import qualified Language.Haskell.Exts as H +import System.Console.GetOpt +import System.Environment +import System.Exit + +import Paths_hgettext (version) + +data Options = Options + { outputFile :: FilePath + , 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 +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.Module H.SrcSpanInfo -> [(Int, String)] +toTranslate f z = [ (H.srcSpanStartLine (H.srcInfoSpan loc), s) + | H.App _ (H.Var _ + (H.UnQual _ + (H.Ident _ x))) + (H.Lit _ + (H.String loc s _slit)) + <- universeBi z :: [H.Exp H.SrcSpanInfo] + , x == f] + +formatMessage :: String -> [(FilePath, Int)] -> String +formatMessage s locs = unlines $ + map (uncurry formatLoc) locs ++ + [ "msgid " ++ (show s) + , "msgstr \"\"" + , "" + ] + where + formatLoc src l = "#: " ++ src ++ ":" ++ (show l) + + +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 -> [FilePath] -> IO () +process Options{printVersion = True} _ = + putStrLn $ "hgettext, version " ++ (showVersion version) +process opts fl = do + dat <- forM fl $ \fn -> do + m <- readSource fn + evaluate $ force [ (s,(fn,loc)) | (loc,s) <- toTranslate (keyword opts) m ] + + let entries = Map.fromListWith Set.union [ (s,Set.singleton (fn,loc)) | d <- dat, (s,(fn,loc)) <- d ] + + writeFile (outputFile opts) $ do + writePOTFile [ formatMessage s (Set.toList locs) | (s,locs) <- Map.toList entries ] + where + readSource "-" = do + c <- getContents + case H.parseFileContents c of + H.ParseFailed loc msg -> do + putStrLn (concat [ ":", show (H.srcLine loc), ":", show (H.srcColumn loc), ": error: ", msg ]) + exitFailure + H.ParseOk m -> return m + readSource f = do + pm <- H.parseFile f + case pm of + H.ParseFailed loc msg -> do + putStrLn (concat [ f, ":", show (H.srcLine loc), ":", show (H.srcColumn loc), ": error: ", msg ]) + exitFailure + H.ParseOk m -> return m + +main :: IO () +main = getArgs >>= parseArgs >>= uncurry process diff --git a/src/Distribution/Simple/I18N/GetText.hs b/src/Distribution/Simple/I18N/GetText.hs --- a/src/Distribution/Simple/I18N/GetText.hs +++ b/src/Distribution/Simple/I18N/GetText.hs @@ -24,13 +24,13 @@ -- -- The module defines following @.cabal@ fields: -- --- [@x-gettext-domain-name@] Name of the domain. One ofmore +-- [@x-gettext-domain-name@] Name of the domain. One or more -- 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@ +-- 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 @@ -46,7 +46,7 @@ -- -- > ... -- > prepareI18N = do --- > setLocale LC_ALL (Just "") +-- > setLocale LC_ALL (Just "") -- > bindTextDomain __MESSAGE_CATALOG_DOMAIN__ (Just __MESSAGE_CATALOG_DIR__) -- > textDomain __MESSAGE_CATALOG_DOMAIN__ -- > @@ -57,66 +57,73 @@ -- > ... -- -- --- /NOTE:/ files, passed in the @x-gettext-po-files@ are not +-- __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 +-- __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 +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 Distribution.PackageDescription +import Distribution.Simple +import Distribution.Simple.InstallDirs as I +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Setup +import Distribution.Simple.Utils +import Distribution.Verbosity -import Language.Haskell.Extension +import Control.Arrow (second) +import Control.Monad +import Data.List (nub, unfoldr) +import Data.Maybe (fromMaybe, listToMaybe) +import System.Directory +import System.Exit +import System.FilePath +import System.Process -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 +import Internal -- | 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 +-- PO files to the system. -- +-- Pre-existing hook handlers are executed before the GetText +-- handlers. +-- installGetTextHooks :: UserHooks -- ^ initial user hooks -> UserHooks -- ^ patched user hooks -installGetTextHooks uh = uh{ - confHook = \a b -> - (confHook uh) a b >>= - return . updateLocalBuildInfo, +installGetTextHooks uh = + uh { confHook = \a b -> do + lbi <- (confHook uh) a b + return (updateLocalBuildInfo lbi) - postInst = \a b c d -> - (postInst uh) a b c d >> - installPOFiles a b c d - } + , postInst = \args iflags pd lbi -> do + postInst uh args iflags pd lbi + installPOFiles (fromFlagOrDefault maxBound (installVerbosity iflags)) lbi + , postCopy = \args cflags pd lbi -> do + postCopy uh args cflags pd lbi + installPOFiles (fromFlagOrDefault maxBound (copyVerbosity cflags)) lbi + } + updateLocalBuildInfo :: LocalBuildInfo -> LocalBuildInfo -updateLocalBuildInfo l = +updateLocalBuildInfo l = let sMap = getCustomFields l [domDef, catDef] = map ($ sMap) [getDomainDefine, getMsgCatalogDefine] dom = getDomainNameDefault sMap (getPackageName l) @@ -124,8 +131,8 @@ [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 = +installPOFiles :: Verbosity -> LocalBuildInfo -> IO () +installPOFiles verb l = let sMap = getCustomFields l destDir = targetDataDir l dom = getDomainNameDefault sMap (getPackageName l) @@ -135,43 +142,48 @@ 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 + ph <- runProcess "msgfmt" [ "--output-file=" ++ (targetDir dom <.> "mo"), file ] + Nothing Nothing Nothing Nothing Nothing + ec <- waitForProcess ph + case ec of + ExitSuccess -> return () + -- only warn for now, as the package may still be usable even if the msg catalogs are missing + ExitFailure n -> warn verb ("'msgfmt' exited with non-zero status (rc = " ++ show n ++ ")") 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 + mapM_ installFile filelist forBuildInfo :: LocalBuildInfo -> (BuildInfo -> BuildInfo) -> LocalBuildInfo -forBuildInfo l f = +forBuildInfo l f = let a = l{localPkgDescr = updPkgDescr (localPkgDescr l)} - updPkgDescr x = x{library = updLibrary (library x), + updPkgDescr x = x{library = updLibrary (library x), executables = updExecs (executables x)} - updLibrary Nothing = Nothing + 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 = +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 = +appendCPPOptions opts l = forBuildInfo l updBuildInfo where updBuildInfo x = x{cppOptions = updOpts (cppOptions x)} updOpts s = nub (s ++ opts) +formatMacro :: Show a => [Char] -> a -> [Char] formatMacro name value = "-D" ++ name ++ "=" ++ (show value) targetDataDir :: LocalBuildInfo -> FilePath -targetDataDir l = +targetDataDir l = let dirTmpls = installDirTemplates l prefix' = prefix dirTmpls data' = datadir dirTmpls @@ -180,7 +192,6 @@ getPackageName :: LocalBuildInfo -> String getPackageName = fromPackageName . packageName . localPkgDescr - where fromPackageName (PackageName s) = s getCustomFields :: LocalBuildInfo -> [(String, String)] getCustomFields = customFieldsPD . localPkgDescr @@ -200,8 +211,7 @@ 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 + 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 - diff --git a/src/Internal.hs b/src/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Internal.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE CPP #-} + +module Internal where + +import Distribution.Simple + +fromPackageName :: PackageName -> String +#if MIN_VERSION_Cabal(2,0,0) +fromPackageName = unPackageName +#else +fromPackageName (PackageName s) = s +#endif diff --git a/src/Text/I18N/GetText.hs b/src/Text/I18N/GetText.hs --- a/src/Text/I18N/GetText.hs +++ b/src/Text/I18N/GetText.hs @@ -11,12 +11,12 @@ 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 +import Data.Maybe (fromMaybe) +import Foreign.C.Error +import Foreign.C.String +import Foreign.C.Types +import Foreign.Ptr +import System.Locale.SetLocale foreign import ccall unsafe "libintl.h gettext" c_gettext @@ -25,7 +25,7 @@ foreign import ccall unsafe "libintl.h dgettext" c_dgettext :: CString -> CString -> IO CString -foreign import ccall unsafe "libintl.h dcgettext" c_dcgettext +foreign import ccall unsafe "libintl.h dcgettext" c_dcgettext :: CString -> CString -> CInt -> IO CString foreign import ccall unsafe "libintl.h ngettext" c_ngettext @@ -58,55 +58,55 @@ 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 Nothing f = f nullPtr withCStringMaybe (Just str) f = withCString str f --- |getText wraps GNU gettext function. It returns translated string for the +-- | '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 __: --- +-- 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' -> +getText s = + withCString s $ \s' -> c_gettext s' >>= fromCStringDefault s --- |dGetText wraps GNU dgettext function. It works similar to 'getText' +-- | '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 = +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' +-- | '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 = +dcGetText domainname cat msgid = withCStringMaybe domainname $ \dn' -> withCString msgid $ \msg' -> - c_dcgettext dn' msg' (categoryToCInt cat) >>= + c_dcgettext dn' msg' (categoryToCInt cat) >>= fromCStringDefault msgid - --- |nGetText wraps GNU ngettext function. It translates text string in the + +-- | '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. -- @@ -115,16 +115,16 @@ -> 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 + -- 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 +-- | '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 @@ -132,7 +132,7 @@ -> 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 + -- plural dnGetText domainname msgid msgid_plural n = withCStringMaybe domainname $ \dn' -> withCString msgid $ \msgid' -> @@ -140,9 +140,9 @@ c_dngettext dn' msgid' msgid_plural' (fromInteger n) >>= fromCStringPluralDefault msgid msgid_plural n --- |dcnGetText wraps GNU dcngettext function. It works similar to 'dnGetText' but +-- | '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 @@ -151,16 +151,16 @@ -> 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 + -- 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' + c_dcngettext dn' msgid' msgid_plural' (fromInteger n) (categoryToCInt cat) >>= fromCStringPluralDefault msgid msgid_plural n --- |bindTextDomain sets the base directory of the hierarchy +-- | 'bindTextDomain' sets the base directory of the hierarchy -- containing message catalogs for a given message domain. -- -- Throws 'IOError' if fails @@ -169,18 +169,18 @@ -> 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 -> +bindTextDomain domainname dirname = + withCString domainname $ \domain -> withCStringMaybe dirname $ \dir -> c_bindtextdomain domain dir >>= fromCStringError "bindTextDomain fails" --- |textDomain sets domain for future 'getText' call +-- | '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 = +textDomain domainname = withCStringMaybe domainname $ \domain -> c_textdomain domain >>= fromCStringError "textDomain fails" diff --git a/src/hgettext.hs b/src/hgettext.hs deleted file mode 100644 --- a/src/hgettext.hs +++ /dev/null @@ -1,97 +0,0 @@ - -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 -