module I18N.Gettext.TH
(gettext, __)
where
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Instances.TH.Lift()
import System.IO.Unsafe
import System.Directory
import Data.IORef
import Control.Monad
import Data.Bifunctor
import Data.Char (isSpace)
import Data.List
import Data.Set (Set)
import qualified Data.Set as S
import qualified Data.ByteString as B
import Data.Text (Text)
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
import System.IO
{-# NOINLINE knownMsgs #-}
knownMsgs :: IORef (Set String)
knownMsgs :: IORef (Set [Char])
knownMsgs = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall a. Set a
S.empty
potFileName :: FilePath
potFileName :: [Char]
potFileName = [Char]
"po/messages.pot"
moFileName :: FilePath
moFileName :: [Char]
moFileName = [Char] -> [Char] -> [Char]
replaceExtension [Char]
potFileName [Char]
".mo"
{-# NOINLINE catalog #-}
catalog :: Maybe Catalog
catalog :: Maybe Catalog
catalog = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
Bool
fe <- [Char] -> IO Bool
doesFileExist [Char]
moFileName
if Bool
fe then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Catalog
loadCatalog [Char]
moFileName
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
header :: String
= [[Char]] -> [Char]
unlines [
[Char]
"# SOME DESCRIPTIVE TITLE.",
[Char]
"# Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER",
[Char]
"# This file is distributed under the same license as the PACKAGE package.",
[Char]
"# FIRST AUTHOR <EMAIL@ADDRESS>, YEAR.",
[Char]
"#",
[Char]
"#: hello.c:140",
[Char]
"#, fuzzy",
[Char]
"msgid \"\"",
[Char]
"msgstr \"\"",
[Char]
"\"Project-Id-Version: PACKAGE VERSION\\n\"",
[Char]
"\"Report-Msgid-Bugs-To: \\n\"",
[Char]
"\"POT-Creation-Date: 2022-08-03 07:51+0200\\n\"",
[Char]
"\"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\\n\"",
[Char]
"\"Last-Translator: FULL NAME <EMAIL@ADDRESS>\\n\"",
[Char]
"\"Language-Team: LANGUAGE <LL@li.org>\\n\"",
[Char]
"\"Language: \\n\"",
[Char]
"\"MIME-Version: 1.0\\n\"",
[Char]
"\"Content-Type: text/plain; charset=utf-8\\n\"",
[Char]
"\"Content-Transfer-Encoding: 8bit\\n\""
]
writeFileUtf8 :: FilePath -> IOMode -> String -> IO ()
writeFileUtf8 :: [Char] -> IOMode -> [Char] -> IO ()
writeFileUtf8 [Char]
f IOMode
mode [Char]
txt = forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile [Char]
f IOMode
mode (\ Handle
hdl -> do
Handle -> TextEncoding -> IO ()
hSetEncoding Handle
hdl TextEncoding
utf8
Handle -> [Char] -> IO ()
hPutStr Handle
hdl [Char]
txt)
createPotFile :: Q ()
createPotFile :: Q ()
createPotFile = do
[Char]
fn <- forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ do
Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True ([Char] -> [Char]
takeDirectory [Char]
potFileName)
Bool
potE <- [Char] -> IO Bool
doesFileExist [Char]
potFileName
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
potE forall a b. (a -> b) -> a -> b
$
[Char] -> [Char] -> IO ()
renameFile [Char]
potFileName ([Char]
potFileName forall a. [a] -> [a] -> [a]
++ [Char]
".bak")
[Char] -> IOMode -> [Char] -> IO ()
writeFileUtf8 [Char]
potFileName IOMode
WriteMode [Char]
header
Bool
moE <- [Char] -> IO Bool
doesFileExist [Char]
moFileName
if Bool
moE then [Char] -> IO [Char]
makeAbsolute [Char]
moFileName
else forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
""
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
fn) forall a b. (a -> b) -> a -> b
$ [Char] -> Q ()
addDependentFile [Char]
fn
packStr :: String -> B.ByteString
packStr :: [Char] -> ByteString
packStr = Text -> ByteString
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack
lookupText :: String -> Text
lookupText :: [Char] -> Text
lookupText [Char]
str = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Text
T.pack [Char]
str) (\ Catalog
c -> Text -> Text
TL.toStrict forall a b. (a -> b) -> a -> b
$ Catalog -> ByteString -> Text
G.gettext Catalog
c forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
packStr [Char]
str) Maybe Catalog
catalog
gettextQ :: String -> Q Exp
gettextQ :: [Char] -> Q Exp
gettextQ [Char]
str = do
Set [Char]
kmsgs <- forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ do
Set [Char]
kmsgs <- forall a. IORef a -> IO a
readIORef IORef (Set [Char])
knownMsgs
forall a. IORef a -> a -> IO ()
writeIORef IORef (Set [Char])
knownMsgs (forall a. Ord a => a -> Set a -> Set a
S.insert [Char]
str Set [Char]
kmsgs)
forall (m :: * -> *) a. Monad m => a -> m a
return Set [Char]
kmsgs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Set a -> Bool
S.null Set [Char]
kmsgs) Q ()
createPotFile
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Char]
str forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set [Char]
kmsgs) forall a b. (a -> b) -> a -> b
$ do
Loc
loc <- Q Loc
location
forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ [Char] -> IOMode -> [Char] -> IO ()
writeFileUtf8 [Char]
potFileName IOMode
AppendMode forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$ Loc -> [Char] -> [[Char]]
poEntry Loc
loc [Char]
str
let trans :: Text
trans = [Char] -> Text
lookupText [Char]
str
[| trans |]
quote :: String -> String
quote :: [Char] -> [Char]
quote [Char]
s = Char
'"'forall a. a -> [a] -> [a]
:[Char] -> [Char]
escape [Char]
s
where escape :: [Char] -> [Char]
escape [] = [Char]
"\""
escape (Char
'"':[Char]
s') = Char
'\\'forall a. a -> [a] -> [a]
:Char
'"'forall a. a -> [a] -> [a]
:[Char] -> [Char]
escape [Char]
s'
escape (Char
'\n':[Char]
s') = Char
'\\'forall a. a -> [a] -> [a]
:Char
'n'forall a. a -> [a] -> [a]
:[Char] -> [Char]
escape [Char]
s'
escape (Char
'\r':[Char]
s') = [Char] -> [Char]
escape [Char]
s'
escape (Char
c:[Char]
s') = Char
cforall a. a -> [a] -> [a]
:[Char] -> [Char]
escape [Char]
s'
poEntry :: Loc -> String -> [String]
poEntry :: Loc -> [Char] -> [[Char]]
poEntry Loc
loc [Char]
msg = [
[Char]
"",
[Char]
"#: " forall a. [a] -> [a] -> [a]
++ (Loc -> [Char]
loc_filename Loc
loc) forall a. [a] -> [a] -> [a]
++ [Char]
":0",
[Char]
"msgid " forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
quote [Char]
msg,
[Char]
"msgstr " forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
quote [Char]
msg
]
gettextsDecs :: String -> Q [Dec]
gettextsDecs :: [Char] -> Q [Dec]
gettextsDecs [Char]
str = do
let msgs :: [([Char], [Char])]
msgs = forall a b. (a -> b) -> [a] -> [b]
map [Char] -> ([Char], [Char])
splitKeyMsg forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
parseLines [Char]
str
Set [Char]
kmsgs <- forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ do
Set [Char]
kmsgs <- forall a. IORef a -> IO a
readIORef IORef (Set [Char])
knownMsgs
forall a. IORef a -> a -> IO ()
writeIORef IORef (Set [Char])
knownMsgs (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ Set [Char]
acc ([Char]
_, [Char]
msg) -> [Char]
msg forall a. Ord a => a -> Set a -> Set a
`S.insert` Set [Char]
acc) Set [Char]
kmsgs [([Char], [Char])]
msgs)
forall (m :: * -> *) a. Monad m => a -> m a
return Set [Char]
kmsgs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Set a -> Bool
S.null Set [Char]
kmsgs) Q ()
createPotFile
Loc
loc <- Q Loc
location
forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ [Char] -> IOMode -> [Char] -> IO ()
writeFileUtf8 [Char]
potFileName IOMode
AppendMode forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ Loc -> [Char] -> [[Char]]
poEntry Loc
loc [Char]
msg | ([Char]
_, [Char]
msg) <- [([Char], [Char])]
msgs, [Char]
msg forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set [Char]
kmsgs ]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [([Char], [Char])]
msgs forall a b. (a -> b) -> a -> b
$ \ ([Char]
key, [Char]
msg) ->
let trans :: Text
trans = [Char] -> Text
lookupText [Char]
msg in do
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ([Char] -> Name
mkName [Char]
key) [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| trans |]) []]
parseLines :: String -> [String]
parseLines :: [Char] -> [[Char]]
parseLines [Char]
text = [[Char]] -> [[Char]] -> [[Char]]
go [] ([Char] -> [[Char]]
lines [Char]
text)
where go :: [[Char]] -> [[Char]] -> [[Char]]
go [[Char]]
acc [] = forall a. [a] -> [a]
reverse [[Char]]
acc
go [[Char]]
acc ((Char
'#':[Char]
_):[[Char]]
lines') = [[Char]] -> [[Char]] -> [[Char]]
go [[Char]]
acc [[Char]]
lines'
go [[Char]]
acc ([Char]
line:[[Char]]
lines') =
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace [Char]
line then [[Char]] -> [[Char]] -> [[Char]]
go [[Char]]
acc [[Char]]
lines'
else ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]] -> [[Char]]
collect ([[Char]] -> [[Char]] -> [[Char]]
join [[Char]]
acc) [[Char]
line] [[Char]]
lines'
collect :: ([String] -> [String]) -> [String] -> [String] -> [String]
collect :: ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]] -> [[Char]]
collect [[Char]] -> [[Char]]
j [[Char]]
cl [] = [[Char]] -> [[Char]] -> [[Char]]
go ([[Char]] -> [[Char]]
j [[Char]]
cl) []
collect [[Char]] -> [[Char]]
j [[Char]]
cl ([]:[[Char]]
t) = [[Char]] -> [[Char]] -> [[Char]]
go ([[Char]] -> [[Char]]
j [[Char]]
cl) [[Char]]
t
collect [[Char]] -> [[Char]]
j [[Char]]
cl lines' :: [[Char]]
lines'@((Char
c:[Char]
d):[[Char]]
t) =
if Char -> Bool
isSpace Char
c then ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]] -> [[Char]]
collect [[Char]] -> [[Char]]
j ((forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace [Char]
d)forall a. a -> [a] -> [a]
:[[Char]]
cl) [[Char]]
t
else [[Char]] -> [[Char]] -> [[Char]]
go ([[Char]] -> [[Char]]
j [[Char]]
cl) [[Char]]
lines'
join :: [[Char]] -> [[Char]] -> [[Char]]
join [[Char]]
acc [[Char]]
cl = (forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [[Char]]
cl)forall a. a -> [a] -> [a]
:[[Char]]
acc
splitKeyMsg :: String -> (String, String)
splitKeyMsg :: [Char] -> ([Char], [Char])
splitKeyMsg [Char]
line = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap [Char] -> [Char]
trim ([Char] -> [Char]
trim forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
tail) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/= Char
':') [Char]
line
trim :: String -> String
trim :: [Char] -> [Char]
trim = [Char] -> [Char]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
f
where f :: [Char] -> [Char]
f = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace
gettext :: QuasiQuoter
gettext :: QuasiQuoter
gettext = QuasiQuoter
{ quoteExp :: [Char] -> Q Exp
quoteExp = [Char] -> Q Exp
gettextQ
, quotePat :: [Char] -> Q Pat
quotePat = forall a. HasCallStack => [Char] -> a
error [Char]
"Usage as a pattern is not supported"
, quoteType :: [Char] -> Q Type
quoteType = forall a. HasCallStack => [Char] -> a
error [Char]
"Usage as a type is not supported"
, quoteDec :: [Char] -> Q [Dec]
quoteDec = [Char] -> Q [Dec]
gettextsDecs
}
__ :: QuasiQuoter
__ :: QuasiQuoter
__ = QuasiQuoter
gettext