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

-- |

-- 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 Ticks]
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
/= :: Midi -> Midi -> Bool
$c/= :: Midi -> Midi -> Bool
== :: Midi -> Midi -> Bool
$c== :: Midi -> Midi -> Bool
Eq, Ticks -> Midi -> ShowS
[Midi] -> ShowS
Midi -> String
(Ticks -> Midi -> ShowS)
-> (Midi -> String) -> ([Midi] -> ShowS) -> Show Midi
forall a.
(Ticks -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Midi] -> ShowS
$cshowList :: [Midi] -> ShowS
show :: Midi -> String
$cshow :: Midi -> String
showsPrec :: Ticks -> Midi -> ShowS
$cshowsPrec :: Ticks -> 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 Ticks
trk <- Gen (Track Ticks)
forall a. Arbitrary a => Gen a
arbitrary Gen (Track Ticks)
-> (Track Ticks -> Gen (Track Ticks)) -> Gen (Track Ticks)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Track Ticks -> Gen (Track Ticks)
forall (m :: * -> *) a. Monad m => a -> m a
return (Track Ticks -> Gen (Track Ticks))
-> (Track Ticks -> Track Ticks) -> Track Ticks -> Gen (Track Ticks)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track Ticks -> Track Ticks
fAux
        Midi -> Gen Midi
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 Ticks] -> Midi
Midi FileType
ft TimeDiv
td [Track Ticks
trk]
      else do
        [Track Ticks]
trks <- Gen [Track Ticks]
forall a. Arbitrary a => Gen a
arbitrary Gen [Track Ticks]
-> ([Track Ticks] -> Gen [Track Ticks]) -> Gen [Track Ticks]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Track Ticks] -> Gen [Track Ticks]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Track Ticks] -> Gen [Track Ticks])
-> ([Track Ticks] -> [Track Ticks])
-> [Track Ticks]
-> Gen [Track Ticks]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Track Ticks -> Track Ticks) -> [Track Ticks] -> [Track Ticks]
forall a b. (a -> b) -> [a] -> [b]
map Track Ticks -> Track Ticks
fAux
        Midi -> Gen Midi
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 Ticks] -> Midi
Midi FileType
ft TimeDiv
td [Track Ticks]
trks
    where
    fAux :: Track Ticks -> Track Ticks
fAux = (Track Ticks -> Track Ticks -> Track Ticks
forall a. [a] -> [a] -> [a]
++ [(Ticks
0,Message
TrackEnd)]) (Track Ticks -> Track Ticks)
-> (Track Ticks -> Track Ticks) -> Track Ticks -> Track Ticks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Ticks, Message) -> (Ticks, Message))
-> Track Ticks -> Track Ticks
forall a b. (a -> b) -> [a] -> [b]
map (\(Ticks
dt,Message
m) -> (Ticks -> Ticks
forall a. Num a => a -> a
abs Ticks
dt,Message
m)) (Track Ticks -> Track Ticks)
-> (Track Ticks -> Track Ticks) -> Track Ticks -> Track Ticks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track Ticks -> Track Ticks
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
/= :: FileType -> FileType -> Bool
$c/= :: FileType -> FileType -> Bool
== :: FileType -> FileType -> Bool
$c== :: FileType -> FileType -> Bool
Eq, Ticks -> FileType -> ShowS
[FileType] -> ShowS
FileType -> String
(Ticks -> FileType -> ShowS)
-> (FileType -> String) -> ([FileType] -> ShowS) -> Show FileType
forall a.
(Ticks -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FileType] -> ShowS
$cshowList :: [FileType] -> ShowS
show :: FileType -> String
$cshow :: FileType -> String
showsPrec :: Ticks -> FileType -> ShowS
$cshowsPrec :: Ticks -> 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 (m :: * -> *) a. Monad m => a -> m a
return FileType
SingleTrack , FileType -> Gen FileType
forall (m :: * -> *) a. Monad m => a -> m a
return FileType
MultiTrack , FileType -> Gen FileType
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 (Ticks -> TimeDiv -> ShowS
[TimeDiv] -> ShowS
TimeDiv -> String
(Ticks -> TimeDiv -> ShowS)
-> (TimeDiv -> String) -> ([TimeDiv] -> ShowS) -> Show TimeDiv
forall a.
(Ticks -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimeDiv] -> ShowS
$cshowList :: [TimeDiv] -> ShowS
show :: TimeDiv -> String
$cshow :: TimeDiv -> String
showsPrec :: Ticks -> TimeDiv -> ShowS
$cshowsPrec :: Ticks -> TimeDiv -> ShowS
Show,TimeDiv -> TimeDiv -> Bool
(TimeDiv -> TimeDiv -> Bool)
-> (TimeDiv -> TimeDiv -> Bool) -> Eq TimeDiv
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimeDiv -> TimeDiv -> Bool
$c/= :: TimeDiv -> TimeDiv -> Bool
== :: TimeDiv -> TimeDiv -> Bool
$c== :: TimeDiv -> TimeDiv -> Bool
Eq)

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

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

    Ticks
c <- (Ticks, Ticks) -> Gen Ticks
forall a. Random a => (a, a) -> Gen a
choose (Ticks
0,Ticks
15)
    [Gen Message] -> Gen Message
