-----------------------------------------------------------------------------
-- |
-- Module      : Codec.Midi
-- Copyright   : George Giorgidze
-- License     : BSD3
--
-- Maintainer  : George Giorgidze <http://cs.nott.ac.uk/~ggg/>
-- Stability   : Experimental
-- Portability : Portable
--
-- Reading, writing and maniplating of standard MIDI files
--
-----------------------------------------------------------------------------

module Codec.Midi
  (
    Midi (..)
  , FileType (..)
  , Track
  , TimeDiv (..)
  , Message (..)
  
  , Ticks
  , Time
  , Channel
  , Key
  , Velocity
  , Pressure
  , Preset
  , Bank
  , PitchWheel
  , Tempo
  
  , isNoteOff
  , isNoteOn
  , isKeyPressure
  , isControlChange
  , isProgramChange
  , isChannelPressure
  , isPitchWheel
  , isChannelMessage
  , isMetaMessage
  , isSysexMessage
  , isTrackEnd
  
  , removeTrackEnds
  , toSingleTrack
  , merge
  , fromAbsTime
  , toAbsTime
  , toRealTime
  , fromRealTime
  
  , importFile
  , exportFile
  , parseMidi
  , buildMidi
  , parseTrack
  , buildTrack
  , parseMessage
  , buildMessage
  )
   where

import qualified Data.ByteString.Lazy as L

import Test.QuickCheck (Arbitrary, arbitrary, choose, oneof)

import Codec.ByteString.Parser
import Codec.ByteString.Builder
import Codec.Internal.Arbitrary ()

import Data.Word
import Data.Bits
import Data.Maybe
import Data.List
import Data.Monoid (mempty, mconcat, mappend)
import Control.Applicative
import Control.Monad

data Midi = Midi {
    fileType :: FileType
  , timeDiv :: TimeDiv
  , tracks :: [Track Ticks]
  } deriving (Eq, Show)

instance Arbitrary Midi where
  arbitrary = do
    ft <- arbitrary
    td <- arbitrary
    if ft == SingleTrack
      then do
        trk <- arbitrary >>= return . fAux
        return $! Midi ft td [trk]
      else do
        trks <- arbitrary >>= return . map fAux
        return $! Midi ft td trks
    where
    fAux = (++ [(0,TrackEnd)]) . map (\(dt,m) -> (abs dt,m)) . removeTrackEnds

data FileType = SingleTrack | MultiTrack | MultiPattern
  deriving (Eq, Show)

instance Arbitrary FileType where
  arbitrary = oneof [return SingleTrack , return MultiTrack , return MultiPattern]
  
type Track a = [(a,Message)]

data TimeDiv =
  TicksPerBeat Int | -- 1 -- (2^15 - 1)
  TicksPerSecond Int Int -- 1 - 127
             --  FramesPerSecond TicksPerFrame
  deriving (Show,Eq)

instance Arbitrary TimeDiv where
  arbitrary = oneof [
      choose (1,2 ^ (15 :: Int) - 1) >>= return . TicksPerBeat
    , two (choose (1,127)) >>= \(w1,w2) -> return $! TicksPerSecond w1 w2]

type Ticks = Int -- 0 - (2^28 - 1)
type Time = Double

type Channel = Int  -- 0 - 15
type Key = Int      -- 0 - 127
type Velocity = Int -- 0 - 127
type Pressure = Int -- 0 - 127
type Preset = Int   -- 0 - 127
type Bank = Int
type PitchWheel = Int -- 0 - (2^14 - 1)
type Tempo = Int -- microseconds per beat  1 - (2^24 - 1)

data Message =
-- Channel Messages
  NoteOff         { channel :: !Channel, key :: !Key,              velocity :: !Velocity } |
  NoteOn          { channel :: !Channel, key :: !Key,              velocity :: !Velocity } |
  KeyPressure     { channel :: !Channel, key :: !Key,              pressure :: !Pressure} |
  ControlChange   { channel :: !Channel, controllerNumber :: !Int, controllerValue :: !Int } |
  ProgramChange   { channel :: !Channel, preset :: !Preset } |
  ChannelPressure { channel :: !Channel, pressure :: !Pressure } |
  PitchWheel      { channel :: !Channel, pitchWheel :: !PitchWheel } |
