zmidi-core 0.4.0 → 0.5.0

raw patch · 10 files changed

+402/−148 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGES +27/−0
• src/ZMidi/Core/Datatypes.hs +112/−42
• src/ZMidi/Core/Internal/ExtraTypes.hs +16/−4
• src/ZMidi/Core/Internal/ParserMonad.hs +59/−12
• src/ZMidi/Core/Internal/SimpleFormat.hs +43/−14
• src/ZMidi/Core/Pretty.hs +39/−30
• src/ZMidi/Core/ReadFile.hs +71/−32
• src/ZMidi/Core/VersionNumber.hs +2/−2
• src/ZMidi/Core/WriteFile.hs +16/−11
• zmidi-core.cabal +17/−1

@@ -1,3 +1,30 @@++0.4.0 to 0.5.0:++  * Changed order of @MidiVoiceEnvent@ constructors so the Ord +    instance follows the order of the /tag/ in the MIDI binary+    representation.+ +  * Changed @MidiSysCommonEvent@ to have different constructors +    for unidentified F4 anf F5 events.   ++  * Changed @MidiSysRealTimeEvent@ to have different constructors+    for unidentified F9 and FD events.  ++  * Added more Haddock docs.++  * Various internal code changes.+++0.3.0 to v0.4.0:++  * Added new constructors to @MidiMetaEvent@ for MidiPort and +    MetaOther. MetaOther recognizes otherwise unrecognized events+    improving the robustness of the parser. Similarly a new +    /other/ constructor has been added to @MidiScaleType@ to +    avoid parse errors.++ 0.2.1 to 0.3.0:    * Revised naming of the MIDI data types. All data types now have 

@@ -15,10 +15,9 @@ -- -- Values are sometimes not interpreted. This means that the -- the data types do not fully represent the sematics of the --- data, but all the data is either stored in the tree or --- synthesizeable.--- --- @ readFile >>= writeFile @ will produce an identical binary \[1\]. +-- data, but all the data is either stored within the data type +-- or synthesizeable. Hence, @ readFile >>= writeFile @ will +-- produce an identical binary \[1\].  -- -- \[1\] Or it should, failure indicates a bug... --@@ -207,53 +206,74 @@  -- | Voice events control the output of the synthesizer. ----- Note - the constructors are not in the the same order as their --- byte values. Controller and ProgramChange are higher than they --- /naturally/ occur so the will come first after a comparison or --- sort.+-- Note - change in v0.5.0 - the constructors have been reordered+-- so the Ord instance matches the order of the /tag/ bytes. Any +-- code that relied on sorting MIDI events is likely to need +-- reworking. ----- When generating MIDI, Controller and ProgramChange events --- should be signalled before NoteOn or NoteOff events at the same --- delta-time. Changing the order of the constructors helps to --- sort for this.+-- In serialized MIDI data the top 4 bits of the first byte of the +-- Voice Event are a tag, the bottom 4 bits are the channel +-- number. ZMidi stores the channel number with a Word8 though +-- values should be limited to the range 0-15. -- data MidiVoiceEvent -    -- | @ channel * controller_number * value @ +    -- | Note off.     -- -    -- Controller change, e.g. by a footswitch.-    ---    = Controller          Word8 Word8 Word8--    -- | @ channel * program_number @ - change the instrument -    -- playing on the specified channel. For playback on -    -- computers (rather than synthesizers) the program numbers-    -- will correspond to the /General MIDI/ instrument numbers.-    ---    | ProgramChange       Word8 Word8--    -- | @ channel * note * velocity @ +    -- > 80 to 8F (0 to F is channel number) * note * velocity     --      -- Turn off a sounding note.     ---    | NoteOff             Word8 Word8 Word8   +    = NoteOff             Word8 Word8 Word8    -    -- | @ channel * note * velocity @ +    -- | Note on.+    --+    -- > 90 to 9F (0 to F is channel number) * note * velocity     --      -- Start playing a note.     --     | NoteOn              Word8 Word8 Word8 -    -- | @ channel * note * pressure_value @ +  +    -- | Polyphonic key pressure.+    --+    -- > A0 to AF (0 to F is channel number) * note * pressure_value     --      -- Change of pressure applied to the synthesizer key.      --     | NoteAftertouch      Word8 Word8 Word8      -    -- | @ channel * pressure_value @ ++    -- | Set a controller.+    --+    -- > B0 to BF (0 to F is channel number) * controller_number * value      -- +    -- Controller change, e.g. by a footswitch.+    --+    | Controller          Word8 Word8 Word8+++    -- | Set the program.+    -- +    -- > C0 to CF (0 to F is channel number) * program_number +    --+    -- Change the instrument +    -- playing on the specified channel. For playback on +    -- computers (rather than synthesizers) the program numbers+    -- will correspond to the /General MIDI/ instrument numbers.+    --+    | ProgramChange       Word8 Word8+++    -- | Channel pressure.+    --+    -- > D0 to DF (0 to F is channel number) * pressure_value+    --      | ChanAftertouch      Word8 Word8 -    -- | @ channel * value @ ++    -- | Pitch bend +    --+    -- > E0 to EF (0 to F is channel number) * value     --      -- Change the pitch of a sounding note. Often used to      -- approximate microtonal tunings.@@ -266,8 +286,10 @@ -- | \SysEx\ - system exclusive event.  -- data MidiSysExEvent-    -- | @ length * data @ +    -- | SysEx event.     -- +    -- > F0 * length * data+    --      -- An uninterpreted sys-ex event.     --     = SysEx               Word32 [Word8]@@ -285,33 +307,55 @@ data MidiSysCommonEvent     -- | Time code quarter frame.     -- +    -- > F1 * payload+    --      -- Note the payload is really a byte split into two 4-bit      -- values, however here it is uninterpreted.     --     = QuarterFrame      Word8     +     -- | Song position pointer.     --+    -- > F2 * lsb * msb+    --     | SongPosPointer    Word8       Word8 -    -- | @ song_number @++    -- | Song number.+    -- +    -- > F3 * song_number     --     -- Song number should be in the range 0..127.     --     | SongSelect        Word8 -    -- | Tag should be limited to 0xF4 or 0xF5.++    -- | Undefined system common event.+    -- +    -- > F4     ---    -- Other values would indicate either a badly formed MIDI-    -- file or a failure with the parser.+    | UndefinedF4++    -- | Undefined system common event.+    -- +    -- > F5     ---    | Common_undefined  TagByte+    | UndefinedF5 -    -- | Tune request message for analogue synthesizers.+    -- | Tune request.+    -- +    -- > F6+    -- +    -- Tune request message for analogue synthesizers.     --     | TuneRequest     +     -- | End-of-system-exclusive message.+    -- +    -- > F7+    --      | EOX   deriving (Eq,Show,Ord) @@ -324,33 +368,59 @@ -- data MidiSysRealTimeEvent     -- | Timing signal.+    -- +    -- > F8      --           = TimingClock     -    -- | Tag should be limited to either 0xF9 or 0xFD.+    -- | Undefined real time event.+    -- +    -- > F9     ---    -- Other values would indicate either a badly formed MIDI-    -- file or a failure with the parser.     ---    | RT_undefined      TagByte+    | UndefinedF9+          -- | Start playing a sequence.     -- +    -- > FA+    --      | StartSequence+          -- | Continue playing a stopped sequence.+    -- +    -- > FB     --     | ContinueSequence +     -- | Stop playing a sequence.+    -- +    -- > FC     --     | StopSequence -    -- | Synchronization pulse...++    -- | Undefined real time event.     -- +    -- > FD+    --+    --+    | UndefinedFD++    -- | Active sensing+    -- +    -- > FE+    -- +    -- Synchronization pulse...+    --      | ActiveSensing +     -- | Reset to power-up status.+    -- +    -- > FF     --     | SystemReset   deriving (Eq,Show,Ord)