forall a. [Gen a] -> Gen a
oneof [
        Gen Ticks -> Gen (Ticks, Ticks)
forall (f :: * -> *) a. Applicative f => f a -> f (a, a)
two ((Ticks, Ticks) -> Gen Ticks
forall a. Random a => (a, a) -> Gen a
choose (Ticks
0,Ticks
127))  Gen (Ticks, Ticks)
-> ((Ticks, Ticks) -> Gen Message) -> Gen Message
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Ticks
w2,Ticks
w3) -> Message -> Gen Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message) -> Message -> Gen Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Ticks -> Ticks -> Message
NoteOff Ticks
c Ticks
w2 Ticks
w3
      , Gen Ticks -> Gen (Ticks, Ticks)
forall (f :: * -> *) a. Applicative f => f a -> f (a, a)
two ((Ticks, Ticks) -> Gen Ticks
forall a. Random a => (a, a) -> Gen a
choose (Ticks
0,Ticks
127))  Gen (Ticks, Ticks)
-> ((Ticks, Ticks) -> Gen Message) -> Gen Message
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Ticks
w2,Ticks
w3) -> Message -> Gen Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message) -> Message -> Gen Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Ticks -> Ticks -> Message
NoteOn Ticks
c Ticks
w2 Ticks
w3
      , Gen Ticks -> Gen (Ticks, Ticks)
forall (f :: * -> *) a. Applicative f => f a -> f (a, a)
two ((Ticks, Ticks) -> Gen Ticks
forall a. Random a => (a, a) -> Gen a
choose (Ticks
0,Ticks
127))  Gen (Ticks, Ticks)
-> ((Ticks, Ticks) -> Gen Message) -> Gen Message
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Ticks
w2,Ticks
w3) -> Message -> Gen Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message) -> Message -> Gen Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Ticks -> Ticks -> Message
KeyPressure Ticks
c Ticks
w2 Ticks
w3
      , Gen Ticks -> Gen (Ticks, Ticks)
forall (f :: * -> *) a. Applicative f => f a -> f (a, a)
two ((Ticks, Ticks) -> Gen Ticks
forall a. Random a => (a, a) -> Gen a
choose (Ticks
0,Ticks
127))  Gen (Ticks, Ticks)
-> ((Ticks, Ticks) -> Gen Message) -> Gen Message
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Ticks
w2,Ticks
w3) -> Message -> Gen Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message) -> Message -> Gen Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Ticks -> Ticks -> Message
ControlChange Ticks
c Ticks
w2 Ticks
w3
      , (Ticks, Ticks) -> Gen Ticks
forall a. Random a => (a, a) -> Gen a
choose (Ticks
0,Ticks
127)        Gen Ticks -> (Ticks -> Gen Message) -> Gen Message
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Ticks
w2      -> Message -> Gen Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message) -> Message -> Gen Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Ticks -> Message
ProgramChange Ticks
c Ticks
w2
      , (Ticks, Ticks) -> Gen Ticks
forall a. Random a => (a, a) -> Gen a
choose (Ticks
0,Ticks
127)        Gen Ticks -> (Ticks -> Gen Message) -> Gen Message
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Ticks
w2      -> Message -> Gen Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message) -> Message -> Gen Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Ticks -> Message
ChannelPressure Ticks
c Ticks
w2
      , do Ticks
p <- (Ticks, Ticks) -> Gen Ticks
forall a. Random a => (a, a) -> Gen a
choose (Ticks
0,Ticks
2 Ticks -> Ticks -> Ticks
forall a b. (Num a, Integral b) => a -> b -> a
^ (Ticks
14 :: Int) Ticks -> Ticks -> Ticks
forall a. Num a => a -> a -> a
- Ticks
1)
           Message -> Gen Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message) -> Message -> Gen Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Ticks -> Message
PitchWheel Ticks
c Ticks
p
      -- Meta Messages

      , (Ticks, Ticks) -> Gen Ticks
forall a. Random a => (a, a) -> Gen a
choose (Ticks
0,Ticks
2 Ticks -> Ticks -> Ticks
forall a b. (Num a, Integral b) => a -> b -> a
^ (Ticks
16 :: Int) Ticks -> Ticks -> Ticks
forall a. Num a => a -> a -> a
- Ticks
1) Gen Ticks -> (Ticks -> Gen Message) -> Gen Message
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message -> Gen Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message)
-> (Ticks -> Message) -> Ticks -> Gen Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticks -> Message
SequenceNumber
      , Gen String
forall a. Arbitrary a => Gen a
arbitrary Gen String -> (String -> Gen Message) -> Gen Message
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message -> Gen Message
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message -> Gen Message
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message -> Gen Message
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message -> Gen Message
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message -> Gen Message
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message -> Gen Message
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message -> Gen Message
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 (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message) -> Message -> Gen Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Message
ChannelPrefix Ticks
c
      , Gen String
forall a. Arbitrary a => Gen a
arbitrary Gen String -> (String -> Gen Message) -> Gen Message
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message -> Gen Message
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message -> Gen Message
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
      , (Ticks, Ticks) -> Gen Ticks
