Merge pull request #3 from ffaf1/exe

Various improvements to `hgettext`

Author: portnov

NEWS

@@ -0,0 +1,4 @@
+Next
+----
+
+- hgettext: added support for Unicode characters.

exe/Main.hs

@@ -1,83 +1,56 @@
--- (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))
+-- Originally copied from https://github.com/vasylp/hgettext/
+-- © 2009 Vasyl Pasternak, BSD-3-Clause.
+
+import Options
+import Paths_haskell_gettext (version)
+
+import qualified Data.Generics.Uniplate.Data as G
+import qualified Data.Function as F
+import qualified Data.List as L
+import qualified Data.Ord as O
+import qualified Data.Text as T
+import qualified Data.Time as TM
+import qualified Data.Text.IO.Utf8 as Utf8
+import qualified Data.Version as V
+import qualified Language.Haskell.Exts as H
+
+
+main :: IO ()
+main = do
+    opts <- parseOptions
+    process opts
+
+process :: Options -> IO ()
+process Options{printVersion = True} =
+        putStrLn $ "hgettext (from haskell-gettext), version " ++
+                     (V.showVersion version)
+process opts
+    | null (inputFiles opts) = do
+        putStrLn "hgettext: missing arguments"
+    | otherwise = do
+        t <- mapM read' (inputFiles opts)
+        pot <- formatPotFile $
+                 map (\(n,c) -> formatMessages n $
+                                  toTranslate (keywords opts) c) t
+        Utf8.writeFile (outputFile opts) (T.pack pot)
+    where
+        read' :: FilePath ->
+                 IO (String, H.ParseResult (H.Module H.SrcSpanInfo))
+        read' "-" = getContents >>= \c -> return ("-", H.parseFileContents c)
+        read' f = H.parseFile f >>= \m -> return (f, m)
+
+-------------------------------------------------------------------------------
+-- Write
 
 
 formatPotFile :: [String] -> IO String
-formatPotFile lines = do
-    time <- getZonedTime
-    let timeStr = formatTime defaultTimeLocale "%F %R%z" time
+formatPotFile ls = do
+    time <- TM.getZonedTime
+    let timeStr = TM.formatTime TM.defaultTimeLocale "%F %R%z" time
     let header = formatPotHeader timeStr
-    return $ concat $ header: lines
+    return $ concat (header:ls)
   where
