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

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

--------------------------------------------------------------------------------

import Data.Bits
import Data.Word
import Data.Typeable
import Control.Exception.Base

type TimeStamp = Word32 

--------------------------------------------------------------------------------

-- |A \"regular\" MIDI message.
--
-- Remark: 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).  
-- At the moment, the code auto-translates NoteOn messages with zero velocity to NoteOff messages with velocity 64.
-- This behaviour can be inverted with the Cabal flag 'noNoteOff', which translates all NoteOff messages to
-- NoteOn messages with velocity 0.
data MidiMessage' 
  = NoteOff         !Int !Int     -- ^ Note Off (key, velocity)
  | 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 (Int -> MidiMessage' -> ShowS
[MidiMessage'] -> ShowS
MidiMessage' -> String
(Int -> MidiMessage' -> ShowS)
-> (MidiMessage' -> String)
-> ([MidiMessage'] -> ShowS)
-> Show MidiMessage'
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MidiMessage'] -> ShowS
$cshowList :: [MidiMessage'] -> ShowS
show :: MidiMessage' -> String
$cshow :: MidiMessage' -> String
showsPrec :: Int -> MidiMessage' -> ShowS
$cshowsPrec :: Int -> MidiMessage' -> ShowS
Show,MidiMessage' -> MidiMessage' -> Bool
(MidiMessage' -> MidiMessage' -> Bool)
-> (MidiMessage' -> MidiMessage' -> Bool) -> Eq MidiMessage'
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MidiMessage' -> MidiMessage' -> Bool
$c/= :: MidiMessage' -> MidiMessage' -> Bool
== :: MidiMessage' -> MidiMessage' -> Bool
$c== :: MidiMessage' -> MidiMessage' -> Bool
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                  -- ^ measured in "MIDI beats" (1/16th notes).
  | SongSelect   !Int 
  | TuneRequest
  | SRTClock                           -- ^ clock is sent 24 times per quarter note
  | SRTStart
  | SRTContinue 
  | SRTStop
  | ActiveSensing
  | Reset
  | Undefined
  deriving (Int -> MidiMessage -> ShowS
[MidiMessage] -> ShowS
MidiMessage -> String
(Int -> MidiMessage -> ShowS)
-> (MidiMessage -> String)
-> ([MidiMessage] -> ShowS)
-> Show MidiMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MidiMessage] -> ShowS
$cshowList :: [MidiMessage] -> ShowS
show :: MidiMessage -> String
$cshow :: MidiMessage -> String
showsPrec :: Int -> MidiMessage -> ShowS
$cshowsPrec :: Int -> MidiMessage -> ShowS
Show,MidiMessage -> MidiMessage -> Bool
(MidiMessage -> MidiMessage -> Bool)
-> (MidiMessage -> MidiMessage -> Bool) -> Eq MidiMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MidiMessage -> MidiMessage -> Bool
$c/= :: MidiMessage -> MidiMessage -> Bool
== :: MidiMessage -> MidiMessage -> Bool
$c== :: MidiMessage -> MidiMessage -> Bool
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 (Int -> MidiEvent -> ShowS
[MidiEvent] -> ShowS
MidiEvent -> String
(Int -> MidiEvent -> ShowS)
-> (MidiEvent -> String)
-> ([MidiEvent] -> ShowS)
-> Show MidiEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MidiEvent] -> ShowS
$cshowList :: [MidiEvent] -> ShowS
show :: MidiEvent -> String
$cshow :: MidiEvent -> String
showsPrec :: Int -> MidiEvent -> ShowS
$cshowsPrec :: Int -> MidiEvent -> ShowS
Show,MidiEvent -> MidiEvent -> Bool
(MidiEvent -> MidiEvent -> Bool)
-> (MidiEvent -> MidiEvent -> Bool) -> Eq MidiEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MidiEvent -> MidiEvent -> Bool
$c/= :: MidiEvent -> MidiEvent -> Bool
== :: MidiEvent -> MidiEvent -> Bool
$c== :: MidiEvent -> MidiEvent -> Bool
Eq)

-- |Type of the user callback function.  
type ClientCallback = MidiEvent -> IO ()
  
translateShortMessage :: ShortMessage -> MidiMessage
translateShortMessage :: ShortMessage -> MidiMessage
translateShortMessage (ShortMessage Word8
chn Word8
msg Word8
bt1 Word8
bt2) =
  if Word8
msg Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
15 
    then Int -> MidiMessage' -> MidiMessage
MidiMessage (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
chn Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (MidiMessage' -> MidiMessage) -> MidiMessage' -> MidiMessage
forall a b. (a -> b) -> a -> b
$ Word8 -> Int -> Int -> MidiMessage'
forall a. (Eq a, Num a) => a -> Int -> Int -> MidiMessage'
translate' Word8
msg Int
k Int
v
    else Word8 -> Int -> Int -> MidiMessage
forall a. (Eq a, Num a) => a -> Int -> Int -> MidiMessage
translate'' Word8
chn Int
k Int
v
  where
    k :: Int
k = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
bt1
    v :: Int
v = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
bt2

translate' :: a -> Int -> Int -> MidiMessage'
translate' a
msg Int
k Int
v = case a
msg of
#ifdef HMIDI_NO_NOTEOFF
   8  -> NoteOn k 0
   9  -> NoteOn k v
#else
   a
8  -> Int -> Int -> MidiMessage'
NoteOff Int
k Int
v
   a
9  -> if Int
vInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0 then Int -> Int -> MidiMessage'
NoteOn Int
k Int
v else Int -> Int -> MidiMessage'
NoteOff Int
k Int
64
#endif
   a
10 -> Int -> Int -> MidiMessage'
PolyAftertouch Int
k Int
v
   a
11 -> Int -> Int -> MidiMessage'
CC Int
k Int
v
   a
12 -> Int -> MidiMessage'
ProgramChange Int
k
   a
13 -> Int -> MidiMessage'
Aftertouch Int
k
   a
14 -> Int -> MidiMessage'
PitchWheel (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftL Int
v Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
8192)

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

untranslateShortMessage (SongPosition Int
p) = Int -> Int -> Int -> ShortMessage
sysShortMessage  Int
2 (Int
pInt -> Int -> Int
forall a. Bits a => a -> a -> a
.&.Int
7) (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftR Int
p Int
7) 
untranslateShortMessage (SongSelect   Int
s) = Int -> Int -> Int -> ShortMessage
sysShortMessage  Int
3 (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s) Int
0 
untranslateShortMessage  MidiMessage
TuneRequest     = Int -> Int -> Int -> ShortMessage
sysShortMessage  Int
6 Int
0 Int
0 
untranslateShortMessage  MidiMessage
SRTClock        = Int -> Int -> Int -> ShortMessage
sysShortMessage  Int
8 Int
0 Int
0 
untranslateShortMessage  MidiMessage
SRTStart        = Int -> Int -> Int -> ShortMessage
sysShortMessage Int
10 Int
0 Int
0 
untranslateShortMessage  MidiMessage
SRTContinue     = Int -> Int -> Int -> ShortMessage
sysShortMessage Int
11 Int
0 Int
0 
untranslateShortMessage  MidiMessage
SRTStop         = Int -> Int -> Int -> ShortMessage
sysShortMessage Int
12 Int
0 Int
0 
untranslateShortMessage  MidiMessage
ActiveSensing   = Int -> Int -> Int -> ShortMessage
sysShortMessage Int
14 Int
0 Int
0 
untranslateShortMessage  MidiMessage
Reset           = Int -> Int -> Int -> ShortMessage
sysShortMessage Int
15 Int
0 Int
0 
untranslateShortMessage  MidiMessage
Undefined       = String -> ShortMessage
forall a. HasCallStack => String -> a
error String
"cannot untranslate Undefined" 
untranslateShortMessage (SysEx [Word8]
_)        = String -> ShortMessage
forall a. HasCallStack => String -> a
error String
"cannot untranslate SysEx" 

-- high nibble = message
-- low nibble = chn, or submessage when msg=15 (system messages)
sysShortMessage :: Int -> Int -> Int -> ShortMessage
sysShortMessage :: Int -> Int -> Int -> ShortMessage
sysShortMessage Int
chn Int
bt1 Int
bt2 = 
  Word8 -> Word8 -> Word8 -> Word8 -> ShortMessage
ShortMessage (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
chn) Word8
15 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bt1) (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bt2) 

-- regular short message 
shortMessage :: Int -> Int -> Int -> Int -> ShortMessage
shortMessage :: Int -> Int -> Int -> Int -> ShortMessage
shortMessage Int
chn Int
msg Int
bt1 Int
bt2 = 
  Word8 -> Word8 -> Word8 -> Word8 -> ShortMessage
ShortMessage (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
chn Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
1) (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
msg) (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bt1) (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bt2)
 
-- |Low level stuff.
data ShortMessage = ShortMessage 
  { ShortMessage -> Word8
sm_channel :: Word8
  , ShortMessage -> Word8
sm_msg     :: Word8 
  , ShortMessage -> Word8
sm_byte1   :: Word8
  , ShortMessage -> Word8
sm_byte2   :: Word8 
  } deriving Int -> ShortMessage -> ShowS
[ShortMessage] -> ShowS
ShortMessage -> String
(Int -> ShortMessage -> ShowS)
-> (ShortMessage -> String)
-> ([ShortMessage] -> ShowS)
-> Show ShortMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShortMessage] -> ShowS
$cshowList :: [ShortMessage] -> ShowS
show :: ShortMessage -> String
$cshow :: ShortMessage -> String
showsPrec :: Int -> ShortMessage -> ShowS
$cshowsPrec :: Int -> ShortMessage -> ShowS
Show

--------------------------------------------------------------------------------

data MidiException 
  = MidiException String 
  deriving (Int -> MidiException -> ShowS
[MidiException] -> ShowS
MidiException -> String
(Int -> MidiException -> ShowS)
-> (MidiException -> String)
-> ([MidiException] -> ShowS)
-> Show MidiException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MidiException] -> ShowS
$cshowList :: [MidiException] -> ShowS
show :: MidiException -> String
$cshow :: MidiException -> String
showsPrec :: Int -> MidiException -> ShowS
$cshowsPrec :: Int -> MidiException -> ShowS
Show,Typeable)

instance Exception MidiException where
#if MIN_VERSION_base(4,8,0)
  displayException :: MidiException -> String
displayException (MidiException String
msg) = String
msg
#endif

--------------------------------------------------------------------------------