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

-- |

-- 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
    FileType
ft <- Gen FileType
forall a. Arbitrary a => Gen a
arbitrary
    TimeDiv
td <- Gen TimeDiv
forall a. Arbitrary a => Gen a
arbitrary
    if FileType
ft FileType -> FileType -> Bool
forall a. Eq a => a -> a -> Bool
== FileType
SingleTrack
      then do
        Track Int
trk <- Gen (Track Int)
forall a. Arbitrary a => Gen a
arbitrary Gen (Track Int)
-> (Track Int -> Gen (Track Int)) -> Gen (Track Int)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Track Int -> Gen (Track Int)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Track Int -> Gen (Track Int))
-> (Track Int -> Track Int) -> Track Int -> Gen (Track Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track Int -> Track Int
fAux
        Midi -> Gen Midi
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Midi -> Gen Midi) -> Midi -> Gen Midi
forall a b. (a -> b) -> a -> b
$! FileType -> TimeDiv -> [Track Int] -> Midi
Midi FileType
ft TimeDiv
td [Track Int
trk]
      else do
        [Track Int]
trks <- Gen [Track Int]
forall a. Arbitrary a => Gen a
arbitrary Gen [Track Int]
-> ([Track Int] -> Gen [Track Int]) -> Gen [Track Int]
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Track Int] -> Gen [Track Int]
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Track Int] -> Gen [Track Int])
-> ([Track Int] -> [Track Int]) -> [Track Int] -> Gen [Track Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Track Int -> Track Int) -> [Track Int] -> [Track Int]
forall a b. (a -> b) -> [a] -> [b]
map Track Int -> Track Int
fAux
        Midi -> Gen Midi
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Midi -> Gen Midi) -> Midi -> Gen Midi
forall a b. (a -> b) -> a -> b
$! FileType -> TimeDiv -> [Track Int] -> Midi
Midi FileType
ft TimeDiv
td [Track Int]
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. [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. [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

    Int
c <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0,Int
15)
    [Gen Message] -> Gen Message
forall a. [Gen a] -> Gen a
oneof [
        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
0,Int
127))  Gen (Int, Int) -> ((Int, Int) -> Gen Message) -> Gen Message
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(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
      , 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
0,Int
127))  Gen (Int, Int) -> ((Int, Int) -> Gen Message) -> Gen Message
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(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
      , 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
0,Int
127))  Gen (Int, Int) -> ((Int, Int) -> Gen Message) -> Gen Message
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(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
      , 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
0,Int
127))  Gen (Int, Int) -> ((Int, Int) -> Gen Message) -> Gen Message
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(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
      , (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0,Int
127)        Gen Int -> (Int -> Gen Message) -> Gen Message
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \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
      , (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0,Int
127)        Gen Int -> (Int -> Gen Message) -> Gen Message
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \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 Int
p <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0,Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
14 :: Int) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
           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
PitchWheel Int
c Int
p
      -- Meta Messages

      , (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0,Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
16 :: Int) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Gen Int -> (Int -> Gen Message) -> Gen Message
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message -> Gen Message
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message) -> (Int -> Message) -> Int -> Gen Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Message
SequenceNumber
      , Gen String
forall a. Arbitrary a => Gen a
arbitrary Gen String -> (String -> Gen Message) -> Gen Message
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message -> Gen Message
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message)
-> (String -> Message) -> String -> Gen Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Message
Text
      , Gen String
forall a. Arbitrary a => Gen a
arbitrary Gen String -> (String -> Gen Message) -> Gen Message
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message -> Gen Message
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message)
-> (String -> Message) -> String -> Gen Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Message
Copyright
      , Gen String
forall a. Arbitrary a => Gen a
arbitrary Gen String -> (String -> Gen Message) -> Gen Message
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message -> Gen Message
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message)
-> (String -> Message) -> String -> Gen Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Message
TrackName
      , Gen String
forall a. Arbitrary a => Gen a
arbitrary Gen String -> (String -> Gen Message) -> Gen Message
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message -> Gen Message
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message)
-> (String -> Message) -> String -> Gen Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Message
InstrumentName
      , Gen String
forall a. Arbitrary a => Gen a
arbitrary Gen String -> (String -> Gen Message) -> Gen Message
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message -> Gen Message
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message)
-> (String -> Message) -> String -> Gen Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Message
Lyrics
      , Gen String
forall a. Arbitrary a => Gen a
arbitrary Gen String -> (String -> Gen Message) -> Gen Message
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message -> Gen Message
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message)
-> (String -> Message) -> String -> Gen Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Message
Marker
      , Gen String