+    formatPotHeader :: String -> String
     formatPotHeader timeStr =
        unlines ["# Translation file",
                 "",
@@ -95,18 +68,40 @@ formatPotFile lines = do
                 "\"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
-
+-- Create list of messages from a single file.
+formatMessages :: String -> [(H.SrcSpanInfo, String)] -> String
+formatMessages path l =
+        let sorted = L.sortBy (O.comparing snd) l
+            nubbed = L.nubBy ((==) `F.on` snd) sorted
+        in concatMap potEntry nubbed
+    where
+        potEntry :: (H.SrcSpanInfo, String) -> String
+        potEntry (wl, s) = unlines
+                             ["#: " ++ showSrc wl,
+                              "msgid " ++ (showStringC s),
+                              "msgstr \"\"",
+                              ""]
+
+        showSrc :: H.SrcSpanInfo -> String
+        showSrc wl = path ++ ":" ++
+                     show (H.srcSpanStartLine (H.srcInfoSpan wl)) ++ ":" ++
+                     show (H.srcSpanStartColumn (H.srcInfoSpan wl))
+
+toTranslate :: [String] -> H.ParseResult (H.Module H.SrcSpanInfo) ->
+               [(H.SrcSpanInfo, String)]
+toTranslate f (H.ParseOk z) =
+        L.nub [(loc, s) |
+                H.App _ (H.Var _ (H.UnQual _ (H.Ident _ x)))
+                        (H.Lit _ (H.String loc s _)) <- G.universeBi z,
+                x `elem` f]
+toTranslate _ _ = []
 
+-- Escape a string in a C-like fashion,
+-- see https://www.ibm.com/docs/en/i/7.4?topic=literals-string
+showStringC :: String -> String
+showStringC s0 = '"' : concatMap showCharC s0 ++ "\""
+    where
+      showCharC '"' = "\\\""
+      showCharC '\\' = "\\\\"
+      showCharC '\n' = "\\n"
+      showCharC c = return c

exe/Options.hs

@@ -0,0 +1,68 @@
+module Options (
+        Options(..),
+        parseOptions
+    )
+        where
+
+import Options.Applicative
+
+import qualified System.FilePath as FP
+
+data Options = Options {
+      inputFiles :: [FilePath],
+      outputFile :: FilePath,
+      keywords :: [String],
+      printVersion :: Bool
+    } deriving Show
+
+parseOptions :: IO Options
+parseOptions = execParser infoOpts
+
+-------------------------------------------------------------------------------
+-- Parsers/properties
+
+infoOpts :: ParserInfo Options
+infoOpts = info (options <**> helper)
+  ( fullDesc
+  <> progDesc "Extract translatable strings from Haskell source files."
+  <> header "hgettext (from haskell-gettext)" )
+
+options :: Parser Options
+options = Options <$> inputs <*> outfile <*> kwsDef <*> version
+    where
+        kwsDef = ("__" :) <$> many keyword
+
+inputs :: Parser [FilePath]
+inputs = many (strArgument (metavar "PATH..."))
+
+outfile :: Parser FilePath
+outfile = output <|> ((FP.<.> "po") <$> defaultDomain) <|> pure "messages.po"
+    where
+        output :: Parser FilePath
+        output = strOption
+            ( long "output"
+            <> short 'o'
+            <> metavar "FILE"
+            <> help "write output to specified file" )
+
+        defaultDomain :: Parser FilePath
+        defaultDomain = strOption
+            ( long "default-domain"
+            <> short 'd'
+            <> metavar "NAME"
+            <> help "use NAME.po instead of messages.po" )
+
+keyword :: Parser String
+keyword = strOption
+                ( long "keyword"
+                <> short 'k'
+                <> metavar "WORD"
+                <> help "function names, in which searched words are \
+                        \wrapped. Can be used multiple times, for multiple \
+                        \funcitons" )
+
+version :: Parser Bool
+version = switch
+            ( long "version"
+            <> short 'v'
+            <> help "print version of hgettext" )

haskell-gettext.cabal

@@ -34,12 +34,13 @@ maintainer:          [email protected]
 copyright:           © 2017–2019 Ilya Portnov
 category:            Text
 build-type:          Simple
-extra-doc-files:     README.md
+extra-doc-files:     README.md, NEWS
 extra-source-files:  examples/gmodump.hs
                      examples/gmotest.hs
 
 common shared
-  build-depends:    base == 4.*
+  build-depends:    base == 4.*,
+                    text >= 2.1.2 && < 2.2,
   ghc-options:      -Wall
   default-language: Haskell2010
 
@@ -54,17 +55,20 @@ library
                        containers >=0.5 && < 0.7,
                        mtl >= 2.2.1 && < 2.4,
                        parsec >= 3.1.11 && < 3.2,
-                       text >= 1.2 && < 2.2,
                        time >=1.4 && < 1.13,
                        transformers >=0.3 && < 0.7
   hs-source-dirs:      lib/
 
 executable hgettext
   import:            shared
   main-is:           Main.hs
+  autogen-modules:   Paths_haskell_gettext
+  other-modules:     Options,
+                     Paths_haskell_gettext
   build-depends:     filepath >= 1.4 && < 1.6,
                      haskell-src-exts >= 1.18 && < 1.24,
-                     old-locale >= 1.0 && < 1.1
+                     old-locale >= 1.0 && < 1.1,
+                     optparse-applicative >= 0.18.1 && < 0.19,
                      time >= 1.5.0 && < 1.13,
                      uniplate >= 1.6.12 && < 1.7,
   hs-source-dirs:    exe/

lib/Data/Gettext.hs

@@ -119,7 +119,7 @@ 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)
+cgettext gmo ctx key = gettext gmo (ctx `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.
@@ -140,8 +140,8 @@ cngettext :: Catalog
          -> B.ByteString  -- ^ Plural form in original language
          -> Int           -- ^ Number
          -> T.Text
-cngettext gmo context single plural n =
-  ngettext' gmo (context `B.append` "\4" `B.append` single `B.append` "\0" `B.append` plural) n
+cngettext gmo ctx single plural n =
+  ngettext' gmo (ctx `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]@.

lib/Data/Gettext/GmoFile.hs

@@ -69,11 +69,3 @@ parseGmo = do
               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
-

lib/Data/Gettext/Parsers.hs

@@ -38,8 +38,8 @@ type Headers = [Header]
 pHeader :: Parser Header
 pHeader = do
   name <- (many1 $ alphaNum <|> char '-') <?> "Header name"
-  char ':'
-  many $ oneOf " \t"
+  _ <- char ':'
+  _ <- many $ oneOf " \t"
   value <- many $ noneOf "\r\n"
   return (T.pack name, T.pack value)
 
@@ -51,8 +51,8 @@ pHeaders = pHeader `sepEndBy` newline
 -- 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 ->
+  let ls = filter (not . T.null) $ T.splitOn "\n" t
+  forM ls $ \line ->
     case T.splitOn ": " line of
       [name, value] -> return (name, value)
       (name:values) -> return (name, T.intercalate ": " values)
@@ -91,7 +91,7 @@ pTernary :: Parser (Expr, Expr)
 pTernary = do
   reservedOp "?"
   true <- pExpr
-  colon
+  _ <- colon
   false <- pExpr
   return (true, false)
 
@@ -100,11 +100,11 @@ pTernary = do
 -- starting from @nplurals=@.
 pPlural :: Parser (Int, Expr)
 pPlural = do
-  symbol "nplurals"
+  _ <- symbol "nplurals"
   reservedOp "="
   n <- natural
-  semi
-  symbol "plural"
+  _ <- semi
+  _ <- symbol "plural"
   reservedOp "="
   expr <- pExpr
   return (n, expr)

lib/Data/Gettext/Plural.hs

@@ -77,4 +77,4 @@ eval (If cond true false) n =
 eval (Binary op x y) n =
   evalOp op (eval x n) (eval y n)
 eval (Negate x) n = negate $ eval x n
-
+eval (Not x) n = if eval x n == 0 then 1 else eval x n