{- |
   Module    : Polysemy.Video
   License   : MIT
   Stability : experimental

Experimental Video processing DSL for Polysemy.
-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeOperators       #-}
module Polysemy.Video where

import           Control.Monad.IO.Class
import           Data.Text              (Text)
import qualified Data.Text              as T
import           Formatting
import           Path
import           Path.Utils
import           Polysemy
import qualified Turtle                 as S

-- | Timestamp data type.
data Time = Time
  { Time -> Int
hour    :: Int
  , Time -> Int
minutes :: Int
  , Time -> Int
seconds :: Int
  , Time -> Int
frame   :: Int
  } deriving (Time -> Time -> Bool
(Time -> Time -> Bool) -> (Time -> Time -> Bool) -> Eq Time
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Time -> Time -> Bool
$c/= :: Time -> Time -> Bool
== :: Time -> Time -> Bool
$c== :: Time -> Time -> Bool
Eq, Eq Time
Eq Time
-> (Time -> Time -> Ordering)
-> (Time -> Time -> Bool)
-> (Time -> Time -> Bool)
-> (Time -> Time -> Bool)
-> (Time -> Time -> Bool)
-> (Time -> Time -> Time)
-> (Time -> Time -> Time)
-> Ord Time
Time -> Time -> Bool
Time -> Time -> Ordering
Time -> Time -> Time
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Time -> Time -> Time
$cmin :: Time -> Time -> Time
max :: Time -> Time -> Time
$cmax :: Time -> Time -> Time
>= :: Time -> Time -> Bool
$c>= :: Time -> Time -> Bool
> :: Time -> Time -> Bool
$c> :: Time -> Time -> Bool
<= :: Time -> Time -> Bool
$c<= :: Time -> Time -> Bool
< :: Time -> Time -> Bool
$c< :: Time -> Time -> Bool
compare :: Time -> Time -> Ordering
$ccompare :: Time -> Time -> Ordering
$cp1Ord :: Eq Time
Ord, Int -> Time -> ShowS
[Time] -> ShowS
Time -> String
(Int -> Time -> ShowS)
-> (Time -> String) -> ([Time] -> ShowS) -> Show Time
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Time] -> ShowS
$cshowList :: [Time] -> ShowS
show :: Time -> String
$cshow :: Time -> String
showsPrec :: Int -> Time -> ShowS
$cshowsPrec :: Int -> Time -> ShowS
Show)

-- | Interval of two timestamps.
data Range = Range
  { Range -> Time
from :: Time
  , Range -> Time
to   :: Time
  } deriving (Range -> Range -> Bool
(Range -> Range -> Bool) -> (Range -> Range -> Bool) -> Eq Range
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Range -> Range -> Bool
$c/= :: Range -> Range -> Bool
== :: Range -> Range -> Bool
$c== :: Range -> Range -> Bool
Eq, Eq Range
Eq Range
-> (Range -> Range -> Ordering)
-> (Range -> Range -> Bool)
-> (Range -> Range -> Bool)
-> (Range -> Range -> Bool)
-> (Range -> Range -> Bool)
-> (Range -> Range -> Range)
-> (Range -> Range -> Range)
-> Ord Range
Range -> Range -> Bool
Range -> Range -> Ordering
Range -> Range -> Range
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Range -> Range -> Range
$cmin :: Range -> Range -> Range
max :: Range -> Range -> Range
$cmax :: Range -> Range -> Range
>= :: Range -> Range -> Bool
$c>= :: Range -> Range -> Bool
> :: Range -> Range -> Bool
$c> :: Range -> Range -> Bool
<= :: Range -> Range -> Bool
$c<= :: Range -> Range -> Bool
< :: Range -> Range -> Bool
$c< :: Range -> Range -> Bool
compare :: Range -> Range -> Ordering
$ccompare :: Range -> Range -> Ordering
$cp1Ord :: Eq Range
Ord, Int -> Range -> ShowS
[Range] -> ShowS
Range -> String
(Int -> Range -> ShowS)
-> (Range -> String) -> ([Range] -> ShowS) -> Show Range
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Range] -> ShowS
$cshowList :: [Range] -> ShowS
show :: Range -> String
$cshow :: Range -> String
showsPrec :: Int -> Range -> ShowS
$cshowsPrec :: Int -> Range -> ShowS
Show)

-- |
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