forall a. Arbitrary a => Gen a
arbitrary Gen String -> (String -> Gen Message) -> Gen Message
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message -> Gen Message
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message)
-> (String -> Message) -> String -> Gen Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Message
CuePoint
      , 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 -> Message
ChannelPrefix Int
c
      , Gen String
forall a. Arbitrary a => Gen a
arbitrary Gen String -> (String -> Gen Message) -> Gen Message
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message -> Gen Message
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message)
-> (String -> Message) -> String -> Gen Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Message
ProgramName
      , Gen String
forall a. Arbitrary a => Gen a
arbitrary Gen String -> (String -> Gen Message) -> Gen Message
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message -> Gen Message
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message)
-> (String -> Message) -> String -> Gen Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Message
DeviceName
      , (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0,Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
14 :: Int) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Gen Int -> (Int -> Gen Message) -> Gen Message
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message -> Gen Message
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message) -> (Int -> Message) -> Int -> Gen Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Message
TempoChange
      , do Int
w1 <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0,Int
23)
           Int
w2 <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0,Int
59)
           Int
w3 <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0,Int
59)
           Int
w4 <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0,Int
30)
           Int
w5 <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0,Int
99)
           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 -> Int -> Int -> Message
SMPTEOffset Int
w1 Int
w2 Int
w3 Int
w4 Int
w5
      , do Int
w1 <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0,Int
255)
           Int
w2 <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0,Int
255)
           Int
w3 <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0,Int
255)
           Int
w4 <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1,Int
255)
           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 -> Int -> Message
TimeSignature Int
w1 Int
w2 Int
w3 Int
w4
      , do Int
w1 <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (-Int
7,Int
7)
           Int
w2 <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0,Int
1)
           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
KeySignature Int
w1 Int
w2
      , Gen ByteString
forall a. Arbitrary a => Gen a
arbitrary Gen ByteString -> (ByteString -> Gen Message) -> Gen Message
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \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 Int
w <- [Gen Int] -> Gen Int
forall a. [Gen a] -> Gen a
oneof [Int -> Gen Int
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0xF0, Int -> Gen Int
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0xF7]
           ByteString
bs <- Gen ByteString
forall a. Arbitrary a => Gen a
arbitrary
           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
Sysex Int
w ByteString
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
  ByteString
bs <- String -> IO ByteString
L.readFile String
f
  Either String Midi -> IO (Either String Midi)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Midi -> IO (Either String Midi))
-> Either String Midi -> IO (Either String Midi)
forall a b. (a -> b) -> a -> b
$! Parser Midi -> ByteString -> Either String Midi
forall a. Parser a -> ByteString -> Either String a
runParser Parser Midi
parseMidi ByteString
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
_ <- String -> Parser String
string String
"MThd"
  Word32
_ <- Word32 -> Parser Word32
word32be Word32
6
  Word16
formatType' <- Parser Word16
getWord16be
  Word16
trackNumber' <- Parser Word16
getWord16be
  Word16
timeDivision' <- Parser Word16
getWord16be
  let timeDivision :: TimeDiv
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 (Word16
formatType',Word16
trackNumber') of
    (Word16
0,Word16
1) -> do
      Track Int
track' <- Parser (Track Int)
parseTrack
      Midi -> Parser Midi
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Midi -> Parser Midi) -> Midi -> Parser Midi
forall a b. (a -> b) -> a -> b
$! FileType -> TimeDiv -> [Track Int] -> Midi
Midi FileType
SingleTrack TimeDiv
timeDivision [Track Int
track']
    (Word16
1,Word16
n) -> do
      [Track Int]
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
      Midi -> Parser Midi
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Midi -> Parser Midi) -> Midi -> Parser Midi
forall a b. (a -> b) -> a -> b
$! FileType -> TimeDiv -> [Track Int] -> Midi
Midi FileType
MultiTrack TimeDiv
timeDivision [Track Int]
tracks'
    (Word16
2,Word16
n) -> do
      [Track Int]
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
      Midi -> Parser Midi
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Midi -> Parser Midi) -> Midi -> Parser Midi
forall a b. (a -> b) -> a -> b
$! FileType -> TimeDiv -> [Track Int] -> Midi
Midi FileType
MultiPattern TimeDiv
timeDivision [Track Int]
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
_ <- String -> Parser String
string String
"MTrk"
  Word32
_ <- Parser Word32
getWord32be -- trackSize

  Track Int
track' <- Maybe Message -> Parser (Track Int)
parseMessages Maybe Message
forall a. Maybe a
Nothing
  Track Int -> Parser (Track Int)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Track Int
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
  Int
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
  Message