forall a. Random a => (a, a) -> Gen a
choose (Ticks
0,Ticks
2 Ticks -> Ticks -> Ticks
forall a b. (Num a, Integral b) => a -> b -> a
^ (Ticks
14 :: Int) Ticks -> Ticks -> Ticks
forall a. Num a => a -> a -> a
- Ticks
1) Gen Ticks -> (Ticks -> Gen Message) -> Gen Message
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message -> Gen Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message)
-> (Ticks -> Message) -> Ticks -> Gen Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticks -> Message
TempoChange
      , do Ticks
w1 <- (Ticks, Ticks) -> Gen Ticks
forall a. Random a => (a, a) -> Gen a
choose (Ticks
0,Ticks
23)
           Ticks
w2 <- (Ticks, Ticks) -> Gen Ticks
forall a. Random a => (a, a) -> Gen a
choose (Ticks
0,Ticks
59)
           Ticks
w3 <- (Ticks, Ticks) -> Gen Ticks
forall a. Random a => (a, a) -> Gen a
choose (Ticks
0,Ticks
59)
           Ticks
w4 <- (Ticks, Ticks) -> Gen Ticks
forall a. Random a => (a, a) -> Gen a
choose (Ticks
0,Ticks
30)
           Ticks
w5 <- (Ticks, Ticks) -> Gen Ticks
forall a. Random a => (a, a) -> Gen a
choose (Ticks
0,Ticks
99)
           Message -> Gen Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message) -> Message -> Gen Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Ticks -> Ticks -> Ticks -> Ticks -> Message
SMPTEOffset Ticks
w1 Ticks
w2 Ticks
w3 Ticks
w4 Ticks
w5
      , do Ticks
w1 <- (Ticks, Ticks) -> Gen Ticks
forall a. Random a => (a, a) -> Gen a
choose (Ticks
0,Ticks
255)
           Ticks
w2 <- (Ticks, Ticks) -> Gen Ticks
forall a. Random a => (a, a) -> Gen a
choose (Ticks
0,Ticks
255)
           Ticks
w3 <- (Ticks, Ticks) -> Gen Ticks
forall a. Random a => (a, a) -> Gen a
choose (Ticks
0,Ticks
255)
           Ticks
w4 <- (Ticks, Ticks) -> Gen Ticks
forall a. Random a => (a, a) -> Gen a
choose (Ticks
1,Ticks
255)
           Message -> Gen Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message) -> Message -> Gen Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Ticks -> Ticks -> Ticks -> Message
TimeSignature Ticks
w1 Ticks
w2 Ticks
w3 Ticks
w4
      , do Ticks
w1 <- (Ticks, Ticks) -> Gen Ticks
forall a. Random a => (a, a) -> Gen a
choose (-Ticks
7,Ticks
7)
           Ticks
w2 <- (Ticks, Ticks) -> Gen Ticks
forall a. Random a => (a, a) -> Gen a
choose (Ticks
0,Ticks
1)
           Message -> Gen Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message) -> Message -> Gen Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Ticks -> Message
KeySignature Ticks
w1 Ticks
w2
      , Gen ByteString
forall a. Arbitrary a => Gen a
arbitrary Gen ByteString -> (ByteString -> Gen Message) -> Gen Message
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ByteString
bs -> Message -> Gen Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message) -> Message -> Gen Message
forall a b. (a -> b) -> a -> b
$! Ticks -> ByteString -> Message
Reserved Ticks
0x60 ByteString
bs
      -- System Exclusive Messages

      , do Ticks
w <- [Gen Ticks] -> Gen Ticks
forall a. [Gen a] -> Gen a
oneof [Ticks -> Gen Ticks
forall (m :: * -> *) a. Monad m => a -> m a
return Ticks
0xF0, Ticks -> Gen Ticks
forall (m :: * -> *) a. Monad m => a -> m a
return Ticks
0xF7]
           ByteString
bs <- Gen ByteString
forall a. Arbitrary a => Gen a
arbitrary
           Message -> Gen Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Gen Message) -> Message -> Gen Message
forall a b. (a -> b) -> a -> b
$! Ticks -> ByteString -> Message
Sysex Ticks
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 Ticks
_ ByteString
_) = Bool
True
isSysexMessage Message
_ = Bool
False

isMetaMessage :: Message -> Bool
isMetaMessage :: Message -> Bool
isMetaMessage Message
msg = case Message
msg of
  SequenceNumber Ticks
_ -> 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 Ticks
_ -> Bool
True
  ProgramName String
_ -> Bool
True
  DeviceName String
_ -> Bool
True
  Message
TrackEnd -> Bool
True
  TempoChange Ticks
_ -> Bool
True
  SMPTEOffset Ticks
_ Ticks
_ Ticks
_ Ticks
_ Ticks
_ -> Bool
True
  TimeSignature Ticks
_ Ticks
_ Ticks
_ Ticks
_ -> Bool
True
  KeySignature Ticks
_ Ticks
_ -> Bool
True
  Reserved Ticks
_ 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 :: Track a -> Track a
removeTrackEnds [] = []
removeTrackEnds Track a
trk = ((a, Message) -> Bool) -> Track a -> Track a
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) Track a
trk

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

