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

-- |

-- 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 {
    Midi -> FileType
fileType :: FileType
  , Midi -> TimeDiv
timeDiv :: TimeDiv
  , Midi -> [Track Int]
tracks :: [Track Ticks]
  } deriving (Midi -> Midi -> Bool
(Midi -> Midi -> Bool) -> (Midi -> Midi -> Bool) -> Eq Midi
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Midi -> Midi -> Bool
== :: Midi -> Midi -> Bool
$c/= :: Midi -> Midi -> Bool
/= :: Midi -> Midi -> Bool
Eq, Int -> Midi -> ShowS
[Midi] -> ShowS
Midi -> String
(Int -> Midi -> ShowS)
-> (Midi -> String) -> ([Midi] -> ShowS) -> Show Midi
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Midi -> ShowS
showsPrec :: Int -> Midi -> ShowS
$cshow :: Midi -> String
show :: Midi -> String
$cshowList :: [Midi] -> ShowS
showList :: [Midi] -> ShowS
Show)

instance Arbitrary Midi where
  arbitrary :: Gen Midi
arbitrary = do
    ft <- Gen FileType
forall a. Arbitrary a => Gen a
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 :: Track Int -> Track Int
fAux = (Track Int -> Track Int -> Track Int
forall a. [a] -> [a] -> [a]
++ [(Int
0,Message
TrackEnd)]) (Track Int -> Track Int)
-> (Track Int -> Track Int) -> Track Int -> Track Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Message) -> (Int, Message)) -> Track Int -> Track Int
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
dt,Message
m) -> (Int -> Int
forall a. Num a => a -> a
abs Int
dt,Message
m)) (Track Int -> Track Int)
-> (Track Int -> Track Int) -> Track Int -> Track Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track Int -> Track Int
forall a. Track a -> Track a
removeTrackEnds

data FileType = SingleTrack | MultiTrack | MultiPattern
  deriving (FileType -> FileType -> Bool
(FileType -> FileType -> Bool)
-> (FileType -> FileType -> Bool) -> Eq FileType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FileType -> FileType -> Bool
== :: FileType -> FileType -> Bool
$c/= :: FileType -> FileType -> Bool
/= :: FileType -> FileType -> Bool
Eq, Int -> FileType -> ShowS
[FileType] -> ShowS
FileType -> String
(Int -> FileType -> ShowS)
-> (FileType -> String) -> ([FileType] -> ShowS) -> Show FileType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FileType -> ShowS
showsPrec :: Int -> FileType -> ShowS
$cshow :: FileType -> String
show :: FileType -> String
$cshowList :: [FileType] -> ShowS
showList :: [FileType] -> ShowS
Show)

instance Arbitrary FileType where
  arbitrary :: Gen FileType
arbitrary = [Gen FileType] -> Gen FileType
forall a. HasCallStack => [Gen a] -> Gen a
oneof [FileType -> Gen FileType
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return FileType
SingleTrack , FileType -> Gen FileType
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return FileType
MultiTrack , FileType -> Gen FileType
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return FileType
MultiPattern]
  
type Track a = [(a,Message)]

data TimeDiv =
  TicksPerBeat Int | -- 1 -- (2^15 - 1)

  TicksPerSecond Int Int -- 1 - 127

             --  FramesPerSecond TicksPerFrame

  deriving (Int -> TimeDiv -> ShowS
[TimeDiv] -> ShowS
TimeDiv -> String
(Int -> TimeDiv -> ShowS)
-> (TimeDiv -> String) -> ([TimeDiv] -> ShowS) -> Show TimeDiv
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TimeDiv -> ShowS
showsPrec :: Int -> TimeDiv -> ShowS
$cshow :: TimeDiv -> String
show :: TimeDiv -> String
$cshowList :: [TimeDiv] -> ShowS
showList :: [TimeDiv] -> ShowS
Show,TimeDiv -> TimeDiv -> Bool
(TimeDiv -> TimeDiv -> Bool)
-> (TimeDiv -> TimeDiv -> Bool) -> Eq TimeDiv
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TimeDiv -> TimeDiv -> Bool
== :: TimeDiv -> TimeDiv -> Bool
$c/= :: TimeDiv -> TimeDiv -> Bool
/= :: TimeDiv -> TimeDiv -> Bool
Eq)

