From 8d895a2fc99a9e6e53557afb396c2269e1af8559 Mon Sep 17 00:00:00 2001 From: John Watson Date: Wed, 14 Sep 2022 18:22:10 +0100 Subject: [PATCH] Purescript 0.15.4 Tidy up the parser a little. The only change is now a depedency on bifunctors. --- CHANGELOG.md | 6 +- bower.json | 1 + package.json | 2 +- packages.dhall | 4 +- spago.dhall | 1 + src/Data/Midi/Parser.purs | 152 +++++++++++++++++--------------------- 6 files changed, 77 insertions(+), 89 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 3e8d23c..daf796e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,10 @@ # Changelog -### Version 4.0,0 (2022-04-06) +### Version 4.0.1 (pending) +* PS Compiler 0.15.4 +* add dependency on bifunctors + +### Version 4.0.0 (2022-04-06) * PS Compiler 0.15.0 * (replace test-unit with spec) diff --git a/bower.json b/bower.json index d81073c..2cf3b93 100644 --- a/bower.json +++ b/bower.json @@ -18,6 +18,7 @@ }, "dependencies": { "purescript-prelude": "^6.0.0", + "purescript-bifunctors": "^6.0.0", "purescript-lists": "^7.0.0", "purescript-string-parsers": "^8.0.0", "purescript-integers": "^6.0.0", diff --git a/package.json b/package.json index 1d3ab88..4aafc82 100644 --- a/package.json +++ b/package.json @@ -8,7 +8,7 @@ }, "devDependencies": { "pulp": "^16.0.0", - "purescript": "^0.15.0", + "purescript": "^0.15.4", "purescript-psa": "^0.6.0", "spago": "^0.20.9" } diff --git a/packages.dhall b/packages.dhall index c665ce5..5f0e6e4 100644 --- a/packages.dhall +++ b/packages.dhall @@ -105,7 +105,7 @@ in upstream ------------------------------- -} let upstream = - https://github.com/purescript/package-sets/releases/download/psc-0.15.0-20220502/packages.dhall - sha256:38d347aeba9fe6359c208abe87a5cecf1ffb14294f11ad19664ae35c59b6e29a + https://github.com/purescript/package-sets/releases/download/psc-0.15.4-20220901/packages.dhall + sha256:f1531b29c21ac437ffe5666c1b6cc76f0a9c29d3c9d107ff047aa2567744994f in upstream diff --git a/spago.dhall b/spago.dhall index 248ccb7..96fd4ee 100644 --- a/spago.dhall +++ b/spago.dhall @@ -5,6 +5,7 @@ You can edit this file as you like. { name = "midi" , dependencies = [ "arrays" + , "bifunctors" , "control" , "effect" , "either" diff --git a/src/Data/Midi/Parser.purs b/src/Data/Midi/Parser.purs index cf281b9..858f02a 100644 --- a/src/Data/Midi/Parser.purs +++ b/src/Data/Midi/Parser.purs @@ -10,8 +10,9 @@ import Data.Midi import Control.Alt ((<|>)) import Data.Array (cons, fromFoldable) as Array +import Data.Bifunctor (lmap) import Data.Char (fromCharCode, toCharCode) -import Data.Either (Either(..)) +import Data.Either (Either) import Data.Foldable (foldl) import Data.Int (pow) import Data.Int.Bits (and, shl) @@ -368,6 +369,15 @@ timeSignature :: Parser Event timeSignature = bchar 0x58 *> bchar 0x04 *> (buildTimeSig <$> int8 <*> int8 <*> int8 <*> int8) "time signature" + where + buildTimeSig :: Int -> Int -> Int -> Int -> Event + buildTimeSig nn dd cc bb = + let + denom = + 2 `pow` dd + in + TimeSignature nn denom cc bb + keySignature :: Parser Event keySignature = bchar 0x59 *> bchar 0x02 *> (KeySignature <$> signedInt8 <*> int8) @@ -388,6 +398,13 @@ streamSysEx = buildStreamSysEx <$> bchar 0xF0 <*> (many1Till notSysExEnd (char $ unsafeFromCharCode sysExTerminator)) + where + -- build a SysEx message for a stream-based SysEx event + -- this simply means appending the terminating 0xF7 to the data bytes + buildStreamSysEx :: Int -> Nel.NonEmptyList Char -> Event + buildStreamSysEx sysExType bytes = + buildSysEx sysExType (bytes <> (Nel.singleton $ unsafeFromCharCode sysExTerminator)) + {- parse an unspecified meta event The possible range for an event type is 00-7F. Not all values in this range are @@ -418,30 +435,76 @@ noteOn :: Parser Event noteOn = buildNote <$> brange 0x90 0x9F <*> int8 <*> int8 "note on" + where + -- build NoteOn (unless the velocity is zero in which case NoteOff) + buildNote :: Int -> Int -> Int -> Event + buildNote cmd note velocity = + let + channel = + and cmd 0x0F + in + case (velocity == 0) of + true -> + NoteOff channel note velocity + + _ -> + NoteOn channel note velocity + + noteOff :: Parser Event noteOff = buildNoteOff <$> brange 0x80 0x8F <*> int8 <*> int8 "note off" + where + buildNoteOff :: Int -> Int -> Int -> Event + buildNoteOff cmd note velocity = + channelBuilder3 NoteOff cmd note velocity + noteAfterTouch :: Parser Event noteAfterTouch = buildNoteAfterTouch <$> brange 0xA0 0xAF <*> int8 <*> int8 "note after touch" + where + buildNoteAfterTouch :: Int -> Int -> Int -> Event + buildNoteAfterTouch cmd note pressure = + channelBuilder3 NoteAfterTouch cmd note pressure + controlChange :: Parser Event controlChange = buildControlChange <$> brange 0xB0 0xBF <*> int8 <*> int8 "control change" + where + buildControlChange :: Int -> Int -> Int -> Event + buildControlChange cmd num value = + channelBuilder3 ControlChange cmd num value + programChange :: Parser Event programChange = buildProgramChange <$> brange 0xC0 0xCF <*> int8 "program change" + where + buildProgramChange :: Int -> Int -> Event + buildProgramChange cmd num = + channelBuilder2 ProgramChange cmd num + channelAfterTouch :: Parser Event channelAfterTouch = buildChannelAfterTouch <$> brange 0xD0 0xDF <*> int8 "channel after touch" + where + buildChannelAfterTouch :: Int -> Int -> Event + buildChannelAfterTouch cmd num = + channelBuilder2 ChannelAfterTouch cmd num + pitchBend :: Parser Event pitchBend = buildPitchBend <$> brange 0xE0 0xEF <*> int8 <*> int8 "pitch bend" + where + buildPitchBend :: Int -> Int -> Int -> Event + buildPitchBend cmd lsb msb = + channelBuilder2 PitchBend cmd $ lsb + (shl msb 7) + -- running status is somewhat anomalous. It inherits the 'type' of the last event parsed, -- (here called the parent) which must be a channel event. -- We now macro-expand the running status message to be the type (and use the channel status) @@ -495,23 +558,6 @@ buildRecording :: Header -> List Track -> Recording buildRecording h ts = Recording { header: h, tracks : ts } --- build NoteOn (unless the velocity is zero in which case NoteOff) -buildNote :: Int -> Int -> Int -> Event -buildNote cmd note velocity = - let - channel = - and cmd 0x0F - - isOff = - (velocity == 0) - in - case isOff of - true -> - NoteOff channel note velocity - - _ -> - NoteOn channel note velocity - -- abstract builders that construct MidiEvents that all have the same shape channelBuilder3 :: (Int -> Int -> Int -> Event) -> Int -> Int -> Int -> Event channelBuilder3 construct cmd x y = @@ -529,52 +575,6 @@ channelBuilder2 construct cmd x = in construct channel x --- build NoteOff -buildNoteOff :: Int -> Int -> Int -> Event -buildNoteOff cmd note velocity = - channelBuilder3 NoteOff cmd note velocity - --- build Note AfterTouch AKA Polyphonic Key Pressure -buildNoteAfterTouch :: Int -> Int -> Int -> Event -buildNoteAfterTouch cmd note pressure = - channelBuilder3 NoteAfterTouch cmd note pressure - --- build Control Change -buildControlChange :: Int -> Int -> Int -> Event -buildControlChange cmd num value = - channelBuilder3 ControlChange cmd num value - --- build Program Change -buildProgramChange :: Int -> Int -> Event -buildProgramChange cmd num = - channelBuilder2 ProgramChange cmd num - --- build Channel AfterTouch AKA Channel Key Pressure -buildChannelAfterTouch :: Int -> Int -> Event -buildChannelAfterTouch cmd num = - channelBuilder2 ChannelAfterTouch cmd num - --- build Pitch Bend -buildPitchBend :: Int -> Int -> Int -> Event -buildPitchBend cmd lsb msb = - channelBuilder2 PitchBend cmd $ lsb + (shl msb 7) - --- build a Time Signature -buildTimeSig :: Int -> Int -> Int -> Int -> Event -buildTimeSig nn dd cc bb = - let - denom = - 2 `pow` dd - in - TimeSignature nn denom cc bb - --- build a SysEx message for a stream-based SysEx event --- this simply means appending the terminating 0xF7 to the data bytes -buildStreamSysEx :: Int -> Nel.NonEmptyList Char -> Event -buildStreamSysEx sysExType bytes = - buildSysEx sysExType (bytes <> (Nel.singleton $ unsafeFromCharCode sysExTerminator)) - -- buildSysEx sysExType (bytes <> (unsafeFromCharCode sysExTerminator : Nil)) - buildSysEx :: Int -> Nel.NonEmptyList Char -> Event buildSysEx sysExType bytes = let @@ -599,7 +599,6 @@ consumeOverspill actual expected = count (cnt - expected) int8 ) - -- utils catChars :: List Char -> String catChars = @@ -609,29 +608,17 @@ unsafeFromCharCode :: Int -> Char unsafeFromCharCode i = fromMaybe 'a' $ fromCharCode i - -- exported functions -- | Parse a MIDI event that emanates from a Web MIDI connection to the browser. parseMidiEvent :: String -> Either String Event parseMidiEvent s = - case runParser midiStreamEvent s of - -- case runParser (midiEvent Nothing) s of - Right n -> - Right n - - Left e -> - Left $ show e + lmap show $ runParser midiStreamEvent s -- | Parse a normalised MIDI string. parse :: String -> Either String Recording parse s = - case runParser midi s of - Right n -> - Right n - - Left e -> - Left $ show e + lmap show $ runParser midi s -- | Normalise the input. The un-normalised input can by obtained (for example) -- | by using readAsBinaryString or else by using XMLHttpRequest and then making @@ -649,9 +636,4 @@ normalise = -- | Parse a MIDI message. Probably only useful for debug purposes. parseMidiMessage :: String -> Either String Message parseMidiMessage s = - case runParser (midiMessage Nothing) s of - Right n -> - Right n - - Left e -> - Left $ show e + lmap show $ runParser (midiMessage Nothing) s