{-# LANGUAGE CPP #-}

{- | The FluidSynth backend for 'Termtab.Audio.AudioEngine': owns a
settings\/synth\/audio-driver triple from "Termtab.Audio.FluidSynth.Raw"
and exposes it as domain-typed operations ('noteOn', 'noteOff',
'programChange' take 'Termtab.Types' newtypes, not raw 'Foreign.C.Types.CInt's).
"Termtab.Audio" dispatches to this module whenever
'Termtab.Audio.Types.BackendFluidSynth' is selected.
-}
module Termtab.Audio.FluidSynth (
    FluidSynthEngine,
    initFluidSynth,
    shutdownFluidSynth,
    withFluidSynth,
    noteOn,
    noteOff,
    programChange,
) where

import Control.Exception (Exception, bracket, throwIO)
import Control.Monad (void, when)
import Foreign.C.String (withCString)
import Foreign.Ptr (Ptr, nullPtr)

import Termtab.Audio.FluidSynth.Raw
import Termtab.Audio.Types (AudioConfig (..))
import Termtab.Types (MidiChannel (..), MidiProgram (..), Pitch (..), Velocity (..))

{- | The FluidSynth audio driver name to request for the current OS,
chosen at compile time. Picked explicitly rather than letting FluidSynth
auto-detect, because auto-detect often prefers JACK even on macOS, which
then fails outright if @jackd@ isn't running.
-}
audioDriverName :: String
#if defined(darwin_HOST_OS)
audioDriverName = "coreaudio"
#elif defined(mingw32_HOST_OS)
audioDriverName = "dsound"
#else
audioDriverName :: String
audioDriverName = String
"pulseaudio"
#endif

{- | An initialized FluidSynth instance: settings, synth, and audio driver
handles that must all be torn down together (see 'shutdownFluidSynth')
in the reverse of their creation order.
-}
data FluidSynthEngine = FluidSynthEngine
    { FluidSynthEngine -> Ptr C'fluid_settings_t
fseSettings :: Ptr C'fluid_settings_t
    , FluidSynthEngine -> Ptr C'fluid_synth_t
fseSynth :: Ptr C'fluid_synth_t
    , FluidSynthEngine -> Ptr C'fluid_audio_driver_t
fseDriver :: Ptr C'fluid_audio_driver_t
    }

{- | Failure modes of 'initFluidSynth', thrown as exceptions rather than
returned, so that a partially-constructed engine can never be observed —
see 'initFluidSynth' for exactly when each is raised and what it cleans
up first.
-}
data FluidSynthError
    = SettingsCreationFailed
    | SynthCreationFailed
    | SoundFontLoadFailed FilePath
    | AudioDriverCreationFailed
    deriving (Int -> FluidSynthError -> ShowS
[FluidSynthError] -> ShowS
FluidSynthError -> String
(Int -> FluidSynthError -> ShowS)
-> (FluidSynthError -> String)
-> ([FluidSynthError] -> ShowS)
-> Show FluidSynthError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FluidSynthError -> ShowS
showsPrec :: Int -> FluidSynthError -> ShowS
$cshow :: FluidSynthError -> String
show :: FluidSynthError -> String
$cshowList :: [FluidSynthError] -> ShowS
showList :: [FluidSynthError] -> ShowS
Show)

instance Exception FluidSynthError

{- | Bring up a FluidSynth instance: create settings, force the
platform-appropriate 'audioDriverName', create the synth, load the
SoundFont from 'acSoundFontPath', then start the audio driver. Each step
that can fail tears down everything created so far before throwing the
corresponding 'FluidSynthError', so callers never get a half-initialized
'FluidSynthEngine'.
-}
initFluidSynth :: AudioConfig -> IO FluidSynthEngine
initFluidSynth :: AudioConfig -> IO FluidSynthEngine
initFluidSynth AudioConfig
cfg = do
    settings <- IO (Ptr C'fluid_settings_t)
c'new_fluid_settings
    when (settings == nullPtr) $ throwIO SettingsCreationFailed

    -- Set the audio driver explicitly per platform.
    -- FluidSynth's auto-detect often picks JACK first (even on macOS),
    -- which fails if jackd isn't running.
    withCString "audio.driver" $ \CString
key ->
        String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
audioDriverName ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
val ->
            IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr C'fluid_settings_t -> CString -> CString -> IO CInt
c'fluid_settings_setstr Ptr C'fluid_settings_t
settings CString
key CString
val

    synth <- c'new_fluid_synth settings
    when (synth == nullPtr) $ do
        c'delete_fluid_settings settings
        throwIO SynthCreationFailed

    sfResult <- withCString (acSoundFontPath cfg) $ \CString
path ->
        Ptr C'fluid_synth_t -> CString -> CInt -> IO CInt
c'fluid_synth_sfload Ptr C'fluid_synth_t
synth CString
path CInt
1
    when (sfResult < 0) $ do
        c'delete_fluid_synth synth
        c'delete_fluid_settings settings
        throwIO (SoundFontLoadFailed (acSoundFontPath cfg))

    driver <- c'new_fluid_audio_driver settings synth
    when (driver == nullPtr) $ do
        c'delete_fluid_synth synth
        c'delete_fluid_settings settings
        throwIO AudioDriverCreationFailed

    return
        FluidSynthEngine
            { fseSettings = settings
            , fseSynth = synth
            , fseDriver = driver
            }

{- | Tear down a 'FluidSynthEngine' in the reverse of 'initFluidSynth''s
creation order: audio driver, then synth, then settings.
-}
shutdownFluidSynth :: FluidSynthEngine -> IO ()
shutdownFluidSynth :: FluidSynthEngine -> IO ()
shutdownFluidSynth FluidSynthEngine
engine = do
    Ptr C'fluid_audio_driver_t -> IO ()
c'delete_fluid_audio_driver (FluidSynthEngine -> Ptr C'fluid_audio_driver_t
fseDriver FluidSynthEngine
engine)
    Ptr C'fluid_synth_t -> IO ()
c'delete_fluid_synth (FluidSynthEngine -> Ptr C'fluid_synth_t
fseSynth FluidSynthEngine
engine)
    Ptr C'fluid_settings_t -> IO ()