instance Arbitrary TimeDiv where
  arbitrary :: Gen TimeDiv
arbitrary = [Gen TimeDiv] -> Gen TimeDiv
forall a. HasCallStack => [Gen a] -> Gen a
oneof [
      (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1,Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
15 :: Int) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Gen Int -> (Int -> Gen TimeDiv) -> Gen TimeDiv
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TimeDiv -> Gen TimeDiv
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (TimeDiv -> Gen TimeDiv) -> (Int -> TimeDiv) -> Int -> Gen TimeDiv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> TimeDiv
TicksPerBeat
    , Gen Int -> Gen (Int, Int)
forall (f :: * -> *) a. Applicative f => f a -> f (a, a)
two ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1,Int
127)) Gen (Int, Int) -> ((Int, Int) -> Gen TimeDiv) -> Gen TimeDiv
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Int
w1,Int
w2) -> TimeDiv -> Gen TimeDiv
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (TimeDiv -> Gen TimeDiv) -> TimeDiv -> Gen TimeDiv
forall a b. (a -> b) -> a -> b
$! Int -> Int -> TimeDiv
TicksPerSecond Int
w1 Int
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         { Message -> Int
channel :: !Channel, Message -> Int
key :: !Key,              Message -> Int
velocity :: !Velocity } |
  NoteOn          { channel :: !Channel, key :: !Key,              velocity :: !Velocity } |
  KeyPressure     { channel :: !Channel, key :: !Key,              Message -> Int
pressure :: !Pressure} |
  ControlChange   { channel :: !Channel, Message -> Int
controllerNumber :: !Int, Message -> Int
controllerValue :: !Int } |
  ProgramChange   { channel :: !Channel, Message -> Int
preset :: !Preset } |
  ChannelPressure { channel :: !Channel, pressure :: !Pressure } |
  PitchWheel      { channel :: !Channel, Message -> Int
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 (Int -> Message -> ShowS
[Message] -> ShowS
Message -> String
(Int -> Message -> ShowS)
-> (Message -> String) -> ([Message] -> ShowS) -> Show Message
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Message -> ShowS
showsPrec :: Int -> Message -> ShowS
$cshow :: Message -> String
show :: Message -> String
$cshowList :: [Message] -> ShowS
showList :: [Message] -> ShowS
Show,Message -> Message -> Bool
(Message -> Message -> Bool)
-> (Message -> Message -> Bool) -> Eq Message
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Message -> Message -> Bool
== :: Message -> Message -> Bool
$c/= :: Message -> Message -> Bool
/= :: Message -> Message -> Bool
Eq)

instance Arbitrary Message where
  arbitrary :: Gen Message
arbitrary = do
    -- Channel Messages

    c <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0,Int
15)
    oneof [
        two (choose (0,127))  >>= \(Int
w2,Int
w3) -> Message -> Gen Message
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message) -> Message -> Gen Message
forall a b. (a -> b) -> a -> b
$! Int -> Int -> Int -> Message
NoteOff Int
c Int
w2 Int
w3
      , two (choose (0,127))  >>= \(Int
w2,Int
w3) -> Message -> Gen Message
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message) -> Message -> Gen Message
forall a b. (a -> b) -> a -> b
$! Int -> Int -> Int -> Message
NoteOn Int
c Int
w2 Int
w3
      , two (choose (0,127))  >>= \(Int
w2,Int
w3) -> Message -> Gen Message
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message) -> Message -> Gen Message
forall a b. (a -> b) -> a -> b
$! Int -> Int -> Int -> Message
KeyPressure Int
c Int
w2 Int
w3
      , two (choose (0,127))  >>= \(Int
w2,Int
w3) -> Message -> Gen Message
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message) -> Message -> Gen Message
forall a b. (a -> b) -> a -> b
$! Int -> Int -> Int -> Message
ControlChange Int
c Int
w2 Int
w3
      , choose (0,127)        >>= \Int
w2      -> Message -> Gen Message
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message) -> Message -> Gen Message
forall a b. (a -> b) -> a -> b
$! Int -> Int -> Message
ProgramChange Int
c Int
w2
      , choose (0,127)        >>= \Int
