-- 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 = 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 = [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 <- forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (forall a b. (a -> b) -> a -> b
$ AppDir
app_dir) forall a b. (a -> b) -> a -> b
$
        Load
Sc.PatchDb.load_synth forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Text, (MakeDb, Load))]
all_loads
    let synths :: [Synth]
synths = 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        -- The parsec error already includes the filename.
        Left FilePath
err -> forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (FilePath -> Text
txt FilePath
err) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
        Right Map Qualified [Annotation]
annots -> forall (m :: * -> *) a. Monad m => a -> m a
return Map Qualified [Annotation]
annots
    let (Db InstrumentCode
db, [Text]
warns) = forall code. [SynthDecl code] -> (Db code, [Text])
Inst.db [Synth]
synths
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Text]
synth_warnings forall a. [a] -> [a] -> [a]
++ [Text]
warns) forall a b. (a -> b) -> a -> b
$ \Text
msg -> forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"inst db: " forall a. Semigroup a => a -> a -> a
<> Text
msg
    (Db InstrumentCode
db, [Qualified]
not_found) <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall code.
Map Qualified [Annotation] -> Db code -> (Db code, [Qualified])
Inst.annotate Map Qualified [Annotation]
annots Db InstrumentCode
db
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Qualified]
not_found) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"annotated instruments not found: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [Qualified]
not_found
    forall (m :: * -> *) a. Monad m => a -> m a
return Db InstrumentCode
db