msg <- Maybe Message -> Parser Message
parseMessage Maybe Message
mPreMsg
  if (Message -> Bool
isTrackEnd Message
msg)
    then Track Int -> Parser (Track Int)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Int
dt,Message
msg)]
    else do
      let mMsg :: Maybe Message
mMsg = if Message -> Bool
isChannelMessage Message
msg then (Message -> Maybe Message
forall a. a -> Maybe a
Just Message
msg) else Maybe Message
mPreMsg
      Track Int
msgs <- Maybe Message -> Parser (Track Int)
parseMessages Maybe Message
mMsg
      Track Int -> Parser (Track Int)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Track Int -> Parser (Track Int))
-> Track Int -> Parser (Track Int)
forall a b. (a -> b) -> a -> b
$! (Int
dt,Message
msg) (Int, Message) -> Track Int -> Track Int
forall a. a -> [a] -> [a]
: Track Int
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
    Word8
_ <- 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))
    Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Parser ()) -> Bool -> Parser ()
forall a b. (a -> b) -> a -> b
$ (Maybe Message -> Bool
forall a. Maybe a -> Bool
isJust Maybe Message
mPreMsg) Bool -> Bool -> Bool
&& (Message -> Bool
isNeededMsg (Message -> Bool) -> Message -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe Message -> Message
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Message
mPreMsg)
    Int -> Parser Int
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Parser Int) -> Int -> Parser Int
forall a b. (a -> b) -> a -> b
$! Message -> Int
channel (Maybe Message -> Message
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Message
mPreMsg)
  p2 :: Parser Int
p2 = do
    Word8
w8 <- Parser Word8
getWord8
    Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Word8
msgCode Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
shiftR Word8
w8 Int
4)
    Int -> Parser Int
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Parser Int) -> Int -> Parser Int
forall a b. (a -> b) -> a -> b
$! Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ Word8
w8 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. (Word8
0x0F :: Word8)

parseNoteOff :: Maybe Message -> Parser Message
parseNoteOff :: Maybe Message -> Parser Message
parseNoteOff Maybe Message
mPreMsg = do
  Int
ch <- Maybe Message -> (Message -> Bool) -> Word8 -> Parser Int
parseChannel Maybe Message
mPreMsg Message -> Bool
isNoteOff Word8
0x08
  Word8
p1 <- Parser Word8
getWord8
  Word8
p2 <- Parser Word8
getWord8
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Int -> Int -> Int -> Message
NoteOff Int
ch (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
p1) (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
p2)

parseNoteOn :: Maybe Message -> Parser Message
parseNoteOn :: Maybe Message -> Parser Message
parseNoteOn Maybe Message
mPreMsg = do
  Int
ch <- Maybe Message -> (Message -> Bool) -> Word8 -> Parser Int
parseChannel Maybe Message
mPreMsg Message -> Bool
isNoteOn Word8
0x09
  Word8
p1 <- Parser Word8
getWord8
  Word8
p2 <- Parser Word8
getWord8
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Int -> Int -> Int -> Message
NoteOn Int
ch (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
p1) (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
p2)

parseKeyPressure :: Maybe Message -> Parser Message
parseKeyPressure :: Maybe Message -> Parser Message
parseKeyPressure Maybe Message
mPreMsg = do
  Int
ch <- Maybe Message -> (Message -> Bool) -> Word8 -> Parser Int
parseChannel Maybe Message
mPreMsg Message -> Bool
isKeyPressure Word8
0x0A
  Word8
p1 <- Parser Word8
getWord8
  Word8
p2 <- Parser Word8
getWord8
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Int -> Int -> Int -> Message
KeyPressure Int
ch (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
p1) (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
p2)

parseControlChange :: Maybe Message -> Parser Message
parseControlChange :: Maybe Message -> Parser Message
parseControlChange Maybe Message
mPreMsg = do
  Int
ch <- Maybe Message -> (Message -> Bool) -> Word8 -> Parser Int
parseChannel Maybe Message
mPreMsg Message -> Bool
isControlChange Word8
0x0B
  Word8
p1 <- Parser Word8
getWord8
  Word8
p2 <- Parser Word8
getWord8
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Int -> Int -> Int -> Message
ControlChange Int
ch (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
p1) (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
p2)

parseProgramChange :: Maybe Message -> Parser Message
parseProgramChange :: Maybe Message -> Parser Message
parseProgramChange Maybe Message
mPreMsg = do
  Int
