361 lines
13 KiB
Haskell
Executable File
361 lines
13 KiB
Haskell
Executable File
#!/usr/bin/env stack
|
|
|
|
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
-- stack runghc --package unordered-containers --package text --package editor-open --package cmdargs --package pointedlist --package filepath --package temporary --package directory --package process --package exceptions
|
|
|
|
{-# OPTIONS_GHC -fno-warn-missing-fields #-}
|
|
|
|
{-# LANGUAGE OverloadedStrings
|
|
, ViewPatterns
|
|
, NamedFieldPuns
|
|
, RecordWildCards
|
|
, TemplateHaskell
|
|
, DeriveGeneric, DeriveDataTypeable
|
|
, MagicHash
|
|
, MultiWayIf
|
|
#-}
|
|
|
|
import Data.Text (Text)
|
|
import qualified Data.Text.IO as Text
|
|
import qualified Data.Text as Text
|
|
|
|
import Data.HashSet (HashSet)
|
|
import qualified Data.HashSet as HashSet
|
|
|
|
import Data.HashMap.Strict (HashMap)
|
|
import qualified Data.HashMap.Strict as HashMap
|
|
|
|
import Text.Editor (Template, mkTemplate, userEditorDefault, _default_editor)
|
|
|
|
import Numeric.Natural
|
|
|
|
import System.Environment (getArgs)
|
|
|
|
import Control.Monad
|
|
import Control.Arrow
|
|
import Data.Maybe
|
|
import Data.List
|
|
import Data.List.PointedList (PointedList)
|
|
import qualified Data.List.PointedList as P
|
|
|
|
import System.Console.CmdArgs.Implicit
|
|
import System.Console.CmdArgs.Quote
|
|
|
|
import Data.Foldable
|
|
|
|
import Data.Data (Data)
|
|
import GHC.Generics (Generic)
|
|
-- import Data.Typeable (Typeable)
|
|
|
|
import System.FilePath hiding (combine)
|
|
import System.Directory
|
|
import System.Process
|
|
|
|
import System.IO
|
|
import System.Exit
|
|
import System.IO.Temp (withSystemTempFile, writeSystemTempFile)
|
|
import System.IO.Error
|
|
|
|
import Data.Ord (Down(..))
|
|
|
|
import Control.Monad.Catch
|
|
|
|
import Data.Containers.ListUtils
|
|
|
|
|
|
data Translate
|
|
= TranslateMsgs
|
|
{ msgFiles :: [FilePath]
|
|
, msgOnlyLang :: Bool
|
|
, msgRequiredLangs :: [String]
|
|
}
|
|
| TranslateI18nDirectory
|
|
{ i18nDir :: FilePath
|
|
, i18nOnlyLang :: Bool
|
|
, i18nRequiredLangs :: [String]
|
|
, i18nSourceLangs :: [String]
|
|
}
|
|
deriving (Eq, Ord, Read, Show, Generic, Data)
|
|
|
|
$(cmdArgsQuote [d|
|
|
messages = TranslateMsgs
|
|
{ msgFiles = [] &=# args
|
|
&=# typFile
|
|
, msgOnlyLang = True
|
|
&=# name "only-lang"
|
|
&=# help "Should only the language compononent (en, de, ...) be considered?"
|
|
, msgRequiredLangs = []
|
|
&=# name "required"
|
|
&=# help "Which languages are required to exist?"
|
|
&=# typ "LANG"
|
|
}
|
|
i18n = TranslateI18nDirectory
|
|
{ i18nDir = def &=# argPos 0
|
|
&=# typDir
|
|
, i18nOnlyLang = True
|
|
&=# name "only-lang"
|
|
&=# help "Should only the language compononent (en, de, ...) be considered?"
|
|
, i18nRequiredLangs = []
|
|
&=# name "required"
|
|
&=# help "Which languages are required to exist?"
|
|
&=# typ "LANG"
|
|
, i18nSourceLangs = []
|
|
&=# name "source"
|
|
&=# help "Preference order for source of translation"
|
|
&=# typ "LANG"
|
|
}
|
|
|
|
run = cmdArgs# (modes# [ messages &=# auto &=# name "msgs"
|
|
, i18n &=# name "dir"
|
|
]) :: IO Translate
|
|
|])
|
|
|
|
|
|
type LineNumber = Natural
|
|
type MsgName = Text
|
|
type ArgName = Text
|
|
type ArgType = Text
|
|
|
|
data MsgDefinition = MsgDefinition
|
|
{ msgName :: MsgName
|
|
, msgArgs :: [(ArgName, Maybe ArgType)]
|
|
, msgTrans :: Text
|
|
}
|
|
|
|
data MsgFile = MsgFile
|
|
{ msgFile :: FilePath
|
|
, msgDefinitions :: [MsgDefinition]
|
|
, msgNames :: HashSet MsgName
|
|
}
|
|
|
|
|
|
main :: IO ()
|
|
main = main' =<< run
|
|
where
|
|
main' m@TranslateMsgs{..}
|
|
| null msgRequiredLangs = main' m{ msgRequiredLangs = ["de-de-formal", "en-eu"] }
|
|
| otherwise = do
|
|
msgFiles' <- nubOrd . (msgFiles ++) <$> getMissingFiles m
|
|
|
|
let
|
|
filePairs :: [(FilePath, FilePath)]
|
|
filePairs = concat $ zipWith (fmap . (,)) msgFiles (tail $ tails msgFiles')
|
|
mapM_ (\(f1, f2) -> join $ combine <$> readMsgFile f1 <*> readMsgFile f2) filePairs
|
|
main' m@TranslateI18nDirectory{..}
|
|
| null i18nRequiredLangs = main' m{ i18nRequiredLangs = ["de-de-formal", "en-eu"] }
|
|
| null i18nSourceLangs = main' m{ i18nSourceLangs = ["de-de-formal"] }
|
|
| otherwise = do
|
|
missing <- getMissingFiles m
|
|
forM_ missing $ \missing' -> do
|
|
translateSource <- getTranslateSource m missing'
|
|
case translateSource of
|
|
Just src -> translateFrom src missing'
|
|
Nothing -> do
|
|
hPutStrLn stderr "Could not determine translation source."
|
|
exitWith $ ExitFailure 1
|
|
|
|
|
|
readMsgFile :: FilePath -> IO MsgFile
|
|
readMsgFile f = catchIf isDoesNotExistError readMsgFile' . const . return $ MsgFile f mempty mempty
|
|
where readMsgFile' = readMsgText f <$> Text.readFile f
|
|
|
|
readMsgText :: FilePath -> Text -> MsgFile
|
|
readMsgText f (Text.lines -> ls) =
|
|
let defs = mapMaybe readMsgLine ls
|
|
names = HashSet.fromList $ map msgName defs
|
|
in MsgFile
|
|
{ msgFile = f
|
|
, msgDefinitions = defs
|
|
, msgNames = names
|
|
}
|
|
|
|
readMsgLine :: Text -> Maybe MsgDefinition
|
|
readMsgLine l = do
|
|
guard . not $ "#" `Text.isPrefixOf` l
|
|
let
|
|
(msgPrefix, trans) = Text.breakOn ":" l
|
|
parts = filter (not . Text.null) $ Text.splitOn " " msgPrefix
|
|
parseArg arg = (argName, Text.stripPrefix "@" argType)
|
|
where
|
|
(argName, argType) = Text.breakOn "@" arg
|
|
if | msgName : args <- parts
|
|
-> do
|
|
t <- Text.stripPrefix ":" trans
|
|
return MsgDefinition
|
|
{ msgName
|
|
, msgArgs = map parseArg args
|
|
, msgTrans = Text.strip t
|
|
}
|
|
| otherwise
|
|
-> Nothing
|
|
|
|
|
|
computeMissing :: MsgFile -> MsgFile -> [MsgDefinition]
|
|
computeMissing f1 f2 = filter f $ msgDefinitions f1
|
|
where f MsgDefinition{..} = not $ msgName `HashSet.member` msgNames f2
|
|
|
|
renderMsg :: MsgDefinition -> Text
|
|
renderMsg MsgDefinition{..} = (<> (": " <> msgTrans)) . Text.unwords $
|
|
[ msgName ] ++
|
|
[ argName <> maybe Text.empty ("@" <>) mArgType
|
|
| (argName, mArgType) <- msgArgs
|
|
]
|
|
|
|
insertIntoFile :: MsgFile -> MsgFile -> MsgFile -> IO ()
|
|
insertIntoFile target reference source = do
|
|
let getLines = fmap (P.fromListEnd . Text.lines) . Text.readFile
|
|
|
|
forM_ (msgDefinitions source) $ \msgDef -> do
|
|
targetLines <- catchIf isDoesNotExistError (getLines $ msgFile target) . const $ return Nothing
|
|
referenceLines <- getLines $ msgFile reference
|
|
|
|
case toList <$> targetLines of
|
|
Just lines -> do
|
|
let template = takeFileName (msgFile target) <.> Text.unpack (msgName msgDef) <.> "..bak"
|
|
void . writeSystemTempFile template . Text.unpack $ Text.unlines lines
|
|
Nothing -> return ()
|
|
|
|
let -- fName = "/tmp" </> takeFileName (msgFile target) <.> Text.unpack (msgName msgDef)
|
|
fName = msgFile target
|
|
Text.writeFile fName . Text.unlines $ if
|
|
| Just targetLines' <- targetLines
|
|
, Just referenceLines' <- referenceLines
|
|
-> toList $ insertInto targetLines' referenceLines' msgDef
|
|
| otherwise
|
|
-> renderMsg msgDef : maybe [] toList targetLines
|
|
where
|
|
insertInto ts rs msgDef
|
|
= let rs' = focusDef rs
|
|
where focusDef rs
|
|
| Just f <- readMsgLine $ P._focus rs
|
|
, msgName f == msgName msgDef
|
|
= rs
|
|
| otherwise
|
|
= maybe rs focusDef $ P.previous rs
|
|
ts' = alignFocus 0 ts rs'
|
|
where alignFocus off cts crs
|
|
| Just rp <- P.previous crs
|
|
, Just rdef <- readMsgLine $ P._focus rp
|
|
, Just tdef <- readMsgLine $ P._focus cts
|
|
= if | msgName tdef /= msgName rdef
|
|
, Just nts <- P.previous cts
|
|
-> alignFocus off nts crs
|
|
| msgName tdef /= msgName rdef
|
|
, Just nrs <- P.previous crs
|
|
-> alignFocus 0 ts nrs
|
|
| otherwise
|
|
-> insertOffset off cts crs
|
|
| Just nrs <- P.previous crs
|
|
, Just _ <- readMsgLine $ P._focus cts
|
|
= alignFocus (succ off) cts nrs
|
|
| Just nts <- P.previous cts
|
|
= alignFocus off nts crs
|
|
| otherwise
|
|
= P.insertRight (renderMsg msgDef) ts
|
|
insertOffset 0 cts _ = P.insertRight (renderMsg msgDef) cts
|
|
insertOffset n cts crs
|
|
| Just nrs <- P.next crs
|
|
= insertOffset (pred n) (P.insertRight (P._focus crs) cts) nrs
|
|
| otherwise
|
|
= P.insertRight (renderMsg msgDef) cts
|
|
in ts'
|
|
|
|
combine :: MsgFile -> MsgFile -> IO ()
|
|
combine f1 f2 = insertMissing f1 f2 >> insertMissing f2 f1
|
|
where
|
|
insertMissing :: MsgFile -> MsgFile -> IO ()
|
|
insertMissing f1' f2' = do
|
|
let missing = computeMissing f1' f2'
|
|
header = Text.unlines
|
|
[ "# Translate from: " <> Text.pack (msgFile f1')
|
|
, "# Target: " <> Text.pack (msgFile f2')
|
|
]
|
|
query = (Text.unlines . (header :) . pure) . Text.unlines $ map renderMsg missing
|
|
unless (null missing) $ do
|
|
response <- runUserEditor (mkTemplate "msg") query
|
|
let responseMsgs = readMsgText "" response
|
|
responseMsgs' = responseMsgs { msgDefinitions = map stripTypes $ msgDefinitions responseMsgs }
|
|
stripTypes defn = defn { msgArgs = map (\(n, _) -> (n, Nothing)) $ msgArgs defn }
|
|
insertIntoFile f2' f1' responseMsgs'
|
|
|
|
|
|
normalizeLang :: Bool -> String -> String
|
|
normalizeLang onlyLang
|
|
| onlyLang = fst . break (== '-')
|
|
| otherwise = id
|
|
|
|
getLang :: Bool -> FilePath -> String
|
|
getLang onlyLang = normalizeLang onlyLang . Text.unpack . last . Text.splitOn "." . Text.pack . dropExtension . takeFileName
|
|
|
|
replaceLang :: FilePath -> String -> FilePath
|
|
replaceLang reference l = takeDirectory reference </> withPrefix l <.> takeExtension reference
|
|
where prefix = getPrefix reference
|
|
withPrefix | not $ null prefix = (prefix <.>)
|
|
| otherwise = id
|
|
|
|
getPrefix :: FilePath -> String
|
|
getPrefix = Text.unpack . Text.intercalate "." . init . Text.splitOn "." . Text.pack . dropExtension . takeFileName
|
|
|
|
getFiles :: FilePath -> IO [FilePath]
|
|
getFiles dir = filterM doesFileExist . map (dir </>) =<< listDirectory dir
|
|
|
|
getTranslateSource :: Translate -> FilePath -> IO (Maybe FilePath)
|
|
getTranslateSource TranslateI18nDirectory{..} missing = do
|
|
fs <- getFiles i18nDir
|
|
let fs' = sortOn (\(getLang i18nOnlyLang -> l) -> Down . elemIndex l . reverse $ map (normalizeLang i18nOnlyLang) i18nSourceLangs)
|
|
[ f
|
|
| f <- fs
|
|
, getPrefix f == getPrefix missing
|
|
, takeExtension f == takeExtension missing
|
|
]
|
|
return $ listToMaybe fs'
|
|
|
|
getMissingFiles :: Translate -> IO [FilePath]
|
|
getMissingFiles TranslateI18nDirectory{..} = do
|
|
fs <- getFiles i18nDir
|
|
|
|
let
|
|
exts :: HashMap (String, String) [FilePath]
|
|
exts = HashMap.fromListWith (<>) $ map ((getPrefix &&& takeExtension) &&& pure) fs
|
|
|
|
return . flip concatMap exts $ \refs@(r : _) ->
|
|
let ls :: [String]
|
|
ls = map (getLang i18nOnlyLang) refs
|
|
missing :: [String]
|
|
missing = filter (\l -> not $ any (== normalizeLang i18nOnlyLang l) ls) i18nRequiredLangs
|
|
in map (replaceLang r) missing
|
|
getMissingFiles TranslateMsgs{..} = do
|
|
fs <- concat <$> mapM getFiles (map takeDirectory msgFiles)
|
|
|
|
let
|
|
exts :: HashMap String [FilePath]
|
|
exts = HashMap.fromListWith (<>) $ map (takeExtension &&& pure) fs
|
|
|
|
return . flip concatMap exts $ \refs@(r : _) ->
|
|
let ls :: [String]
|
|
ls = map (getLang msgOnlyLang) refs
|
|
missing :: [String]
|
|
missing = filter (\l -> not $ any (== normalizeLang msgOnlyLang l) ls) msgRequiredLangs
|
|
in map (replaceLang r) missing
|
|
|
|
|
|
translateFrom :: FilePath -> FilePath -> IO ()
|
|
translateFrom from to = do
|
|
editor <- userEditorDefault _default_editor
|
|
flip onError (removeFile to) $ do
|
|
copyFile from to
|
|
callProcess editor [to]
|
|
|
|
|
|
runUserEditor :: Template -> Text -> IO Text
|
|
runUserEditor templ initialContents = withSystemTempFile templ $ \filePath hdl -> do
|
|
editor <- userEditorDefault _default_editor
|
|
hSetBuffering hdl NoBuffering
|
|
Text.hPutStr hdl initialContents
|
|
hClose hdl
|
|
callProcess editor [filePath]
|
|
Text.readFile filePath
|