merge :: (Num a, Ord a) => Track a -> Track a -> Track a
merge :: 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 :: 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 :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
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 :: 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 :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
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 Ticks -> Track Time
toRealTime (TicksPerBeat Ticks
tpb) Track Ticks
trk = Track Time
trk'
  where
  (Ticks
_,Track Time
trk') = (Ticks -> (Ticks, Message) -> (Ticks, (Time, Message)))
-> Ticks -> Track Ticks -> (Ticks, Track Time)
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL Ticks -> (Ticks, Message) -> (Ticks, (Time, Message))
f (Ticks -> Ticks -> Ticks
forall a. Integral a => a -> a -> a
div Ticks
60000000 Ticks
120) Track Ticks
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
/ Ticks -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Ticks
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 :: Ticks -> (Ticks, Message) -> (Ticks, (Time, Message))
f Ticks
_ (Ticks
dt, TempoChange Ticks
tempo) = (Ticks
tempo, (Ticks -> Ticks -> Time
forall a a a. (Fractional a, Integral a, Integral a) => a -> a -> a
formula Ticks
dt Ticks
tempo, Ticks -> Message
TempoChange Ticks
tempo))
  f Ticks
tempo (Ticks
dt,Message
msg) = (Ticks
tempo, (Ticks -> Ticks -> Time
forall a a a. (Fractional a, Integral a, Integral a) => a -> a -> a
formula Ticks
dt Ticks
tempo,Message
msg))
toRealTime (TicksPerSecond Ticks
fps Ticks
tpf) Track Ticks
trk = ((Ticks, Message) -> (Time, Message)) -> Track Ticks -> Track Time
forall a b. (a -> b) -> [a] -> [b]
map (Ticks, Message) -> (Time, Message)
forall a a b. (Fractional a, Integral a) => (a, b) -> (a, b)
f Track Ticks
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
/ (Ticks -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Ticks
fps a -> a -> a
forall a. Num a => a -> a -> a
* Ticks -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Ticks
tpf), b
msg)

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

  formula :: a -> a -> b
formula a
dt a
tempo = 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
* Ticks -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Ticks
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 :: Ticks -> (Time, Message) -> (Ticks, (Ticks, Message))
f Ticks
_ (Time
dt, TempoChange Ticks
tempo) = (Ticks
tempo, (Time -> Ticks -> Ticks
forall a b a. (RealFrac a, Integral b, Integral a) => a -> a -> b
formula Time
dt Ticks
tempo, Ticks -> Message
TempoChange Ticks
tempo))
  f Ticks
tempo (Time
dt,Message
msg) = (Ticks
tempo, (Time -> Ticks -> Ticks
forall a b a. (RealFrac a, Integral b, Integral a) => a -> a -> b
formula Time
dt Ticks
tempo,Message
msg))
fromRealTime (TicksPerSecond Ticks
fps Ticks
tpf) Track Time
trk = ((Time, Message) -> (Ticks, Message)) -> Track Time -> Track Ticks
forall a b. (a -> b) -> [a] -> [b]
map (Time, Message) -> (Ticks, 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 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
* Ticks -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Ticks
fps a -> a -> a
forall a. Num a => a -> a -> a
* Ticks -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Ticks
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 (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 -> Ticks -> Bool
forall a. Bits a => a -> Ticks -> Bool
testBit Word16
timeDivision' Ticks
15
        then Ticks -> Ticks -> TimeDiv
TicksPerSecond
               (Word16 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Ticks) -> Word16 -> Ticks
forall a b. (a -> b) -> a -> b
$ ((Word16 -> Ticks -> Word16) -> Ticks -> Word16 -> Word16
forall a b c. (a -> b -> c) -> b -> a -> c
flip Word16 -> Ticks -> Word16
forall a. Bits a => a -> Ticks -> a
shiftR) Ticks
9  (Word16 -> Word16) -> Word16 -> Word16
forall a b. (a -> b) -> a -> b
$ Word16 -> Ticks -> Word16
forall a. Bits a => a -> Ticks -> a
shiftL Word16
timeDivision' Ticks
1)
               (Word16 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Ticks) -> Word16 -> Ticks
forall a b. (a -> b) -> a -> b
$ ((Word16 -> Ticks -> Word16) -> Ticks -> Word16 -> Word16
forall a b c. (a -> b -> c) -> b -> a -> c
flip Word16 -> Ticks -> Word16
forall a. Bits a => a -> Ticks -> a
shiftR) Ticks
8  (Word16 -> Word16) -> Word16 -> Word16
forall a b. (a -> b) -> a -> b
$ Word16 -> Ticks -> Word16
forall a. Bits a => a -> Ticks -> a
shiftL Word16
timeDivision' Ticks
8)
        else Ticks -> TimeDiv