w2      -> Message -> Gen Message
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message) -> Message -> Gen Message
forall a b. (a -> b) -> a -> b
$! Int -> Int -> Message
ChannelPressure Int
c Int
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 >>= \ByteString
bs -> Message -> Gen Message
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message) -> Message -> Gen Message
forall a b. (a -> b) -> a -> b
$! Int -> ByteString -> Message
Reserved Int
0x60 ByteString
bs
      -- System Exclusive Messages

      , do w <- oneof [return 0xF0, return 0xF7]
           bs <- arbitrary
           return $! Sysex w bs]

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

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

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

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

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

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

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

isChannelMessage :: Message -> Bool
isChannelMessage :: Message -> Bool
isChannelMessage Message
msg = (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Message -> Bool
isMetaMessage Message
msg) Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Message -> Bool
isSysexMessage Message
msg)

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

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

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

removeTrackEnds :: Track a -> Track a
removeTrackEnds :: forall a. Track a -> Track a
removeTrackEnds [] = []
removeTrackEnds [(a, Message)]
trk = ((a, Message) -> Bool) -> [(a, Message)] -> [(a, Message)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> ((a, Message) -> Bool) -> (a, Message) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Bool
isTrackEnd (Message -> Bool)
-> ((a, Message) -> Message) -> (a, Message) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Message) -> Message
forall a b. (a, b) -> b
snd) [(a, Message)]
trk

toSingleTrack :: Midi -> Midi
toSingleTrack :: Midi -> Midi
toSingleTrack m :: Midi
m@(Midi FileType
SingleTrack TimeDiv
_ [Track Int]
_) = Midi
m
toSingleTrack (Midi FileType
MultiTrack TimeDiv
td [Track Int]
trks) = FileType -> TimeDiv -> [Track Int] -> Midi
Midi FileType
SingleTrack TimeDiv
td [Track Int
trk']
  where trk' :: Track Int
trk' = (Track Int -> Track Int -> Track Int)
-> Track Int -> [Track Int] -> Track Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Track Int -> Track Int -> Track Int
forall a. (Num a, Ord a) => Track a -> Track a -> Track a
merge [] [Track Int]
trks
toSingleTrack (Midi FileType
MultiPattern TimeDiv
td [Track Int]
trks) = FileType -> TimeDiv -> [Track Int] -> Midi
Midi FileType
SingleTrack TimeDiv
td [Track Int
trk']
  where trk' :: Track Int
trk' = ([Track Int] -> Track Int
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Track Int] -> Track Int) -> [Track Int] -> Track Int
forall a b. (a -> b) -> a -> b
$ (Track Int -> Track Int) -> [Track Int] -> [Track Int]
forall a b. (a -> b) -> [a] -> [b]
map Track Int -> Track Int
forall a. Track a -> Track a
removeTrackEnds [Track Int]
trks) Track Int -> Track Int -> Track Int
forall a. [a] -> [a] -> [a]
++ [(Int
0,Message
TrackEnd)]

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

