module Ribosome.Test.Screenshot where

import Chiasma.Data.CodecError (CodecError)
import Chiasma.Effect.Codec (NativeCommandCodecE)
import Chiasma.Effect.TmuxClient (NativeTmux)
import qualified Chiasma.Test.Screenshot as Chiasma
import Chiasma.Tmux (withTmux)
import Chiasma.TmuxApi (Tmux)
import Control.Lens.Regex.Text (group, regex)
import Exon (exon)
import Hedgehog.Internal.Property (Failure)
import qualified Log
import Path (reldir)
import Polysemy.Chronos (ChronosTime)
import qualified Polysemy.Test as Test
import Polysemy.Test (Hedgehog, Test, TestError (TestError), (===))
import Prelude hiding (group)
import qualified Time
import Time (Seconds (Seconds))

import Ribosome.Host.Effect.Log (StderrLog, stderrLog)
import Ribosome.Test.Wait (assertWait)

-- |Nvim appears to add random whitespace sequences, optionally interspersed with color codes, to empty lines.
-- This remotes that noise from lines starting with `~\ESC[39m` or `\ESC[94m~\ESC[39m`.
sanitize :: Text -> Text
sanitize :: Text -> Text
sanitize =
  [regex|(\x{1b}\[94m)?~((\s|\x{1b}\[94m|\x{1b}\[39m)*)$|] ((Match -> Identity Match) -> Text -> Identity Text)
-> ((Text -> Identity Text) -> Match -> Identity Match)
-> (Text -> Identity Text)
-> Text
-> Identity Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IndexedTraversal' Text Match Text
group Int
1 ((Text -> Identity Text) -> Text -> Identity Text)
-> Text -> Text -> Text
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
""

screenshot ::
  Members [Tmux, Test, Error TestError, Embed IO] r =>
  Bool ->
  Bool ->
  Text ->
  Int ->
  Sem r (Maybe ([Text], [Text]))
screenshot :: forall (r :: EffectRow).
Members '[Tmux, Test, Error TestError, Embed IO] r =>
Bool -> Bool -> Text -> Int -> Sem r (Maybe ([Text], [Text]))
screenshot Bool
record Bool
sane Text
name Int
pane = do
  Path Abs Dir
storage <- Path Rel Dir -> Sem r (Path Abs Dir)
forall p (r :: EffectRow).
Member Test r =>
Path Rel p -> Sem r (Path Abs p)
Test.fixturePath [reldir|screenshots|]
  (Text -> TestError)
-> Sem (Error Text : r) (Maybe ([Text], [Text]))
-> Sem r (Maybe ([Text], [Text]))
forall e1 e2 (r :: EffectRow) a.
Member (Error e2) r =>
(e1 -> e2) -> Sem (Error e1 : r) a -> Sem r a
mapError Text -> TestError
TestError ((Text -> Text)
-> Bool
-> Path Abs Dir
-> Text
-> Int
-> Sem (Error Text : r) (Maybe ([Text], [Text]))
forall (r :: EffectRow).
Members '[Tmux, Error Text, Embed IO] r =>
(Text -> Text)
-> Bool
-> Path Abs Dir
-> Text
-> Int
-> Sem r (Maybe ([Text], [Text]))
Chiasma.screenshotSanitized (if Bool
sane then Text -> Text
sanitize else Text -> Text
forall a. a -> a
id) Bool
record Path Abs Dir
storage Text
name Int
pane)

assertScreenshot ::
  HasCallStack =>
  Members [NativeTmux, NativeCommandCodecE, Stop CodecError] r =>
  Members [Hedgehog IO, Test, Error TestError, Error Failure, ChronosTime, Race, Embed IO] r =>
  Bool ->
  Text ->
  Int ->
  Sem r ()
assertScreenshot :: forall (r :: EffectRow).
(HasCallStack,
 Members '[NativeTmux, NativeCommandCodecE, Stop CodecError] r,
 Members
   '[Hedgehog IO, Test, Error TestError, Error Failure, ChronosTime,
     Race, Embed IO]
   r) =>
Bool -> Text -> Int -> Sem r ()
assertScreenshot Bool
sane Text
name Int
pane =
  (HasCallStack => Sem r ()) -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Sem r ()) -> Sem r ())
