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 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 String)
knownMsgs = IO (IORef (Set String)) -> IORef (Set String)
forall a. IO a -> a
unsafePerformIO (IO (IORef (Set String)) -> IORef (Set String))
-> IO (IORef (Set String)) -> IORef (Set String)
forall a b. (a -> b) -> a -> b
$ Set String -> IO (IORef (Set String))
forall a. a -> IO (IORef a)
newIORef Set String
forall a. Set a
S.empty

potFileName :: FilePath
potFileName :: String
potFileName = String
"po/messages.pot"


-- poFileName :: FilePath
-- poFileName = replaceExtension potFileName ".po"

moFileName :: FilePath
moFileName :: String
moFileName = String -> String -> String
replaceExtension String
potFileName String
".mo"

{-# NOINLINE catalog #-}
catalog :: Catalog
catalog :: Catalog
catalog = IO Catalog -> Catalog
forall a. IO a -> a
unsafePerformIO (IO Catalog -> Catalog) -> IO Catalog -> Catalog
forall a b. (a -> b) -> a -> b
$ String -> IO Catalog
loadCatalog String
moFileName


header :: String
header :: String
header = [String] -> String
unlines [
  String
"# SOME DESCRIPTIVE TITLE.",
  String
"# Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER",
  String
"# This file is distributed under the same license as the PACKAGE package.",
  String
"# FIRST AUTHOR <EMAIL@ADDRESS>, YEAR.",
  String
"#",
  String
"#: hello.c:140",
  String
"#, fuzzy",
  String
"msgid \"\"",
  String
"msgstr \"\"",
  String
"\"Project-Id-Version: PACKAGE VERSION\\n\"",
  String
"\"Report-Msgid-Bugs-To: \\n\"",
  String
"\"POT-Creation-Date: 2022-08-03 07:51+0200\\n\"",
  String
"\"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\\n\"",
  String
"\"Last-Translator: FULL NAME <EMAIL@ADDRESS>\\n\"",
  String
"\"Language-Team: LANGUAGE <LL@li.org>\\n\"",
  String
"\"Language: \\n\"",
  String
"\"MIME-Version: 1.0\\n\"",
  String
"\"Content-Type: text/plain; charset=utf-8\\n\"",
  String
"\"Content-Transfer-Encoding: 8bit\\n\""
  ]




writeFileUtf8 :: FilePath -> IOMode -> String -> IO ()
writeFileUtf8 :: String -> IOMode -> String -> IO ()
writeFileUtf8 String
f IOMode
mode String
txt = String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
f IOMode
mode (\ Handle
hdl -> do
                                               Handle -> TextEncoding -> IO ()
hSetEncoding Handle
hdl TextEncoding
utf8
                                               Handle -> String -> IO ()
hPutStr Handle
hdl String
txt)  

createPotFile :: Q ()
createPotFile :: Q ()
createPotFile = do
  String
fn <- IO String -> Q String
forall a. IO a -> Q a
runIO (IO String -> Q String) -> IO String -> Q String
forall a b. (a -> b) -> a -> b
$ do
      Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> String
takeDirectory String
potFileName)
      Bool
potE <- String -> IO Bool
doesFileExist String
potFileName    
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
potE (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> String -> IO ()
renameFile String
potFileName (String
potFileName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".bak")

      String -> IOMode -> String -> IO ()
writeFileUtf8 String
potFileName IOMode
WriteMode String
header
      String -> IO String
makeAbsolute String
moFileName
  String -> Q ()
addDependentFile String
fn


packStr :: String -> B.ByteString
packStr :: String -> ByteString
packStr = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

gettextQ  :: String -> Q Exp
gettextQ :: String -> Q Exp
gettextQ String
str = do
  Set String
kmsgs <- IO (Set String) -> Q (Set String)
forall a. IO a -> Q a
runIO (IO (Set String) -> Q (Set String))
-> IO (Set String) -> Q (Set String)
forall a b. (a -> b) -> a -> b
$ do
     Set String
kmsgs <- IORef (Set String) -> IO (Set String)
forall a. IORef a -> IO a
readIORef IORef (Set String)
knownMsgs
     IORef (Set String) -> Set String -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Set String)
knownMsgs (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
S.insert String
str Set String
kmsgs)
     Set String -> IO (Set String)
forall (m :: * -> *) a. Monad m => a -> m a
return Set String
kmsgs

  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Set String -> Bool
forall a. Set a -> Bool
S.null Set String
kmsgs) Q ()
createPotFile
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
str String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set String
kmsgs) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ do
    Loc
loc <- Q Loc
location
    IO () -> Q ()
