gettext-th (empty) → 0.1.0.0
raw patch · 3 files changed
+208/−0 lines, 3 filesdep +basedep +bytestringdep +directory
Dependencies added: base, bytestring, directory, filepath, haskell-gettext, template-haskell, text
Files
- CHANGELOG.md +5/−0
- gettext-th.cabal +41/−0
- src/I18N/Gettext/TH.hs +162/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for gettext-th++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ gettext-th.cabal view
@@ -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
+ src/I18N/Gettext/TH.hs view
@@ -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 <EMAIL@ADDRESS>, 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 <EMAIL@ADDRESS>\\n\"",+ "\"Language-Team: LANGUAGE <LL@li.org>\\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+ }