-> (HasCallStack => Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Sem (Resumable CodecError Tmux : r) () -> Sem r ()
forall (command :: * -> *) err i o resource (r :: EffectRow).
Members '[ScopedTmux resource i o, Codec command i o !! err] r =>
InterpreterFor (TmuxApi command !! err) r
withTmux (Sem (Resumable CodecError Tmux : r) () -> Sem r ())
-> Sem (Resumable CodecError Tmux : r) () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Sem (Tmux : Resumable CodecError Tmux : r) ()
-> Sem (Resumable CodecError Tmux : r) ()
forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow).
Members '[Resumable err eff, Stop err] r =>
InterpreterFor eff r
restop do
    Sem (Tmux : Resumable CodecError Tmux : r) (Maybe ([Text], [Text]))
-> (Maybe ([Text], [Text])
    -> Sem (Tmux : Resumable CodecError Tmux : r) ())
-> Sem (Tmux : Resumable CodecError Tmux : r) ()
forall (m :: * -> *) t d (r :: EffectRow) a b.
(Monad m, HasCallStack,
 Members
   '[Hedgehog m, Time t d, Race, Error Failure, Embed IO] r) =>
Sem r a -> (a -> Sem r b) -> Sem r b
assertWait (Bool
-> Bool
-> Text
-> Int
-> Sem
     (Tmux : Resumable CodecError Tmux : r) (Maybe ([Text], [Text]))
forall (r :: EffectRow).
Members '[Tmux, Test, Error TestError, Embed IO] r =>
Bool -> Bool -> Text -> Int -> Sem r (Maybe ([Text], [Text]))
screenshot Bool
False Bool
sane Text
name Int
pane) ((([Text], [Text]) -> Sem (Tmux : Resumable CodecError Tmux : r) ())
-> Maybe ([Text], [Text])
-> Sem (Tmux : Resumable CodecError Tmux : r) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ([Text], [Text]) -> Sem (Tmux : Resumable CodecError Tmux : r) ()
forall {m :: * -> *} {a} {r :: EffectRow}.
(Monad m, Eq a, Show a, Member (Hedgehog m) r) =>
(a, a) -> Sem r ()
check)
  where
    check :: (a, a) -> Sem r ()
check (a
current, a
existing) =
      a
existing a -> a -> Sem r ()
forall a (m :: * -> *) (r :: EffectRow).
(Monad m, Eq a, Show a, HasCallStack, Member (Hedgehog m) r) =>
a -> a -> Sem r ()
=== a
current

updateScreeshot ::
  HasCallStack =>
  Members [NativeTmux, NativeCommandCodecE, Stop CodecError] r =>
  Members [Hedgehog IO, Test, Error TestError, Error Failure, ChronosTime, StderrLog, Race, Embed IO] r =>
  Bool ->
  Text ->
  Int ->
  Sem r ()
updateScreeshot :: forall (r :: EffectRow).
(HasCallStack,
 Members '[NativeTmux, NativeCommandCodecE, Stop CodecError] r,
 Members
   '[Hedgehog IO, Test, Error TestError, Error Failure, ChronosTime,
     StderrLog, Race, Embed IO]
   r) =>
Bool -> Text -> Int -> Sem r ()
updateScreeshot Bool
sane Text
name Int
pane =
  Sem (Resumable CodecError Tmux : r) () -> Sem r ()
forall (command :: * -> *) err i o resource (r :: EffectRow).
Members '[ScopedTmux resource i o, Codec command i o !! err] r =>
InterpreterFor (TmuxApi command !! err) r
withTmux (Sem (Resumable CodecError Tmux : r) () -> Sem r ())
-> Sem (Resumable CodecError Tmux : r) () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Sem (Tmux : Resumable CodecError Tmux : r) ()
-> Sem (Resumable CodecError Tmux : r) ()
forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow).
Members '[Resumable err eff, Stop err] r =>
InterpreterFor eff r
restop do
    Sem (Log : Tmux : Resumable CodecError Tmux : r) ()
