{-# 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 -> Text -> IO Text
defaultDeepL Config
config Text
x = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
x (Maybe Text -> Text) -> IO (Maybe Text) -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> Text -> IO (Maybe Text)
deepL Config
config Text
x

deepL :: Config -> Text -> IO (Maybe Text)
deepL :: Config -> Text -> IO (Maybe Text)
deepL Config {FilePath
Text
lang :: Config -> Text
output :: Config -> FilePath
input :: Config -> FilePath
token :: Config -> Text
lang :: Text
output :: FilePath
input :: FilePath
token :: Text
..} Text
x = do
  Response ByteString
r <-
    FilePath -> [FormParam] -> IO (Response ByteString)
forall a. Postable a => FilePath -> a -> IO (Response ByteString)
post
      FilePath
"https://api.deepl.com/v2/translate"
      [ ByteString
"auth_key" ByteString -> Text -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= Text
token
      , ByteString
"text" ByteString -> Text -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= Text
x
      , ByteString
"target_lang" ByteString -> Text -> FormParam
forall v. FormValue v => ByteString -> v -> FormParam
:= Text
lang
      ]
  Maybe Text -> IO (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$
    Response ByteString
r
      Response ByteString
-> Getting (First Text) (Response ByteString) Text -> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? (ByteString -> Const (First Text) ByteString)
-> Response ByteString -> Const (First Text) (Response ByteString)
forall body0 body1.
Lens (Response body0) (Response body1) body0 body1
responseBody
        ((ByteString -> Const (First Text) ByteString)
 -> Response ByteString -> Const (First Text) (Response ByteString))
-> ((Text -> Const (First Text) Text)
    -> ByteString -> Const (First Text) ByteString)
-> Getting (First Text) (Response ByteString) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Traversal' ByteString Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"translations"
        ((Value -> Const (First Text) Value)
 -> ByteString -> Const (First Text) ByteString)
-> ((Text -> Const (First Text) Text)
    -> Value -> Const (First Text) Value)
-> (Text -> Const (First Text) Text)
-> ByteString
-> Const (First Text) ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector Value -> Const (First Text) (Vector Value))
-> Value -> Const (First Text) Value
forall t. AsValue t => Prism' t (Vector Value)
_Array
        ((Vector Value -> Const (First Text) (Vector Value))
 -> Value -> Const (First Text) Value)
-> ((Text -> Const (First Text) Text)
    -> Vector Value -> Const (First Text) (Vector Value))
-> (Text -> Const (First Text) Text)
-> Value
-> Const (First Text) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Const (First Text) Value)
-> Vector Value -> Const (First Text) (Vector Value)
forall s a. Cons s s a a => Traversal' s a
_head
        ((Value -> Const (First Text) Value)
 -> Vector Value -> Const (First Text) (Vector Value))
-> ((Text -> Const (First Text) Text)
    -> Value -> Const (First Text) Value)
-> (Text -> Const (First Text) Text)
-> Vector Value
-> Const (First Text) (Vector Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"text"
        ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> ((Text -> Const (First Text) Text)
    -> Value -> Const (First Text) Value)
-> (Text -> Const (First Text) Text)
-> Value
-> Const (First Text) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (First Text) Text)
-> Value -> Const (First Text) Value
forall t. AsPrimitive t => Prism' t Text
_String

limit :: Int
limit :: Int
limit = Int
30_000

translateFile :: Config -> IO ()
translateFile :: Config -> IO ()
translateFile config :: Config
config@Config {FilePath
Text
lang :: Text
output :: FilePath
input :: FilePath
token :: Text
lang :: Config -> Text
output :: Config -> FilePath
input :: Config -> FilePath
token :: Config -> Text
..} = ResourceT IO () -> IO ()
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO () -> IO ()) -> ResourceT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Handle
handleIn <- case FilePath
input of
    FilePath
"" -> Handle -> ResourceT IO Handle
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
stdin
    FilePath
filePath -> do
      Handle