c'delete_fluid_settings (FluidSynthEngine -> Ptr C'fluid_settings_t
fseSettings FluidSynthEngine
engine)

{- | Initialize a 'FluidSynthEngine', run an action with it, and shut it
down afterwards even on exception (via @bracket@).
-}
withFluidSynth :: AudioConfig -> (FluidSynthEngine -> IO a) -> IO a
withFluidSynth :: forall a. AudioConfig -> (FluidSynthEngine -> IO a) -> IO a
withFluidSynth AudioConfig
cfg = IO FluidSynthEngine
-> (FluidSynthEngine -> IO ())
-> (FluidSynthEngine -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (AudioConfig -> IO FluidSynthEngine
initFluidSynth AudioConfig
cfg) FluidSynthEngine -> IO ()
shutdownFluidSynth

-- | Start a note sounding on the given channel\/pitch\/velocity.
noteOn :: FluidSynthEngine -> MidiChannel -> Pitch -> Velocity -> IO ()
noteOn :: FluidSynthEngine -> MidiChannel -> Pitch -> Velocity -> IO ()
noteOn FluidSynthEngine
engine (MidiChannel Int
ch) (Pitch Int
p) (Velocity Int
v) =
    IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$
        Ptr C'fluid_synth_t -> CInt -> CInt -> CInt -> IO CInt
c'fluid_synth_noteon
            (FluidSynthEngine -> Ptr C'fluid_synth_t
fseSynth FluidSynthEngine
engine)
            (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ch)
            (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
p)
            (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v)

-- | Stop the note previously started with 'noteOn' at the same channel\/pitch.
noteOff :: FluidSynthEngine -> MidiChannel -> Pitch -> IO ()
noteOff :: FluidSynthEngine -> MidiChannel -> Pitch -> IO ()
noteOff FluidSynthEngine
engine (MidiChannel Int
ch) (Pitch Int
p) =
    IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$
        Ptr C'fluid_synth_t -> CInt -> CInt -> IO CInt
c'fluid_synth_noteoff
            (FluidSynthEngine -> Ptr C'fluid_synth_t
fseSynth FluidSynthEngine
engine)
            (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ch)
            (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
p)

{- | Switch the given channel to the given General MIDI program (instrument
patch) from the loaded SoundFont.
-}
programChange :: FluidSynthEngine -> MidiChannel -> MidiProgram -> IO ()
programChange :: FluidSynthEngine -> MidiChannel -> MidiProgram -> IO ()
programChange FluidSynthEngine
engine (MidiChannel Int
ch) (MidiProgram Int
prog) =
    IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$
        Ptr C'fluid_synth_t -> CInt -> CInt -> IO CInt
c'fluid_synth_program_change
            (FluidSynthEngine -> Ptr C'fluid_synth_t
fseSynth FluidSynthEngine
engine)
            (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ch)
            (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
prog)