-- Meta Messages
  SequenceNumber !Int | -- 0 - (2^16 - 1)
  Text !String |
  Copyright !String |
  TrackName !String |
  InstrumentName !String |
  Lyrics !String |
  Marker !String |
  CuePoint !String |
  ChannelPrefix !Channel |
  ProgramName !String |
  DeviceName !String |
  TrackEnd |
  TempoChange !Tempo |
  SMPTEOffset !Int !Int !Int !Int !Int | -- 0-23  0-59  0-59  0-30 0-99
  TimeSignature !Int !Int !Int !Int | -- 0-255  0-255   0-255   1-255
  KeySignature !Int !Int | -- -7 - 7  0 - 1
  Reserved !Int !L.ByteString |
  -- System Exclusive Messages
  Sysex !Int !L.ByteString -- 0xF0 or 0xF7
  deriving (Show,Eq)

instance Arbitrary Message where
  arbitrary = do
    -- Channel Messages
    c <- choose (0,15)
    oneof [
        two (choose (0,127))  >>= \(w2,w3) -> return $! NoteOff c w2 w3
      , two (choose (0,127))  >>= \(w2,w3) -> return $! NoteOn c w2 w3
      , two (choose (0,127))  >>= \(w2,w3) -> return $! KeyPressure c w2 w3
      , two (choose (0,127))  >>= \(w2,w3) -> return $! ControlChange c w2 w3
      , choose (0,127)        >>= \w2      -> return $! ProgramChange c w2
      , choose (0,127)        >>= \w2      -> return $! ChannelPressure c w2
      , do p <- choose (0,2 ^ (14 :: Int) - 1)
           return $! PitchWheel c p
      -- Meta Messages
      , choose (0,2 ^ (16 :: Int) - 1) >>= return . SequenceNumber
      , arbitrary >>= return . Text
      , arbitrary >>= return . Copyright
      , arbitrary >>= return . TrackName
      , arbitrary >>= return . InstrumentName
      , arbitrary >>= return . Lyrics
      , arbitrary >>= return . Marker
      , arbitrary >>= return . CuePoint
      , return $! ChannelPrefix c
      , arbitrary >>= return . ProgramName
      , arbitrary >>= return . DeviceName
      , choose (0,2 ^ (14 :: Int) - 1) >>= return . TempoChange
      , do w1 <- choose (0,23)
           w2 <- choose (0,59)
           w3 <- choose (0,59)
           w4 <- choose (0,30)
           w5 <- choose (0,99)
           return $! SMPTEOffset w1 w2 w3 w4 w5
      , do w1 <- choose (0,255)
           w2 <- choose (0,255)
           w3 <- choose (0,255)
           w4 <- choose (1,255)
           return $! TimeSignature w1 w2 w3 w4
      , do w1 <- choose (-7,7)
           w2 <- choose (0,1)
           return $! KeySignature w1 w2
      , arbitrary >>= \bs -> return $! Reserved 0x60 bs
      -- System Exclusive Messages
      , do w <- oneof [return 0xF0, return 0xF7]
           bs <- arbitrary
           return $! Sysex w bs]

isNoteOff :: Message -> Bool
isNoteOff (NoteOff {}) = True
isNoteOff _ = False

isNoteOn :: Message -> Bool
isNoteOn (NoteOn {}) = True
isNoteOn _ = False

isKeyPressure :: Message -> Bool
isKeyPressure (KeyPressure {}) = True
isKeyPressure _ = False

isControlChange :: Message -> Bool
isControlChange (ControlChange {}) = True
isControlChange _ = False

isProgramChange :: Message -> Bool
isProgramChange (ProgramChange {}) = True
isProgramChange _ = False