h <- IO Handle -> ResourceT IO Handle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handle -> ResourceT IO Handle)
-> IO Handle -> ResourceT IO Handle
forall a b. (a -> b) -> a -> b
$ FilePath -> IOMode -> IO Handle
openBinaryFile FilePath
filePath IOMode
ReadMode
      IO () -> ResourceT IO ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
register (IO () -> ResourceT IO ReleaseKey)
-> IO () -> ResourceT IO ReleaseKey
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
h
      Handle -> ResourceT IO Handle
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
h
  Handle
handleOut <- case FilePath
output of
    FilePath
"" -> Handle -> ResourceT IO Handle
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
stdout
    FilePath
filePath -> do
      Handle
h <- IO Handle -> ResourceT IO Handle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handle -> ResourceT IO Handle)
-> IO Handle -> ResourceT IO Handle
forall a b. (a -> b) -> a -> b
$ FilePath -> IOMode -> IO Handle
openBinaryFile FilePath
filePath IOMode
WriteMode
      IO () -> ResourceT IO ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
register (IO () -> ResourceT IO ReleaseKey)
-> IO () -> ResourceT IO ReleaseKey
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
h
      Handle -> ResourceT IO Handle
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
h
  Handle -> ByteStream (ResourceT IO) () -> ResourceT IO ()
forall (m :: * -> *) r.
MonadIO m =>
Handle -> ByteStream m r -> m r
SB.toHandle Handle
handleOut
    (ByteStream (ResourceT IO) () -> ResourceT IO ())
-> (ByteStream (ResourceT IO) () -> ByteStream (ResourceT IO) ())
-> ByteStream (ResourceT IO) ()
-> ResourceT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream (ByteStream (ResourceT IO)) (ResourceT IO) ()
-> ByteStream (ResourceT IO) ()
forall (m :: * -> *) r.
Monad m =>
Stream (ByteStream m) m r -> ByteStream m r
SB.unlines
    (Stream (ByteStream (ResourceT IO)) (ResourceT IO) ()
 -> ByteStream (ResourceT IO) ())
-> (ByteStream (ResourceT IO) ()
    -> Stream (ByteStream (ResourceT IO)) (ResourceT IO) ())
-> ByteStream (ResourceT IO) ()
-> ByteStream (ResourceT IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. Of ByteString x -> ByteStream (ResourceT IO) x)
-> Stream (Of ByteString) (ResourceT IO) ()
-> Stream (ByteStream (ResourceT IO)) (ResourceT IO) ()
forall (m :: * -> *) (f :: * -> *) (g :: * -> *) r.
(Monad m, Functor f) =>
(forall x. f x -> g x) -> Stream f m r -> Stream g m r
S.maps (\(x :> r) -> x
r x -> ByteStream (ResourceT IO) () -> ByteStream (ResourceT IO) x
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> ByteStream (ResourceT IO) ()
forall (m :: * -> *). ByteString -> ByteStream m ()
SB.fromStrict (ByteString -> ByteString
B.init ByteString
x))
    (Stream (Of ByteString) (ResourceT IO) ()
 -> Stream (ByteStream (ResourceT IO)) (ResourceT IO) ())
-> (ByteStream (ResourceT IO) ()
    -> Stream (Of ByteString) (ResourceT IO) ())
-> ByteStream (ResourceT IO) ()
-> Stream (ByteStream (ResourceT IO)) (ResourceT IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x.
 Stream (Of (ByteString, Int)) (ResourceT IO) x
 -> ResourceT IO (Of ByteString x))
-> Stream
     (Stream (Of (ByteString, Int)) (ResourceT IO)) (ResourceT IO) ()
-> Stream (Of ByteString) (ResourceT IO) ()
forall (m :: * -> *) (f :: * -> *) (g :: * -> *) r.
(Monad m, Functor f) =>
(forall x. f x -> m (g x)) -> Stream f m r -> Stream g m r
S.mapped do
      \Stream (Of (ByteString, Int)) (ResourceT IO) x
s -> do
        [(ByteString, Int)]