-> Sem (Tmux : Resumable CodecError Tmux : r) ()
forall (r :: EffectRow). Member StderrLog r => InterpreterFor Log r
stderrLog (Text -> Sem (Log : Tmux : Resumable CodecError Tmux : r) ()
forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.info [exon|Waiting for one second before storing new screenshot for '#{name}'|])
    Seconds -> Sem (Tmux : Resumable CodecError Tmux : r) ()
forall t d u (r :: EffectRow).
(TimeUnit u, Member (Time t d) r) =>
u -> Sem r ()
Time.sleep (Int64 -> Seconds
Seconds Int64
1)
    Sem (Tmux : Resumable CodecError Tmux : r) (Maybe ([Text], [Text]))
-> Sem (Tmux : Resumable CodecError Tmux : r) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Bool
-> Bool
-> Text
-> Int
-> Sem
     (Tmux : Resumable CodecError Tmux : r) (Maybe ([Text], [Text]))
forall (r :: EffectRow).
Members '[Tmux, Test, Error TestError, Embed IO] r =>
Bool -> Bool -> Text -> Int -> Sem r (Maybe ([Text], [Text]))
screenshot Bool
sane Bool
True Text
name Int
pane)

awaitScreenshot' ::
  HasCallStack =>
  Members [NativeTmux, NativeCommandCodecE, Stop CodecError] r =>
  Members [Hedgehog IO, Test, Error TestError, Error Failure, ChronosTime, StderrLog, Race, Embed IO] r =>
  Bool ->
  Bool ->
  Text ->
  Int ->
  Sem r ()
awaitScreenshot' :: forall (r :: EffectRow).
(HasCallStack,
 Members '[NativeTmux, NativeCommandCodecE, Stop CodecError] r,
 Members
   '[Hedgehog IO, Test, Error TestError, Error Failure, ChronosTime,
     StderrLog, Race, Embed IO]
   r) =>
Bool -> Bool -> Text -> Int -> Sem r ()
awaitScreenshot' = \case
  Bool
True ->
    Bool -> Text -> Int -> Sem r ()
forall (r :: EffectRow).
(HasCallStack,
 Members '[NativeTmux, NativeCommandCodecE, Stop CodecError] r,
 Members
   '[Hedgehog IO, Test, Error TestError, Error Failure, ChronosTime,
     StderrLog, Race, Embed IO]
   r) =>
Bool -> Text -> Int -> Sem r ()
updateScreeshot
  Bool
False ->
    (HasCallStack => Bool -> Text -> Int -> Sem r ())
-> Bool -> Text -> Int -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack HasCallStack => Bool -> Text -> Int -> Sem r ()
forall (r :: EffectRow).
(HasCallStack,
 Members '[NativeTmux, NativeCommandCodecE, Stop CodecError] r,
 Members
   '[Hedgehog IO, Test, Error TestError, Error Failure, ChronosTime,
     Race, Embed IO]
   r) =>
Bool -> Text -> Int -> Sem r ()
assertScreenshot

awaitScreenshot ::
  HasCallStack =>
  Members [NativeTmux, NativeCommandCodecE, Stop CodecError] r =>
  Members [Hedgehog IO, Test, Error TestError, Error Failure, ChronosTime, StderrLog, Race, Embed IO] r =>
  Bool ->
  Text ->
  Int ->
  Sem r ()
awaitScreenshot :: forall (r :: EffectRow).
(HasCallStack,
 Members '[NativeTmux, NativeCommandCodecE, Stop CodecError] r,
 Members
   '[Hedgehog IO, Test, Error TestError, Error Failure, ChronosTime,
     StderrLog, Race, Embed IO]
   r) =>
Bool -> Text -> Int -> Sem r ()
awaitScreenshot Bool
record =
  (HasCallStack => Text -> Int -> Sem r ())
-> Text -> Int -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
    Bool -> Bool -> Text -> Int -> Sem r ()
forall (r :: EffectRow).
(HasCallStack,
 Members '[NativeTmux, NativeCommandCodecE, Stop CodecError] r,
 Members
   '[Hedgehog IO, Test, Error TestError, Error Failure, ChronosTime,
     StderrLog, Race, Embed IO]
   r) =>
Bool -> Bool -> Text -> Int -> Sem r ()
awaitScreenshot' Bool
record Bool
True