{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}

-- |
--   Module    : Polysemy.Video
--   License   : MIT
--   Stability : experimental
--
-- Experimental Video processing DSL for Polysemy.
module Polysemy.Video
  ( ClipProcess (..),
    extractAudio,
    extractClips,
    extractFrames,
    runFFMpegCli,
    traceFFMpegArgs,
    ignoreClipProcess,
  )
where

import Control.Monad.IO.Class
import Data.Text (Text)
import Formatting
import Media.Timestamp
import Media.Timestamp.Formatting
import Path
import Path.Formatting
import Polysemy
import Polysemy.Trace
import qualified Turtle as S

-- | Effect for disecting a video file.
--
-- @since 0.1.1.0
data ClipProcess m a where
  ExtractAudio :: Path b File -> [(Range, Path b' File)] -> ClipProcess m ()
  ExtractClips :: Path b File -> [(Range, Path b' File)] -> ClipProcess m ()
  ExtractFrames :: Path b File -> [(Time, Path b' File)] -> ClipProcess m ()

makeSem ''ClipProcess

-- | "-ss <x>" where x is a timestamp.
seekFF :: Time -> [Text]
seekFF :: Time -> [Text]
seekFF Time
t = [Text
"-ss", Format Text (Time -> Text) -> Time -> Text
forall a. Format Text a -> a
sformat Format Text (Time -> Text)
forall r. Format r (Time -> r)
timef Time
t]

-- | "-ss <x> -to <y> <output>".
rangeFF :: Range -> Path b File -> [Text]
rangeFF :: Range -> Path b File -> [Text]
rangeFF (Range Time
f Time
t) Path b File
x = Time -> [Text]
seekFF Time
f [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
"-to", Format Text (Time -> Text) -> Time -> Text
forall a. Format Text a -> a
sformat Format Text (Time -> Text)
forall r. Format r (Time -> r)
timef Time
t, Format Text (Path b File -> Text) -> Path b File -> Text
forall a. Format Text a -> a
sformat Format Text (Path b File -> Text)
forall r b t. Format r (Path b t -> r)
pathf Path b File
x]

-- | "-ss <x> -vframes 1 <output>"
frameFF :: Time -> Path b File -> [Text]
frameFF :: Time -> Path b File -> [Text]
frameFF Time
t Path b File
x = Time -> [Text]
seekFF Time
t [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
"-vframes", Text
"1", Format Text (Path b File -> Text) -> Path b File -> Text
forall a. Format Text a -> a
sformat Format Text (Path b File -> Text)
forall r b t. Format r (Path b t -> r)
pathf Path b File
x]

-- | "-i <output>"
inputFF :: Path b File -> [Text]
inputFF :: Path b File -> [Text]
inputFF Path b File
x = [Text
"-i", Format Text (Path b File -> Text) -> Path b File -> Text
forall a. Format Text a -> a
sformat Format Text (Path b File -> Text)
forall r b t. Format r (Path b t -> r)
pathf Path b File
x]

-- | "ffmpeg -y" followed by some arguments.
runffmpeg :: MonadIO m => [Text] -> m ()
runffmpeg :: [Text] -> m ()
runffmpeg [Text]
xs = Shell Line -> m ()
forall (io :: * -> *) a. MonadIO io => Shell a -> io ()
S.sh (Shell Line -> m ()) -> Shell Line -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Shell Line -> Shell Line
S.inproc Text
"ffmpeg" (Text
"-y" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
"-loglevel" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
"warning" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
xs) Shell Line
forall a. Monoid a => a
mempty

-- | "mkdir -p" with a `Path b Dir`.
mktreeFP :: MonadIO m => Path b Dir -> m ()
mktreeFP :: Path b Dir -> m ()
mktreeFP = FilePath -> m ()
forall (io :: * -> *). MonadIO io => FilePath -> io ()
S.mktree (FilePath -> m ())
-> (Path b Dir -> FilePath) -> Path b Dir -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FilePath
S.decodeString (String -> FilePath)
-> (Path b Dir -> String) -> Path b Dir -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path b Dir -> String
forall b t. Path b t -> String
toFilePath

-- | Interpret `ClipProcess` by running it against ffmpeg on the command line.
--
-- @since 0.2.0.0
runFFMpegCli :: Member (Embed IO) effs => Sem (ClipProcess ': effs) a -> Sem effs a
runFFMpegCli :: Sem (ClipProcess : effs) a -> Sem effs a
runFFMpegCli = (forall (rInitial :: EffectRow) x.
 ClipProcess (Sem rInitial) x -> Sem effs x)
-> Sem (ClipProcess : effs) a -> Sem effs a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: EffectRow) x.
  ClipProcess (Sem rInitial) x -> Sem effs x)
 -> Sem (ClipProcess : effs) a -> Sem effs a)
-> (forall (rInitial :: EffectRow) x.
    ClipProcess (Sem rInitial) x -> Sem effs x)
-> Sem (ClipProcess : effs) a
-> Sem effs a
forall a b. (a -> b) -> a -> b
$ \case
  ExtractAudio x ts -> (Path b' Dir -> Sem effs ()) -> [Path b' Dir] -> Sem effs ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Path b' Dir -> Sem effs ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
mktreeFP (Path b' File -> Path b' Dir
forall b t. Path b t -> Path b Dir
parent (Path b' File -> Path b' Dir)
-> ((Range, Path b' File) -> Path b' File)
-> (Range, Path b' File)
-> Path b' Dir
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Range, Path b' File) -> Path b' File
forall a b. (a, b) -> b
snd ((Range, Path b' File) -> Path b' Dir)
-> [(Range, Path b' File)] -> [Path b' Dir]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Range, Path b' File)]
ts) Sem effs () -> Sem effs () -> Sem effs ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Text] -> Sem effs ()
forall (m :: * -> *). MonadIO m => [Text] -> m ()
runffmpeg (Path b File -> [Text]
forall b. Path b File -> [Text]
inputFF Path b File
x [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ((Range -> Path b' File -> [Text])
-> (Range, Path b' File) -> [Text]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Range -> Path b' File -> [Text]
forall b. Range -> Path b File -> [Text]
rangeFF ((Range, Path b' File) -> [Text])
-> [(Range, Path b' File)] -> [Text]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(Range, Path b' File)]
ts))
  ExtractClips x ts -> (Path b' Dir -> Sem effs ()) -> [Path b' Dir] -> Sem effs ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Path b' Dir -> Sem effs ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
mktreeFP (Path b' File -> Path b' Dir
forall b t. Path b t -> Path b Dir
parent (Path b' File -> Path b' Dir)
-> ((Range, Path b' File) -> Path b' File)
-> (Range, Path b' File)
-> Path b' Dir
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Range, Path b' File) -> Path b' File
forall a b. (a, b) -> b
snd ((Range, Path b' File) -> Path b' Dir)
-> [(Range, Path b' File)] -> [Path b' Dir]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Range, Path b' File)]
ts) Sem effs () -> Sem effs () -> Sem effs ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Text] -> Sem effs ()
forall (m :: * -> *). MonadIO m => [Text] -> m ()
runffmpeg (Path b File -> [Text]
forall b. Path b File -> [Text]
inputFF Path b File
x [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ((Range -> Path b' File -> [Text])
-> (Range, Path b' File) -> [Text]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Range -> Path b' File -> [Text]
forall b. Range -> Path b File -> [Text]
rangeFF ((Range, Path b' File) -> [Text])
-> [(Range, Path b' File)] -> [Text]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(Range, Path b' File)]
ts))
  ExtractFrames x ts -> (Path b' Dir -> Sem effs ()) -> [Path b' Dir] -> Sem effs ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Path b' Dir -> Sem effs ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
mktreeFP (Path b' File -> Path b' Dir
forall b t. Path b t -> Path b Dir
parent (Path b' File -> Path b' Dir)
-> ((Time, Path b' File) -> Path b' File)
-> (Time, Path b' File)
-> Path b' Dir
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time, Path b' File) -> Path b' File
forall a b. (a, b) -> b
snd ((Time, Path b' File) -> Path b' Dir)
-> [(Time, Path b' File)] -> [Path b' Dir]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Time, Path b' File)]
ts) Sem effs () -> Sem effs () -> Sem effs ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Text] -> Sem effs ()
forall (m :: * -> *). MonadIO m => [Text] -> m ()
runffmpeg (Path b File -> [Text]
forall b. Path b File -> [Text]
inputFF Path b File
x [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ((Time -> Path b' File -> [Text]) -> (Time, Path b' File) -> [Text]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Time -> Path b' File -> [Text]
forall b. Time -> Path b File -> [Text]
frameFF ((Time, Path b' File) -> [Text])
-> [(Time, Path b' File)] -> [Text]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(Time, Path b' File)]
ts))

-- | Trace `ClipProcess` by printing out the arguments it would pass to ffmpeg.
--
-- @since 0.2.0.0
traceFFMpegArgs :: Members '[ClipProcess, Trace] r => Sem r a -> Sem r a
traceFFMpegArgs :: Sem r a -> Sem r a
traceFFMpegArgs = (forall x (rInitial :: EffectRow).
 ClipProcess (Sem rInitial) x -> Sem r x)
-> Sem r a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
(Member e r, FirstOrder e "intercept") =>
(forall x (rInitial :: EffectRow). e (Sem rInitial) x -> Sem r x)
-> Sem r a -> Sem r a
intercept ((forall x (rInitial :: EffectRow).
  ClipProcess (Sem rInitial) x -> Sem r x)
 -> Sem r a -> Sem r a)
-> (forall x (rInitial :: EffectRow).
    ClipProcess (Sem rInitial) x -> Sem r x)
-> Sem r a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  ExtractAudio x ts -> do
    String -> Sem r ()
forall (r :: EffectRow).
MemberWithError Trace r =>
String -> Sem r ()
trace (String -> Sem r ()) -> String -> Sem r ()
forall a b. (a -> b) -> a -> b
$ [Text] -> String
forall a. Show a => a -> String
show ([Text] -> String) -> [Text] -> String
forall a b. (a -> b) -> a -> b
$ Path b File -> [Text]
forall b. Path b File -> [Text]
inputFF Path b File
x [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ((Range -> Path b' File -> [Text])
-> (Range, Path b' File) -> [Text]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Range -> Path b' File -> [Text]
forall b. Range -> Path b File -> [Text]
rangeFF ((Range, Path b' File) -> [Text])
-> [(Range, Path b' File)] -> [Text]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(Range, Path b' File)]
ts)
    Path b File -> [(Range, Path b' File)] -> Sem r ()
forall (r :: EffectRow) b b'.
MemberWithError ClipProcess r =>
Path b File -> [(Range, Path b' File)] -> Sem r ()
extractAudio Path b File
x [(Range, Path b' File)]
ts
  ExtractClips x ts -> do
    String -> Sem r ()
forall (r :: EffectRow).
MemberWithError Trace r =>
String -> Sem r ()
trace (String -> Sem r ()) -> String -> Sem r ()
forall a b. (a -> b) -> a -> b
$ [Text] -> String
forall a. Show a => a -> String
show ([Text] -> String) -> [Text] -> String
forall a b. (a -> b) -> a -> b
$ Path b File -> [Text]
forall b. Path b File -> [Text]
inputFF Path b File
x [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ((Range -> Path b' File -> [Text])
-> (Range, Path b' File) -> [Text]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Range -> Path b' File -> [Text]
forall b. Range -> Path b File -> [Text]
rangeFF ((Range, Path b' File) -> [Text])
-> [(Range, Path b' File)] -> [Text]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(Range, Path b' File)]
ts)
    Path b File -> [(Range, Path b' File)] -> Sem r ()
forall (r :: EffectRow) b b'.
MemberWithError ClipProcess r =>
Path b File -> [(Range, Path b' File)] -> Sem r ()
extractClips Path b File
x [(Range, Path b' File)]
ts
  ExtractFrames x ts -> do
    String -> Sem r ()
forall (r :: EffectRow).
MemberWithError Trace r =>
String -> Sem r ()
trace (String -> Sem r ()) -> String -> Sem r ()
forall a b. (a -> b) -> a -> b
$ [Text] -> String
forall a. Show a => a -> String
show ([Text] -> String) -> [Text] -> String
forall a b. (a -> b) -> a -> b
$ Path b File -> [Text]
forall b. Path b File -> [Text]
inputFF Path b File
x [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ((Time -> Path b' File -> [Text]) -> (Time, Path b' File) -> [Text]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Time -> Path b' File -> [Text]
forall b. Time -> Path b File -> [Text]
frameFF ((Time, Path b' File) -> [Text])
-> [(Time, Path b' File)] -> [Text]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(Time, Path b' File)]
ts)
    Path b File -> [(Time, Path b' File)] -> Sem r ()
forall (r :: EffectRow) b b'.
MemberWithError ClipProcess r =>
Path b File -> [(Time, Path b' File)] -> Sem r ()
extractFrames Path b File
x [(Time, Path b' File)]
ts

-- | Noop the `ClipProcess` effect.
--
-- @since 0.2.0.0
ignoreClipProcess :: Sem (ClipProcess ': r) a -> Sem r a
ignoreClipProcess :: Sem (ClipProcess : r) a -> Sem r a
ignoreClipProcess = (forall (rInitial :: EffectRow) x.
 ClipProcess (Sem rInitial) x -> Sem r x)
-> Sem (ClipProcess : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: EffectRow) x.
  ClipProcess (Sem rInitial) x -> Sem r x)
 -> Sem (ClipProcess : r) a -> Sem r a)
-> (forall (rInitial :: EffectRow) x.
    ClipProcess (Sem rInitial) x -> Sem r x)
-> Sem (ClipProcess : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  ExtractAudio _ _ -> () -> Sem r ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  ExtractClips _ _ -> () -> Sem r ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  ExtractFrames _ _ -> () -> Sem r ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()