-- Copyright 2013 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 StandaloneDeriving #-}
{- | Functions to save and load the midi db.

    Unlike in "Cmd.Serialize", I don't bother with versions here, because this
    is intended to be just a cache.
-}
module Instrument.Serialize (serialize, unserialize, InstrumentDb(..)) where
import qualified Data.Map as Map
import qualified Data.Time as Time

import qualified Util.Serialize as Serialize
import Util.Serialize (Serialize, get, put, get_tag, put_tag, bad_tag)
import Midi.Instances ()
import Cmd.Serialize ()
import qualified Perform.Midi.Patch as Patch
import qualified Instrument.Common as Common
import qualified Instrument.InstT as InstT
import qualified Instrument.Search as Search
import Global


-- | Serialize instrument definitions to a file.
serialize :: FilePath -> InstrumentDb -> IO ()
serialize :: FilePath -> InstrumentDb -> IO ()
serialize FilePath
fn = IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ())
-> (InstrumentDb -> IO Bool) -> InstrumentDb -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Magic InstrumentDb -> FilePath -> InstrumentDb -> IO Bool
forall a. Serialize a => Magic a -> FilePath -> a -> IO Bool
Serialize.serialize Magic InstrumentDb
instrument_db_magic FilePath
fn

-- | Unserialize instrument definitions.
unserialize :: FilePath -> IO (Either Serialize.UnserializeError InstrumentDb)
unserialize :: FilePath -> IO (Either UnserializeError InstrumentDb)
unserialize = Magic InstrumentDb
-> FilePath -> IO (Either UnserializeError InstrumentDb)
forall a.
Serialize a =>
Magic a -> FilePath -> IO (Either UnserializeError a)
Serialize.unserialize Magic InstrumentDb
instrument_db_magic

instrument_db_magic :: Serialize.Magic InstrumentDb
instrument_db_magic :: Magic InstrumentDb
instrument_db_magic = Char -> Char -> Char -> Char -> Magic InstrumentDb
forall {k} (a :: k). Char -> Char -> Char -> Char -> Magic a
Serialize.Magic Char
'i' Char
'n' Char
's' Char
't'

-- | Time serialized, patches.
data InstrumentDb = InstrumentDb
    Time.UTCTime (Map.Map InstT.Name (Patch.Patch, Common.Common ()))

-- * instances

instance Serialize InstrumentDb where
    put :: Putter InstrumentDb
put (InstrumentDb UTCTime
a Map Name (Patch, Common ())
b) = Putter UTCTime
forall a. Serialize a => Putter a
put UTCTime
a PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter (Map Name (Patch, Common ()))
forall a. Serialize a => Putter a
put Map Name (Patch, Common ())
b
    get :: Get InstrumentDb
get = UTCTime -> Map Name (Patch, Common ()) -> InstrumentDb
InstrumentDb (UTCTime -> Map Name (Patch, Common ()) -> InstrumentDb)
-> Get UTCTime -> Get (Map Name (Patch, Common ()) -> InstrumentDb)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get UTCTime
forall a. Serialize a => Get a
get Get (Map Name (Patch, Common ()) -> InstrumentDb)
-> Get (Map Name (Patch, Common ())) -> Get InstrumentDb
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (Map Name (Patch, Common ()))
forall a. Serialize a => Get a
get

instance Serialize (Common.Common ()) where
    put :: Putter (Common ())
put (Common.Common ()
a Environ
b [Tag]
c Doc
d Set Flag
e CallMap
f) =
        Putter ()
forall a. Serialize a => Putter a
put ()
a PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Environ
forall a. Serialize a => Putter a
put Environ
b PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter [Tag]
forall a. Serialize a => Putter a
put [Tag]
c PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Doc
forall a. Serialize a => Putter a
put Doc
d PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter (Set Flag)
forall a. Serialize a => Putter a
put Set Flag
e PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter CallMap
forall a. Serialize a => Putter a
put CallMap
f
    get :: Get (Common ())
