-- 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.Log as Log
import qualified Util.Logger as Logger
import qualified Util.Seq as Seq

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
    (Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> IO ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice (Text -> IO ()) -> (Text -> Text) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text
"synth " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
synth_name Text -> Text -> Text
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)) (InstrumentDb -> IO ()) -> InstrumentDb -> IO ()
forall a b. (a -> b) -> a -> b
$
        UTCTime -> Map Text (Patch, Common ()) -> InstrumentDb
Instrument.Serialize.InstrumentDb UTCTime
now (Patch -> (Patch, Common ())
strip_code (Patch -> (Patch, Common ()))
-> Map Text Patch -> Map Text (Patch, Common ())
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 IO (Either UnserializeError InstrumentDb)
-> (Either UnserializeError InstrumentDb -> IO (Maybe Synth))
-> IO (Maybe Synth)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left UnserializeError
err -> do
            Text -> IO ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Error loading instrument db " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall a. Show a => a -> Text
showt [Char]
fname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.strip (UnserializeError -> Text
forall a. Pretty a => a -> Text
pretty UnserializeError
err)
            Maybe Synth -> IO (Maybe Synth)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Synth
forall a. Maybe a
Nothing
        Right (Instrument.Serialize.InstrumentDb UTCTime
_time Map Text (Patch, Common ())
patch_map) ->
            Maybe Synth -> IO (Maybe Synth)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Synth -> IO (Maybe Synth))
-> Maybe Synth -> IO (Maybe Synth)
forall a b. (a -> b) -> a -> b
$ Synth -> Maybe Synth
forall a. a -> Maybe a
Just (Synth -> Maybe Synth) -> Synth -> Maybe Synth
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [(Text, Inst InstrumentCode)] -> Synth
forall code. Text -> Text -> [(Text, Inst code)] -> SynthDecl code
Inst.SynthDecl Text
synth_name Text
doc
                (((Text, (Patch, Common ())) -> (Text, Inst InstrumentCode))
-> [(Text, (Patch, Common ()))] -> [(Text, Inst InstrumentCode)]
forall a b. (a -> b) -> [a] -> [b]
map (((Patch, Common ()) -> Inst InstrumentCode)
-> (Text, (Patch, Common ())) -> (Text, Inst InstrumentCode)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Patch, Common ()) -> Inst InstrumentCode
forall {code}. (Patch, Common code) -> Inst InstrumentCode
make) (Map Text (Patch, Common ()) -> [(Text, (Patch, Common ()))]
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 (Patch -> Inst InstrumentCode) -> Patch -> Inst InstrumentCode
forall a b. (a -> b) -> a -> b
$
        (Patch :-> Common Code
MidiInst.common (Patch :-> Common Code) -> Common Code -> Patch -> Patch
forall f a. Lens f a -> a -> f -> f
#= Common code
common { common_code :: Code
Common.common_code = Patch -> Code
get_code Patch
patch }) (Patch -> Patch) -> 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 [Char] -> [Char] -> [Char]
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.
    LoggerT Text Identity [(Text, Patch)] -> (Map Text Patch, [Text])
forall {w} {a}. LoggerT w Identity [(Text, a)] -> (Map Text a, [w])
run (LoggerT Text Identity [(Text, Patch)] -> (Map Text Patch, [Text]))
-> ([Patch] -> LoggerT Text Identity [(Text, Patch)])
-> [Patch]
-> (Map Text Patch, [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Text, [Patch]) -> LoggerT Text Identity [(Text, Patch)])
-> [(Text, [Patch])] -> LoggerT Text Identity [(Text, Patch)]
forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM (Text, [Patch]) -> LoggerT Text Identity [(Text, Patch)]
split ([(Text, [Patch])] -> LoggerT Text Identity [(Text, Patch)])
-> ([(Text, [Patch])] -> LoggerT Text Identity [(Text, [Patch])])
-> [(Text, [Patch])]
-> LoggerT Text Identity [(Text, Patch)]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ((Text, [Patch]) -> LoggerT Text Identity (Text, [Patch]))
-> [(Text, [Patch])] -> LoggerT Text Identity [(Text, [Patch])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Text, [Patch]) -> LoggerT Text Identity (Text, [Patch])
drop_dup_initialization)
        ([(Text, [Patch])] -> LoggerT Text Identity [(Text, Patch)])