@@ -41,14 +41,21 @@ -- | SplitByte - divide a byte into the upper four and lower  -- 4 bits. -- -data SplitByte = SB { upper4 :: Word8, lower4 :: Word8 }+-- Note upper4 is not shifted (this is a change in v 0.5.0).+-- +data SplitByte = SB { upper4 :: !Word8, lower4 :: !Word8 }   deriving (Eq,Ord,Show) +-- | Split a Word8.+-- splitByte :: Word8 -> SplitByte-splitByte i = SB ((i .&. 0xF0) `shiftR` 4) (i .&. 0x0F)+splitByte i = SB (i .&. 0xF0) (i .&. 0x0F) ++-- | Make a Word8 from a Splitbyte.+-- joinByte :: SplitByte -> Word8-joinByte (SB a b) = (a `shiftL` 4) + (b .&. 0x0F)+joinByte (SB a b) = (a .&. 0xF0) + (b .&. 0x0F)   --------------------------------------------------------------------------------@@ -77,7 +84,8 @@ downl :: Word32 -> Word8 downl = (0x7f .&.) . fromIntegral  -+-- | Make a Word32 from a Varlen.+-- fromVarlen :: Varlen -> Word32 fromVarlen (V1 a)       = up a fromVarlen (V2 a b)     = (left7 $ up a)  + up b@@ -103,6 +111,8 @@ right21   :: Word32 -> Word32 right21   = (`shiftR` 21) +-- | Make a Varlen from a Word32.+-- toVarlen :: Word32 -> Varlen toVarlen i      | i < 0x80           = V1 (downl i)@@ -111,5 +121,7 @@     | otherwise          = V4 (down $ right21 i) (down $ right14 i)                               (down $ right7  i) (downl i) +-- | Show a integral as a hex value with \n @0x@ prefix.+-- hexStr :: (Show a, Integral a) => a -> String hexStr i = (showString "0x" . showHex i) "" 

