{-# LANGUAGE ExplicitForAll #-}
module Midi where
import           BasePrelude
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import           Data.ByteString.Char8 (pack, unpack)
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 Sound.MIDI.ALSA
import Sound.MIDI.ALSA.Query
import qualified Sound.MIDI.ALSA.Construct as Construct
import Sound.MIDI.Message

import Codec.Midi
import Codec.ByteString.Builder
import Codec.ByteString.Parser

-- 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.Data)
type RecordedEvent = (TimeSpec, Codec.Midi.Message)

data Recording = StartRecording TimeSpec |
                  RecordingInProgress TimeSpec TimeSpec [RecordedEvent]

data CompleteRecording = CompleteRecording {
    _recStart :: TimeSpec,
    _recEnd   :: TimeSpec,
    _recFirst :: TimeSpec,
    _recLast  :: TimeSpec,
    _recEvents :: [RecordedEvent]
}

class Playable p where
    playableEvents :: p -> [RecordedEvent]
instance Playable Recording where
    playableEvents (StartRecording _) = []
    playableEvents (RecordingInProgress _ _ ls) = ls
instance Playable CompleteRecording where
    playableEvents = _recEvents

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

instance Monoid CompleteRecording where
    mempty = CompleteRecording 0 0 0 0 []
    (CompleteRecording s _e f _l evts) `mappend` (CompleteRecording _s' e' _f' l' evts') =
        CompleteRecording s e' f l' (evts' ++ evts)

maybesnd :: forall t t1. (t, Maybe t1) -> Maybe (t, t1)
maybesnd (_, Nothing) = Nothing
maybesnd (x, Just y) = Just (x, y)

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

convertEvents :: [(TimeSpec, Event.Data)] -> [(TimeSpec, Codec.Midi.Message)]
convertEvents = mapMaybe (maybesnd . fmap conv)
    where
      conv :: Event.Data -> Maybe Codec.Midi.Message
      conv (Event.NoteEv Event.NoteOn  (Event.Note c p v _ _)) = Just $ cpv Codec.Midi.NoteOn  c p v
      conv (Event.NoteEv Event.NoteOff (Event.Note c p v _ _)) = Just $ cpv Codec.Midi.NoteOff c p v
      conv _ = Nothing
      cpv f c p v = f (fi $ Event.unChannel c) (fi $ Event.unPitch p) (fi $ Event.unVelocity v)
      fi = fromIntegral

setChannel :: Codec.Midi.Channel -> Codec.Midi.Message -> Codec.Midi.Message
setChannel c (NoteOff _ k v) = (NoteOff c k v)
setChannel c (NoteOn  _ k v) = (NoteOn  c k v)
setChannel c (ProgramChange _ p) = (ProgramChange c p)
setChannel c (ControlChange _ n v) = (ControlChange c n v)
setChannel c (KeyPressure _ k p) = (KeyPressure c k p)
setChannel c (ChannelPressure _ p) = (ChannelPressure c p)
setChannel c (PitchWheel _ p) = (PitchWheel c p)
setChannel _ x = x

unConvertEvents :: [(TimeSpec, Codec.Midi.Message)] -> [(TimeSpec, Event.Data)]
unConvertEvents = mapMaybe (maybesnd . fmap conv)
    where
      conv :: Codec.Midi.Message -> Maybe Event.Data
      conv (Codec.Midi.NoteOn  c p v) = Just $ cpv c p v Event.NoteOn
      conv (Codec.Midi.NoteOff c p v) = Just $ cpv c p v Event.NoteOff
      conv _ = Nothing
      cpv c p v f = Event.NoteEv f (Event.Note (Event.Channel $ fi c) (Event.Pitch $ fi p) (Event.Velocity $ fi v) (Event.Velocity $ fi v) (Event.Duration 0))
      fi = fromIntegral

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 (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 . overFirsts toDeltas . map (first timeSpecAsNanoSecs) . (fmap . fmap) (toLazyByteString . buildMessage) . reverse
bytesToMidi :: BS.ByteString -> [RecordedEvent]
bytesToMidi = unpack >>> read >>> overFirsts fromDeltas >>> map (first fromInteger) >>> (fmap . fmap) f >>> reverse
  where f :: LBS.ByteString -> Codec.Midi.Message
        f = runParser (parseMessage Nothing) >>> either error id

overFirsts :: ([a1] -> [a]) -> [(a1, b)] -> [(a, b)]
overFirsts f = uncurry zip . first f . unzip

toDeltas :: Num n => [n] -> [n]
toDeltas xs = zipWith (-) xs (0:xs)

fromDeltas :: Num n => [n] -> [n]
fromDeltas = helper 0
    where
      helper _ [] = []
      helper n (x:xs) = (n+x) : helper (n+x) xs

-- fromDeltas :: Num n => [n] -> [n]
-- fromDeltas = foldr (\a b -> a:map (a +) b) []