fradrive/translate.hs

#!/usr/bin/env stack
-- 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, Typeable, 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