@@ -32,8 +32,7 @@   , char8    , (<??>)-  , reportError-  , catchError+  , fatalError    , count   , gencount@@ -51,7 +50,11 @@ import Data.Int import Data.Word -+-- | Position of the parser in the input stream.+-- +-- This is exposed by the ReadFile API and may be useful for +-- /disassembling/ a MIDI file that causes a parse failure.+--  type Pos = Int  data ParserState = ParserState @@ -59,12 +62,17 @@        , input     :: L.ByteString         } -+-- | Error message - alias for String.+-- type ErrMsg = String +-- | ParseErr is the position of the error and a message.+-- data ParseErr = ParseErr !Pos !ErrMsg   deriving (Eq,Show) +-- | Parser newtype.+-- newtype ParserM a = ParserM            { getParserM :: ParserState -> (Either ParseErr a, ParserState) } @@ -88,55 +96,85 @@                                 Left e -> (Left e, s')                                 Right a -> (getParserM . k) a s' +-- | Run the parser.+-- runParser :: L.ByteString -> ParserM a -> Either ParseErr a runParser bs mf = fst $ getParserM mf (ParserState { pos = 0, input = bs})  +-- | Get current Pos.+-- getPos :: ParserM Int getPos = ParserM $ \s -> (Right $ pos s, s) +-- | Parse a Word8.+-- word8 :: ParserM Word8 word8 = ParserM $ \s@(ParserState n bs) -> case L.uncons bs of      Nothing      -> (Left (ParseErr n "word8 - no more data."), s)     Just (a,bs') -> (Right a, ParserState (n+1) bs')  --- NEEDS CHECKING!++-- | Parse an Int8. -- int8 :: ParserM Int8 int8 = fromIntegral <$> word8 -+-- | Parse a Word16 (big-endian).+-- word16be :: ParserM Word16 word16be = ParserM $ \s@(ParserState n bs) -> case uncons2 bs of     Nothing -> (Left (ParseErr n "word16be - no more data."), s)     Just (a,b,bs') -> (Right $ w16be a b, ParserState (n+2) bs') +-- | Parse a Word24 (big-endian).+-- word24be :: ParserM Word32 word24be = ParserM $ \s@(ParserState n bs) -> case uncons3 bs of     Nothing -> (Left (ParseErr n "word24be - no more data."), s)     Just (a,b,c,bs') -> (Right $ w24be a b c, ParserState (n+3) bs') +-- | Parse a Word32 (big-endian).+-- word32be :: ParserM Word32 word32be = ParserM $ \s@(ParserState n bs) -> case uncons4 bs of     Nothing -> (Left (ParseErr n "word32be - no more data."), s)     Just (a,b,c,d,bs') -> (Right $ w32be a b c d, ParserState (n+4) bs') -+-- | Parse a Char.+-- char8 :: ParserM Char char8 = (chr . fromIntegral) <$> word8  infixr 0 <??> +-- | Assign an error message to a Parser.+-- (<??>) :: ErrMsg -> ParserM a -> ParserM a (<??>) msg p = ParserM $ \s ->                   case getParserM p s of                    (Left (ParseErr n _),s') -> (Left (ParseErr n msg),s')                    (Right a,            s') -> (Right a,s') -reportError :: ErrMsg -> ParserM a-reportError msg = ParserM $ \s -> (Left (ParseErr (pos s) msg), s)+-- | Throw a fatal error.+--+fatalError :: ErrMsg -> ParserM a+fatalError msg = ParserM $ \s -> (Left (ParseErr (pos s) msg), s) +{-++-- It is possible to catch error, _but_ we can\'t reliably+-- recover from them so this function is not useful.+--+-- We can\'t recover as we don\'t know where in the input to +-- start parsing from if we drop the problemmatic input.+--+-- Unlike Parsec, the MIDI format is deterministic - we don\'t +-- need backtracking to resolve ambiguity. So we don\'t need+-- a choice or alt combinator. +-- + -- | This uses backtracking... -- catchError :: ParserM a -> (ErrMsg -> ParserM a) -> ParserM a@@ -144,24 +182,33 @@                    case getParserM f s of                      (Left (ParseErr _ msg),_)  -> getParserM (g msg) s                      (Right a,              s') -> (Right a,s')+-} ++-- | Apply the parser for /count/ times, forming a list.+-- count :: Int -> ParserM a -> ParserM [a] count i p      | i <= 0    = pure []     | otherwise = (:) <$> p <*> count (i-1) p  +-- | Apply the parser for /count/ times, derive the final answer+-- from the intermediate list with the supplied function.+-- gencount :: Integral i => ParserM i -> ParserM a -> (i -> [a] -> ans) -> ParserM ans gencount plen p constr = do      i   <- plen     xs  <- count (fromIntegral i) p      return $ constr i xs -+-- | Parse a text of length /n/.+-- text :: Int -> ParserM String text i = count i char8 -+-- | Run a parser within a bounded section of the input stream.+-- boundRepeat :: Int -> ParserM a -> ParserM [a] boundRepeat n p = getPos >>= \start -> step (start + n)   where@@ -170,7 +217,7 @@                   ; case compare i lim of                       LT -> do { as <- step lim; return (a:as) }                       EQ -> return [a]-                      GT -> reportError "boundRepeat - parser exceeds limit"+                      GT -> fatalError "boundRepeat - parser exceeds limit"                   }  

@@ -10,7 +10,7 @@ -- Stability   :  unstable -- Portability :  As per dependencies. ----- Simple formating combinators.+-- Simple line-oriented formatting combinators. -- -------------------------------------------------------------------------------- @@ -22,10 +22,10 @@   , output    , cat-  , ssep+  , sep   , char   , text-  , multiply+  , repeatChar    , padl   , padr@@ -39,15 +39,17 @@ import Data.Word import Numeric --- Strings are represented as Hughes lists +-- | Strings are represented as Hughes lists  -- -- ShowS is a Hughes list representation specialized to Strings -- type H a = [a] -> [a] -type HString = H Char +type HString = H Char +-- | Make a HString of spaces.+-- spaceH :: Int -> HString  spaceH n = showString $ replicate n ' ' @@ -56,13 +58,22 @@ fromH = ($ [])  -- | Docs represent a single line - they should not contain --- newlines...+-- newlines. ---data Doc = Doc { width :: !Int, doch :: HString }+data Doc = Doc { +    -- | Width of the doc.+    width :: !Int,  +    -- | Internal representation.+    doch :: HString }++-- | Make a literal Doc from a String.+-- doc :: String -> Doc doc s = Doc (length s) (showString s)  +-- | Unwrap a Doc making a String.+-- output :: Doc -> String output = fromH . doch @@ -75,44 +86,62 @@  infixr 6 `cat` +-- | Concatenate - no space.+-- cat :: Doc -> Doc -> Doc cat = mappend -infixr 6 `ssep`+infixr 6 `sep` -ssep :: Doc -> Doc -> Doc-ssep (Doc i1 f1) (Doc i2 f2) = Doc (1+i1+i2) (f1 . (' ':) . f2)+-- | Concatenate - with space.+--+sep :: Doc -> Doc -> Doc+sep (Doc i1 f1) (Doc i2 f2) = Doc (1+i1+i2) (f1 . (' ':) . f2)  +-- | Make a Doc from a Char.+-- char :: Char -> Doc  char c = Doc 1 (c:) +-- | Make a Doc from a String.+-- text :: String -> Doc text = doc  -multiply :: Int -> Char -> Doc-multiply n c = Doc n (showString $ replicate n c)+-- | Repeat the Char /n/ times to make a Doc.+--+repeatChar :: Int -> Char -> Doc+repeatChar n c = Doc n (showString $ replicate n c)  +-- | Pad the left with space.+-- padl :: Int -> Doc -> Doc padl i d@(Doc n f) | i > n     = Doc i (spaceH (i-n) . f)                    | otherwise = d +-- | Pad the right with space.+-- padr :: Int -> Doc -> Doc padr i d@(Doc n f) | i > n     = Doc i (f . spaceH (i-n))                    | otherwise = d -+-- | Show as a two digit hex number.+-- hex2 :: Word8 -> Doc hex2 n | n < 0x10  = Doc 2 (('0' :) . showHex n)        | otherwise = Doc 2 (showHex n)   +-- | Show as a four digit hex number.+-- hex4 :: Word16 -> Doc hex4 n | n < 0x10   = Doc 4 (('0':) . ('0':) . ('0':) . showHex n)        | n < 0x100  = Doc 4 (('0':) . ('0':) . showHex n)        | n < 0x1000 = Doc 4 (('0':) . showHex n)        | otherwise = Doc 4 (showHex n)   -+-- | Show an Integral value as a base 10 number.+-- integral :: (Show a, Integral a) => a -> Doc integral = doc . show 

@@ -11,6 +11,12 @@ -- Portability :  As per dependencies. -- -- Pretty print the MIDI representation.+-- +-- The output format is lossy - the content of Meta and SysEx +-- events may be abbreviated. This makes the format unsuitable +-- as a text representation of MIDI, however it can enable+-- quick /disassembly/ of MIDI files in order to see the note+-- events. -- -------------------------------------------------------------------------------- @@ -70,7 +76,7 @@ --------------------------------------------------------------------------------  column2 :: String -> Doc -> Doc-column2 s d2 = padr 20 (text s) `cat` char '|' `ssep` d2 +column2 s d2 = padr 20 (text s) `cat` char '|' `sep` d2   ppFormat :: MidiFormat -> Doc ppFormat = column2 "MIDI Format" . step @@ -85,19 +91,19 @@ ppTimeDivision :: MidiTimeDivision -> Doc ppTimeDivision = column2 "Time Division" . step   where-    step (FPS i)   = text "fps"   `ssep` integral i-    step (TPB i)   = text "ticks" `ssep` integral i+    step (FPS i)   = text "fps"   `sep` integral i+    step (TPB i)   = text "ticks" `sep` integral i  infixr 7 `dashsep`  dashsep :: Doc -> Doc -> Doc-dashsep d1 d2 = d1 `ssep` char '-' `ssep` d2+dashsep d1 d2 = d1 `sep` char '-' `sep` d2  message :: Word32 -> MidiMessage -> (Word32,Doc) message acc (delta,evt) =      (n, acctime `dashsep` dtime `dashsep` ppEvent evt)   where-    n             = acc + fromIntegral delta +    n       = acc + fromIntegral delta      acctime = padl 12 (integral n)     dtime   = padl 6  (integral delta) @@ -118,25 +124,25 @@  ppVoiceEvent :: MidiVoiceEvent -> Doc ppVoiceEvent (Controller c n v)     = -    event "controller" (hex2 c `ssep` hex2 n `ssep` hex2 v)+    event "controller" (hex2 c `sep` hex2 n `sep` hex2 v)  ppVoiceEvent (ProgramChange c n)    = -    event "program-change" (hex2 c `ssep` hex2 n)+    event "program-change" (hex2 c `sep` hex2 n)  ppVoiceEvent (NoteOff c n v)        =-    event "note-off" (hex2 c `ssep` hex2 n `ssep` hex2 v)+    event "note-off" (hex2 c `sep` hex2 n `sep` hex2 v)  ppVoiceEvent (NoteOn c n v)         = -    event "note-on" (hex2 c `ssep` hex2 n `ssep` hex2 v)+    event "note-on" (hex2 c `sep` hex2 n `sep` hex2 v)  ppVoiceEvent (NoteAftertouch c n v) =-    event "note-aftertouch" (hex2 c `ssep` hex2 n `ssep` hex2 v)+    event "note-aftertouch" (hex2 c `sep` hex2 n `sep` hex2 v)  ppVoiceEvent (ChanAftertouch c v)   = -    event "channel-aftertouch" (hex2 c `ssep` hex2 v)+    event "channel-aftertouch" (hex2 c `sep` hex2 v)  ppVoiceEvent (PitchBend c v)        =-    event "pitch-bend" (hex2 c `ssep` hex4 v)+    event "pitch-bend" (hex2 c `sep` hex4 v)   ppSysExEvent :: MidiSysExEvent -> Doc@@ -148,25 +154,28 @@     event "time-code-quarter-frame" (hex2 sb)  ppSysCommonEvent (SongPosPointer a b)   = -    event "sys-common song pos. pointer" (hex2 a `ssep` hex2 b)+    event "sys-common song pos. pointer" (hex2 a `sep` hex2 b)  ppSysCommonEvent (SongSelect w)         = event "song-select" (hex2 w) -ppSysCommonEvent (Common_undefined tag) = event "sys-common" (hex2 tag)+ppSysCommonEvent (UndefinedF4)          = text "undefined 0xF4" -ppSysCommonEvent TuneRequest            = text "tune-request"+ppSysCommonEvent (UndefinedF5)          = text "undefined 0xF5" -ppSysCommonEvent EOX                    = text "end-of-sys-ex"+ppSysCommonEvent (TuneRequest)          = text "tune-request" +ppSysCommonEvent (EOX)                  = text "end-of-sys-ex" + ppSysRealTimeEvent :: MidiSysRealTimeEvent -> Doc-ppSysRealTimeEvent TimingClock          = text "sys-real-time timing-clock"-ppSysRealTimeEvent (RT_undefined tag)   = event "sys-real-time" (hex2 tag)-ppSysRealTimeEvent StartSequence        = text "sys-real-time start"-ppSysRealTimeEvent ContinueSequence     = text "sys-real-time continue"-ppSysRealTimeEvent StopSequence         = text "sys-real-time stop"-ppSysRealTimeEvent ActiveSensing        = text "sys-real-time active sensing"-ppSysRealTimeEvent SystemReset          = text "system-reset"+ppSysRealTimeEvent (TimingClock)        = text "sys-real-time timing-clock"+ppSysRealTimeEvent (UndefinedF9)        = text "sys-real-time 0xF9"+ppSysRealTimeEvent (StartSequence)      = text "sys-real-time start"+ppSysRealTimeEvent (ContinueSequence)   = text "sys-real-time continue"+ppSysRealTimeEvent (StopSequence)       = text "sys-real-time stop"+ppSysRealTimeEvent (UndefinedFD)        = text "sys-real-time 0xFD"+ppSysRealTimeEvent (ActiveSensing)      = text "sys-real-time active sensing"+ppSysRealTimeEvent (SystemReset)        = text "system-reset"   ppMetaEvent :: MidiMetaEvent -> Doc@@ -175,7 +184,7 @@ ppMetaEvent (SequenceNumber w)        = event "sequence-number" (hex4 w)  ppMetaEvent (ChannelPrefix a b)       = -    event "channel-prefix" (hex2 a `ssep` hex2 b)+    event "channel-prefix" (hex2 a `sep` hex2 b)  ppMetaEvent (MidiPort w)              = event "midi-port" (hex2 w) @@ -190,17 +199,17 @@     event "time-signature" (mconcat $ map hex2 [n,d,m,t])  ppMetaEvent (KeySignature n sc)       = -    event "key-signature" (integral n `ssep` ppScale sc)+    event "key-signature" (integral n `sep` ppScale sc)  ppMetaEvent (SSME n ws)               =      event "sequencer-specific" (byteList n ws)  ppMetaEvent (MetaOther ty len ws)     =-    event "meta-other" (hex2 ty `ssep` byteList len ws)+    event "meta-other" (hex2 ty `sep` byteList len ws)  byteList :: (Show a, Integral a) => a -> [Word8] -> Doc  byteList n ws | n < 10    = integral n `cat` mconcat (map hex2 ws)-              | otherwise = integral n `cat` multiply 10 '.'+              | otherwise = integral n `cat` repeatChar 10 '.'   textType :: MidiTextType -> String@@ -214,6 +223,6 @@     ppScale :: MidiScaleType -> Doc-ppScale MAJOR  = text "major"-ppScale MINOR  = text "minor"-ppScale (SCALE_OTHER i) = text "unrecognized scale" `ssep` hex2 i+ppScale (MAJOR)         = text "major"+ppScale (MINOR)         = text "minor"+ppScale (SCALE_OTHER i) = text "unrecognized scale" `sep` hex2 i

@@ -10,8 +10,13 @@ -- Stability   :  unstable -- Portability :  As per dependencies. ----- A MIDI file parser. +-- A top down (Parsec style) MIDI file parser.  --+-- For valid input, the parser should parse without error +-- (i.e all cases of event types are fully enumerated). +-- Malformed input (syntactically bad events, or truncated data) +-- will cause fatal parse errors.+-- --------------------------------------------------------------------------------  module ZMidi.Core.ReadFile @@ -37,7 +42,8 @@ import qualified Data.ByteString.Lazy   as L import Data.Word -+-- | Read a well formed MIDI file. +--  readMidi :: FilePath -> IO (Either ParseErr MidiFile) readMidi filename =     liftM (runParser `flip` midiFile) (L.readFile filename)@@ -57,9 +63,10 @@     trackCount (MidiHeader _ n _) = fromIntegral n  header :: ParserM MidiHeader  -header = MidiHeader <$> (assertString "MThd" *> assertWord32 (6::Int) *> format)-                    <*> word16be-                    <*> timeDivision+header = +    MidiHeader <$> (assertString "MThd" *> assertWord32 (6::Int) *> fileFormat)+               <*> word16be+               <*> timeDivision   @@ -81,48 +88,66 @@ deltaTime :: ParserM DeltaTime deltaTime = "delta time" <??> fmap fromIntegral getVarlen +-- | Parse an event - for valid input this function should parse+-- without error (i.e all cases of event types are fully +-- enumerated). +--+-- Malformed input (syntactically bad events, or truncated data) +-- can cause fatal parse errors.+-- event :: ParserM MidiEvent event = word8 >>= step   where     -- 00..7f  -- /data/-    step n | n    == 0xFF   = MetaEvent        <$> (word8 >>= metaEvent)-           | 0xF8 <= n      = SysRealTimeEvent <$> sysRealTimeEvent n-           | 0xF1 <= n      = SysCommonEvent   <$> sysCommonEvent n-           | n    == 0xF0   = SysExEvent       <$> sysExEvent-           | 0x80 <= n      = VoiceEvent       <$> voiceEvent (splitByte n)-           | otherwise      = DataEvent        <$> dataEvent n+    step n | n == 0xFF  = MetaEvent        <$> (word8 >>= metaEvent)+           | n >= 0xF8  = SysRealTimeEvent <$> sysRealTimeEvent n+           | n >= 0xF1  = SysCommonEvent   <$> sysCommonEvent n+           | n == 0xF0  = SysExEvent       <$> sysExEvent+           | n >= 0x80  = VoiceEvent       <$> voiceEvent (splitByte n)+           | otherwise  = DataEvent        <$> dataEvent n  dataEvent :: Word8 -> ParserM MidiDataEvent dataEvent tag = pure $ MidiDataEvent tag      +-- | Input is a contiguous sequence 0x80 to 0xE0 (considering +-- just the top half-byte) so any match failure indicates this +-- parser is called with an invalid argument - either the +-- splitByte function or the event parser is wrong.+-- voiceEvent :: SplitByte -> ParserM MidiVoiceEvent-voiceEvent (SB 0x8 ch)  = +voiceEvent (SB 0x80 ch)  =      "note-off"          <??> (NoteOff ch)        <$> word8 <*> word8 -voiceEvent (SB 0x9 ch)  = +voiceEvent (SB 0x90 ch)  =      "note-on"           <??> (NoteOn ch)         <$> word8 <*> word8 -voiceEvent (SB 0xA ch)  = +voiceEvent (SB 0xA0 ch)  =      "note aftertouch"   <??> (NoteAftertouch ch) <$> word8 <*> word8     -voiceEvent (SB 0xB ch)  = +voiceEvent (SB 0xB0 ch)  =      "controller"        <??> (Controller ch)     <$> word8 <*> word8 -voiceEvent (SB 0xC ch)  = +voiceEvent (SB 0xC0 ch)  =      "program change"    <??> (ProgramChange ch)  <$> word8  -voiceEvent (SB 0xD ch)  = +voiceEvent (SB 0xD0 ch)  =      "chan aftertouch"   <??> (ChanAftertouch ch) <$> word8  -voiceEvent (SB 0xE ch)  = +voiceEvent (SB 0xE0 ch)  =      "pitch bend"        <??> (PitchBend ch)      <$> word16be -voiceEvent (SB z   _ )  = reportError $ "voiceEvent " ++ hexStr z +-- This is an /impossible/ match - to get here either @splitByte@ +-- or the pattern match of @step@ in @event@ would be wrong.+voiceEvent (SB z   _ )  = impossibleMatch $ "voiceEvent " ++ hexStr z    +-- | Input is a contiguous sequence 0xF1 to 0xF7 so any match +-- failure indicates this parser is called with an invalid +-- argument (i.e. the event parser is wrong).+-- sysCommonEvent :: Word8 -> ParserM MidiSysCommonEvent sysCommonEvent 0xF1     =      "quarter frame"     <??> QuarterFrame                  <$> word8@@ -133,36 +158,45 @@ sysCommonEvent 0xF3     =      "song select"       <??> SongSelect                    <$> word8 -sysCommonEvent 0xF4     = pure $ Common_undefined 0xF4+sysCommonEvent 0xF4     = pure UndefinedF4 -sysCommonEvent 0xF5     = pure $ Common_undefined 0xF5+sysCommonEvent 0xF5     = pure UndefinedF5  sysCommonEvent 0xF6     = pure TuneRequest  sysCommonEvent 0xF7     = pure EOX -sysCommonEvent tag      = pure $ Common_undefined tag+sysCommonEvent tag      = impossibleMatch $ "sysCommonEvent " ++ hexStr tag  +-- | Input is a contiguous sequence 0xF8 to 0xFF so any match +-- failure indicates this parser is called with an invalid +-- argument (i.e. the event parser is wrong).+-- sysRealTimeEvent :: Word8 -> ParserM MidiSysRealTimeEvent sysRealTimeEvent 0xF8 = pure TimingClock-sysRealTimeEvent 0xF9 = pure $ RT_undefined 0xF9+sysRealTimeEvent 0xF9 = pure UndefinedF9 sysRealTimeEvent 0xFA = pure StartSequence sysRealTimeEvent 0xFB = pure ContinueSequence sysRealTimeEvent 0xFC = pure StopSequence-sysRealTimeEvent 0xFD = pure $ RT_undefined 0xFD+sysRealTimeEvent 0xFD = pure UndefinedFD sysRealTimeEvent 0xFE = pure ActiveSensing sysRealTimeEvent 0xFF = pure SystemReset-sysRealTimeEvent tag  = pure $ RT_undefined tag+sysRealTimeEvent tag  = impossibleMatch $ "sysRealTimeEvent " ++ hexStr tag   +-- | 0xF0 has been parsed, SysEx is uninterpreted.+-- sysExEvent :: ParserM MidiSysExEvent sysExEvent = "sys-ex" <??> getVarlenBytes SysEx  --- FF and the "type" byte already parsed, input to this function --- is the type byte.+-- | 0xFF and the "type" byte already parsed, input to this +-- function is the type byte. --+-- Not all MetaEvents are enumerated - unrecognized ones are +-- delegated to @MetaOther@.+-- metaEvent :: Word8 -> ParserM MidiMetaEvent metaEvent 0x00          =      "sequence number"   <??> SequenceNumber <$> (assertWord8 2 *> word16be)@@ -211,13 +245,13 @@                             -format :: ParserM MidiFormat-format = word16be >>= fn +fileFormat :: ParserM MidiFormat+fileFormat = word16be >>= fn    where      fn 0 = return MF0     fn 1 = return MF1     fn 2 = return MF2-    fn z = reportError $ +    fn z = fatalError $                "getFormat - unrecognized file format " ++ hexStr z          timeDivision :: ParserM MidiTimeDivision@@ -240,6 +274,10 @@ -------------------------------------------------------------------------------- -- helpers ++impossibleMatch :: String -> ParserM a+impossibleMatch ss = fatalError $ +    "impossible match: " ++ ss ++ "\nSeeing this is a error in ReadFile."   assertWord8 :: Word8 -> ParserM Word8 assertWord8 i = postCheck word8 (==i) msg@@ -272,7 +310,7 @@     step1     = word8 >>= \a -> if high a then step2 a else return (V1 a)     step2 a   = word8 >>= \b -> if high b then step3 a b else return (V2 a b)     step3 a b = word8 >>= \c -> if high c then do { d <- word8-                                                  ; return (V4 a b c d)}+                                                  ; return (V4 a b c d) }                                           else return (V3 a b c)    @@ -280,6 +318,7 @@  -- | Apply parse then apply the check, if the check fails report -- the error message. +-- postCheck :: ParserM a -> (a -> Bool) -> String -> ParserM a postCheck p check msg = p >>= \ans -> -    if check ans then return ans else reportError msg+    if check ans then return ans else fatalError msg

@@ -22,7 +22,7 @@  -- | Version number ----- > (0,4,0)+-- > (0,5,0) -- zmidi_core_version :: (Int,Int,Int)-zmidi_core_version = (0,4,0)+zmidi_core_version = (0,5,0)

@@ -34,7 +34,8 @@  import System.IO -+-- | Write a MIDI file.+-- writeMidi :: FilePath -> MidiFile -> IO () writeMidi filename midi =      openBinaryFile filename WriteMode        >>= \hdl -> @@ -123,24 +124,28 @@ putSysCommonEvent (SongSelect w)           =      putWord8 0xF3 *> putWord8 w -putSysCommonEvent (Common_undefined tag)   = -    putWord8 tag+putSysCommonEvent (UndefinedF4)            = +    putWord8 0xF4 +putSysCommonEvent (UndefinedF5)            = +    putWord8 0xF5+ putSysCommonEvent TuneRequest              =      putWord8 0xF6 -putSysCommonEvent EOX                      = +putSysCommonEvent (EOX)                    =      putWord8 0xF7   putSysRealTimeEvent :: MidiSysRealTimeEvent -> PutM ()-putSysRealTimeEvent TimingClock            = putWord8 0xF8-putSysRealTimeEvent (RT_undefined tag)     = putWord8 tag-putSysRealTimeEvent StartSequence          = putWord8 0xFA-putSysRealTimeEvent ContinueSequence       = putWord8 0xFB-putSysRealTimeEvent StopSequence           = putWord8 0xFC-putSysRealTimeEvent ActiveSensing          = putWord8 0xFE-putSysRealTimeEvent SystemReset            = putWord8 0xFF+putSysRealTimeEvent (TimingClock)          = putWord8 0xF8+putSysRealTimeEvent (UndefinedF9)          = putWord8 0xF9+putSysRealTimeEvent (StartSequence)        = putWord8 0xFA+putSysRealTimeEvent (ContinueSequence)     = putWord8 0xFB+putSysRealTimeEvent (StopSequence)         = putWord8 0xFC+putSysRealTimeEvent (UndefinedFD)          = putWord8 0xFD+putSysRealTimeEvent (ActiveSensing)        = putWord8 0xFE+putSysRealTimeEvent (SystemReset)          = putWord8 0xFF   putMetaEvent :: MidiMetaEvent -> PutM ()

@@ -1,5 +1,5 @@ name:             zmidi-core-version:          0.4.0+version:          0.5.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -13,6 +13,22 @@   dependencies only on ByteString and Data.Binary.   .   Changelog:+  .+  v0.4.0 to v0.5.0:+  .+  * Changed order of @MidiVoiceEnvent@ constructors so the Ord +    instance follows the order of the /tag/ in the MIDI binary+    representation.+  . +  * Changed @MidiSysCommonEvent@ to have different constructors +    for unidentified F4 anf F5 events.   +  .+  * Changed @MidiSysRealTimeEvent@ to have different constructors+    for unidentified F9 and FD events.  +  . +  * Added more Haddock docs.+  .+  * Various internal code changes.   .   v0.3.0 to v0.4.0:   .