-- |The hardware-independent part of the Midi binding.

{-# LANGUAGE CPP #-}
module System.Midi.Base 
    ( TimeStamp
    , MidiMessage'(..)
    , MidiMessage(..)
    , MidiEvent(..)
    , ClientCallback
    , ShortMessage(..)
    , translateShortMessage
    , untranslateShortMessage
    , shortMessage
    ) where

import Data.Bits
import Data.Word

type TimeStamp = Word32 

-- |A \"regular\" Midi message.
--
-- Remark: `NoteOff` not having a velocity field is a design decision, and a questionable one. According to the
-- Midi standard, NoteOff also has a velocity. However, most keyboards do not use this feature (send the default
-- value 64), and there are keyboards which do not send NoteOff messages at all, but send NoteOn messages with
-- zero velocity instead (for example the EMU Xboard series). I don't know what would be a good solution. 
-- At the moment, the code auto-translates NoteOn messages with zero velocity to NoteOff messages, and the
-- NoteOff velocity is ignored. This behaviour can be inverted with the Cabal flag NoNoteOff.
data MidiMessage' 
    = NoteOff         !Int          -- ^ Note Off (key)
    | NoteOn          !Int !Int     -- ^ Note On (key, velocity)
    | PolyAftertouch  !Int !Int     -- ^ Polyphonic key pressure (key, pressure)
    | CC              !Int !Int     -- ^ Control Change (controller, value)
    | ProgramChange   !Int          -- ^ Program Change (program)
    | Aftertouch      !Int          -- ^ Global aftertouch (pressure)
    | PitchWheel      !Int          -- ^ Pitch wheel (value, from -8192..+8191)
    deriving (Show,Eq)
    
-- |The type representing a Midi message.  
data MidiMessage 
    = MidiMessage  !Int !MidiMessage'    -- ^ first argument is the Midi channel (1..16)
    | SysEx        [Word8]               -- ^ not including the bytes 0xf0, 0xf7
    | SongPosition !Int
    | SongSelect   !Int 
    | TuneRequest
    | SRTClock
    | SRTStart
    | SRTContinue 
    | SRTStop
    | ActiveSensing
    | Reset
    | Undefined
    deriving (Show,Eq)
    
-- |The type representing a timestamped Midi message. 
-- Time is measured in milisecs elapsed since the last call to `System.Midi.start`.
data MidiEvent = MidiEvent !TimeStamp !MidiMessage deriving (Show,Eq)

-- |Type of the user callback function.  
type ClientCallback = MidiEvent -> IO ()
    
translateShortMessage :: ShortMessage -> MidiMessage
translateShortMessage (ShortMessage chn msg bt1 bt2) =
    if msg < 15 
      then MidiMessage (fromIntegral chn + 1) $ translate' msg k v
      else translate'' chn k v
    where
      k = fromIntegral bt1
      v = fromIntegral bt2

translate' msg k v = case msg of
#ifdef HMidi_NO_NOTEOFF
     8  -> NoteOn k 0
     9  -> NoteOn k v
#else
     8  -> NoteOff k
     9  -> if v>0 then NoteOn k v else NoteOff k
#endif
     10 -> PolyAftertouch k v
     11 -> CC k v
     12 -> ProgramChange k
     13 -> Aftertouch k
     14 -> PitchWheel (k + shiftL v 7 - 8192)

translate'' lo a b = case lo of
    0  -> Undefined
    1  -> Undefined
    2  -> SongPosition (a + shiftL b 7)
    3  -> SongSelect a 
    4  -> Undefined
    5  -> Undefined
    6  -> TuneRequest
    7  -> Undefined
    8  -> SRTClock
    9  -> Undefined
    10 -> SRTStart
    11 -> SRTContinue
    12 -> SRTStop
    13 -> Undefined
    14 -> ActiveSensing
    15 -> Reset
 
untranslateShortMessage :: MidiMessage -> ShortMessage
untranslateShortMessage (MidiMessage chn msg') = 
    case msg' of
      NoteOff k           -> shortMessage chn  8 k 64
      NoteOn  k v         -> shortMessage chn  9 k v
      PolyAftertouch k v  -> shortMessage chn 10 k v
      CC k v              -> shortMessage chn 11 k v
      ProgramChange k     -> shortMessage chn 12 k 0
      Aftertouch k        -> shortMessage chn 13 k 0
      PitchWheel n        -> let m = min 16383 $ max 0 $ n + 8192 in shortMessage chn 14 (m.&.127) (shiftR m 7) 

untranslateShortMessage (SongPosition p) = shortMessage 15  3 (p.&.7) (shiftR p 7) 
untranslateShortMessage (SongSelect   s) = shortMessage 15  3 (fromIntegral s) 0 
untranslateShortMessage  TuneRequest     = shortMessage 15  6 0 0 
untranslateShortMessage  SRTClock        = shortMessage 15  8 0 0 
untranslateShortMessage  SRTStart        = shortMessage 15 10 0 0 
untranslateShortMessage  SRTContinue     = shortMessage 15 11 0 0 
untranslateShortMessage  SRTStop         = shortMessage 15 12 0 0 
untranslateShortMessage  ActiveSensing   = shortMessage 15 14 0 0 
untranslateShortMessage  Reset           = shortMessage 15 15 0 0 
untranslateShortMessage  Undefined       = error "cannot untranslate Undefined" 
untranslateShortMessage (SysEx _)        = error "cannot untranslate SysEx" 
 
shortMessage :: Int -> Int -> Int -> Int -> ShortMessage
shortMessage chn msg bt1 bt2 = 
    ShortMessage (fromIntegral chn - 1) (fromIntegral msg) (fromIntegral bt1) (fromIntegral bt2)
 
-- |Low level stuff.
data ShortMessage = ShortMessage 
    { sm_channel :: Word8
    , sm_msg     :: Word8 
    , sm_byte1   :: Word8
    , sm_byte2   :: Word8 
    } deriving Show