diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for gettext-th + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/gettext-th.cabal b/gettext-th.cabal new file mode 100644 --- /dev/null +++ b/gettext-th.cabal @@ -0,0 +1,41 @@ +cabal-version: 2.4 +name: gettext-th +version: 0.1.0.0 + +synopsis: gettext-th can internationlise a haskell program with gettext at compile time without runtime dependencies + +-- A longer description of the package. +description: + The [gettext](https://www.gnu.org/software/gettext/) project provides a library and tools for internationalization and localization of software. gettext-th allows you to use the gettext tooling without adding any runtime dependencies because texts are exchanged at compile time. But this also means that you have an application per language. + +bug-reports: https://github.com/chrbauer/gettext-th/issues + +-- The license under which the package is released. +license: BSD-3-Clause +author: Christoph Bauer +maintainer: mail@christoph-bauer.net + +-- A copyright notice. +-- copyright: +category: i18, Text +extra-source-files: CHANGELOG.md + +library + exposed-modules: I18N.Gettext.TH + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base >= 4 && < 5 + , bytestring + , directory + , filepath + , haskell-gettext + , template-haskell + , text + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fwarn-tabs + default-extensions: TemplateHaskell, TupleSections, DeriveLift, RecordWildCards, QuasiQuotes, OverloadedStrings, FlexibleContexts diff --git a/src/I18N/Gettext/TH.hs b/src/I18N/Gettext/TH.hs new file mode 100644 --- /dev/null +++ b/src/I18N/Gettext/TH.hs @@ -0,0 +1,162 @@ +module I18N.Gettext.TH +(gettext, __, gettexts) +where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import System.IO.Unsafe +import System.Directory +import Data.IORef +import Control.Monad +import Data.Bifunctor +import Data.Char (isSpace) +import Data.List + +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Text.Encoding (encodeUtf8) + +import qualified Data.Gettext as G +import Data.Gettext (Catalog, loadCatalog) +import System.FilePath.Posix + + +{-# NOINLINE firstCall #-} +firstCall :: IORef Bool +firstCall = unsafePerformIO $ newIORef True + +potFileName :: FilePath +potFileName = "po/messages.pot" + + +poFileName :: FilePath +poFileName = replaceExtension potFileName ".po" + +moFileName :: FilePath +moFileName = replaceExtension potFileName ".mo" + +{-# NOINLINE catalog #-} +catalog :: Catalog +catalog = unsafePerformIO $ loadCatalog moFileName + + +header :: String +header = unlines [ + "# SOME DESCRIPTIVE TITLE.", + "# Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER", + "# This file is distributed under the same license as the PACKAGE package.", + "# FIRST AUTHOR , YEAR.", + "#", + "#: hello.c:140", + "#, fuzzy", + "msgid \"\"", + "msgstr \"\"", + "\"Project-Id-Version: PACKAGE VERSION\\n\"", + "\"Report-Msgid-Bugs-To: \\n\"", + "\"POT-Creation-Date: 2022-08-03 07:51+0200\\n\"", + "\"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\\n\"", + "\"Last-Translator: FULL NAME \\n\"", + "\"Language-Team: LANGUAGE \\n\"", + "\"Language: \\n\"", + "\"MIME-Version: 1.0\\n\"", + "\"Content-Type: text/plain; charset=CHARSET\\n\"", + "\"Content-Transfer-Encoding: 8bit\\n\"" + ] + +createPotFile :: Q () +createPotFile = do + runIO $ do + f <- readIORef firstCall + when f $ do + writeIORef firstCall False + createDirectoryIfMissing True (takeDirectory potFileName) + potE <- doesFileExist potFileName + when potE $ + renameFile potFileName (potFileName ++ ".bak") + + writeFile potFileName header + --addDependentFile poFileName + + +packStr :: String -> B.ByteString +packStr = encodeUtf8 . T.pack + + +gettextQ :: String -> Q Exp +gettextQ str = do + createPotFile + loc <- location + runIO $ appendFile potFileName $ unlines [ + "", + "#: " ++ (loc_filename loc) ++ ":0", -- TODO line nr or char pos + "msgid \"" ++ str ++ "\"", + "msgstr \"" ++ str ++ "\"" + ] + let trans = TL.toStrict $ G.gettext catalog (packStr str) + [| trans |] + + +gettext :: QuasiQuoter +gettext = QuasiQuoter + { quoteExp = gettextQ + , quotePat = error "Usage as a parttern is not supported" + , quoteType = error "Usage as a type is not supported" + , quoteDec = error "Usage as a decl is not supported" + + } + +__ :: QuasiQuoter +__ = gettext + + +gettextsDecs :: String -> Q [Dec] +gettextsDecs str = do + createPotFile + loc <- location + let msgs = map splitKeyMsg $ parseLines str + runIO $ appendFile potFileName $ unlines $ concat [[ + "", + "#: " ++ (loc_filename loc) ++ ":0", -- TODO line nr or char pos + "msgid " ++ show msg, + "msgstr " ++ show msg + ] | (_, msg) <- msgs ] + + forM msgs $ \ (key, msg) -> + let trans = TL.toStrict $ G.gettext catalog (packStr msg) in do + e <- [| trans |] + return $ FunD (mkName key) [Clause [] (NormalB e) []] + + + + +parseLines :: String -> [String] +parseLines text = go [] (lines text) + where go acc [] = reverse acc + go acc (('#':_):lines') = go acc lines' + go acc (line:lines') = + if all isSpace line then go acc lines' + else collect (join acc) [line] lines' + collect :: ([String] -> [String]) -> [String] -> [String] -> [String] + collect j cl [] = go (j cl) [] + collect j cl lines'@(h@(c:d):t) = + if isSpace c then collect j ((dropWhile isSpace d):cl) t + else go (j cl) lines' + join acc cl = (intercalate "\n" $ reverse cl):acc + +splitKeyMsg :: String -> (String, String) +splitKeyMsg line = bimap trim (trim . tail)$ span (/= ':') line + + +trim :: String -> String +trim = f . f + where f = reverse . dropWhile isSpace + + +gettexts :: QuasiQuoter +gettexts = QuasiQuoter + { quoteExp = error "Usage as a decl is not supported" + , quotePat = error "Usage as a parttern is not supported" + , quoteType = error "Usage as a type is not supported" + , quoteDec = gettextsDecs + }