-- 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 CPP #-}
{- | Load the instrument db.  This collects together all the local instrument
    definitions.

    MIDI instrument definitions are local configuration, so this expects
    a locally defined Local.Instrument module, which should export:

    > midi_synths :: [MidiInst.Synth]
    > all_loads :: [(InstT.SynthName, ('MidiInst.MakeDb', 'MidiInst.Load'))]

    "Instrument.MakeDb" is used to create the caches that @all_loads@ relies
    on.
-}
module App.LoadInstruments where
import           System.FilePath ((</>))

import qualified App.Config as Config
import qualified App.Path as Path
import qualified Cmd.Cmd as Cmd
import qualified Cmd.Instrument.MidiInst as MidiInst
import qualified Instrument.Inst as Inst
import qualified Instrument.InstT as InstT
import qualified Instrument.Parse as Parse
import qualified Local.Instrument
import qualified Perform.Im.Play
import qualified Perform.Lilypond.Constants as Lilypond.Constants
import qualified Perform.Sc.PatchDb as Sc.PatchDb
import qualified Util.Log as Log

#include "hsconfig.h"
#if defined(ENABLE_IM) && !defined(TESTING)
import qualified Synth.Faust.PatchDb as Faust.PatchDb
import qualified Synth.Sampler.PatchDb as Sampler.PatchDb
import qualified User.Elaforge.Instrument.Ness as Ness
#endif

import           Global


midi_synths :: [MidiInst.Synth]
midi_synths :: [Synth]
midi_synths = [Synth]
Local.Instrument.midi_synths

-- | Each synth that caches to disk has a function to make the cache, and one
-- to load it.
all_loads :: [(InstT.SynthName, (MidiInst.MakeDb, MidiInst.Load))]
all_loads :: [(Text, (MakeDb, Load))]
all_loads = [(Text, (MakeDb, Load))]
Local.Instrument.all_loads

im_synths :: [MidiInst.Synth]
im_synths :: [Synth]
im_synths =
    [ Synth
Perform.Im.Play.play_cache_synth
#if defined(ENABLE_IM) && !defined(TESTING)
    , Synth
Sampler.PatchDb.synth
    , Synth
Faust.PatchDb.synth
    , Synth
Ness.synth
#endif
    ]

-- | Warnings validating synths.  TODO this should probably be merged with
-- MidiInst.Synth.
synth_warnings :: [Text]
synth_warnings :: [Text]
synth_warnings = [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [
#if defined(ENABLE_IM) && !defined(TESTING)
    [Text]
Faust.PatchDb.warnings
#endif
    ]

internal_synths :: [MidiInst.Synth]
internal_synths :: [Synth]
internal_synths = [InstrumentCode -> Synth
forall code. code -> SynthDecl code
Lilypond.Constants.ly_synth InstrumentCode
Cmd.empty_code]

load :: Path.AppDir -> IO (Inst.Db Cmd.InstrumentCode)
load :: AppDir -> IO (Db InstrumentCode)
load AppDir
app_dir = do
    [Synth]
loaded <- (Load -> IO (Maybe Synth)) -> [Load] -> IO [Synth]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (Load -> Load
forall a b. (a -> b) -> a -> b
$ AppDir
app_dir) ([Load] -> IO [Synth]) -> [Load] -> IO [Synth]
forall a b. (a -> b) -> a -> b
$
        Load
Sc.PatchDb.load_synth Load -> [Load] -> [Load]
forall a. a -> [a] -> [a]
: ((Text, (MakeDb, Load)) -> Load)
-> [(Text, (MakeDb, Load))] -> [Load]
forall a b. (a -> b) -> [a] -> [b]
map ((MakeDb, Load) -> Load
forall a b. (a, b) -> b
snd ((MakeDb, Load) -> Load)
-> ((Text, (MakeDb, Load)) -> (MakeDb, Load))
-> (Text, (MakeDb, Load))
-> Load
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, (MakeDb, Load)) -> (MakeDb, Load)
forall a b. (a, b) -> b
snd) [(Text, (MakeDb, Load))]
all_loads
    let synths :: [Synth]
synths = [[Synth]] -> [Synth]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [Synth]
im_synths
            , [Synth]
loaded
            , [Synth]
midi_synths
            , [Synth]
internal_synths
            ]
    let annot_fn :: FilePath
annot_fn = AppDir -> Relative -> FilePath
Path.to_absolute AppDir
app_dir Relative
Config.local_dir
            FilePath -> FilePath -> FilePath
</> FilePath
"instrument_annotations"
    Map Qualified [Annotation]
annots <- FilePath -> IO (Either FilePath (Map Qualified [Annotation]))
Parse.parse_annotations FilePath
annot_fn IO (Either FilePath (Map Qualified [Annotation]))
-> (Either FilePath (Map Qualified [Annotation])
    -> IO (Map Qualified [Annotation]))
-> IO (Map Qualified [Annotation])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        -- The parsec error already includes the filename.
        Left FilePath
err -> Text -> IO ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (FilePath -> Text
txt FilePath
err) IO ()
-> IO (Map Qualified [Annotation])
-> IO (Map Qualified [Annotation])
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Map Qualified [Annotation] -> IO (Map Qualified [Annotation])
forall (m :: * -> *) a. Monad m => a -> m a
return Map Qualified [Annotation]
forall a. Monoid a => a
mempty
        Right Map Qualified [Annotation]
annots -> Map Qualified [Annotation] -> IO (Map Qualified [Annotation])
forall (m :: * -> *) a. Monad m => a -> m a
return Map Qualified [Annotation]
annots
    let (Db InstrumentCode
db, [Text]
warns) = [Synth] -> (Db InstrumentCode, [Text])
forall code. [SynthDecl code] -> (Db code, [Text])
Inst.db [Synth]
synths
    [Text] -> (Text -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Text]
synth_warnings [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
warns) ((Text -> IO ()) -> IO ()) -> (Text -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Text
msg -> Text -> IO ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"inst db: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
    (Db InstrumentCode
db, [Qualified]
not_found) <- (Db InstrumentCode, [Qualified])
-> IO (Db InstrumentCode, [Qualified])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Db InstrumentCode, [Qualified])
 -> IO (Db InstrumentCode, [Qualified]))
-> (Db InstrumentCode, [Qualified])
-> IO (Db InstrumentCode, [Qualified])
forall a b. (a -> b) -> a -> b
$ Map Qualified [Annotation]
-> Db InstrumentCode -> (Db InstrumentCode, [Qualified])
forall code.
Map Qualified [Annotation] -> Db code -> (Db code, [Qualified])
Inst.annotate Map Qualified [Annotation]
annots Db InstrumentCode
db
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Qualified] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Qualified]
not_found) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> IO ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"annotated instruments not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Qualified] -> Text
forall a. Pretty a => a -> Text
pretty [Qualified]
not_found
    Db InstrumentCode -> IO (Db InstrumentCode)
forall (m :: * -> *) a. Monad m => a -> m a
return Db InstrumentCode
db