forall a. IO a -> Q a
runIO (IO () -> Q ()) -> IO () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> IOMode -> String -> IO ()
writeFileUtf8 String
potFileName IOMode
AppendMode (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Loc -> String -> [String]
poEntry Loc
loc String
str
  let trans :: Text
trans = Text -> Text
TL.toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Catalog -> ByteString -> Text
G.gettext Catalog
catalog (String -> ByteString
packStr String
str)
  [| trans |]

quote :: String -> String
quote :: String -> String
quote String
s =  Char
'"'Char -> String -> String
forall a. a -> [a] -> [a]
:String -> String
escape String
s
  where escape :: String -> String
escape [] = String
"\""
        escape (Char
'"':String
s') = Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
'"'Char -> String -> String
forall a. a -> [a] -> [a]
:String -> String
escape String
s'
        escape (Char
'\n':String
s') = Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
'n'Char -> String -> String
forall a. a -> [a] -> [a]
:String -> String
escape String
s'
        escape (Char
'\r':String
s') = String -> String
escape String
s'
        escape (Char
c:String
s') = Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String -> String
escape String
s'
        

poEntry :: Loc -> String -> [String]
poEntry :: Loc -> String -> [String]
poEntry Loc
loc String
msg = [
      String
"",
      String
"#: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Loc -> String
loc_filename Loc
loc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":0", -- TODO line nr or char pos
      String
"msgid " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
quote String
msg,
      String
"msgstr " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
quote String
msg 
      ]

gettextsDecs  :: String -> Q [Dec]
gettextsDecs :: String -> Q [Dec]
gettextsDecs String
str = do
  let msgs :: [(String, String)]
msgs = (String -> (String, String)) -> [String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map String -> (String, String)
splitKeyMsg ([String] -> [(String, String)]) -> [String] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ String -> [String]
parseLines String
str  
  Set String
kmsgs <- IO (Set String) -> Q (Set String)
forall a. IO a -> Q a
runIO (IO (Set String) -> Q (Set String))
-> IO (Set String) -> Q (Set String)
forall a b. (a -> b) -> a -> b
$ do
     Set String
kmsgs <- IORef (Set String) -> IO (Set String)
forall a. IORef a -> IO a
readIORef IORef (Set String)
knownMsgs
     IORef (Set String) -> Set String -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Set String)
knownMsgs ((Set String -> (String, String) -> Set String)
-> Set String -> [(String, String)] -> Set String
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ Set String
acc (String
_, String
msg) -> String
msg String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
`S.insert` Set String
acc) Set String
kmsgs [(String, String)]
msgs)
     Set String -> IO (Set String)
forall (m :: * -> *) a. Monad m => a -> m a
return Set String
kmsgs
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Set String -> Bool
forall a. Set a -> Bool
S.null Set String
kmsgs) Q ()
createPotFile
  Loc
loc <- Q Loc
location

  IO () -> Q ()
forall a. IO a -> Q a
runIO (IO () -> Q ()) -> IO () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> IOMode -> String -> IO ()
writeFileUtf8 String
potFileName IOMode
AppendMode (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ Loc -> String -> [String]
poEntry Loc
loc String
msg | (String
_, String
msg) <- [(String, String)]
msgs, String
msg String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set String
kmsgs ]    

  [(String, String)] -> ((String, String) -> Q Dec) -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(String, String)]
msgs (((String, String) -> Q Dec) -> Q [Dec])
-> ((String, String) -> Q Dec) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \ (String
key, String
msg) ->
              let trans :: Text
trans = Text -> Text
TL.toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Catalog -> ByteString -> Text
G.gettext Catalog
catalog (String -> ByteString
packStr String
msg) in do
                 Name -> [ClauseQ] -> Q Dec
funD (String -> Name
mkName String
key) [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (Q Exp -> BodyQ
normalB [| trans |]) []]
                 

         

parseLines :: String -> [String]
parseLines :: String -> [String]
parseLines String
text = [String] -> [String] -> [String]
go [] (String -> [String]
lines String
text)
   where go :: [String] -> [String] -> [String]
go [String]
acc [] = [String] -> [String]
forall a. [a] -> [a]
reverse [String]
acc
         go [String]
acc ((Char
'#':String
_):[String]
lines') = [String] -> [String] -> [String]
go [String]
acc [String]
lines'
         go [String]
acc (String
line:[String]
lines') =
           if (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
line then [String] -> [String] -> [String]
go [String]
acc [String]
lines'
             else ([String] -> [String]) -> [String] -> [String] -> [String]
collect ([String] -> [String] -> [String]
join [String]
acc) [String
line] [String]
lines'
         collect :: ([String] -> [String]) -> [String] -> [String] -> [String]
         collect :: ([String] -> [String]) -> [String] -> [String] -> [String]
collect [String] -> [String]
j [String]
cl [] = [String] -> [String] -> [String]
go ([String] -> [String]
j [String]
cl) []
         collect [String] -> [String]
j [String]
cl ([]:[String]
t) = [String] -> [String] -> [String]
go ([String] -> [String]
j [String]
cl) [String]
t
         collect [String] -> [String]
j [String]
cl lines' :: [String]
lines'@((Char
c:String
d):[String]
t) =
                   if Char -> Bool
isSpace Char
c then ([String] -> [String]) -> [String] -> [String] -> [String]
collect [String] -> [String]
j (((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
d)String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
cl) [String]
t
                     else [String] -> [String] -> [String]
go ([String] -> [String]
j [String]
cl) [String]
lines'
         join :: [String] -> [String] -> [String]
join [String]
acc [String]
cl = (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
reverse [String]
cl)String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
acc

splitKeyMsg :: String -> (String, String)        
splitKeyMsg :: String -> (String, String)
splitKeyMsg String
line =  (String -> String)
-> (String -> String) -> (String, String) -> (String, String)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap String -> String
trim (String -> String
trim (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
tail) ((String, String) -> (String, String))
-> (String, String) -> (String, String)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') String
line 
  

trim :: String -> String
trim :: String -> String
trim = String -> String
f (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
f
   where f :: String -> String
f = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace


gettext :: QuasiQuoter
gettext :: QuasiQuoter
gettext = QuasiQuoter :: (String -> Q Exp)
-> (String -> PatQ)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp  = String -> Q Exp
gettextQ
  , quotePat :: String -> PatQ
quotePat  = String -> String -> PatQ
forall a. HasCallStack => String -> a
error String
"Usage as a pattern is not supported"
  , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"Usage as a type is not supported"
  , quoteDec :: String -> Q [Dec]
quoteDec = String -> Q [Dec]
gettextsDecs
  }

__ :: QuasiQuoter
__ :: QuasiQuoter
__ = QuasiQuoter
gettext