toAbsTime :: (Num a) => Track a -> Track a
toAbsTime :: forall a. Num a => Track a -> Track a
toAbsTime Track a
trk = [a] -> [Message] -> Track a
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
ts' [Message]
ms
  where
  ([a]
ts,[Message]
ms) = Track a -> ([a], [Message])
forall a b. [(a, b)] -> ([a], [b])
unzip Track a
trk
  (a
_,[a]
ts') = (a -> a -> (a, a)) -> a -> [a] -> (a, [a])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (\a
acc a
t -> let t' :: a
t' = a
acc a -> a -> a
forall a. Num a => a -> a -> a
+ a
t in (a
t',a
t')) a
0 [a]
ts
  
fromAbsTime :: (Num a) => Track a -> Track a
fromAbsTime :: forall a. Num a => Track a -> Track a
fromAbsTime Track a
trk = [a] -> [Message] -> Track a
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
ts' [Message]
ms
  where
  ([a]
ts,[Message]
ms) = Track a -> ([a], [Message])
forall a b. [(a, b)] -> ([a], [b])
unzip Track a
trk
  (a
_,[a]
ts') = (a -> a -> (a, a)) -> a -> [a] -> (a, [a])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (\a
acc a
t -> (a
t,a
t a -> a -> a
forall a. Num a => a -> a -> a
- a
acc)) a
0 [a]
ts

toRealTime :: TimeDiv -> Track Ticks -> Track Time
toRealTime :: TimeDiv -> Track Int -> Track Time
toRealTime (TicksPerBeat Int
tpb) Track Int
trk = Track Time
trk'
  where
  (Int
_,Track Time
trk') = (Int -> (Int, Message) -> (Int, (Time, Message)))
-> Int -> Track Int -> (Int, Track Time)
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Int -> (Int, Message) -> (Int, (Time, Message))
f (Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
60000000 Int
120) Track Int
trk -- default tempo 120 beats per minute

  formula :: a -> a -> a
formula a
dt a
tempo =
    (a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
dt a -> a -> a
forall a. Fractional a => a -> a -> a
/ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tpb) a -> a -> a
forall a. Num a => a -> a -> a
* (a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
tempo) a -> a -> a
forall a. Num a => a -> a -> a
* (a
1.0E-6)
  f :: Tempo -> (Ticks,Message) -> (Tempo, (Time,Message))
  f :: Int -> (Int, Message) -> (Int, (Time, Message))
f Int
_ (Int
dt, TempoChange Int
tempo) = (Int
tempo, (Int -> Int -> Time
forall {a} {a} {a}.
(Fractional a, Integral a, Integral a) =>
a -> a -> a
formula Int
dt Int
tempo, Int -> Message
TempoChange Int
tempo))
  f Int
tempo (Int
dt,Message
msg) = (Int
tempo, (Int -> Int -> Time
forall {a} {a} {a}.
(Fractional a, Integral a, Integral a) =>
a -> a -> a
formula Int
dt Int
tempo,Message
msg))
toRealTime (TicksPerSecond Int
fps Int
tpf) Track Int
trk = ((Int, Message) -> (Time, Message)) -> Track Int -> Track Time
forall a b. (a -> b) -> [a] -> [b]
map (Int, Message) -> (Time, Message)
forall {a} {a} {b}. (Fractional a, Integral a) => (a, b) -> (a, b)
f Track Int
trk
  where
  f :: (a, b) -> (a, b)
f (a
dt,b
msg) = (a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
dt a -> a -> a
forall a. Fractional a => a -> a -> a
/ (Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
fps a -> a -> a
forall a. Num a => a -> a -> a
* Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tpf), b
msg)

fromRealTime :: TimeDiv -> Track Time -> Track Ticks
fromRealTime :: TimeDiv -> Track Time -> Track Int
fromRealTime (TicksPerBeat Int
tpb) Track Time
trk = Track Int
trk'
  where
  (Int
_,Track Int
trk') = (Int -> (Time, Message) -> (Int, (Int, Message)))
-> Int -> Track Time -> (Int, Track Int)
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Int -> (Time, Message) -> (Int, (Int, Message))
f (Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
60000000 Int
120) Track Time
trk -- default tempo 120 beats per minute

  formula :: a -> a -> b
formula a
dt a
tempo = a -> b
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$
    (a
dt a -> a -> a
forall a. Num a => a -> a -> a
* Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tpb) a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
tempo a -> a -> a
forall a. Num a => a -> a -> a
* a
1.0E-6)
  f :: Tempo -> (Time,Message) -> (Tempo, (Ticks,Message))
  f :: Int -> (Time, Message) -> (Int, (Int, Message))
f Int
_ (Time
dt, TempoChange Int
tempo) = (Int
tempo, (Time -> Int -> Int
forall {a} {b} {a}.
(RealFrac a, Integral b, Integral a) =>
a -> a -> b
formula Time
dt Int
tempo, Int -> Message
TempoChange Int
tempo))
  f Int
tempo (Time
dt,Message
msg) = (Int
tempo, (Time -> Int -> Int
forall {a} {b} {a}.
(RealFrac a, Integral b, Integral a) =>
a -> a -> b
formula Time
dt Int
tempo,Message
msg))
fromRealTime (TicksPerSecond Int
fps Int
tpf) Track Time
trk = ((Time, Message) -> (Int, Message)) -> Track Time -> Track Int
forall a b. (a -> b) -> [a] -> [b]
map (Time, Message) -> (Int, Message)
forall {a} {a} {b}. (RealFrac a, Integral a) => (a, b) -> (a, b)
f Track Time
trk
  where
  f :: (a, b) -> (a, b)
f (a
dt,b
msg) = (a -> a
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
dt a -> a -> a
forall a. Num a => a -> a -> a
* Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
fps a -> a -> a
forall a. Num a => a -> a -> a
* Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tpf, b
msg)

-- MIDI import

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

exportFile :: FilePath -> Midi ->  IO ()
exportFile :: String -> Midi -> IO ()
exportFile String
f Midi
m = do
  let bs :: ByteString
bs = Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Midi -> Builder
buildMidi Midi
m
  String -> ByteString -> IO ()
L.writeFile String
f ByteString
bs

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


parseMidi :: Parser Midi
parseMidi :: Parser Midi
parseMidi = do
  _ <- String -> Parser String
string String
"MThd"
  _ <- word32be 6
  formatType' <- getWord16be
  trackNumber' <- getWord16be
  timeDivision' <- getWord16be
  let timeDivision = if Word16 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word16
timeDivision' Int
15
        then Int -> Int -> TimeDiv
TicksPerSecond
               (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int) -> Word16 -> Int
forall a b. (a -> b) -> a -> b
$ ((Word16 -> Int -> Word16) -> Int -> Word16 -> Word16
forall a b c. (a -> b -> c) -> b -> a -> c
flip Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
shiftR) Int
9  (Word16 -> Word16) -> Word16 -> Word16
forall a b. (a -> b) -> a -> b
$ Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
shiftL Word16
timeDivision' Int
1)
               (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int) -> Word16 -> Int
forall a b. (a -> b) -> a -> b
$ ((Word16 -> Int -> Word16) -> Int -> Word16 -> Word16
forall a b c. (a -> b -> c) -> b -> a -> c
flip Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
shiftR) Int
8  (Word16 -> Word16) -> Word16 -> Word16
forall a b. (a -> b) -> a -> b
$ Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
shiftL Word16
timeDivision' Int
8)
        else Int -> TimeDiv
TicksPerBeat (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
timeDivision')
  case (formatType',trackNumber') of
    (Word16
0,Word16
1) -> do
      track' <- Parser (Track Int)
parseTrack
      return $! Midi SingleTrack timeDivision [track']
    (Word16
1,Word16
n) -> do
      tracks' <- [Parser (Track Int)] -> Parser [Track Int]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Parser (Track Int)] -> Parser [Track Int])
-> [Parser (Track Int)] -> Parser [Track Int]
forall a b. (a -> b) -> a -> b
$ Int -> Parser (Track Int) -> [Parser (Track Int)]
forall a. Int -> a -> [a]
replicate (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
n) Parser (Track Int)
parseTrack
      return $! Midi MultiTrack timeDivision tracks'
    (Word16
2,Word16
n) -> do
      tracks' <- [Parser (Track Int)] -> Parser [Track Int]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Parser (Track Int)] -> Parser [Track Int])
-> [Parser (Track Int)] -> Parser [Track Int]
forall a b. (a -> b) -> a -> b
$ Int -> Parser (Track Int) -> [Parser (Track Int)]
forall a. Int -> a -> [a]
replicate (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
n) Parser (Track Int)
parseTrack
      return $! Midi MultiPattern timeDivision tracks'
    (Word16, Word16)
_ -> String -> Parser Midi
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid Midi file format"

buildMidi :: Midi -> Builder
buildMidi :: Midi -> Builder
buildMidi Midi
m = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [
    String -> Builder
putString String
"MThd"
  , Word32 -> Builder
putWord32be Word32
6
  , case Midi -> FileType
fileType Midi
m of
      FileType
SingleTrack -> Word16 -> Builder
putWord16be Word16
0
      FileType
MultiTrack -> Word16 -> Builder
putWord16be Word16
1
      FileType
MultiPattern -> Word16 -> Builder
putWord16be Word16
2
  , Word16 -> Builder
putWord16be (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ [Track Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Track Int] -> Int) -> [Track Int] -> Int
forall a b. (a -> b) -> a -> b
$ Midi -> [Track Int]
tracks Midi
m)
  , case Midi -> TimeDiv
timeDiv Midi
m of
      TicksPerBeat Int
i -> Word16 -> Builder
putWord16be (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
      TicksPerSecond Int
i1 Int
i2 -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [
          Word8 -> Builder
putWord8 (Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
setBit (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i1) Int
7)
        , Word8 -> Builder
putWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i2)]
  , [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ((Track Int -> Builder) -> [Track Int] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map Track Int -> Builder
buildTrack ([Track Int] -> [Builder]) -> [Track Int] -> [Builder]
forall a b. (a -> b) -> a -> b
$ Midi -> [Track Int]
tracks Midi
m)]
  
parseTrack :: Parser (Track Ticks)
parseTrack :: Parser (Track Int)
parseTrack = do
  _ <- String -> Parser String
string String
"MTrk"
  _ <- getWord32be -- trackSize

  track' <- parseMessages Nothing
  return track'
 
buildTrack :: Track Ticks -> Builder
buildTrack :: Track Int -> Builder
buildTrack Track Int
trk = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [
    String -> Builder
putString String
"MTrk"
  , Word32 -> Builder
putWord32be (Word32 -> Builder) -> Word32 -> Builder
forall a b. (a -> b) -> a -> b
$ Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word32) -> Int64 -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
L.length ByteString
bs
  , ByteString -> Builder
fromLazyByteString ByteString
bs]
  where
  f :: (a, Message) -> Builder
f (a
dt,Message
msg) = (Word64 -> Builder
putVarLenBe (Word64 -> Builder) -> Word64 -> Builder
forall a b. (a -> b) -> a -> b
$ a -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
dt) Builder -> Builder -> Builder
`append` Message -> Builder
buildMessage Message
msg
  bs :: ByteString
bs = Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (((Int, Message) -> Builder) -> Track Int -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Message) -> Builder
forall {a}. Integral a => (a, Message) -> Builder
f Track Int
trk)

parseMessages :: Maybe Message -> Parser (Track Ticks)
parseMessages :: Maybe Message -> Parser (Track Int)
parseMessages Maybe Message
mPreMsg = do
  dt <- Parser Word64
getVarLenBe Parser Word64 -> (Word64 -> Parser Int) -> Parser Int
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Parser Int
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Parser Int) -> (Word64 -> Int) -> Word64 -> Parser Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  msg <- parseMessage mPreMsg
  if (isTrackEnd msg)
    then return [(dt,msg)]
    else do
      let mMsg = if Message -> Bool