TicksPerBeat (Word16 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
timeDivision')
  case (Word16
formatType',Word16
trackNumber') of
    (Word16
0,Word16
1) -> do
      Track Ticks
track' <- Parser (Track Ticks)
parseTrack
      Midi -> Parser Midi
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 Ticks] -> Midi
Midi FileType
SingleTrack TimeDiv
timeDivision [Track Ticks
track']
    (Word16
1,Word16
n) -> do
      [Track Ticks]
tracks' <- [Parser (Track Ticks)] -> Parser [Track Ticks]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Parser (Track Ticks)] -> Parser [Track Ticks])
-> [Parser (Track Ticks)] -> Parser [Track Ticks]
forall a b. (a -> b) -> a -> b
$ Ticks -> Parser (Track Ticks) -> [Parser (Track Ticks)]
forall a. Ticks -> a -> [a]
replicate (Word16 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
n) Parser (Track Ticks)
parseTrack
      Midi -> Parser Midi
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 Ticks] -> Midi
Midi FileType
MultiTrack TimeDiv
timeDivision [Track Ticks]
tracks'
    (Word16
2,Word16
n) -> do
      [Track Ticks]
tracks' <- [Parser (Track Ticks)] -> Parser [Track Ticks]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Parser (Track Ticks)] -> Parser [Track Ticks])
-> [Parser (Track Ticks)] -> Parser [Track Ticks]
forall a b. (a -> b) -> a -> b
$ Ticks -> Parser (Track Ticks) -> [Parser (Track Ticks)]
forall a. Ticks -> a -> [a]
replicate (Word16 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
n) Parser (Track Ticks)
parseTrack
      Midi -> Parser Midi
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 Ticks] -> Midi
Midi FileType
MultiPattern TimeDiv
timeDivision [Track Ticks]
tracks'
    (Word16, Word16)
_ -> String -> Parser Midi
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 (Ticks -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word16) -> Ticks -> Word16
forall a b. (a -> b) -> a -> b
$ [Track Ticks] -> Ticks
forall (t :: * -> *) a. Foldable t => t a -> Ticks
length ([Track Ticks] -> Ticks) -> [Track Ticks] -> Ticks
forall a b. (a -> b) -> a -> b
$ Midi -> [Track Ticks]
tracks Midi
m)
  , case Midi -> TimeDiv
timeDiv Midi
m of
      TicksPerBeat Ticks
i -> Word16 -> Builder
putWord16be (Ticks -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Ticks
i)
      TicksPerSecond Ticks
i1 Ticks
i2 -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [
          Word8 -> Builder
putWord8 (Word8 -> Ticks -> Word8
forall a. Bits a => a -> Ticks -> a
setBit (Ticks -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Ticks
i1) Ticks
7)
        , Word8 -> Builder
putWord8 (Ticks -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Ticks
i2)]
  , [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ((Track Ticks -> Builder) -> [Track Ticks] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map Track Ticks -> Builder
buildTrack ([Track Ticks] -> [Builder]) -> [Track Ticks] -> [Builder]
forall a b. (a -> b) -> a -> b
$ Midi -> [Track Ticks]
tracks Midi
m)]
  
parseTrack :: Parser (Track Ticks)
parseTrack :: Parser (Track Ticks)
parseTrack = do
  String
_ <- String -> Parser String
string String
"MTrk"
  Word32
_ <- Parser Word32
getWord32be -- trackSize

  Track Ticks
track' <- Maybe Message -> Parser (Track Ticks)
parseMessages Maybe Message
forall a. Maybe a
Nothing
  Track Ticks -> Parser (Track Ticks)
forall (m :: * -> *) a. Monad m => a -> m a
return Track Ticks
track'
 
buildTrack :: Track Ticks -> Builder
buildTrack :: Track Ticks -> Builder
buildTrack Track Ticks
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 (((Ticks, Message) -> Builder) -> Track Ticks -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Ticks, Message) -> Builder
forall a. Integral a => (a, Message) -> Builder
f Track Ticks
trk)

parseMessages :: Maybe Message -> Parser (Track Ticks)
parseMessages :: Maybe Message -> Parser (Track Ticks)
parseMessages Maybe Message
mPreMsg = do
  Ticks
dt <- Parser Word64
getVarLenBe Parser Word64 -> (Word64 -> Parser Ticks) -> Parser Ticks
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ticks -> Parser Ticks
forall (m :: * -> *) a. Monad m => a -> m a
return (Ticks -> Parser Ticks)
-> (Word64 -> Ticks) -> Word64 -> Parser Ticks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Ticks
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 Ticks -> Parser (Track Ticks)
forall (m :: * -> *) a. Monad m => a -> m a
return [(Ticks
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 Ticks
msgs <- Maybe Message -> Parser (Track Ticks)
parseMessages Maybe Message
mMsg
      Track Ticks -> Parser (Track Ticks)
forall (m :: * -> *) a. Monad m => a -> m a
return (Track Ticks -> Parser (Track Ticks))
-> Track Ticks -> Parser (Track Ticks)
forall a b. (a -> b) -> a -> b
$! (Ticks
dt,Message
msg) (Ticks, Message) -> Track Ticks -> Track Ticks
forall a. a -> [a] -> [a]
: Track Ticks
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 Ticks
parseChannel Maybe Message
mPreMsg Message -> Bool
isNeededMsg Word8
msgCode = Parser Ticks
p1 Parser Ticks -> Parser Ticks -> Parser Ticks
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Ticks
p2
  where
  p1 :: Parser Ticks
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)
    Ticks -> Parser Ticks
forall (m :: * -> *) a. Monad m => a -> m a
return (Ticks -> Parser Ticks) -> Ticks -> Parser Ticks
forall a b. (a -> b) -> a -> b
$! Message -> Ticks
channel (Maybe Message -> Message
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Message
mPreMsg)
  p2 :: Parser Ticks
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 -> Ticks -> Word8
forall a. Bits a => a -> Ticks -> a
shiftR Word8
w8 Ticks
4)
    Ticks -> Parser Ticks
