deepl-0.1.0.0: src/DeepL.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-cse #-}

module DeepL where

import Config (Config (..))
import qualified Control.Foldl as L
import Control.Lens (lmap, (^?), _head)
import Control.Monad.Trans.Resource (register, runResourceT)
import Data.Aeson.Lens
  ( AsPrimitive (_String)
  , AsValue (_Array)
  , key
  )
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B
import Network.Wreq (FormParam ((:=)), post, responseBody)
import Protolude
import Streaming (Of (..), Stream, effect, inspect, wrap)
import qualified Streaming.ByteString.Char8 as SB
import qualified Streaming.Prelude as S
import System.IO (hClose, openBinaryFile)

defaultDeepL :: Config -> Text -> IO Text
defaultDeepL config x = fromMaybe x <$> deepL config x

deepL :: Config -> Text -> IO (Maybe Text)
deepL Config {..} x = do
  r <-
    post
      "https://api.deepl.com/v2/translate"
      [ "auth_key" := token
      , "text" := x
      , "target_lang" := lang
      ]
  pure $
    r
      ^? responseBody
        . key "translations"
        . _Array
        . _head
        . key "text"
        . _String

limit :: Int
limit = 30_000

translateFile :: Config -> IO ()
translateFile config@Config {..} = runResourceT $ do
  handleIn <- case input of
    "" -> pure stdin
    filePath -> do
      h <- liftIO $ openBinaryFile filePath ReadMode
      register $ hClose h
      pure h
  handleOut <- case output of
    "" -> pure stdout
    filePath -> do
      h <- liftIO $ openBinaryFile filePath WriteMode
      register $ hClose h
      pure h
  SB.toHandle handleOut
    . SB.unlines
    . S.maps (\(x :> r) -> r <$ SB.fromStrict (B.init x))
    . S.mapped do
      \s -> do
        rs :> rest <- S.toList s
        z <- liftIO $ defaultDeepL config $ decodeUtf8 . B.unlines . fmap fst $ rs
        pure $ encodeUtf8 z :> rest
    . breaker
    . S.map
      do \v -> (v, B.length v)
    . S.mapped SB.toStrict
    . SB.lines
    $ SB.fromHandle handleIn

breaker
  :: Monad m
  => Stream (Of (ByteString, Int)) m r
  -> Stream (Stream (Of (ByteString, Int)) m) m r
breaker s = effect $ do
  x <- inspect s
  pure $ case x of
    Left r -> pure r
    Right q -> wrap $ fmap breaker $ step $ wrap q

step
  :: Monad m
  => Stream (Of (ByteString, Int)) m r
  -> Stream (Of (ByteString, Int)) m (Stream (Of (ByteString, Int)) m r)
step = L.purely S.breakWhen (lmap snd L.sum) (> limit)