rs :> x
rest <- Stream (Of (ByteString, Int)) (ResourceT IO) x
-> ResourceT IO (Of [(ByteString, Int)] x)
forall (m :: * -> *) a r.
Monad m =>
Stream (Of a) m r -> m (Of [a] r)
S.toList Stream (Of (ByteString, Int)) (ResourceT IO) x
s
        Text
z <- IO Text -> ResourceT IO Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ResourceT IO Text) -> IO Text -> ResourceT IO Text
forall a b. (a -> b) -> a -> b
$ Config -> Text -> IO Text
defaultDeepL Config
config (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> ([(ByteString, Int)] -> ByteString)
-> [(ByteString, Int)]
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
B.unlines ([ByteString] -> ByteString)
-> ([(ByteString, Int)] -> [ByteString])
-> [(ByteString, Int)]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, Int) -> ByteString)
-> [(ByteString, Int)] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString, Int) -> ByteString
forall a b. (a, b) -> a
fst ([(ByteString, Int)] -> Text) -> [(ByteString, Int)] -> Text
forall a b. (a -> b) -> a -> b
$ [(ByteString, Int)]
rs
        Of ByteString x -> ResourceT IO (Of ByteString x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Of ByteString x -> ResourceT IO (Of ByteString x))
-> Of ByteString x -> ResourceT IO (Of ByteString x)
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
z ByteString -> x -> Of ByteString x
forall a b. a -> b -> Of a b
:> x
rest
    (Stream
   (Stream (Of (ByteString, Int)) (ResourceT IO)) (ResourceT IO) ()
 -> Stream (Of ByteString) (ResourceT IO) ())
-> (ByteStream (ResourceT IO) ()
    -> Stream
         (Stream (Of (ByteString, Int)) (ResourceT IO)) (ResourceT IO) ())