ch <- Maybe Message -> (Message -> Bool) -> Word8 -> Parser Int
parseChannel Maybe Message
mPreMsg Message -> Bool
isProgramChange Word8
0x0C
  Word8
p1 <- Parser Word8
getWord8
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Int -> Int -> Message
ProgramChange Int
ch (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
p1)

parseChannelPressure :: Maybe Message -> Parser Message
parseChannelPressure :: Maybe Message -> Parser Message
parseChannelPressure Maybe Message
mPreMsg = do
  Int
ch <- Maybe Message -> (Message -> Bool) -> Word8 -> Parser Int
parseChannel Maybe Message
mPreMsg Message -> Bool
isChannelPressure Word8
0x0D
  Word8
p1 <- Parser Word8
getWord8
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Int -> Int -> Message
ChannelPressure Int
ch (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
p1)
  
parsePitchWheel :: Maybe Message -> Parser Message
parsePitchWheel :: Maybe Message -> Parser Message
parsePitchWheel Maybe Message
mPreMsg = do
  Int
ch <- Maybe Message -> (Message -> Bool) -> Word8 -> Parser Int
parseChannel Maybe Message
mPreMsg Message -> Bool
isPitchWheel Word8
0x0E
  Word8
p1 <- Parser Word8
getWord8
  Word8
p2 <- Parser Word8
getWord8
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Int -> Int -> Message
PitchWheel Int
ch (Int -> Message) -> Int -> Message
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftL (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
p2) Int
7) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
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
_ <- Word8 -> Parser Word8
word8 Word8
0xFF
  [Parser Message] -> Parser Message
forall a. [Parser a] -> Parser a
choice [
      Parser Message
parseSequenceNumber
    , Parser Message
parseText
    , Parser Message
parseCopyright
    , Parser Message
parseTrackName
    , Parser Message
parseInstrumentName
    , Parser Message
parseLyrics
    , Parser Message
parseMarker
    , Parser Message
parseCuePoint
    , Parser Message
parseChannelPrefix
    , Parser Message
parseProgramName
    , Parser Message
parseDeviceName
    , Parser Message
parseTrackEnd
    , Parser Message
parseTempoChange
    , Parser Message
parseSMPTEOffset
    , Parser Message
parseTimeSignature
    , Parser Message
parseKeySignature
    , Parser Message
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
_ <- Word8 -> Parser Word8
word8 Word8
0x00
  Word64
_ <- Word64 -> Parser Word64
varLenBe Word64
2
  Word16
n <- Parser Word16
getWord16be
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Int -> Message
SequenceNumber (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
n)

parseText :: Parser Message
parseText :: Parser Message
parseText = do
  Word8
_ <- Word8 -> Parser Word8
word8 Word8
0x01
  Word64
l <- Parser Word64
getVarLenBe
  String
s <- Int -> Parser String
getString (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
l)
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! String -> Message
Text String
s

parseCopyright :: Parser Message
parseCopyright :: Parser Message
parseCopyright = do
  Word8
_ <- Word8 -> Parser Word8
word8 Word8
0x02
  Word64
l <- Parser Word64
getVarLenBe
  String
s <- Int -> Parser String
getString (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
l)
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! String -> Message
Copyright String
s

parseTrackName :: Parser Message
parseTrackName :: Parser Message
parseTrackName = do
  Word8
_ <- Word8 -> Parser Word8
word8 Word8
0x03
  Word64
l <- Parser Word64
getVarLenBe
  String
s <- Int -> Parser String
getString (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
l)
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! String -> Message
TrackName String
s

parseInstrumentName :: Parser Message
parseInstrumentName :: Parser Message
parseInstrumentName = do
  Word8
_ <- Word8 -> Parser Word8
word8 Word8
0x04
  Word64
l <- Parser Word64
getVarLenBe
  String
s <- Int -> Parser String
getString (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
l)
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! String -> Message
InstrumentName String
s

parseLyrics :: Parser Message
parseLyrics :: Parser Message
parseLyrics = do
  Word8
_ <- Word8 -> Parser Word8
word8 Word8
0x05
  Word64
l <- Parser Word64
getVarLenBe
  String
s <- Int -> Parser String
getString (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
l)
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! String -> Message
Lyrics String
s

parseMarker :: Parser Message
parseMarker :: Parser Message
parseMarker = do
  Word8
_ <- Word8 -> Parser Word8
word8 Word8
0x06
  Word64
l <- Parser Word64
getVarLenBe
  String
s <- Int -> Parser String
getString (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
l)
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! String -> Message
Marker String
s

parseCuePoint :: Parser Message
parseCuePoint :: Parser Message
parseCuePoint = do
  Word8
_ <- Word8 -> Parser Word8
word8 Word8
0x07
  Word64
l <- Parser Word64
getVarLenBe
  String
s <- Int -> Parser String
getString (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
l)
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! String -> Message
CuePoint String
s

parseProgramName :: Parser Message
parseProgramName :: Parser Message
parseProgramName = do
  Word8
_ <- Word8 -> Parser Word8
word8 Word8
0x08
  Word64
l <- Parser Word64
getVarLenBe
  String
s <- Int -> Parser String
getString (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
l)
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! String -> Message
ProgramName String
s

parseDeviceName :: Parser Message
parseDeviceName :: Parser Message
parseDeviceName = do
  Word8
_ <- Word8 -> Parser Word8
word8 Word8
0x09
  Word64
l <- Parser Word64
getVarLenBe
  String
s <- Int -> Parser String
getString (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
l)
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! String -> Message
DeviceName String
s

parseChannelPrefix :: Parser Message
parseChannelPrefix :: Parser Message
parseChannelPrefix = do
  Word8
_ <- Word8 -> Parser Word8
word8 Word8
0x20
  Word64
_ <- Word64 -> Parser Word64
varLenBe Word64
1
  Word8
p <- Parser Word8
getWord8
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Int -> Message
ChannelPrefix (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
p)

parseTrackEnd :: Parser Message
parseTrackEnd :: Parser Message
parseTrackEnd =  do
  Word8
_ <- Word8 -> Parser Word8
word8 Word8
0x2F
  Word64
_ <- Word64 -> Parser Word64
varLenBe Word64
0
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Message
TrackEnd

parseTempoChange :: Parser Message
parseTempoChange :: Parser Message
parseTempoChange = do
  Word8
_ <- Word8 -> Parser Word8
word8 Word8
0x51
  Word64
_ <- Word64 -> Parser Word64
varLenBe Word64
3
  Word32
t <- Parser Word32
getWord24be
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Int -> Message
TempoChange (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
t)

parseSMPTEOffset :: Parser Message
parseSMPTEOffset :: Parser Message
parseSMPTEOffset = do
  Word8
_ <- Word8 -> Parser Word8
word8 Word8
0x54
  Word64
_ <- Word64 -> Parser Word64
varLenBe Word64
5
  ByteString
bs <- Int64 -> Parser ByteString
getLazyByteString Int64
5
  let [Int
n1,Int
n2,Int
n3,Int
n4,Int
n5] = (Word8 -> Int) -> [Word8] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> [Word8]
L.unpack ByteString
bs)
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Int -> Int -> Int -> Int -> Int -> Message
SMPTEOffset Int
n1 Int
n2 Int
n3 Int
n4 Int
n5