isChannelMessage Message
msg then (Message -> Maybe Message
forall a. a -> Maybe a
Just Message
msg) else Maybe Message
mPreMsg
      msgs <- parseMessages mMsg
      return $! (dt,msg) : msgs

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

parseSMPTEOffset :: Parser Message
parseSMPTEOffset :: Parser Message
parseSMPTEOffset = do
  _ <- Word8 -> Parser Word8
word8 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 :: Parser Message
parseTimeSignature = do
  _ <- Word8 -> Parser Word8
word8 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 :: Parser Message
parseKeySignature = do
  _ <- Word8 -> Parser Word8
word8 Word8
0x59
  _ <- varLenBe 2
  n1 <- getInt8
  n2 <- getWord8
  return $! KeySignature (fromIntegral n1) (fromIntegral n2)

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

parseSysexMessage :: Parser Message
parseSysexMessage :: Parser Message
parseSysexMessage = do
  w <- (Word8 -> Parser Word8
word8 Word8
0xF0) Parser Word8 -> Parser Word8 -> Parser Word8
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Word8 -> Parser Word8
word8 Word8
0xF7)
  l <- getVarLenBe
  d <- getLazyByteString (fromIntegral l)
  return $! Sysex (fromIntegral w) d

buildSysexMessage :: Message -> Builder
buildSysexMessage :: Message -> Builder
buildSysexMessage (Sysex Int
i ByteString
bs) =
  [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ Word8 -> Builder
putWord8 (Word8 -> Builder) -> Word8 -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int
i
          , Word64 -> Builder
putVarLenBe (Word64 -> Builder) -> Word64 -> Builder
forall a b. (a -> b) -> a -> b
$ Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word64) -> Int64 -> Word64
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
L.length ByteString
bs
          , ByteString -> Builder
fromLazyByteString ByteString
bs]
buildSysexMessage Message
_ = Builder
forall a. Monoid a => a
mempty

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