start to move midi serialization into separate file

4 files changed, 72 insertions, 43 deletions

diff --git a/Midi.hs b/Midi.hs
new file mode 100644
index 0000000..4609d04
--- /dev/null
+++ b/Midi.hs
@@ -0,0 +1,59 @@
+module Midi where
+import           BasePrelude
+import qualified Data.ByteString       as BS
+import           Data.ByteString.Char8 (pack)
+import           Prelude               hiding (id, (.))
+-- import           Sound.MIDI.ALSA
+import           System.Clock
+import           Database.SQLite.Simple
+import           Database.SQLite.Simple.FromRow ()
+
+import qualified Sound.ALSA.Sequencer.Event     as Event
+
+-- import qualified Sound.ALSA.Sequencer
+-- import qualified Sound.ALSA.Sequencer.Address
+-- import qualified Sound.ALSA.Sequencer.Port
+-- import qualified Sound.ALSA.Sequencer.Queue
+-- import qualified Sound.ALSA.Sequencer.Time as Time
+-- import qualified Sound.ALSA.Sequencer.RealTime as RealTime
+
+type RecordedEvent = (TimeSpec, Event.T)
+
+data Recording = StartRecording TimeSpec |
+                  RecordingInProgress TimeSpec TimeSpec [RecordedEvent]
+    deriving Show
+
+data CompleteRecording = CompleteRecording {
+    _recStart :: TimeSpec,
+    _recEnd   :: TimeSpec,
+    _recFirst :: TimeSpec,
+    _recLast  :: TimeSpec,
+    _recEvents :: [RecordedEvent]
+} deriving Show
+
+instance FromRow CompleteRecording where
+  fromRow = cons <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field
+    where
+        cons a a' b b' c c' d d' z = CompleteRecording (TimeSpec a a') (TimeSpec b b') (TimeSpec c c') (TimeSpec d d') (bytesToMidi z)
+
+instance ToRow CompleteRecording where
+  toRow reco = toRow (s, ns, s', ns', s'', ns'', s''', ns''', midiToBytes midi)
+    where
+      (CompleteRecording (TimeSpec s ns) (TimeSpec s' ns') (TimeSpec s'' ns'') (TimeSpec s''' ns''') midi) = reco
+
+
+recordEvents :: Recording -> [RecordedEvent]-> Recording
+recordEvents (RecordingInProgress x y orig) new = RecordingInProgress x y $ new ++ orig
+recordEvents i@(StartRecording _) [] = i
+recordEvents (StartRecording x) new@(_:_) = RecordingInProgress x y 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
+bytesToMidi :: BS.ByteString -> [RecordedEvent]
+bytesToMidi = undefined
diff --git a/axis-of-eval.cabal b/axis-of-eval.cabal
index f69d3f5..acafc72 100644
--- a/axis-of-eval.cabal
+++ b/axis-of-eval.cabal
@@ -26,7 +26,8 @@ executable midi-dump
   default-language: Haskell2010
   hs-source-dirs: .
   build-depends:
-    base, time, containers, haskore, alsa-seq, alsa-core, mtl, clock, sqlite-simple, bytestring, base-prelude
+    base, time, containers, haskore, alsa-seq, alsa-core, mtl, clock,
+    sqlite-simple, bytestring, base-prelude, midi-alsa, midi
   main-is: midi-dump.hs
   other-modules: AlsaSeq
   ghc-options: -threaded -W -Wall -O2
diff --git a/midi-dump.hs b/midi-dump.hs
index f053e28..07281f5 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -14,8 +14,6 @@ import qualified Sound.ALSA.Sequencer.Event     as Event
 import           System.Clock
 
 import           Control.Applicative
-import qualified Data.ByteString                as BS
-import           Data.ByteString.Char8          (pack)
 import           Data.Int
 import           Database.SQLite.Simple
 import           Database.SQLite.Simple.FromRow ()
@@ -31,6 +29,8 @@ import qualified Sound.ALSA.Sequencer.Queue
 import qualified Sound.ALSA.Sequencer.Time as Time
 import qualified Sound.ALSA.Sequencer.RealTime as RealTime
 
+import Midi
+
 verbose :: Bool
 verbose = False
 
