write sqlite in a separate thread

this doesn't actually seem to make it faster, so something is wrong.

2 files changed, 22 insertions, 8 deletions

diff --git a/axis-of-eval.cabal b/axis-of-eval.cabal
index 49ee7f7..73ba50f 100644
--- a/axis-of-eval.cabal
+++ b/axis-of-eval.cabal
@@ -26,6 +26,6 @@ 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, time, containers, haskore, alsa-seq, alsa-core, mtl, clock, sqlite-simple, bytestring, base-prelude
   main-is: midi-dump.hs
   other-modules: AlsaSeq
diff --git a/midi-dump.hs b/midi-dump.hs
index a6fd36a..c4e319a 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -19,6 +19,10 @@ import           Database.SQLite.Simple.FromRow
 import Data.Int
 import Data.ByteString.Char8 (pack)
 
+import Control.Concurrent.Chan
+import Prelude hiding ((.))
+import BasePrelude hiding (loop)
+
 verbose = False
 
 main = main' `AlsaExc.catch` handler
@@ -41,7 +45,7 @@ data LoopState = LoopState {
 }
 
 getAbsTime = do
-  (sqlite, startTime, startTimeReal, _, _, _, _, _, _) <- ask
+  (_, sqlite, startTime, startTimeReal, _, _, _, _, _, _) <- ask
   now <- liftIO $ getTime Monotonic
   return $ now - startTime + startTimeReal
 
@@ -57,12 +61,13 @@ main' = withAlsaInit $ \h public private q publicAddr privateAddr -> do
 
   sqlite <- open "test.db"
   execute_ sqlite "CREATE TABLE IF NOT EXISTS chunks (id INTEGER PRIMARY KEY, sec INTEGER, nsec INTEGER, midi BLOB)"
+  saver <- startSaver sqlite
 
-  (_, ()) <- execRWST loop (sqlite, startTime, startTimeReal, h, public, private, q, publicAddr, privateAddr) (emptyLoopState startTime)
+  (_, ()) <- execRWST loop (saver, sqlite, startTime, startTimeReal, h, public, private, q, publicAddr, privateAddr) (emptyLoopState startTime)
   return ()
 
 loop = do
-  (_, startTime, startTimeReal, h, _, _, q, publicAddr, _) <- ask
+  (_, _, startTime, startTimeReal, h, _, _, q, publicAddr, _) <- ask
 
   oldKeys <- gets keysDown
   let forwardNOW = forwardNoteEvent h q publicAddr
@@ -94,11 +99,20 @@ instance ToRow Chunk where
   toRow (Chunk s ns b) = toRow (s, ns, b)
 
 saveMidi chunk = do
-  (sqlite, _, _, _, _, _, _, _, _) <- ask
+  (saver, _, _, _, _, _, _, _, _, _) <- ask
   (TimeSpec s ns) <- gets lastTick
-  let bytes = pack $ show chunk
-  liftIO $ execute sqlite "INSERT INTO chunks (sec, nsec, midi) VALUES (?,?,?)" (Chunk s ns bytes)
-  return ()
+  liftIO $ writeChan saver (s, ns, chunk)
+
+startSaver sqlite = do
+  chan <- liftIO $ newChan
+  thread <- liftIO $ forkIO (saver sqlite chan)
+  return chan
+  where
+    saver sqlite chan = forever $ do
+      (s, ns, chunk) <- readChan chan
+      let bytes = pack $ show chunk
+      liftIO $ execute sqlite "INSERT INTO chunks (sec, nsec, midi) VALUES (?,?,?)" (Chunk s ns bytes)
+      return ()
 
 getMidiDesc :: EVENT -> Maybe String
 getMidiDesc (MidiEvent _ (Event.Cons _ _ _ _ _ _ (Event.NoteEv Event.NoteOn  ev))) = return $ ("on:" ++)  $ showPitch $ unPitch $ Event.noteNote ev