parseTimeSignature :: Parser Message
parseTimeSignature :: Parser Message
parseTimeSignature = do
  Word8
_ <- Word8 -> Parser Word8
word8 Word8
0x58
  Word64
_ <- Word64 -> Parser Word64
varLenBe Word64
4
  ByteString
bs <- Int64 -> Parser ByteString
getLazyByteString Int64
4
  let [Int
n1,Int
n2,Int
n3,Int
n4] = (Word8 -> Int) -> [Word8] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> [Word8]
L.unpack ByteString
bs)
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Int -> Int -> Int -> Int -> Message
TimeSignature Int
n1 Int
n2 Int
n3 Int
n4

parseKeySignature :: Parser Message
parseKeySignature :: Parser Message
parseKeySignature = do
  Word8
_ <- Word8 -> Parser Word8
word8 Word8
0x59
  Word64
_ <- Word64 -> Parser Word64
varLenBe Word64
2
  Int8
n1 <- Parser Int8
getInt8
  Word8
n2 <- Parser Word8
getWord8
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Int -> Int -> Message
KeySignature (Int8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
n1) (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n2)

parseReserved :: Parser Message
parseReserved :: Parser Message
parseReserved = do
  Word8
t <- Parser Word8
getWord8
  Word64
l <- Parser Word64
getVarLenBe
  ByteString
bs <- Int64 -> Parser ByteString
getLazyByteString (Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
l)
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Int -> ByteString -> Message
Reserved (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
t)  ByteString
bs

parseSysexMessage :: Parser Message
parseSysexMessage :: Parser Message
parseSysexMessage = do
  Word8
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)
  Word64
l <- Parser Word64
getVarLenBe
  ByteString
d <- Int64 -> Parser ByteString
getLazyByteString (Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
l)
  Message -> Parser Message
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Int -> ByteString -> Message
Sysex (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w) ByteString
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