module I18N.Gettext.TH
(gettext, __)
where

import Language.Haskell.TH
import Language.Haskell.TH.Quote
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 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 :: IORef Bool
firstCall = IO (IORef Bool) -> IORef Bool
forall a. IO a -> a
unsafePerformIO (IO (IORef Bool) -> IORef Bool) -> IO (IORef Bool) -> IORef Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
True

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


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

moFileName :: FilePath
moFileName :: FilePath
moFileName = FilePath -> FilePath -> FilePath
replaceExtension FilePath
potFileName FilePath
".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
$ FilePath -> IO Catalog
loadCatalog FilePath
moFileName


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

createPotFile :: Q ()
createPotFile :: Q ()
createPotFile = do
  IO () -> Q ()
forall a. IO a -> Q a
runIO (IO () -> Q ()) -> IO () -> Q ()
forall a b. (a -> b) -> a -> b
$ do
    Bool
f <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
firstCall
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
f (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
firstCall Bool
False
      Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
potFileName)
      Bool
potE <- FilePath -> IO Bool
doesFileExist FilePath
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
$
        FilePath -> FilePath -> IO ()
renameFile FilePath
potFileName (FilePath
potFileName FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
".bak")

      FilePath -> FilePath -> IO ()
writeFile FilePath
potFileName FilePath
header
    --addDependentFile poFileName


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


gettextQ  :: String -> Q Exp
gettextQ :: FilePath -> Q Exp
gettextQ FilePath
str = do
  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
$ FilePath -> FilePath -> IO ()
appendFile FilePath
potFileName (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ Loc -> FilePath -> [FilePath]
poEntry Loc
loc FilePath
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 (FilePath -> ByteString
packStr FilePath
str)
  [| trans |]


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

gettextsDecs  :: String -> Q [Dec]
gettextsDecs :: FilePath -> Q [Dec]
gettextsDecs FilePath
str = do
  Q ()
createPotFile
  Loc
loc <- Q Loc
location
  let msgs :: [(FilePath, FilePath)]
msgs = (FilePath -> (FilePath, FilePath))
-> [FilePath] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> (FilePath, FilePath)
splitKeyMsg ([FilePath] -> [(FilePath, FilePath)])
-> [FilePath] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
parseLines FilePath
str  
  IO () -> Q ()
forall a. IO a -> Q a
runIO (IO () -> Q ()) -> IO () -> Q ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
appendFile FilePath
potFileName (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ Loc -> FilePath -> [FilePath]
poEntry Loc
loc FilePath
msg | (FilePath
_, FilePath
msg) <- [(FilePath, FilePath)]
msgs ]    

  [(FilePath, FilePath)]
-> ((FilePath, FilePath) -> Q Dec) -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(FilePath, FilePath)]
msgs (((FilePath, FilePath) -> Q Dec) -> Q [Dec])
-> ((FilePath, FilePath) -> Q Dec) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \ (FilePath
key, FilePath
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 (FilePath -> ByteString
packStr FilePath
msg) in do
                 Exp
e <-  [| trans |]
                 Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD (FilePath -> Name
mkName FilePath
key) [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
e) []]
                 

         

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

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

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


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

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