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

module Cmd.Instrument.MidiInstDb (
    save_synth, load_synth
    , generate_names, clean_name
) where
import qualified Control.Monad.Identity as Identity
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Time as Time

import           System.FilePath ((</>))

import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Logger as Logger

import qualified App.Config as Config
import qualified App.Path as Path
import qualified Cmd.Instrument.MidiInst as MidiInst
import qualified Instrument.Common as Common
import qualified Instrument.Inst as Inst
import qualified Instrument.InstT as InstT
import qualified Instrument.Serialize
import qualified Instrument.Tag as Tag

import qualified Perform.Midi.Patch as Patch

import           Global



-- | Some instruments want to load their patches in elaborate slow ways, like
-- parsing a directory full of sysexes.  These patches can export a @make_db@
-- function, which will do the slow parts and save the results in a cache file.
-- The @load@ function will simply read the cache file, if present.
save_synth :: Path.AppDir -> InstT.SynthName -> [MidiInst.Patch] -> IO ()
save_synth :: AppDir -> Text -> [Patch] -> IO ()
save_synth AppDir
app_dir Text
synth_name [Patch]
patches = do
    -- Assume these are loaded from files, so I'll need to generate valid
    -- names.
    let (Map Text Patch
patch_map, [Text]
logs) = [Patch] -> (Map Text Patch, [Text])
generate_names [Patch]
patches
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text
"synth " forall a. Semigroup a => a -> a -> a
<> Text
synth_name forall a. Semigroup a => a -> a -> a
<> Text
": ") <>)) [Text]
logs
    UTCTime
now <- IO UTCTime
Time.getCurrentTime
    [Char] -> InstrumentDb -> IO ()
Instrument.Serialize.serialize (AppDir -> [Char] -> [Char]
db_path AppDir
app_dir (Text -> [Char]
untxt Text
synth_name)) forall a b. (a -> b) -> a -> b
$
        UTCTime -> Map Text (Patch, Common ()) -> InstrumentDb
Instrument.Serialize.InstrumentDb UTCTime
now (Patch -> (Patch, Common ())
strip_code forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text Patch
patch_map)
    where
    strip_code :: MidiInst.Patch -> (Patch.Patch, Common.Common ())
    strip_code :: Patch -> (Patch, Common ())
strip_code (MidiInst.Patch Patch
patch Maybe Text
_dummy Common Code
common) =
        (Patch
patch, Common Code
common { common_code :: ()
Common.common_code = () })

load_synth :: (Patch.Patch -> MidiInst.Code) -> InstT.SynthName -> Text
    -> Path.AppDir -> IO (Maybe MidiInst.Synth)
load_synth :: (Patch -> Code) -> Text -> Text -> AppDir -> IO (Maybe Synth)
load_synth Patch -> Code
get_code Text
synth_name Text
doc AppDir
app_dir = do
    let fname :: [Char]
fname = AppDir -> [Char] -> [Char]
db_path AppDir
app_dir (Text -> [Char]
untxt Text
synth_name)
    [Char] -> IO (Either UnserializeError InstrumentDb)
Instrument.Serialize.unserialize [Char]
fname forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left UnserializeError
err -> do
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"Error loading instrument db " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Char]
fname forall a. Semigroup a => a -> a -> a
<> Text
": "
                forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.strip (forall a. Pretty a => a -> Text
pretty UnserializeError
err)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Right (Instrument.Serialize.InstrumentDb UTCTime
_time Map Text (Patch, Common ())
patch_map) ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall code. Text -> Text -> [(Text, Inst code)] -> SynthDecl code
Inst.SynthDecl Text
synth_name Text
doc
                (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall {code}. (Patch, Common code) -> Inst InstrumentCode
make) (forall k a. Map k a -> [(k, a)]
Map.toList Map Text (Patch, Common ())
patch_map))
    where
    make :: (Patch, Common code) -> Inst InstrumentCode
make (Patch
patch, Common code
common) = Patch -> Inst InstrumentCode
MidiInst.make_inst forall a b. (a -> b) -> a -> b
$
        (Patch :-> Common Code
MidiInst.common forall f a. Lens f a -> a -> f -> f
#= Common code
common { common_code :: Code
Common.common_code = Patch -> Code
get_code Patch
patch }) forall a b. (a -> b) -> a -> b
$
        Patch -> Patch
MidiInst.make_patch Patch
patch

db_path :: Path.AppDir -> FilePath -> FilePath
db_path :: AppDir -> [Char] -> [Char]
db_path AppDir
app_dir [Char]
name =
    AppDir -> Relative -> [Char]
Path.to_absolute AppDir
app_dir Relative
Config.instrument_cache_dir [Char] -> [Char] -> [Char]
</> [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
".db"

-- * generate_names

-- | 'Patch.inst_name' is the name as it appears on the synth, so it's not
-- guaranteed to be unique.  Also, due to loading from sysexes, there may be
-- duplicate patches.  Generate valid names for the patches, drop duplicates,
-- and disambiguate names that wind up the same.
generate_names :: [MidiInst.Patch] -> (Map InstT.Name MidiInst.Patch, [Text])
generate_names :: [Patch] -> (Map Text Patch, [Text])
generate_names = -- This only touches the 'MidiInst.patch_patch' field.
    forall {w} {a}. LoggerT w Identity [(Text, a)] -> (Map Text a, [w])
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM (Text, [Patch]) -> LoggerT Text Identity [(Text, Patch)]
split forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Text, [Patch]) -> Logger (Text, [Patch])
drop_dup_initialization)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a. Ord key => (a -> key) -> [a] -> [(key, [a])]
Lists.keyedGroupSort (Text -> Text
clean_name forall b c a. (b -> c) -> (a -> b) -> a -> c
. Patch -> Text
inst_name)
    where
    run :: LoggerT w Identity [(Text, a)] -> (Map Text a, [w])
run = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
Identity.runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) w a. Monad m => LoggerT w m a -> m (a, [w])
Logger.run
    -- If the name and initialization is the same, they are likely duplicates.
    drop_dup_initialization :: (InstT.Name, [MidiInst.Patch])
        -> Logger (InstT.Name, [MidiInst.Patch])
    drop_dup_initialization :: (Text, [Patch]) -> Logger (Text, [Patch])
drop_dup_initialization (Text
name, [Patch]
patches) = do
        let ([Patch]
unique, [(Patch, [Patch])]
dups) = forall k a. Ord k => (a -> k) -> [a] -> ([a], [(a, [a])])
Lists.partitionDups
                (Patch -> InitializePatch
Patch.patch_initialize forall b c a. (b -> c) -> (a -> b) -> a -> c
. Patch -> Patch
MidiInst.patch_patch) [Patch]
patches
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Patch, [Patch])]
dups forall a b. (a -> b) -> a -> b
$ \(Patch
patch, [Patch]
dups) ->
            forall {m :: * -> *}. MonadLogger Text m => Text -> [Patch] -> m ()
log (Text
"dropped patches with the same initialization as "
                forall a. Semigroup a => a -> a -> a
<> Patch -> Text
details Patch
patch) [Patch]
dups
        forall (m :: * -> *) a. Monad m => a -> m a
return (Text
name, [Patch]
unique)
    -- The remaining patches are probably different and just happened to get
    -- the same name, so number them to disambiguate.
    split :: (InstT.Name, [MidiInst.Patch])
        -> Logger [(InstT.Name, MidiInst.Patch)]
    split :: (Text, [Patch]) -> LoggerT Text Identity [(Text, Patch)]
split (Text
name, patches :: [Patch]
patches@(Patch
_:Patch
_:[Patch]
_)) = do
        let named :: [(Text, Patch)]
named = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map ((Text
name<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> Text
showt) [Integer
1..]) [Patch]
patches
        forall {m :: * -> *}. MonadLogger Text m => Text -> [Patch] -> m ()
log (Text
"split into " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Text, Patch)]
named)) [Patch]
patches
        forall (m :: * -> *) a. Monad m => a -> m a
return [(Text, Patch)]
named
    split (Text
name, [Patch]
patches) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text
name,) [Patch]
patches

    log :: Text -> [Patch] -> m ()
log Text
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    log Text
msg [Patch]
patches = forall w (m :: * -> *). MonadLogger w m => w -> m ()
Logger.log forall a b. (a -> b) -> a -> b
$ Text
msg forall a. Semigroup a => a -> a -> a
<> Text
": "
        forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map Patch -> Text
details [Patch]
patches)
    details :: Patch -> Text
details Patch
patch =
        Patch -> Text
inst_name Patch
patch forall a. Semigroup a => a -> a -> a
<> Text
" (" forall a. Semigroup a => a -> a -> a
<> forall a. a -> Maybe a -> a
fromMaybe Text
"" (Patch -> Maybe Text
filename Patch
patch) forall a. Semigroup a => a -> a -> a
<> Text
")"
    inst_name :: Patch -> Text
inst_name = Patch -> Text
Patch.patch_name forall b c a. (b -> c) -> (a -> b) -> a -> c
. Patch -> Patch
MidiInst.patch_patch
    filename :: Patch -> Maybe Text
filename = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
Tag.file forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall code. Common code -> [(Text, Text)]
Common.common_tags forall b c a. (b -> c) -> (a -> b) -> a -> c
. Patch -> Common Code
MidiInst.patch_common

type Logger a = Logger.LoggerT Text Identity.Identity a

-- | People like to put wacky characters in their names, but it makes them
-- hard to type.
clean_name :: Text -> InstT.Name
clean_name :: Text -> Text
clean_name =
    (Char -> Bool) -> Text -> Text
Text.dropWhileEnd (forall a. Eq a => a -> a -> Bool
==Char
'-') forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
Text.dropWhile (forall a. Eq a => a -> a -> Bool
==Char
'-')
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
strip_dups
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
Text.filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
valid_instrument_chars) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> Text -> Text
Text.map Char -> Char
replace
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.toLower
    where
    strip_dups :: Text -> Text
strip_dups = Text -> [Text] -> Text
Text.intercalate Text
"-" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
Text.split (forall a. Eq a => a -> a -> Bool
==Char
'-')
    replace :: Char -> Char
replace Char
c
        | Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
" _/" :: [Char]) = Char
'-'
        | Bool
otherwise = Char
c

valid_instrument_chars :: [Char]
valid_instrument_chars :: [Char]
valid_instrument_chars = Char
'-' forall a. a -> [a] -> [a]
: [Char
'0'..Char
'9'] forall a. [a] -> [a] -> [a]
++ [Char
'a'..Char
'z']