isChannelPressure :: Message -> Bool
isChannelPressure (ChannelPressure {}) = True
isChannelPressure _ = False

isPitchWheel :: Message -> Bool
isPitchWheel (PitchWheel {}) = True
isPitchWheel _ = False

isChannelMessage :: Message -> Bool
isChannelMessage msg = (not $ isMetaMessage msg) && (not $ isSysexMessage msg)

isSysexMessage :: Message -> Bool
isSysexMessage (Sysex _ _) = True
isSysexMessage _ = False

isMetaMessage :: Message -> Bool
isMetaMessage msg = case msg of
  SequenceNumber _ -> True
  Text _ -> True
  Copyright _ -> True
  TrackName _ -> True
  InstrumentName _ -> True
  Lyrics _ -> True
  Marker _ -> True
  CuePoint _ -> True
  ChannelPrefix _ -> True
  ProgramName _ -> True
  DeviceName _ -> True
  TrackEnd -> True
  TempoChange _ -> True
  SMPTEOffset _ _ _ _ _ -> True
  TimeSignature _ _ _ _ -> True
  KeySignature _ _ -> True
  Reserved _ _ -> True
  _ -> False

isTrackEnd :: Message -> Bool
isTrackEnd TrackEnd = True
isTrackEnd _ = False

removeTrackEnds :: Track a -> Track a
removeTrackEnds [] = []
removeTrackEnds trk = filter (not. isTrackEnd . snd) trk

