-- Copyright 2018 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ExistentialQuantification #-}
-- | This is a simple utility to resample audio files.  It keeps the format and
-- channels the same.
module Util.Audio.ResampleMain where
import qualified Control.Concurrent.Async as Async
import qualified Control.Concurrent.QSem as QSem
import qualified Control.Exception as Exception
import qualified Control.Monad.Trans.Resource as Resource

import qualified GHC.TypeLits as TypeLits
import qualified Sound.File.Sndfile as Sndfile
import qualified System.Console.GetOpt as GetOpt
import qualified System.Environment as Environment
import qualified System.Exit as Exit

import qualified Util.Audio.Audio as Audio
import qualified Util.Audio.File as File
import qualified Util.Audio.Resample as Resample
import qualified Util.Lists as Lists

import           Global


main :: IO ()
main :: IO ()
main = do
    [String]
args <- IO [String]
Environment.getArgs
    ([Flag]
flags, [String]
args) <- case forall a.
ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])
GetOpt.getOpt forall a. ArgOrder a
GetOpt.Permute [OptDescr Flag]
options [String]
args of
        ([Flag]
flags, [String]
args, []) -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Flag]
flags, [String]
args)
        ([Flag]
_, [String]
_, [String]
errs) -> forall {b}. String -> IO b
usage ([String] -> String
unlines [String]
errs)
    let srate :: Int
srate = forall a. a -> Maybe a -> a
fromMaybe Int
defaultSRate forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
Lists.last [Int
sr | SRate Int
sr <- [Flag]
flags]
    Maybe SampleFormat
depth <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> IO SampleFormat
parseDepth forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
Lists.last [String
s | Depth String
s <- [Flag]
flags]
    let write :: String -> String -> IO ()
write String
input String
output = Bool -> Maybe SampleFormat -> Int -> String -> String -> IO ()
process (Flag
Set forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags) Maybe SampleFormat
depth Int
srate String
input String
output
    case [String]
args of
        [String]
_ | Flag
Info forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
args forall a b. (a -> b) -> a -> b
$ \String
input -> do
            Maybe Info
info <- String -> IO (Maybe Info)
File.getInfo String
input
            String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
input forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"no file" forall a. Show a => a -> String
show Maybe Info
info
        [String]
_ | Flag
InPlace forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags -> forall a. Int -> [a] -> (a -> IO ()) -> IO ()
for_ Int
4 [String]
args forall a b. (a -> b) -> a -> b
$ \String
input -> do
            String -> IO ()
putStrLn String
input
            -- safe because File.write writes to a tmp file and renames
            String -> String -> IO ()
write String
input String
input
        [String
input, String
output] -> String -> String -> IO ()
write String
input String
output
        [String]
_ -> forall {b}. String -> IO b
usage String
""
    where
    usage :: String -> IO b
usage String
msg = do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
msg) forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Error: " forall a. Semigroup a => a -> a -> a
<> String
msg
        String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ forall a. String -> [OptDescr a] -> String
GetOpt.usageInfo String
"usage: resample [ flags ] input [ output ]"
            [OptDescr Flag]
options
        forall a. IO a
Exit.exitFailure

for_ :: Int -> [a] -> (a -> IO ()) -> IO ()
for_ :: forall a. Int -> [a] -> (a -> IO ()) -> IO ()
for_ Int
cpus [a]
xs a -> IO ()
f = do
    QSem
sem <- Int -> IO QSem
QSem.newQSem Int
cpus
    forall (f :: * -> *) a b. Foldable f => f a -> (a -> IO b) -> IO ()
Async.forConcurrently_ [a]
xs forall a b. (a -> b) -> a -> b
$ \a
x ->
        forall a b c. IO a -> IO b -> IO c -> IO c
Exception.bracket_ (QSem -> IO ()
QSem.waitQSem QSem
sem) (QSem -> IO ()
QSem.signalQSem QSem
sem) (a -> IO ()
f a
x)

defaultSRate :: Int
defaultSRate :: Int
defaultSRate = Int
44100

data Flag = Set | InPlace | SRate Int | Depth String | Info
    deriving (Flag -> Flag -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Flag -> Flag -> Bool
$c/= :: Flag -> Flag -> Bool
== :: Flag -> Flag -> Bool
$c== :: Flag -> Flag -> Bool
Eq, Int -> Flag -> ShowS
[Flag] -> ShowS
Flag -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Flag] -> ShowS
$cshowList :: [Flag] -> ShowS
show :: Flag -> String
$cshow :: Flag -> String
showsPrec :: Int -> Flag -> ShowS
$cshowsPrec :: Int -> Flag -> ShowS
Show)

