hgettext-0.1.8: src/hgettext.hs

import Language.Haskell.Parser
import Language.Haskell.Syntax

import System.Environment
import System.Console.GetOpt

import Data.Generics.PlateData

import Distribution.Simple.PreProcess.Unlit

import Data.List

data Options = Options {
      outputFile :: String,
      keyword :: String
    } 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"
    ]


defaultOptions = Options "messages.po" "__"

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 -> ParseResult HsModule -> [(Int, String)]
toTranslate f (ParseOk z) = nub [ (0, s) | HsApp (HsVar (UnQual (HsIdent x))) (HsLit (HsString 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 <EMAIL@ADDRESS>\\n\"",
                               "\"Language-Team: LANGUAGE <LL@li.org>\\n\"",
                               "\"MIME-Version: 1.0\\n\"",
                               "\"Content-Type: text/plain; charset=UTF-8\\n\"",
                               "\"Content-Transfer-Encoding: 8bit\\n\"",
                               ""]

process :: Options -> [String] -> IO ()
process opts fl = do
  t <- mapM read' fl
  writeFile (outputFile opts) $ writePOTFile $ map (\(n,c) -> formatMessages n $ toTranslate (keyword opts) $ parseModule c) t
    where read' "-" = do 
                    s <- getContents
                    return ("-", either id (\_ -> "") (unlit "-" s))
          read' s = do 
                    c <- readFile s
                    return (s, either id (\_ -> "") (unlit s c))

main = 
    getArgs >>= parseArgs >>= uncurry process