-> ByteStream (ResourceT IO) ()
-> Stream (Of ByteString) (ResourceT IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream (Of (ByteString, Int)) (ResourceT IO) ()
-> Stream
     (Stream (Of (ByteString, Int)) (ResourceT IO)) (ResourceT IO) ()
forall (m :: * -> *) r.
Monad m =>
Stream (Of (ByteString, Int)) m r
-> Stream (Stream (Of (ByteString, Int)) m) m r
breaker
    (Stream (Of (ByteString, Int)) (ResourceT IO) ()
 -> Stream
      (Stream (Of (ByteString, Int)) (ResourceT IO)) (ResourceT IO) ())
-> (ByteStream (ResourceT IO) ()
    -> Stream (Of (ByteString, Int)) (ResourceT IO) ())
-> ByteStream (ResourceT IO) ()
-> Stream
     (Stream (Of (ByteString, Int)) (ResourceT IO)) (ResourceT IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> (ByteString, Int))
-> Stream (Of ByteString) (ResourceT IO) ()
-> Stream (Of (ByteString, Int)) (ResourceT IO) ()
forall (m :: * -> *) a b r.
Monad m =>
(a -> b) -> Stream (Of a) m r -> Stream (Of b) m r
S.map
      do \ByteString
v -> (ByteString
v, ByteString -> Int
B.length ByteString
v)
    (Stream (Of ByteString) (ResourceT IO) ()
 -> Stream (Of (ByteString, Int)) (ResourceT IO) ())
-> (ByteStream (ResourceT IO) ()
    -> Stream (Of ByteString) (ResourceT IO) ())
-> ByteStream (ResourceT IO) ()
-> Stream (Of (ByteString, Int)) (ResourceT IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x.
 ByteStream (ResourceT IO) x -> ResourceT IO (Of ByteString x))
-> Stream (ByteStream (ResourceT IO)) (ResourceT IO) ()
-> Stream (Of ByteString) (ResourceT IO) ()
forall (m :: * -> *) (f :: * -> *) (g :: * -> *) r.
(Monad m, Functor f) =>
(forall x. f x -> m (g x)) -> Stream f m r -> Stream g m r
S.mapped forall x.
ByteStream (ResourceT IO) x -> ResourceT IO (Of ByteString x)
forall (m :: * -> *) r.
Monad m =>
ByteStream m r -> m (Of ByteString r)
SB.toStrict
    (Stream (ByteStream (ResourceT IO)) (ResourceT IO) ()
 -> Stream (Of ByteString) (ResourceT IO) ())
-> (ByteStream (ResourceT IO) ()
    -> Stream (ByteStream (ResourceT IO)) (ResourceT IO) ())
-> ByteStream (ResourceT IO) ()
-> Stream (Of ByteString) (ResourceT IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteStream (ResourceT IO) ()
-> Stream (ByteStream (ResourceT IO)) (ResourceT IO) ()
forall (m :: * -> *) r.
Monad m =>
ByteStream m r -> Stream (ByteStream m) m r
SB.lines
    (ByteStream (ResourceT IO) () -> ResourceT IO ())
-> ByteStream (ResourceT IO) () -> ResourceT IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteStream (ResourceT IO) ()
forall (m :: * -> *). MonadIO m => Handle -> ByteStream m ()
SB.fromHandle Handle
handleIn

breaker
  :: Monad m
  => Stream (Of (ByteString, Int)) m r
  -> Stream (Stream (Of (ByteString, Int)) m) m r
breaker :: Stream (Of (ByteString, Int)) m r
-> Stream (Stream (Of (ByteString, Int)) m) m r
breaker Stream (Of (ByteString, Int)) m r
s = m (Stream (Stream (Of (ByteString, Int)) m) m r)
-> Stream (Stream (Of (ByteString, Int)) m) m r
forall (m :: * -> *) (f :: * -> *) r.
(Monad m, Functor f) =>
m (Stream f m r) -> Stream f m r
effect (m (Stream (Stream (Of (ByteString, Int)) m) m r)
 -> Stream (Stream (Of (ByteString, Int)) m) m r)
-> m (Stream (Stream (Of (ByteString, Int)) m) m r)
-> Stream (Stream (Of (ByteString, Int)) m) m r
forall a b. (a -> b) -> a -> b
$ do
  Either r (Of (ByteString, Int) (Stream (Of (ByteString, Int)) m r))
x <- Stream (Of (ByteString, Int)) m r
-> m (Either
        r (Of (ByteString, Int) (Stream (Of (ByteString, Int)) m r)))
forall (m :: * -> *) (f :: * -> *) r.
Monad m =>
Stream f m r -> m (Either r (f (Stream f m r)))
inspect Stream (Of (ByteString, Int)) m r
s
  Stream (Stream (Of (ByteString, Int)) m) m r
-> m (Stream (Stream (Of (ByteString, Int)) m) m r)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stream (Stream (Of (ByteString, Int)) m) m r
 -> m (Stream (Stream (Of (ByteString, Int)) m) m r))
-> Stream (Stream (Of (ByteString, Int)) m) m r
-> m (Stream (Stream (Of (ByteString, Int)) m) m r)
forall a b. (a -> b) -> a -> b
$ case Either r (Of (ByteString, Int) (Stream (Of (ByteString, Int)) m r))
x of
    Left r
r -> r -> Stream (Stream (Of (ByteString, Int)) m) m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r
    Right Of (ByteString, Int) (Stream (Of (ByteString, Int)) m r)
q -> Stream
  (Of (ByteString, Int))
  m
  (Stream (Stream (Of (ByteString, Int)) m) m r)
-> Stream (Stream (Of (ByteString, Int)) m) m r
forall (m :: * -> *) (f :: * -> *) r.
(Monad m, Functor f) =>
f (Stream f m r) -> Stream f m r
wrap (Stream
   (Of (ByteString, Int))
   m
   (Stream (Stream (Of (ByteString, Int)) m) m r)
 -> Stream (Stream (Of (ByteString, Int)) m) m r)
-> Stream
     (Of (ByteString, Int))
     m
     (Stream (Stream (Of (ByteString, Int)) m) m r)
-> Stream (Stream (Of (ByteString, Int)) m) m r
forall a b. (a -> b) -> a -> b
$ (Stream (Of (ByteString, Int)) m r
 -> Stream (Stream (Of (ByteString, Int)) m) m r)
-> Stream
     (Of (ByteString, Int)) m (Stream (Of (ByteString, Int)) m r)
-> Stream
     (Of (ByteString, Int))
     m
     (Stream (Stream (Of (ByteString, Int)) m) m r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Stream (Of (ByteString, Int)) m r
-> Stream (Stream (Of (ByteString, Int)) m) m r
forall (m :: * -> *) r.
Monad m =>
Stream (Of (ByteString, Int)) m r
-> Stream (Stream (Of (ByteString, Int)) m) m r
breaker (Stream
   (Of (ByteString, Int)) m (Stream (Of (ByteString, Int)) m r)
 -> Stream
      (Of (ByteString, Int))
      m
      (Stream (Stream (Of (ByteString, Int)) m) m r))
-> Stream
     (Of (ByteString, Int)) m (Stream (Of (ByteString, Int)) m r)
-> Stream
     (Of (ByteString, Int))
     m
     (Stream (Stream (Of (ByteString, Int)) m) m r)
forall a b. (a -> b) -> a -> b
$ Stream (Of (ByteString, Int)) m r
-> Stream
     (Of (ByteString, Int)) m (Stream (Of (ByteString, Int)) m r)
forall (m :: * -> *) r.
Monad m =>
Stream (Of (ByteString, Int)) m r
-> Stream
     (Of (ByteString, Int)) m (Stream (Of (ByteString, Int)) m r)
step (Stream (Of (ByteString, Int)) m r
 -> Stream
      (Of (ByteString, Int)) m (Stream (Of (ByteString, Int)) m r))
-> Stream (Of (ByteString, Int)) m r
-> Stream
     (Of (ByteString, Int)) m (Stream (Of (ByteString, Int)) m r)
forall a b. (a -> b) -> a -> b
$ Of (ByteString, Int) (Stream (Of (ByteString, Int)) m r)
-> Stream (Of (ByteString, Int)) m r
forall (m :: * -> *) (f :: * -> *) r.
(Monad m, Functor f) =>
f (Stream f m r) -> Stream f m r
wrap Of (ByteString, Int) (Stream (Of (ByteString, Int)) m r)
q

step
  :: Monad m
  => Stream (Of (ByteString, Int)) m r
  -> Stream (Of (ByteString, Int)) m (Stream (Of (ByteString, Int)) m r)
step :: Stream (Of (ByteString, Int)) m r
-> Stream
     (Of (ByteString, Int)) m (Stream (Of (ByteString, Int)) m r)
step = (forall x.
 (x -> (ByteString, Int) -> x)
 -> x
 -> (x -> Int)
 -> (Int -> Bool)
 -> Stream (Of (ByteString, Int)) m r
 -> Stream
      (Of (ByteString, Int)) m (Stream (Of (ByteString, Int)) m r))
-> Fold (ByteString, Int) Int
-> (Int -> Bool)
-> Stream (Of (ByteString, Int)) m r
-> Stream
     (Of (ByteString, Int)) m (Stream (Of (ByteString, Int)) m r)
forall a b r.
(forall x. (x -> a -> x) -> x -> (x -> b) -> r) -> Fold a b -> r
L.purely forall x.
(x -> (ByteString, Int) -> x)
-> x
-> (x -> Int)
-> (Int -> Bool)
-> Stream (Of (ByteString, Int)) m r
-> Stream
     (Of (ByteString, Int)) m (Stream (Of (ByteString, Int)) m r)
forall (m :: * -> *) x a b r.
Monad m =>
(x -> a -> x)
-> x
-> (x -> b)
-> (b -> Bool)
-> Stream (Of a) m r
-> Stream (Of a) m (Stream (Of a) m r)
S.breakWhen (((ByteString, Int) -> Int)
-> Fold Int Int -> Fold (ByteString, Int) Int
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap (ByteString, Int) -> Int
forall a b. (a, b) -> b
snd Fold Int Int
forall a. Num a => Fold a a
L.sum) (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
limit)