-> ([Patch] -> [(Text, [Patch])])
-> [Patch]
-> LoggerT Text Identity [(Text, Patch)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Patch -> Text) -> [Patch] -> [(Text, [Patch])]
forall key a. Ord key => (a -> key) -> [a] -> [(key, [a])]
Seq.keyed_group_sort (Text -> Text
clean_name (Text -> Text) -> (Patch -> Text) -> Patch -> Text
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 = ([(Text, a)] -> Map Text a)
-> ([(Text, a)], [w]) -> (Map Text a, [w])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [(Text, a)] -> Map Text a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (([(Text, a)], [w]) -> (Map Text a, [w]))
-> (LoggerT w Identity [(Text, a)] -> ([(Text, a)], [w]))
-> LoggerT w Identity [(Text, a)]
-> (Map Text a, [w])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity ([(Text, a)], [w]) -> ([(Text, a)], [w])
forall a. Identity a -> a
Identity.runIdentity (Identity ([(Text, a)], [w]) -> ([(Text, a)], [w]))
-> (LoggerT w Identity [(Text, a)] -> Identity ([(Text, a)], [w]))
-> LoggerT w Identity [(Text, a)]
-> ([(Text, a)], [w])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoggerT w Identity [(Text, a)] -> Identity ([(Text, a)], [w])
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]) -> LoggerT Text Identity (Text, [Patch])
drop_dup_initialization (Text
name, [Patch]
patches) = do
        let ([Patch]
unique, [(Patch, [Patch])]
dups) = (Patch -> InitializePatch)
-> [Patch] -> ([Patch], [(Patch, [Patch])])
forall k a. Ord k => (a -> k) -> [a] -> ([a], [(a, [a])])
Seq.partition_dups
                (Patch -> InitializePatch
Patch.patch_initialize (Patch -> InitializePatch)
-> (Patch -> Patch) -> Patch -> InitializePatch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Patch -> Patch
MidiInst.patch_patch) [Patch]
patches
        [(Patch, [Patch])]
-> ((Patch, [Patch]) -> LoggerT Text Identity ())
-> LoggerT Text Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Patch, [Patch])]
dups (((Patch, [Patch]) -> LoggerT Text Identity ())
 -> LoggerT Text Identity ())
-> ((Patch, [Patch]) -> LoggerT Text Identity ())
-> LoggerT Text Identity ()
forall a b. (a -> b) -> a -> b
$ \(Patch
patch, [Patch]
dups) ->
            Text -> [Patch] -> LoggerT Text Identity ()
forall {m :: * -> *}. MonadLogger Text m => Text -> [Patch] -> m ()
log (Text
"dropped patches with the same initialization as "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Patch -> Text
details Patch
patch) [Patch]
dups
        (Text, [Patch]) -> LoggerT Text Identity (Text, [Patch])
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 = [Text] -> [Patch] -> [(Text, Patch)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Integer -> Text) -> [Integer] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text
name<>) (Text -> Text) -> (Integer -> Text) -> Integer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Text
forall a. Show a => a -> Text
showt) [Integer
1..]) [Patch]
patches
        Text -> [Patch] -> LoggerT Text Identity ()
forall {m :: * -> *}. MonadLogger Text m => Text -> [Patch] -> m ()
log (Text
"split into " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " (((Text, Patch) -> Text) -> [(Text, Patch)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Patch) -> Text
forall a b. (a, b) -> a
fst [(Text, Patch)]
named)) [Patch]
patches
        [(Text, Patch)] -> LoggerT Text Identity [(Text, Patch)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Text, Patch)]
named
    split (Text
name, [Patch]
patches) = [(Text, Patch)] -> LoggerT Text Identity [(Text, Patch)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Text, Patch)] -> LoggerT Text Identity [(Text, Patch)])
-> [(Text, Patch)] -> LoggerT Text Identity [(Text, Patch)]
forall a b. (a -> b) -> a -> b
$ (Patch -> (Text, Patch)) -> [Patch] -> [(Text, Patch)]
forall a b. (a -> b) -> [a] -> [b]
map (Text
name,) [Patch]
patches

    log :: Text -> [Patch] -> m ()
log Text
_ [] = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    log Text
msg [Patch]
patches = Text -> m ()
forall w (m :: * -> *). MonadLogger w m => w -> m ()
Logger.log (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " ((Patch -> Text) -> [Patch] -> [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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Patch -> Maybe Text
filename Patch
patch) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    inst_name :: Patch -> Text
inst_name = Patch -> Text
Patch.patch_name (Patch -> Text) -> (Patch -> Patch) -> Patch -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Patch -> Patch
MidiInst.patch_patch
    filename :: Patch -> Maybe Text
filename = Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
Tag.file ([(Text, Text)] -> Maybe Text)
-> (Patch -> [(Text, Text)]) -> Patch -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Common Code -> [(Text, Text)]
forall code. Common code -> [(Text, Text)]
Common.common_tags (Common Code -> [(Text, Text)])
-> (Patch -> Common Code) -> Patch -> [(Text, Text)]
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 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'-') (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
Text.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'-')
        (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
strip_dups
        (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
Text.filter (Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
valid_instrument_chars) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> Text -> Text
Text.map Char -> Char
replace
        (Text -> Text) -> (Text -> Text) -> Text -> Text
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
"-" ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null)
        ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
Text.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'-')
    replace :: Char -> Char
replace Char
c
        | Char
c Char -> [Char] -> Bool
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
'-' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char
'0'..Char
'9'] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char
'a'..Char
'z']