toSingleTrack :: Midi -> Midi
toSingleTrack m@(Midi SingleTrack _ _) = m
toSingleTrack (Midi MultiTrack td trks) = Midi SingleTrack td [trk']
  where trk' = foldl' merge [] trks
toSingleTrack (Midi MultiPattern td trks) = Midi SingleTrack td [trk']
  where trk' = (concat $ map removeTrackEnds trks) ++ [(0,TrackEnd)]

merge :: (Num a, Ord a) => Track a -> Track a -> Track a
merge track1 track2 = (fromAbsTime $ f trk1' trk2') ++ [(0,TrackEnd)]
  where
  trk1' = toAbsTime $ removeTrackEnds track1
  trk2' = toAbsTime $ removeTrackEnds track2
  f trk [] = trk
  f [] trk = trk
  f ((dt1,m1) : trk1) ((dt2,m2) : trk2) = if dt1 <= dt2
      then (dt1,m1) : (f trk1 ((dt2,m2) : trk2))
      else (dt2,m2) : (f ((dt1,m1) : trk1) trk2)

toAbsTime :: (Num a) => Track a -> Track a
toAbsTime trk = zip ts' ms
  where
  (ts,ms) = unzip trk
  (_,ts') = mapAccumL (\acc t -> let t' = acc + t in (t',t')) 0 ts
  
fromAbsTime :: (Num a) => Track a -> Track a
fromAbsTime trk = zip ts' ms
  where
  (ts,ms) = unzip trk
  (_,ts') = mapAccumL (\acc t -> (t,t - acc)) 0 ts

toRealTime :: TimeDiv -> Track Ticks -> Track Time
toRealTime (TicksPerBeat tpb) trk = trk'
  where
  (_,trk') = mapAccumL f (div 60000000 120) trk -- default tempo 120 beats per minute
  formula dt tempo =
    (fromIntegral dt / fromIntegral tpb) * (fromIntegral tempo) * (1.0E-6)
  f :: Tempo -> (Ticks,Message) -> (Tempo, (Time,Message))
  f _ (dt, TempoChange tempo) = (tempo, (formula dt tempo, TempoChange tempo))
  f tempo (dt,msg) = (tempo, (formula dt tempo,msg))
toRealTime (TicksPerSecond fps tpf) trk = map f trk
  where
  f (dt,msg) = (fromIntegral dt / (fromIntegral fps * fromIntegral tpf), msg)

fromRealTime :: TimeDiv -> Track Time -> Track Ticks
fromRealTime (TicksPerBeat tpb) trk = trk'
  where
  (_,trk') = mapAccumL f (div 60000000 120) trk -- default tempo 120 beats per minute
  formula dt tempo = round $
    (dt * fromIntegral tpb) / (fromIntegral tempo * 1.0E-6)
  f :: Tempo -> (Time,Message) -> (Tempo, (Ticks,Message))
  f _ (dt, TempoChange tempo) = (tempo, (formula dt tempo, TempoChange tempo))
  f tempo (dt,msg) = (tempo, (formula dt tempo,msg))
fromRealTime (TicksPerSecond fps tpf) trk = map f trk
  where
  f (dt,msg) = (round $ dt * fromIntegral fps * fromIntegral tpf, msg)

-- MIDI import
importFile :: FilePath -> IO (Either String Midi)
importFile f = do
  bs <- L.readFile f
  return $! runParser parseMidi bs

exportFile :: FilePath -> Midi ->  IO ()
exportFile f m = do
  let bs = toLazyByteString $ buildMidi m
  L.writeFile f bs

-- All numeric values are stored in big-endian format

parseMidi :: Parser Midi
parseMidi = do
  _ <- string "MThd"
  _ <- word32be 6
  formatType' <- getWord16be
  trackNumber' <- getWord16be
  timeDivision' <- getWord16be
  let timeDivision = if testBit timeDivision' 15
        then TicksPerSecond
               (fromIntegral $ (flip shiftR) 9  $ shiftL timeDivision' 1)
               (fromIntegral $ (flip shiftR) 8  $ shiftL timeDivision' 8)
        else TicksPerBeat (fromIntegral timeDivision')
  case (formatType',trackNumber') of
    (0,1) -> do
      track' <- parseTrack
      return $! Midi SingleTrack timeDivision [track']
    (1,n) -> do
      tracks' <- sequence $ replicate (fromIntegral n) parseTrack
      return $! Midi MultiTrack timeDivision tracks'
    (2,n) -> do
      tracks' <- sequence $ replicate (fromIntegral n) parseTrack
      return $! Midi MultiPattern timeDivision tracks'
    _ -> fail "Invalid Midi file format"

buildMidi :: Midi -> Builder
buildMidi m = mconcat [
    putString "MThd"
  , putWord32be 6
  , case fileType m of
      SingleTrack -> putWord16be 0
      MultiTrack -> putWord16be 1
      MultiPattern -> putWord16be 2
  , putWord16be (fromIntegral $ length $ tracks m)
  , case timeDiv m of
      TicksPerBeat i -> putWord16be (fromIntegral i)
      TicksPerSecond i1 i2 -> mconcat [
          putWord8 (setBit (fromIntegral i1) 7)
        , putWord8 (fromIntegral i2)]
  , mconcat (map buildTrack $ tracks m)]
  
parseTrack :: Parser (Track Ticks)
parseTrack = do
  _ <- string "MTrk"
  _ <- getWord32be -- trackSize
  track' <- parseMessages Nothing
  return track'
 
buildTrack :: Track Ticks -> Builder
buildTrack trk = mconcat [
    putString "MTrk"
  , putWord32be $ fromIntegral $ L.length bs
  , fromLazyByteString bs]
  where
  f (dt,msg) = (putVarLenBe $ fromIntegral dt) `append` buildMessage msg
  bs = toLazyByteString $ mconcat (map f trk)

parseMessages :: Maybe Message -> Parser (Track Ticks)
parseMessages mPreMsg = do
  dt <- getVarLenBe >>= return . fromIntegral
  msg <- parseMessage mPreMsg
  if (isTrackEnd msg)
    then return [(dt,msg)]
    else do
      let mMsg = if isChannelMessage msg then (Just msg) else mPreMsg
      msgs <- parseMessages mMsg
      return $! (dt,msg) : msgs

parseMessage :: Maybe Message -> Parser Message
parseMessage mPreMsg = choice [
      parseChannelMessage mPreMsg
    , parseMetaMessage
    , parseSysexMessage]
  
buildMessage :: Message -> Builder
buildMessage msg | isChannelMessage msg = buildChannelMessage msg
buildMessage msg | isMetaMessage msg = buildMetaMessage msg
buildMessage msg | isSysexMessage msg = buildSysexMessage msg
buildMessage _ = mempty
  
parseChannelMessage :: Maybe Message -> Parser Message
parseChannelMessage mPreMsg = choice $ map (\f -> f mPreMsg) [
      parseNoteOff
    , parseNoteOn
    , parseKeyPressure
    , parseControlChange
    , parseProgramChange
    , parseChannelPressure
    , parsePitchWheel
  ]

parseChannel :: Maybe Message -> (Message -> Bool) -> Word8 -> Parser Channel
parseChannel mPreMsg isNeededMsg msgCode = p1 <|> p2
  where
  p1 = do
    _ <- lookAhead (satisfy ( < 0x80))
    guard $ (isJust mPreMsg) && (isNeededMsg $ fromJust mPreMsg)
    return $! channel (fromJust mPreMsg)
  p2 = do
    w8 <- getWord8
    guard (msgCode == shiftR w8 4)
    return $! fromIntegral $ w8 .&. (0x0F :: Word8)

parseNoteOff :: Maybe Message -> Parser Message
parseNoteOff mPreMsg = do
  ch <- parseChannel mPreMsg isNoteOff 0x08
  p1 <- getWord8
  p2 <- getWord8
  return $! NoteOff ch (fromIntegral p1) (fromIntegral p2)

parseNoteOn :: Maybe Message -> Parser Message
parseNoteOn mPreMsg = do
  ch <- parseChannel mPreMsg isNoteOn 0x09
  p1 <- getWord8
  p2 <- getWord8
  return $! NoteOn ch (fromIntegral p1) (fromIntegral p2)

parseKeyPressure :: Maybe Message -> Parser Message
parseKeyPressure mPreMsg = do
  ch <- parseChannel mPreMsg isKeyPressure 0x0A
  p1 <- getWord8
  p2 <- getWord8
  return $! KeyPressure ch (fromIntegral p1) (fromIntegral p2)

parseControlChange :: Maybe Message -> Parser Message
parseControlChange mPreMsg = do
  ch <- parseChannel mPreMsg isControlChange 0x0B
  p1 <- getWord8
  p2 <- getWord8
  return $! ControlChange ch (fromIntegral p1) (fromIntegral p2)

parseProgramChange :: Maybe Message -> Parser Message
parseProgramChange mPreMsg = do
  ch <- parseChannel mPreMsg isProgramChange 0x0C
  p1 <- getWord8
  return $! ProgramChange ch (fromIntegral p1)

parseChannelPressure :: Maybe Message -> Parser Message
parseChannelPressure mPreMsg = do
  ch <- parseChannel mPreMsg isChannelPressure 0x0D
  p1 <- getWord8
  return $! ChannelPressure ch (fromIntegral p1)
  
parsePitchWheel :: Maybe Message -> Parser Message
parsePitchWheel mPreMsg = do
  ch <- parseChannel mPreMsg isPitchWheel 0x0E
  p1 <- getWord8
  p2 <- getWord8
  return $! PitchWheel ch $ (shiftL (fromIntegral p2) 7) .|. (fromIntegral p1)

buildChannelMessage :: Message -> Builder
buildChannelMessage msg = case msg of
  NoteOff         _ p1 p2  -> mconcat
    [f 0x08, putWord8 $ fromIntegral $ p1, putWord8 $ fromIntegral $ p2]
  NoteOn          _ p1 p2  -> mconcat
    [f 0x09, putWord8 $ fromIntegral $ p1, putWord8 $ fromIntegral $ p2]
  KeyPressure     _ p1 p2  -> mconcat
    [f 0x0A, putWord8 $ fromIntegral $ p1, putWord8 $ fromIntegral $ p2]
  ControlChange   _ p1 p2  -> mconcat
    [f 0x0B, putWord8 $ fromIntegral $ p1, putWord8 $ fromIntegral $ p2]
  ProgramChange   _ p1     -> mconcat [f 0x0C, putWord8 $ fromIntegral $ p1]
  ChannelPressure _ p1     -> mconcat [f 0x0D, putWord8 $ fromIntegral $ p1]
  PitchWheel      _ p1     -> mconcat [ f 0x0E
                                      , putWord8 (fromIntegral $ p1 .&. 0x7F)
                                      , putWord8 (fromIntegral $ shiftR p1 7)]
  _ -> mempty
  where
  f :: Int -> Builder
  f w8 = putWord8 $ fromIntegral $ (shiftL w8 4) .|. (channel msg)
  
parseMetaMessage :: Parser Message
parseMetaMessage = do
  _ <- word8 0xFF
  choice [
      parseSequenceNumber
    , parseText
    , parseCopyright
    , parseTrackName
    , parseInstrumentName
    , parseLyrics
    , parseMarker
    , parseCuePoint
    , parseChannelPrefix
    , parseProgramName
    , parseDeviceName
    , parseTrackEnd
    , parseTempoChange
    , parseSMPTEOffset
    , parseTimeSignature
    , parseKeySignature
    , parseReserved
    ]

buildMetaMessage :: Message -> Builder
buildMetaMessage msg = putWord8 0xFF `mappend`
  case msg of
    SequenceNumber i -> mconcat
      [putWord8 0x00, putVarLenBe 2, putWord16be $ fromIntegral $ i]
    Text s -> mconcat
      [putWord8 0x01, putVarLenBe (fromIntegral $ length s), putString s]
    Copyright s -> mconcat
      [putWord8 0x02, putVarLenBe (fromIntegral $ length s), putString s]
    TrackName s -> mconcat
      [putWord8 0x03, putVarLenBe (fromIntegral $ length s), putString s]
    InstrumentName s -> mconcat
      [putWord8 0x04, putVarLenBe (fromIntegral $ length s), putString s]
    Lyrics s -> mconcat
      [putWord8 0x05, putVarLenBe (fromIntegral $ length s), putString s]
    Marker s -> mconcat
      [putWord8 0x06, putVarLenBe (fromIntegral $ length s), putString s]
    CuePoint s -> mconcat
      [putWord8 0x07, putVarLenBe (fromIntegral $ length s), putString s]
    ProgramName s -> mconcat
      [putWord8 0x08, putVarLenBe (fromIntegral $ length s), putString s]
    DeviceName s -> mconcat
      [putWord8 0x09, putVarLenBe (fromIntegral $ length s), putString s]
    ChannelPrefix i -> mconcat
      [putWord8 0x20, putVarLenBe 1, putWord8 $ fromIntegral $ i]
    TrackEnd -> putWord8 0x2F `mappend` putVarLenBe 0
    TempoChange i -> mconcat
      [putWord8 0x51, putVarLenBe 3, putWord24be $ fromIntegral $ i]
    SMPTEOffset i1 i2 i3 i4 i5 -> mconcat [
        putWord8 0x54
      , putVarLenBe 5
      , mconcat $ map (putWord8 . fromIntegral) [i1,i2,i3,i4,i5]]
    TimeSignature i1 i2 i3 i4 -> mconcat [
        putWord8 0x58
      , putVarLenBe 4
      , mconcat $ map (putWord8 . fromIntegral) [i1,i2,i3,i4]]
    KeySignature i1 i2 -> mconcat [
        putWord8 0x59
      , putVarLenBe 2
      , putInt8  $ fromIntegral $ i1
      , putWord8 $ fromIntegral $ i2]
    Reserved w bs -> mconcat [
        putWord8 (fromIntegral w)
      , putVarLenBe (fromIntegral $ L.length bs)
      , fromLazyByteString bs]
    _ -> mempty

parseSequenceNumber :: Parser Message
parseSequenceNumber = do
  _ <- word8 0x00
  _ <- varLenBe 2
  n <- getWord16be
  return $! SequenceNumber (fromIntegral n)

parseText :: Parser Message
parseText = do
  _ <- word8 0x01
  l <- getVarLenBe
  s <- getString (fromIntegral l)
  return $! Text s

parseCopyright :: Parser Message
parseCopyright = do
  _ <- word8 0x02
  l <- getVarLenBe
  s <- getString (fromIntegral l)
  return $! Copyright s

parseTrackName :: Parser Message
parseTrackName = do
  _ <- word8 0x03
  l <- getVarLenBe
  s <- getString (fromIntegral l)
  return $! TrackName s

parseInstrumentName :: Parser Message
parseInstrumentName = do
  _ <- word8 0x04
  l <- getVarLenBe
  s <- getString (fromIntegral l)
  return $! InstrumentName s

parseLyrics :: Parser Message
parseLyrics = do
  _ <- word8 0x05
  l <- getVarLenBe
  s <- getString (fromIntegral l)
  return $! Lyrics s

parseMarker :: Parser Message
parseMarker = do
  _ <- word8 0x06
  l <- getVarLenBe
  s <- getString (fromIntegral l)
  return $! Marker s

parseCuePoint :: Parser Message
parseCuePoint = do
  _ <- word8 0x07
  l <- getVarLenBe
  s <- getString (fromIntegral l)
  return $! CuePoint s

parseProgramName :: Parser Message
parseProgramName = do
  _ <- word8 0x08
  l <- getVarLenBe
  s <- getString (fromIntegral l)
  return $! ProgramName s

parseDeviceName :: Parser Message
parseDeviceName = do
  _ <- word8 0x09
  l <- getVarLenBe
  s <- getString (fromIntegral l)
  return $! DeviceName s

parseChannelPrefix :: Parser Message
parseChannelPrefix = do
  _ <- word8 0x20
  _ <- varLenBe 1
  p <- getWord8
  return $! ChannelPrefix (fromIntegral p)

parseTrackEnd :: Parser Message
parseTrackEnd =  do
  _ <- word8 0x2F
  _ <- varLenBe 0
  return $! TrackEnd

parseTempoChange :: Parser Message
parseTempoChange = do
  _ <- word8 0x51
  _ <- varLenBe 3
  t <- getWord24be
  return $! TempoChange (fromIntegral t)

parseSMPTEOffset :: Parser Message
parseSMPTEOffset = do
  _ <- word8 0x54
  _ <- varLenBe 5
  bs <- getLazyByteString 5
  let [n1,n2,n3,n4,n5] = map fromIntegral (L.unpack bs)
  return $! SMPTEOffset n1 n2 n3 n4 n5

parseTimeSignature :: Parser Message
parseTimeSignature = do
  _ <- word8 0x58
  _ <- varLenBe 4
  bs <- getLazyByteString 4
  let [n1,n2,n3,n4] = map fromIntegral (L.unpack bs)
  return $! TimeSignature n1 n2 n3 n4

parseKeySignature :: Parser Message
parseKeySignature = do
  _ <- word8 0x59
  _ <- varLenBe 2
  n1 <- getInt8
  n2 <- getWord8
  return $! KeySignature (fromIntegral n1) (fromIntegral n2)

parseReserved :: Parser Message
parseReserved = do
  t <- getWord8
  l <- getVarLenBe
  bs <- getLazyByteString (fromIntegral l)
  return $! Reserved (fromIntegral t)  bs

parseSysexMessage :: Parser Message
parseSysexMessage = do
  w <- (word8 0xF0) <|> (word8 0xF7)
  l <- getVarLenBe
  d <- getLazyByteString (fromIntegral l)
  return $! Sysex (fromIntegral w) d

buildSysexMessage :: Message -> Builder
buildSysexMessage (Sysex i bs) =
  mconcat [ putWord8 $ fromIntegral $ i
          , putVarLenBe $ fromIntegral $ L.length bs
          , fromLazyByteString bs]
buildSysexMessage _ = mempty

two :: Applicative f => f a -> f (a,a)
two a = pure ((,)) <*> a <*> a