Store recordings as Sound.MIDI.Message.T

My intent in doing this was to have a format suitable for reading
and writing to the database; the old format (using "show" on the
Sound.ALSA.Sequencer.Event.T) could not be read back.

Unfortunately, this new format cannot be read back _OR WRITTEN_!
At least not without more conversion (of my list of pairs into a
Thielemann's specialized event-list).

My new plan is to use HCodec's Codec.Midi.Message instead.  But I'll
commit this before I get to that.

2 files changed, 32 insertions, 11 deletions

diff --git a/Midi.hs b/Midi.hs
index 4609d04..b4f4fc0 100644
--- a/Midi.hs
+++ b/Midi.hs
@@ -1,7 +1,8 @@
+{-# LANGUAGE ExplicitForAll #-}
 module Midi where
 import           BasePrelude
 import qualified Data.ByteString       as BS
-import           Data.ByteString.Char8 (pack)
+-- import           Data.ByteString.Char8 (pack)
 import           Prelude               hiding (id, (.))
 -- import           Sound.MIDI.ALSA
 import           System.Clock
@@ -9,6 +10,10 @@ import           Database.SQLite.Simple
 import           Database.SQLite.Simple.FromRow ()
 
 import qualified Sound.ALSA.Sequencer.Event     as Event
+-- import Sound.MIDI.ALSA
+import Sound.MIDI.ALSA.Query
+import qualified Sound.MIDI.ALSA.Construct as Construct
+import Sound.MIDI.Message
 
 -- import qualified Sound.ALSA.Sequencer
 -- import qualified Sound.ALSA.Sequencer.Address
@@ -17,11 +22,11 @@ import qualified Sound.ALSA.Sequencer.Event     as Event
 -- import qualified Sound.ALSA.Sequencer.Time as Time
 -- import qualified Sound.ALSA.Sequencer.RealTime as RealTime
 
-type RecordedEvent = (TimeSpec, Event.T)
+-- type RecordedEvent = (TimeSpec, Event.Data)
+type RecordedEvent = (TimeSpec, Sound.MIDI.Message.T)
 
 data Recording = StartRecording TimeSpec |
                   RecordingInProgress TimeSpec TimeSpec [RecordedEvent]
-    deriving Show
 
 data CompleteRecording = CompleteRecording {
     _recStart :: TimeSpec,
@@ -29,7 +34,7 @@ data CompleteRecording = CompleteRecording {
     _recFirst :: TimeSpec,
     _recLast  :: TimeSpec,
     _recEvents :: [RecordedEvent]
-} deriving Show
+}
 
 instance FromRow CompleteRecording where
   fromRow = cons <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field
@@ -41,19 +46,35 @@ instance ToRow CompleteRecording where
     where
       (CompleteRecording (TimeSpec s ns) (TimeSpec s' ns') (TimeSpec s'' ns'') (TimeSpec s''' ns''') midi) = reco
 
+maybesnd :: forall t t1. (t, Maybe t1) -> Maybe (t, t1)
+maybesnd (_, Nothing) = Nothing
+maybesnd (x, Just y) = Just (x, y)
 
-recordEvents :: Recording -> [RecordedEvent]-> Recording
-recordEvents (RecordingInProgress x y orig) new = RecordingInProgress x y $ new ++ orig
+convertEvents :: [(TimeSpec, Event.Data)] -> [(TimeSpec, Sound.MIDI.Message.T)]
+convertEvents = mapMaybe (maybesnd . fmap conv)
+    where
+      conv :: Event.Data -> Maybe Sound.MIDI.Message.T
+      conv x@(Event.NoteEv _ _) = uncurry Construct.note <$> note x
+      conv _ = Nothing
+
+unConvertEvents :: [(TimeSpec, Sound.MIDI.Message.T)] -> [(TimeSpec, Event.Data)]
+unConvertEvents = mapMaybe (maybesnd . fmap conv)
+    where
+      conv :: Sound.MIDI.Message.T -> Maybe Event.Data
+      conv msg = uncurry Construct.note <$> note msg
+
+recordEvents :: Recording -> [(TimeSpec, Event.Data)]-> Recording
+recordEvents (RecordingInProgress x y orig) new = RecordingInProgress x y $ convertEvents new ++ orig
 recordEvents i@(StartRecording _) [] = i
-recordEvents (StartRecording x) new@(_:_) = RecordingInProgress x y new
+recordEvents (StartRecording x) new@(_:_) = RecordingInProgress x y (convertEvents new)
     where y = fst $ last new
 
 stopRecording :: Recording -> TimeSpec -> Maybe CompleteRecording
 stopRecording (RecordingInProgress x y ls@((z,_):_)) end = Just $ CompleteRecording x end y z ls
 stopRecording _ _ = Nothing
 
-
 midiToBytes :: [RecordedEvent] -> BS.ByteString
-midiToBytes = pack . show
+-- midiToBytes = pack . show
+midiToBytes = undefined
 bytesToMidi :: BS.ByteString -> [RecordedEvent]
 bytesToMidi = undefined
diff --git a/midi-dump.hs b/midi-dump.hs
index e6d2aca..b531b97 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -197,7 +197,7 @@ type MidiController = MidiControllerT IO
 playRecording :: Recording -> MidiController ()
 playRecording (RecordingInProgress _ _ evts@(_:_)) =
   mapM_ (uncurry delayNoteEv) (zip (subtract (head delays) <$> delays) events)
-  where (delays, events) = unzip $ fmap Event.body <$> reverse evts
+  where (delays, events) = unzip $ reverse $ unConvertEvents evts
 playRecording  _ = return ()
 
 getMidiSender :: MidiController MidiHook
@@ -219,7 +219,7 @@ processMidi = do
     liftIO $ threadDelay 15000 -- 15ms.  Seems like a lot, but it sounds OK.  Cuts CPU down to 2%.
   else do
     now <- getAbsTime
-    let newEvents = map ((,) now) events
+    let newEvents = map ((,) now . Event.body)  events
 
     liftIO $ printChordLn newKeys
     modify $ \s -> s { keysDown = newKeys, _recording = recordEvents (_recording s) newEvents, _lastTick = now }