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 Control.Exception (catch, IOException)

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"


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

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
header :: [Char]
header = [[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", -- TODO line nr or char pos
      [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