{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}

import           AlsaSeq
import           Control.Monad.RWS.Strict
import           Data.List
import           Data.Maybe
import qualified Data.Set                       as Set
import qualified Sound.ALSA.Exception           as AlsaExc
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 ()

import           BasePrelude                    hiding (loop)
import           Control.Concurrent.Chan        ()
import           Prelude                        hiding (id, (.))

import qualified Sound.ALSA.Sequencer
import qualified Sound.ALSA.Sequencer.Address
import qualified Sound.ALSA.Sequencer.Port
import qualified Sound.ALSA.Sequencer.Queue

verbose = False

main = main' `AlsaExc.catch` handler
  where
  handler e = when verbose $ putStrLn $ "alsa_exception: " ++ AlsaExc.show e

type RecordedEvents = [(TimeSpec, Event.T)]

data Recording = Recording {
  _recordingStart  :: TimeSpec, -- from initial silence
  _recordingEvents :: RecordedEvents
}

data FinishedRecording = FinishedRecording Recording TimeSpec

recordEvents :: Recording -> RecordedEvents -> Recording
recordEvents (Recording s orig) new = Recording s (new ++ orig)

data LoopState = LoopState {
  _wantExit  :: Bool,
  keysDown   :: MidiPitchSet,
  _playNOW   :: [Event.Data],
  _recording :: Recording,
  lastTick   :: TimeSpec
}

initializeState now = LoopState False Set.empty [] (emptyRecording now) now

data LoopEnv = LoopEnv {
  _saver         :: Chan FinishedRecording,
  _sqlite        :: Connection,
  _startTime     :: TimeSpec,
  _startTimeReal :: TimeSpec,
  _h             :: Sound.ALSA.Sequencer.T Sound.ALSA.Sequencer.DuplexMode,
  _public        :: Sound.ALSA.Sequencer.Port.T,
  _private       :: Sound.ALSA.Sequencer.Port.T,
  _q             :: Sound.ALSA.Sequencer.Queue.T,
  _publicAddr    :: Sound.ALSA.Sequencer.Address.T,
  _privateAddr   :: Sound.ALSA.Sequencer.Address.T,
  _doSave        :: Bool,
  _lineReader    :: MVar String
}

getAbsTime = do
  startTime <- asks _startTime
  startTimeReal <- asks _startTimeReal
  now <- liftIO $ getTime Monotonic
  return $ now - startTime + startTimeReal

createTable = fromString $ concat
  ["CREATE TABLE IF NOT EXISTS axis_input",
  " (id INTEGER PRIMARY KEY,",
  " start_sec INTEGER,",
  " start_nsec INTEGER,",
  " end_sec INTEGER,",
  " end_nsec INTEGER,",
  " leading_silence INTEGER,",
  " midi BLOB)"]

main' = withAlsaInit $ \h public private q publicAddr privateAddr -> do
  cmdlineAlsaConnect h public

  putStrLn "Rock on!"
  startTime <- getTime Monotonic
  startTimeReal <- getTime Realtime

  sqlite <- open "test.db"
  execute_ sqlite createTable
  saver <- startSaver sqlite
  lineReader <- startLineReader

  doSave <- isNothing <$> lookupEnv "NO_SAVE_MIDI"

  let env = LoopEnv saver sqlite startTime startTimeReal h public private q publicAddr privateAddr doSave lineReader

  (_, ()) <- execRWST mainLoop env $ initializeState startTimeReal
  return ()

mainLoop = do
  maybeReadLine >>= maybe processMidi processCommand
  wantExit <- gets _wantExit

  scheduled <- gets _playNOW
  unless (null scheduled) $ do
    forM_ scheduled playNoteEv
    -- TODO: flush ALSA output here
    modify $ \s -> s { _playNOW = [] }

  unless wantExit mainLoop