forall (m :: * -> *) a. Monad m => a -> m a
return (Ticks -> Parser Ticks) -> Ticks -> Parser Ticks
forall a b. (a -> b) -> a -> b
$! Word8 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Ticks) -> Word8 -> Ticks
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
  Ticks
ch <- Maybe Message -> (Message -> Bool) -> Word8 -> Parser Ticks
parseChannel Maybe Message
mPreMsg Message -> Bool
isNoteOff Word8
0x08
  Word8
p1 <- Parser Word8
getWord8
  Word8
p2 <- Parser Word8
getWord8
  Message -> Parser Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Ticks -> Ticks -> Message
NoteOff Ticks
ch (Word8 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
p1) (Word8 -> Ticks
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
  Ticks
ch <- Maybe Message -> (Message -> Bool) -> Word8 -> Parser Ticks
parseChannel Maybe Message
mPreMsg Message -> Bool
isNoteOn Word8
0x09
  Word8
p1 <- Parser Word8
getWord8
  Word8
p2 <- Parser Word8
getWord8
  Message -> Parser Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Ticks -> Ticks -> Message
NoteOn Ticks
ch (Word8 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
p1) (Word8 -> Ticks
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
  Ticks
ch <- Maybe Message -> (Message -> Bool) -> Word8 -> Parser Ticks
parseChannel Maybe Message
mPreMsg Message -> Bool
isKeyPressure Word8
0x0A
  Word8
p1 <- Parser Word8
getWord8
  Word8
p2 <- Parser Word8
getWord8
  Message -> Parser Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Ticks -> Ticks -> Message
KeyPressure Ticks
ch (Word8 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
p1) (Word8 -> Ticks
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
  Ticks
ch <- Maybe Message -> (Message -> Bool) -> Word8 -> Parser Ticks
parseChannel Maybe Message
mPreMsg Message -> Bool
isControlChange Word8
0x0B
  Word8
p1 <- Parser Word8
getWord8
  Word8
p2 <- Parser Word8
getWord8
  Message -> Parser Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Ticks -> Ticks -> Message
ControlChange Ticks
ch (Word8 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
p1) (Word8 -> Ticks
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
  Ticks
ch <- Maybe Message -> (Message -> Bool) -> Word8 -> Parser Ticks
parseChannel Maybe Message
mPreMsg Message -> Bool
isProgramChange Word8
0x0C
  Word8
p1 <- Parser Word8
getWord8
  Message -> Parser Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Ticks -> Message
ProgramChange Ticks
ch (Word8 -> Ticks
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
  Ticks
ch <- Maybe Message -> (Message -> Bool) -> Word8 -> Parser Ticks
parseChannel Maybe Message
mPreMsg Message -> Bool
isChannelPressure Word8
0x0D
  Word8
p1 <- Parser Word8
getWord8
  Message -> Parser Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Ticks -> Message
ChannelPressure Ticks
ch (Word8 -> Ticks
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
  Ticks
ch <- Maybe Message -> (Message -> Bool) -> Word8 -> Parser Ticks
parseChannel Maybe Message
mPreMsg Message -> Bool
isPitchWheel Word8
0x0E
  Word8
p1 <- Parser Word8
getWord8
  Word8
p2 <- Parser Word8
getWord8
  Message -> Parser Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Ticks -> Message
PitchWheel Ticks
ch (Ticks -> Message) -> Ticks -> Message
forall a b. (a -> b) -> a -> b
$ (Ticks -> Ticks -> Ticks
forall a. Bits a => a -> Ticks -> a
shiftL (Word8 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
p2) Ticks
7) Ticks -> Ticks -> Ticks
forall a. Bits a => a -> a -> a
.|. (Word8 -> Ticks
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         Ticks
_ Ticks
p1 Ticks
p2  -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [Ticks -> Builder
f Ticks
0x08, Word8 -> Builder
putWord8 (Word8 -> Builder) -> Word8 -> Builder
forall a b. (a -> b) -> a -> b
$ Ticks -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word8) -> Ticks -> Word8
forall a b. (a -> b) -> a -> b
$ Ticks
p1, Word8 -> Builder
putWord8 (Word8 -> Builder) -> Word8 -> Builder
forall a b. (a -> b) -> a -> b
$ Ticks -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word8) -> Ticks -> Word8
forall a b. (a -> b) -> a -> b
$ Ticks
p2]
  NoteOn          Ticks
_ Ticks
p1 Ticks
p2  -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [Ticks -> Builder
f Ticks
0x09, Word8 -> Builder
putWord8 (Word8 -> Builder) -> Word8 -> Builder
forall a b. (a -> b) -> a -> b
$ Ticks -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word8) -> Ticks -> Word8
forall a b. (a -> b) -> a -> b
$ Ticks
p1, Word8 -> Builder
putWord8 (Word8 -> Builder) -> Word8 -> Builder
forall a b. (a -> b) -> a -> b
$ Ticks -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word8) -> Ticks -> Word8
forall a b. (a -> b) -> a -> b
$ Ticks
p2]
  KeyPressure     Ticks
_ Ticks
p1 Ticks
p2  -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [Ticks -> Builder
f Ticks
0x0A, Word8 -> Builder
putWord8 (Word8 -> Builder) -> Word8 -> Builder
forall a b. (a -> b) -> a -> b
$ Ticks -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word8) -> Ticks -> Word8
forall a b. (a -> b) -> a -> b
$ Ticks
p1, Word8 -> Builder
putWord8 (Word8 -> Builder) -> Word8 -> Builder
forall a b. (a -> b) -> a -> b
$ Ticks -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word8) -> Ticks -> Word8
forall a b. (a -> b) -> a -> b
$ Ticks
p2]
  ControlChange   Ticks
_ Ticks
p1 Ticks
p2  -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [Ticks -> Builder
f Ticks
0x0B, Word8 -> Builder
putWord8 (Word8 -> Builder) -> Word8 -> Builder
forall a b. (a -> b) -> a -> b
$ Ticks -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word8) -> Ticks -> Word8
forall a b. (a -> b) -> a -> b
$ Ticks
p1, Word8 -> Builder
putWord8 (Word8 -> Builder) -> Word8 -> Builder
forall a b. (a -> b) -> a -> b
$ Ticks -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word8) -> Ticks -> Word8
forall a b. (a -> b) -> a -> b
$ Ticks
p2]
  ProgramChange   Ticks