@@ -39,30 +39,6 @@ main = main' `AlsaExc.catch` handler
   where
   handler e = when verbose $ putStrLn $ "alsa_exception: " ++ AlsaExc.show e
 
-type RecordedEvent = (TimeSpec, Event.T)
-
-data Recording = StartRecording TimeSpec |
-                  RecordingInProgress TimeSpec TimeSpec [RecordedEvent]
-
-data CompleteRecording = CompleteRecording {
-    _recStart :: TimeSpec,
-    _recEnd   :: TimeSpec,
-    _recFirst :: TimeSpec,
-    _recLast  :: TimeSpec,
-    _recEvents :: [RecordedEvent]
-}
-
-recordEvents :: Recording -> [RecordedEvent]-> Recording
-recordEvents (RecordingInProgress x y orig) new = RecordingInProgress x y $ new ++ orig
-recordEvents i@(StartRecording _) [] = i
-recordEvents (StartRecording x) new@(_:_) = RecordingInProgress x y 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
-
-
 data LoopState = LoopState {
   _wantExit  :: Bool,
   keysDown   :: MidiPitchSet,
@@ -176,7 +152,7 @@ playNoteEv :: Event.Data -> RWST LoopEnv () LoopState IO ()
 playNoteEv nevdata = do
   ms <- getMidiSender
   publicAddr <- asks _publicAddr
-  liftIO $ ms $ Event.simple publicAddr nevdata `delayEvent` (10 * 10^(9::Int))
+  liftIO $ ms $ Event.simple publicAddr nevdata `delayEvent` (2 * 10^(9::Int))
 
 _whenFlag :: forall (m :: * -> *) s. MonadState s m => (s -> Bool) -> m () -> m ()
 _whenFlag flag f = gets flag >>= flip when f
@@ -188,6 +164,12 @@ processCommand "C" = do
   let mkNote pitch = Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 128)
   let notes = (Event.NoteEv Event.NoteOn . mkNote) <$> [60, 64, 67]
   modify $ \s -> s { _playNOW = notes }
+processCommand "C'" = do
+  -- changing the duration seems to do nothing
+  let mkNote pitch = Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 128)
+      setDuration d note = note { Event.noteDuration = Event.Duration d }
+  let notes = (Event.NoteEv Event.NoteOn . setDuration 4290000000 . mkNote) <$> [60, 64, 67]
+  modify $ \s -> s { _playNOW = notes }
 processCommand str = liftIO $ putStrLn $ "Unknown command: " ++ str
 
 getMidiSender :: RWST LoopEnv () LoopState IO MidiHook
@@ -239,21 +221,6 @@ startLineReader = do
   _thread <- liftIO $ forkIO (forever $ tryIOError getLine >>= either (const $ putMVar mv "exit") (putMVar mv))
   return mv
 
-midiToBytes :: [RecordedEvent] -> BS.ByteString
-midiToBytes = pack . show
-bytesToMidi :: BS.ByteString -> [RecordedEvent]
-bytesToMidi = undefined
-
-instance FromRow CompleteRecording where
-  fromRow = cons <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field
-    where
-        cons a a' b b' c c' d d' z = CompleteRecording (TimeSpec a a') (TimeSpec b b') (TimeSpec c c') (TimeSpec d d') (bytesToMidi z)
-
-instance ToRow CompleteRecording where
-  toRow reco = toRow (s, ns, s', ns', s'', ns'', s''', ns''', midiToBytes midi)
-    where
-      (CompleteRecording (TimeSpec s ns) (TimeSpec s' ns') (TimeSpec s'' ns'') (TimeSpec s''' ns''') midi) = reco
-
 saveMidi :: forall (m :: * -> *). (MonadIO m, MonadState LoopState m, MonadReader LoopEnv m) => Recording -> m ()
 saveMidi recording = do
   saver <- asks _saver
diff --git a/stack.yaml b/stack.yaml
index abcd766..0fa3f39 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -21,5 +21,7 @@ extra-deps:
 - monoid-transformer-0.0.3
 - storable-record-0.0.3
 
+- midi-alsa-0.2.1
+
 resolver: lts-3.7
 system-ghc: false