options :: [GetOpt.OptDescr Flag]
options :: [OptDescr Flag]
options =
    [ forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
GetOpt.Option [] [String
"srate"]
        (forall a. (String -> a) -> String -> ArgDescr a
GetOpt.ReqArg (Int -> Flag
SRate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> a
read) (forall a. Show a => a -> String
show Int
defaultSRate)) String
"sampling rate"
    , forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
GetOpt.Option [] [String
"depth"] (forall a. (String -> a) -> String -> ArgDescr a
GetOpt.ReqArg String -> Flag
Depth String
"n") String
"bit depth"
    , forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
GetOpt.Option [] [String
"set"] (forall a. a -> ArgDescr a
GetOpt.NoArg Flag
Set)
        String
"set srate, instead of resampling"
    , forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
GetOpt.Option [] [String
"in-place"] (forall a. a -> ArgDescr a
GetOpt.NoArg Flag
InPlace)
        String
"modify file in place"
    , forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
GetOpt.Option [] [String
"info"] (forall a. a -> ArgDescr a
GetOpt.NoArg Flag
Info) String
"just print info"
    ]

parseDepth :: String -> IO Sndfile.SampleFormat
parseDepth :: String -> IO SampleFormat
parseDepth String
s =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO forall a b. (a -> b) -> a -> b
$ Text
"invalid depth: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt String
s) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Maybe SampleFormat
parseDepth_ String
s

parseDepth_ :: String -> Maybe Sndfile.SampleFormat
parseDepth_ :: String -> Maybe SampleFormat
parseDepth_ = \case
    String
"8" -> forall a. a -> Maybe a
Just SampleFormat
Sndfile.SampleFormatPcmU8
    String
"16" -> forall a. a -> Maybe a
Just SampleFormat
Sndfile.SampleFormatPcm16
    String
"24" -> forall a. a -> Maybe a
Just SampleFormat
Sndfile.SampleFormatPcm24
    String
"32" -> forall a. a -> Maybe a
Just SampleFormat
Sndfile.SampleFormatPcm32
    String
"float" -> forall a. a -> Maybe a
Just SampleFormat
Sndfile.SampleFormatFloat
    String
_ -> forall a. Maybe a
Nothing

process :: Bool -> Maybe Sndfile.SampleFormat -> Int -> FilePath -> FilePath
    -> IO ()
process :: Bool -> Maybe SampleFormat -> Int -> String -> String -> IO ()
process Bool
set Maybe SampleFormat
depth Int
srate String
input String
output = case Int -> SomeNat
Audio.someNat Int
srate of
    TypeLits.SomeNat (Proxy n
_ :: Proxy outRate) -> String -> IO (Format, UnknownAudioIO)
File.readUnknown String
input forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        (Format
format, Audio.UnknownAudio (AudioIO rate chan
audio :: Audio.AudioIO inRate inChan)) ->
            forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
Resource.runResourceT forall a b. (a -> b) -> a -> b
$
            forall (rate :: Nat) (chan :: Nat).
(KnownNat rate, KnownNat chan) =>
Format -> String -> AudioIO rate chan -> ResourceT IO ()
File.write @outRate @inChan Format
outFormat String
output forall a b. (a -> b) -> a -> b
$ if Bool
set
                then forall (m :: * -> *) (rate1 :: Nat) (chan :: Nat) (rate2 :: Nat).
Audio m rate1 chan -> Audio m rate2 chan
Audio.castRate AudioIO rate chan
audio
                else forall (rateIn :: Nat) (rateOut :: Nat) (chan :: Nat).
(KnownNat rateIn, KnownNat rateOut, KnownNat chan) =>
Quality -> AudioIO rateIn chan -> AudioIO rateOut chan
Resample.resampleRate Quality
Resample.SincBestQuality AudioIO rate chan
audio
            where
            outFormat :: Format
outFormat = case Maybe SampleFormat
depth of
                Maybe SampleFormat
Nothing -> Format
format
                Just SampleFormat
fmt -> Format
format { sampleFormat :: SampleFormat
Sndfile.sampleFormat = SampleFormat
fmt }