_ Ticks
p1     -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Ticks -> Builder
f Ticks
0x0C, Word8 -> Builder
putWord8 (Word8 -> Builder) -> Word8 -> Builder
forall a b. (a -> b) -> a -> b
$ Ticks -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word8) -> Ticks -> Word8
forall a b. (a -> b) -> a -> b
$ Ticks
p1]
  ChannelPressure Ticks
_ Ticks
p1     -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Ticks -> Builder
f Ticks
0x0D, Word8 -> Builder
putWord8 (Word8 -> Builder) -> Word8 -> Builder
forall a b. (a -> b) -> a -> b
$ Ticks -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word8) -> Ticks -> Word8
forall a b. (a -> b) -> a -> b
$ Ticks
p1]
  PitchWheel      Ticks
_ Ticks
p1     -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ Ticks -> Builder
f Ticks
0x0E
                                      , Word8 -> Builder
putWord8 (Ticks -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word8) -> Ticks -> Word8
forall a b. (a -> b) -> a -> b
$ Ticks
p1 Ticks -> Ticks -> Ticks
forall a. Bits a => a -> a -> a
.&. Ticks
0x7F)
                                      , Word8 -> Builder
putWord8 (Ticks -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word8) -> Ticks -> Word8
forall a b. (a -> b) -> a -> b
$ Ticks -> Ticks -> Ticks
forall a. Bits a => a -> Ticks -> a
shiftR Ticks
p1 Ticks
7)]
  Message
_ -> Builder
forall a. Monoid a => a
mempty
  where
  f :: Int -> Builder
  f :: Ticks -> Builder
f Ticks
w8 = Word8 -> Builder
putWord8 (Word8 -> Builder) -> Word8 -> Builder
forall a b. (a -> b) -> a -> b
$ Ticks -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word8) -> Ticks -> Word8
forall a b. (a -> b) -> a -> b
$ (Ticks -> Ticks -> Ticks
forall a. Bits a => a -> Ticks -> a
shiftL Ticks
w8 Ticks
4) Ticks -> Ticks -> Ticks
forall a. Bits a => a -> a -> a
.|. (Message -> Ticks
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 Ticks
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
$ Ticks -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word16) -> Ticks -> Word16
forall a b. (a -> b) -> a -> b
$ Ticks
i]
    Text String
s -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
      [Word8 -> Builder
putWord8 Word8
0x01, Word64 -> Builder
putVarLenBe (Ticks -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word64) -> Ticks -> Word64
forall a b. (a -> b) -> a -> b
$ String -> Ticks
forall (t :: * -> *) a. Foldable t => t a -> Ticks
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 (Ticks -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word64) -> Ticks -> Word64
forall a b. (a -> b) -> a -> b
$ String -> Ticks
forall (t :: * -> *) a. Foldable t => t a -> Ticks
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 (Ticks -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word64) -> Ticks -> Word64
forall a b. (a -> b) -> a -> b
$ String -> Ticks
forall (t :: * -> *) a. Foldable t => t a -> Ticks
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 (Ticks -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word64) -> Ticks -> Word64
forall a b. (a -> b) -> a -> b
$ String -> Ticks
forall (t :: * -> *) a. Foldable t => t a -> Ticks
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 (Ticks -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word64) -> Ticks -> Word64
forall a b. (a -> b) -> a -> b
$ String -> Ticks
forall (t :: * -> *) a. Foldable t => t a -> Ticks
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 (Ticks -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word64) -> Ticks -> Word64
forall a b. (a -> b) -> a -> b
$ String -> Ticks
forall (t :: * -> *) a. Foldable t => t a -> Ticks
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 (Ticks -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word64) -> Ticks -> Word64
forall a b. (a -> b) -> a -> b
$ String -> Ticks
forall (t :: * -> *) a. Foldable t => t a -> Ticks
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 (Ticks -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word64) -> Ticks -> Word64
forall a b. (a -> b) -> a -> b
$ String -> Ticks
forall (t :: * -> *) a. Foldable t => t a -> Ticks
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 (Ticks -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word64) -> Ticks -> Word64
forall a b. (a -> b) -> a -> b
$ String -> Ticks
forall (t :: * -> *) a. Foldable t => t a -> Ticks
length String
s), String -> Builder
putString String
s]
    ChannelPrefix Ticks
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
$ Ticks -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word8) -> Ticks -> Word8
forall a b. (a -> b) -> a -> b
$ Ticks
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 Ticks
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
$ Ticks -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word32) -> Ticks -> Word32
forall a b. (a -> b) -> a -> b
$ Ticks
i]
    SMPTEOffset Ticks