get = () -> Environ -> [Tag] -> Doc -> Set Flag -> CallMap -> Common ()
forall code.
code
-> Environ -> [Tag] -> Doc -> Set Flag -> CallMap -> Common code
Common.Common (() -> Environ -> [Tag] -> Doc -> Set Flag -> CallMap -> Common ())
-> Get ()
-> Get
     (Environ -> [Tag] -> Doc -> Set Flag -> CallMap -> Common ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ()
forall a. Serialize a => Get a
get Get (Environ -> [Tag] -> Doc -> Set Flag -> CallMap -> Common ())
-> Get Environ
-> Get ([Tag] -> Doc -> Set Flag -> CallMap -> Common ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Environ
forall a. Serialize a => Get a
get Get ([Tag] -> Doc -> Set Flag -> CallMap -> Common ())
-> Get [Tag] -> Get (Doc -> Set Flag -> CallMap -> Common ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [Tag]
forall a. Serialize a => Get a
get Get (Doc -> Set Flag -> CallMap -> Common ())
-> Get Doc -> Get (Set Flag -> CallMap -> Common ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Doc
forall a. Serialize a => Get a
get Get (Set Flag -> CallMap -> Common ())
-> Get (Set Flag) -> Get (CallMap -> Common ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (Set Flag)
forall a. Serialize a => Get a
get Get (CallMap -> Common ()) -> Get CallMap -> Get (Common ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get CallMap
forall a. Serialize a => Get a
get

instance Serialize Search.Index where
    put :: Putter Index
put (Search.Index Map Name (Map Name [Qualified])
a Map Qualified [Tag]
b) = Putter (Map Name (Map Name [Qualified]))
forall a. Serialize a => Putter a
put Map Name (Map Name [Qualified])
a PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter (Map Qualified [Tag])
forall a. Serialize a => Putter a
put Map Qualified [Tag]
b
    get :: Get Index
get = Get (Map Name (Map Name [Qualified]))
forall a. Serialize a => Get a
get Get (Map Name (Map Name [Qualified]))
-> (Map Name (Map Name [Qualified]) -> Get Index) -> Get Index
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Map Name (Map Name [Qualified])
a -> Get (Map Qualified [Tag])
forall a. Serialize a => Get a
get Get (Map Qualified [Tag])
-> (Map Qualified [Tag] -> Get Index) -> Get Index
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Map Qualified [Tag]
b -> Index -> Get Index
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name (Map Name [Qualified]) -> Map Qualified [Tag] -> Index
Search.Index Map Name (Map Name [Qualified])
a Map Qualified [Tag]
b)

instance Serialize Patch.Patch where
    put :: Putter Patch
put (Patch.Patch Name
a ControlMap
b InitializePatch
c AttributeMap
d ModeMap
e Settings
f) = Putter Name
forall a. Serialize a => Putter a
put Name
a PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter ControlMap
forall a. Serialize a => Putter a
put ControlMap
b PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter InitializePatch
forall a. Serialize a => Putter a
put InitializePatch
c
        PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter AttributeMap
forall a. Serialize a => Putter a
put AttributeMap
d PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter ModeMap
forall a. Serialize a => Putter a
put ModeMap
e PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Settings
forall a. Serialize a => Putter a
put Settings
f
    get :: Get Patch
get = Name
-> ControlMap
-> InitializePatch
-> AttributeMap
-> ModeMap
-> Settings
-> Patch
Patch.Patch (Name
 -> ControlMap
 -> InitializePatch
 -> AttributeMap
 -> ModeMap
 -> Settings
 -> Patch)
-> Get Name
-> Get
     (ControlMap
      -> InitializePatch -> AttributeMap -> ModeMap -> Settings -> Patch)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Name
forall a. Serialize a => Get a
get Get
  (ControlMap
   -> InitializePatch -> AttributeMap -> ModeMap -> Settings -> Patch)
-> Get ControlMap
-> Get
     (InitializePatch -> AttributeMap -> ModeMap -> Settings -> Patch)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get ControlMap
forall a. Serialize a => Get a
get Get
  (InitializePatch -> AttributeMap -> ModeMap -> Settings -> Patch)
-> Get InitializePatch
-> Get (AttributeMap -> ModeMap -> Settings -> Patch)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get InitializePatch
forall a. Serialize a => Get a
get Get (AttributeMap -> ModeMap -> Settings -> Patch)
-> Get AttributeMap -> Get (ModeMap -> Settings -> Patch)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get AttributeMap
forall a. Serialize a => Get a
get Get (ModeMap -> Settings -> Patch)
-> Get ModeMap -> Get (Settings -> Patch)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get ModeMap
forall a. Serialize a => Get a
get Get (Settings -> Patch) -> Get Settings -> Get Patch
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Settings
forall a. Serialize a => Get a
get

instance Serialize Patch.InitializePatch where
    put :: Putter InitializePatch
put (Patch.InitializeMidi [Message]
a) = Word8 -> PutM ()
put_tag Word8
0 PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter [Message]
forall a. Serialize a => Putter a
put [Message]
a
    put (Patch.InitializeMessage Name
a) = Word8 -> PutM ()
put_tag Word8
1 PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Name
forall a. Serialize a => Putter a
put Name
a
    put InitializePatch
Patch.NoInitialization = Word8 -> PutM ()
put_tag Word8
2
    get :: Get InitializePatch
get = do
        Word8
tag <- Get Word8
get_tag
        case Word8
tag of
            Word8
0 -> Get [Message]
forall a. Serialize a => Get a
get Get [Message]
-> ([Message] -> Get InitializePatch) -> Get InitializePatch
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Message]
a -> InitializePatch -> Get InitializePatch
forall (m :: * -> *) a. Monad m => a -> m a
return ([Message] -> InitializePatch
Patch.InitializeMidi [Message]
a)
            Word8
1 -> Get Name
forall a. Serialize a => Get a
get Get Name -> (Name -> Get InitializePatch) -> Get InitializePatch
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
a -> InitializePatch -> Get InitializePatch
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> InitializePatch
Patch.InitializeMessage Name
a)
            Word8
2 -> InitializePatch -> Get InitializePatch
forall (m :: * -> *) a. Monad m => a -> m a
return InitializePatch
Patch.NoInitialization
            Word8
_ -> FilePath -> Word8 -> Get InitializePatch
forall a. FilePath -> Word8 -> Get a
bad_tag FilePath
"Patch.InitializePatch" Word8
tag

instance Serialize Patch.Keymap where
    put :: Putter Keymap
put (Patch.UnpitchedKeymap Key
a) = Word8 -> PutM ()
put_tag Word8
0 PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Key
forall a. Serialize a => Putter a
put Key
a
    put (Patch.PitchedKeymap Key
a Key
b Key
c) = Word8 -> PutM ()
put_tag Word8
1 PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Key
forall a. Serialize a => Putter a
put Key
a PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Key
forall a. Serialize a => Putter a
put Key
b PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Key
forall a. Serialize a => Putter a
put Key
c
    get :: Get Keymap
get = do
        Word8
tag <- Get Word8
get_tag
        case Word8
tag of
            Word8
0 -> Key -> Keymap
Patch.UnpitchedKeymap (Key -> Keymap) -> Get Key -> Get Keymap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Key
forall a. Serialize a => Get a
get
            Word8
1 -> Key -> Key -> Key -> Keymap
Patch.PitchedKeymap (Key -> Key -> Key -> Keymap)
-> Get Key -> Get (Key -> Key -> Keymap)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Key
forall a. Serialize a => Get a
get Get (Key -> Key -> Keymap) -> Get Key -> Get (Key -> Keymap)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Key
forall a. Serialize a => Get a
get Get (Key -> Keymap) -> Get Key -> Get Keymap
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Key
forall a. Serialize a => Get a
get
            Word8
_ -> FilePath -> Word8 -> Get Keymap
forall a. FilePath -> Word8 -> Get a
bad_tag FilePath
"Patch.Keymap" Word8
tag

instance Serialize Patch.Keyswitch where
    put :: Putter Keyswitch
put (Patch.Keyswitch Key
a) = Word8 -> PutM ()
put_tag Word8
0 PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Key
forall a. Serialize a => Putter a
put Key
a
    put (Patch.ControlSwitch Word8
a Word8
b) = Word8 -> PutM ()
put_tag Word8
1 PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> PutM ()
forall a. Serialize a => Putter a
put Word8
a PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> PutM ()
forall a. Serialize a => Putter a
put Word8
b
    put (Patch.Aftertouch Word8
a) = Word8 -> PutM ()
put_tag Word8
2 PutM () -> PutM () -> PutM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> PutM ()
forall a. Serialize a => Putter a
put Word8
a
    get :: Get Keyswitch
get = do
        Word8
tag <- Get Word8
get_tag
        case Word8
tag of
            Word8
0 -> Key -> Keyswitch
Patch.Keyswitch (Key -> Keyswitch) -> Get Key -> Get Keyswitch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Key
forall a. Serialize a => Get a
get
            Word8
1 -> Word8 -> Word8 -> Keyswitch
Patch.ControlSwitch (Word8 -> Word8 -> Keyswitch)
-> Get Word8 -> Get (Word8 -> Keyswitch)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
forall a. Serialize a => Get a
get Get (Word8 -> Keyswitch) -> Get Word8 -> Get Keyswitch
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word8
forall a. Serialize a => Get a
get
            Word8
2 -> Word8 -> Keyswitch
Patch.Aftertouch (Word8 -> Keyswitch) -> Get Word8 -> Get Keyswitch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
forall a. Serialize a => Get a
get
            Word8
_ -> FilePath -> Word8 -> Get Keyswitch
forall a. FilePath -> Word8 -> Get a
bad_tag FilePath
"Patch.Keyswitch" Word8
tag

-- Define it here rather than in Patch, or else it doesn't see the Keyswitch
-- instance.
deriving instance Serialize Patch.ModeMap