playNote noteOn note =
  playNoteEv $ Event.NoteEv onoff note
  where onoff = if noteOn then Event.NoteOn else Event.NoteOff

playNoteEv nevdata = do
  ms <- getMidiSender
  publicAddr <- asks _publicAddr
  liftIO $ ms $ Event.simple publicAddr nevdata

whenFlag flag f = gets flag >>= flip when f

processCommand "exit" = modify $ \s -> s { _wantExit = True }
processCommand "" = return ()
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 str = liftIO $ putStrLn $ "Unknown command: " ++ str

getMidiSender = do
  h <- asks _h
  q <- asks _q
  publicAddr <- asks _publicAddr
  return $ forwardNoteEvent h q publicAddr

processMidi = do
  h <- asks _h
  oldKeys <- gets keysDown
  forwardNOW <- getMidiSender
  (events, newKeys) <- liftIO $ parseAlsaEvents' h oldKeys forwardNOW


  if oldKeys == newKeys then
    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

    liftIO $ printChordLn newKeys
    modify $ \s -> s { keysDown = newKeys, _recording = recordEvents (_recording s) newEvents, lastTick = now }

    when (Set.null newKeys) $ do

      doSave <- asks _doSave
      when doSave $ gets _recording >>= saveMidi >> return ()
      modify $ \s -> s { _recording = emptyRecording now }

emptyRecording now = Recording now []

maybeReadLine = asks _lineReader >>= liftIO . tryTakeMVar
startLineReader = do
  mv <- liftIO newEmptyMVar
  thread <- liftIO $ forkIO (forever $ tryIOError getLine >>= either (const $ putMVar mv "exit") (putMVar mv))
  return mv

data Chunk = Chunk Int64 Int64 Int64 Int64 Int64 BS.ByteString
instance FromRow Chunk where
  fromRow = Chunk <$> field <*> field <*> field <*> field <*> field <*> field
instance ToRow Chunk where
  toRow (Chunk s ns s' ns' d m) = toRow (s, ns, s', ns', d, m)

data Chunkable = MkChunk FinishedRecording TimeSpec
instance ToRow Chunkable where
  toRow (MkChunk reco ts) = toRow (s, ns, s', ns', leadingSilence :: Int64, pack $ show midi)
    where
      (FinishedRecording (Recording start@(TimeSpec s ns) midi) (TimeSpec s' ns')) = reco
      leadingSilence = fromIntegral $ timeSpecAsNanoSecs $ ts - start

saveMidi recording = do
  saver <- asks _saver
  end <- gets lastTick
  liftIO $ writeChan saver $ FinishedRecording recording end

startSaver sqlite = do
  chan <- liftIO newChan
  _thread <- liftIO $ forkIO (saver chan)
  return chan
  where
    saver chan = forever $ do
      reco@(FinishedRecording (Recording _ events) _) <- readChan chan
      let start = fst $ head events
          sqlInsert = "INSERT INTO axis_input (start_sec, start_nsec, end_sec, end_nsec, leading_silence, midi) VALUES (?,?,?,?,?,?)"
      liftIO $ execute sqlite sqlInsert (MkChunk reco start)
      return ()


getMidiDesc :: Event.T -> Maybe String
getMidiDesc (Event.Cons _ _ _ _ _ _ (Event.NoteEv Event.NoteOn  ev)) = return $ ("on:" ++)  $ showPitch $ unPitch $ Event.noteNote ev
getMidiDesc (Event.Cons _ _ _ _ _ _ (Event.NoteEv Event.NoteOff ev)) = return $ ("off:" ++) $ showPitch $ unPitch $ Event.noteNote ev
getMidiDesc _ = Nothing

tsDeltas :: [TimeSpec] -> [Integer]
tsDeltas [] = []
tsDeltas ls@(x:_) = zipWith (-) nsecs (0:nsecs)
  where
    nsecs = map timeSpecAsNanoSecs rel
    rel = map (\y -> y - x) ls