i1 Ticks
i2 Ticks
i3 Ticks
i4 Ticks
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
$ (Ticks -> Builder) -> [Ticks] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Word8 -> Builder
putWord8 (Word8 -> Builder) -> (Ticks -> Word8) -> Ticks -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticks -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral) [Ticks
i1,Ticks
i2,Ticks
i3,Ticks
i4,Ticks
i5]]
    TimeSignature Ticks
i1 Ticks
i2 Ticks
i3 Ticks
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
$ (Ticks -> Builder) -> [Ticks] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Word8 -> Builder
putWord8 (Word8 -> Builder) -> (Ticks -> Word8) -> Ticks -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticks -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral) [Ticks
i1,Ticks
i2,Ticks
i3,Ticks
i4]]
    KeySignature Ticks
i1 Ticks
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
$ Ticks -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Int8) -> Ticks -> Int8
forall a b. (a -> b) -> a -> b
$ Ticks
i1
      , Word8 -> Builder
putWord8 (Word8 -> Builder) -> Word8 -> Builder
forall a b. (a -> b) -> a -> b
$ Ticks -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word8) -> Ticks -> Word8
forall a b. (a -> b) -> a -> b
$ Ticks
i2]
    Reserved Ticks
w ByteString
bs -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [
        Word8 -> Builder
putWord8 (Ticks -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Ticks
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 (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Message
SequenceNumber (Word16 -> Ticks
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 <- Ticks -> Parser String
getString (Word64 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
l)
  Message -> Parser Message
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 <- Ticks -> Parser String
getString (Word64 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
l)
  Message -> Parser Message
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 <- Ticks -> Parser String
getString (Word64 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
l)
  Message -> Parser Message
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 <- Ticks -> Parser String
getString (Word64 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
l)
  Message -> Parser Message
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 <- Ticks -> Parser String
getString (Word64 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
l)
  Message -> Parser Message
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 <- Ticks -> Parser String
getString (Word64 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
l)
  Message -> Parser Message
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 <- Ticks -> Parser String
getString (Word64 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
l)
  Message -> Parser Message
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 <- Ticks -> Parser String
getString (Word64 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
l)
  Message -> Parser Message
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 <- Ticks -> Parser String
getString (Word64 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
l)
  Message -> Parser Message
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 (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Message
ChannelPrefix (Word8 -> Ticks
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 (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 (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Message
TempoChange (Word32 -> Ticks
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 [Ticks
n1,Ticks
n2,Ticks
n3,Ticks
n4,Ticks
n5] = (Word8 -> Ticks) -> [Word8] -> [Ticks]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> [Word8]
L.unpack ByteString
bs)
  Message -> Parser Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Ticks -> Ticks -> Ticks -> Ticks -> Message
SMPTEOffset Ticks
n1 Ticks
n2 Ticks
n3 Ticks
n4 Ticks
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 [Ticks
n1,Ticks
n2,Ticks
n3,Ticks
n4] = (Word8 -> Ticks) -> [Word8] -> [Ticks]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> [Word8]
L.unpack ByteString
bs)
  Message -> Parser Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Ticks -> Ticks -> Ticks -> Message
TimeSignature Ticks
n1 Ticks
n2 Ticks
n3 Ticks
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 (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Ticks -> Ticks -> Message
KeySignature (Int8 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
n1) (Word8 -> Ticks
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 (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Ticks -> ByteString -> Message
Reserved (Word8 -> Ticks
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 (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 (m :: * -> *) a. Monad m => a -> m a
return (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$! Ticks -> ByteString -> Message
Sysex (Word8 -> Ticks
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w) ByteString
d

buildSysexMessage :: Message -> Builder
buildSysexMessage :: Message -> Builder
buildSysexMessage (Sysex Ticks
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
$ Ticks -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ticks -> Word8) -> Ticks -> Word8
forall a b. (a -> b) -> a -> b
$ Ticks
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 :: f a -> f (a, a)
two f a
a = (a -> a -> (a, a)) -> f (a -> a -> (a, a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((,)) f (a -> a -> (a, a)) -> f a -> f (a -> (a, a))
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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f a
a