-- | Format a Timestamp to ffmpeg's format 00:00:00.000.
timeFF :: Time -> Text
timeFF :: Time -> Text
timeFF (Time Int
h Int
m Int
s Int
f) = Format Text (Int -> Int -> Int -> Int -> Text)
-> Int -> Int -> Int -> Int -> Text
forall a. Format Text a -> a
sformat (Format
  (Int -> Int -> Int -> Text) (Int -> Int -> Int -> Int -> Text)
forall a r. Integral a => Format r (a -> r)
int Format
  (Int -> Int -> Int -> Text) (Int -> Int -> Int -> Int -> Text)
-> Format Text (Int -> Int -> Int -> Text)
-> Format Text (Int -> Int -> Int -> Int -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Int -> Int -> Int -> Text) (Int -> Int -> Int -> Text)
":" Format (Int -> Int -> Int -> Text) (Int -> Int -> Int -> Text)
-> Format Text (Int -> Int -> Int -> Text)
-> Format Text (Int -> Int -> Int -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Int -> Int -> Text) (Int -> Int -> Int -> Text)
forall a r. Integral a => Format r (a -> r)
int Format (Int -> Int -> Text) (Int -> Int -> Int -> Text)
-> Format Text (Int -> Int -> Text)
-> Format Text (Int -> Int -> Int -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Int -> Int -> Text) (Int -> Int -> Text)
":" Format (Int -> Int -> Text) (Int -> Int -> Text)
-> Format Text (Int -> Int -> Text)
-> Format Text (Int -> Int -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Int -> Text) (Int -> Int -> Text)
forall a r. Integral a => Format r (a -> r)
int Format (Int -> Text) (Int -> Int -> Text)
-> Format Text (Int -> Text) -> Format Text (Int -> Int -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Int -> Text) (Int -> Text)
"." Format (Int -> Text) (Int -> Text)
-> Format Text (Int -> Text) -> Format Text (Int -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Text (Int -> Text)
forall a r. Integral a => Format r (a -> r)
int) Int
h Int
m Int
s Int
f

-- | "-ss <x>" where x is a timestamp.
seekFF :: Time -> [Text]
seekFF :: Time -> [Text]
seekFF Time
t = [Text
"-ss", Time -> Text
timeFF 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", Time -> Text
timeFF Time
t, Path b File -> Text
forall b t. Path b t -> Text
toFilePathText 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", Path b File -> Text
forall b t. Path b t -> Text
toFilePathText Path b File
x]

-- | "-i <output>"
inputFF :: Path b File -> [Text]
inputFF :: Path b File -> [Text]
inputFF Path b File
x = [Text
"-i", Path b File -> Text
forall b t. Path b t -> Text
toFilePathText 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.
interpretFFMpegCli :: Member (Embed IO) effs => Sem (ClipProcess ': effs) a -> Sem effs a
interpretFFMpegCli :: Sem (ClipProcess : effs) a -> Sem effs a
interpretFFMpegCli = (forall x (m :: * -> *). ClipProcess m x -> Sem effs x)
-> Sem (ClipProcess : effs) a -> Sem effs a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (m :: * -> *). e m x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall x (m :: * -> *). ClipProcess m x -> Sem effs x)
 -> Sem (ClipProcess : effs) a -> Sem effs a)
-> (forall x (m :: * -> *). ClipProcess m 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))

-- | Interpret `ClipProcess` by printing out the command it would have run to the terminal.
interpretFFMpegNoop :: Member (Embed IO) effs => Sem (ClipProcess ': effs) a -> Sem effs a
interpretFFMpegNoop :: Sem (ClipProcess : effs) a -> Sem effs a
interpretFFMpegNoop = (forall x (m :: * -> *). ClipProcess m x -> Sem effs x)
-> Sem (ClipProcess : effs) a -> Sem effs a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (m :: * -> *). e m x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall x (m :: * -> *). ClipProcess m x -> Sem effs x)
 -> Sem (ClipProcess : effs) a -> Sem effs a)
-> (forall x (m :: * -> *). ClipProcess m x -> Sem effs x)
-> Sem (ClipProcess : effs) a
-> Sem effs a
forall a b. (a -> b) -> a -> b
$ \case
  ExtractAudio x ts  -> IO () -> Sem effs ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO () -> Sem effs ()) -> IO () -> Sem effs ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall a. Show a => a -> IO ()
print (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
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)
  ExtractClips x ts  -> IO () -> Sem effs ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO () -> Sem effs ()) -> IO () -> Sem effs ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall a. Show a => a -> IO ()
print (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
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)
  ExtractFrames x ts -> IO () -> Sem effs ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO () -> Sem effs ()) -> IO () -> Sem effs ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall a. Show a => a -> IO ()
print (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
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)