zmidi-core 0.6.0 → 0.7.0
raw patch · 19 files changed
+1463/−340 lines, 19 filesdep +containers
Dependencies added: containers
Files
- CHANGES +21/−0
- demo/MidiCopy.hs +11/−4
- demo/MidiPrint.hs +57/−8
- demo/MidiTune.hs +10/−10
- src/ZMidi/Core.hs +7/−3
- src/ZMidi/Core/Canonical.hs +7/−4
- src/ZMidi/Core/Datatypes.hs +46/−22
- src/ZMidi/Core/Internal/ExtraTypes.hs +1/−1
- src/ZMidi/Core/Internal/ParserMonad.hs +30/−4
- src/ZMidi/Core/Internal/SimpleFormat.hs +255/−46
- src/ZMidi/Core/Pretty.hs +191/−152
- src/ZMidi/Core/Pretty/Ascii.hs +222/−0
- src/ZMidi/Core/Pretty/Csv.hs +234/−0
- src/ZMidi/Core/Pretty/Internal.hs +107/−0
- src/ZMidi/Core/Pretty/Interp.hs +141/−0
- src/ZMidi/Core/ReadFile.hs +51/−11
- src/ZMidi/Core/VersionNumber.hs +3/−3
- src/ZMidi/Core/WriteFile.hs +42/−19
- zmidi-core.cabal +27/−53
CHANGES view
@@ -1,4 +1,25 @@ ++0.6.0 to 0.7.0:++ * Changed @ChannelPrefix@ constructor to have a single + argument - channel number (previously it stored a constant + tag 0x01 as well as channel number).++ * Added @SysExCont@ and @SysExEscape@ constructors to the + @MidiSysExEvent@ data type.++ * Added new pretty printers - @Csv@ based on @midicsv@ and + @Ascii@ based on the ASCII MIDI representation in the book + Beyond Midi (the zmidi ASCII representation is simplified).+ The demo application @MidiPrint@ now allows choice of pretty+ printer.++ * @printMidiHeader@ and @printMidiTrack@ from @Pretty@ changed+ to MidiFiles as arguments, @printMidi@ has now become + @putMidi@.++ 0.5.0 to 0.6.0: * Extended the parser and changed the syntax tree to interpret
demo/MidiCopy.hs view
@@ -1,6 +1,6 @@ {-# OPTIONS -Wall #-} --- Read a MIDI file, output the syntax tree.+-- Read a MIDI file, build a syntax tree and encode it again. -- Are the files the same? @@ -19,8 +19,11 @@ _ -> mapM_ putStrLn $ [ "Usage: MidiCopy <filename>" , "--"- , "Read the file, building a syntax tree, print the syntax tree."+ , "Read the file, building a syntax tree, generate binary output"+ , "from the syntax tree."+ , "" , "Tests that read and write are isomorphic." + , "" ] @@ -29,7 +32,11 @@ ans <- readMidi filename case ans of Left err -> print err- Right a -> do { mapM_ putStrLn $ printMidiHeader $ mf_header a- ; writeMidi (filename ++ ".001") a }+ Right mfile -> let outfile = filename ++ ".001"+ in do { mapM_ putStrLn $ printMidiHeader mfile+ ; putStrLn ""+ ; writeMidi outfile mfile+ ; putStrLn $ "Wrote file: " ++ outfile+ }
demo/MidiPrint.hs view
@@ -5,26 +5,75 @@ -- Note - GHC (Windows at least) appears to throw an error if -- the copyright symbol is used a Text meta-event. ++ module Main where import ZMidi.Core +import System.Console.GetOpt import System.Environment+import System.Exit ++header :: String +header = unlines $ + [ "Usage: MidiPrint --format=... <filename>"+ , ""+ , "Formats are 'csv', 'ascii', 'original'."+ ]++help_message :: String+help_message = unlines $ + [ "Decode binary MIDI files." ]+++data Flag = Usage+ | OutFormat String+ deriving (Eq, Show)+++options :: [OptDescr Flag]+options =+ [ Option ['h'] ["help"] (NoArg Usage) help_message+ , Option ['f'] ["format"] (ReqArg OutFormat "original") "output format"+ ]+ main :: IO () main = do args <- getArgs- case args of- [path] -> process path- _ -> putStrLn "Usage: MidiPrint <filename>"+ let (opts, nonopts, errs) = getOpt Permute options args+ main2 opts nonopts errs -process :: FilePath -> IO ()-process filename = do++main2 :: [Flag] -> [FilePath] -> [String] -> IO ()+main2 opts _ _ + | Usage `elem` opts = midiPrintExit $ usageInfo header options+main2 [OutFormat ss] [infile] [] = process ss infile+main2 [] [infile] [] = process "original" infile+main2 _ _ errs = + midiPrintExitFail 1 (concat errs ++ usageInfo header options)+++midiPrintExit :: String -> IO ()+midiPrintExit s = putStrLn s >> exitWith ExitSuccess++midiPrintExitFail :: Int -> String -> IO ()+midiPrintExitFail i s = putStrLn s >> exitWith (ExitFailure i)+++process :: String -> FilePath -> IO ()+process fmt filename = do ans <- readMidi filename case ans of- Left (ParseErr n msg) -> - putStrLn $ "Parse failure at " ++ show n ++ ": " ++ msg- Right m -> printMidi m+ Left (ParseErr n msg) ->+ midiPrintExitFail 1 $ "Parse failure at " ++ show n ++ ": " ++ msg+ Right m -> outputMidi fmt m +outputMidi :: String -> (MidiFile -> IO ())+outputMidi "csv" = putCsv+outputMidi "ascii" = putAscii+outputMidi "original" = putMidi+outputMidi _ = const $ putStrLn "Unrecognized output format."
demo/MidiTune.hs view
@@ -19,6 +19,7 @@ main = do createDirectoryIfMissing True "./out/" writeMidi "./out/midi_tune.mid" midi_tune01+ putStrLn "Wrote file: ./out/midi_tune.mid" midi_tune01 :: MidiFile@@ -36,16 +37,15 @@ sound_track = MidiTrack [ (0, MetaEvent $ TextEvent SEQUENCE_NAME "Track 1") , (0, MetaEvent $ SetTempo 500000)- , (0, VoiceEvent $ NoteOn 0 60 127)- , (480, VoiceEvent $ NoteOff 0 60 15)- , (0, VoiceEvent $ NoteOn 0 62 127)- , (480, VoiceEvent $ NoteOff 0 62 15)- , (0, VoiceEvent $ NoteOn 0 64 127)- , (480, VoiceEvent $ NoteOff 0 64 15)- , (0, VoiceEvent $ NoteOn 0 66 127)- , (480, VoiceEvent $ NoteOff 0 66 15)+ , (0, VoiceEvent RS_OFF $ NoteOn 0 60 127)+ , (480, VoiceEvent RS_OFF $ NoteOff 0 60 15)+ , (0, VoiceEvent RS_OFF $ NoteOn 0 62 127)+ , (480, VoiceEvent RS_OFF $ NoteOff 0 62 15)+ , (0, VoiceEvent RS_OFF $ NoteOn 0 64 127)+ , (480, VoiceEvent RS_OFF $ NoteOff 0 64 15)+ , (0, VoiceEvent RS_OFF $ NoteOn 0 66 127)+ , (480, VoiceEvent RS_OFF $ NoteOff 0 66 15) , (0, MetaEvent $ EndOfTrack) ]- - +
src/ZMidi/Core.hs view
@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : ZMidi.Core--- Copyright : (c) Stephen Tetley 2010-2012+-- Copyright : (c) Stephen Tetley 2010-2013 -- License : BSD3 -- -- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>@@ -21,19 +21,23 @@ module ZMidi.Core (+ module ZMidi.Core.Canonical , module ZMidi.Core.Datatypes , module ZMidi.Core.Pretty+ , module ZMidi.Core.Pretty.Ascii+ , module ZMidi.Core.Pretty.Csv , module ZMidi.Core.ReadFile , module ZMidi.Core.VersionNumber , module ZMidi.Core.WriteFile- - + ) where import ZMidi.Core.Canonical import ZMidi.Core.Datatypes import ZMidi.Core.Pretty+import ZMidi.Core.Pretty.Ascii+import ZMidi.Core.Pretty.Csv import ZMidi.Core.ReadFile import ZMidi.Core.VersionNumber import ZMidi.Core.WriteFile
src/ZMidi/Core/Canonical.hs view
@@ -1,10 +1,9 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : ZMidi.Core.Canonical--- Copyright : (c) Stephen Tetley 2012+-- Copyright : (c) Stephen Tetley 2012-2013 -- License : BSD3 -- -- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>@@ -21,13 +20,13 @@ module ZMidi.Core.Canonical ( -- canonical + canonical ) where import ZMidi.Core.Datatypes + -- | Convert an MidiFile into \"canonical\" form where any -- abbreviation introduced by Running Status is expanded. --@@ -52,4 +51,8 @@ transVoiceEvent :: MidiRunningStatus -> MidiVoiceEvent -> MidiVoiceEvent transVoiceEvent RS_ON (NoteOn ch pch 0) = NoteOff ch pch 0 transVoiceEvent _ evt = evt++++
src/ZMidi/Core/Datatypes.hs view
@@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module : ZMidi.Core.Datatypes--- Copyright : (c) Stephen Tetley 2010-2012+-- Copyright : (c) Stephen Tetley 2010-2013 -- License : BSD3 -- -- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>@@ -41,6 +41,7 @@ , MidiDataOther(..) , MidiVoiceEvent(..) , MidiSysExEvent(..)+ , MidiSysExContPacket(..) , MidiSysCommonEvent(..) , MidiSysRealTimeEvent(..) , MidiMetaEvent(..)@@ -59,8 +60,8 @@ -- from the previous event rather than an absolute time. -- -- DeltaTime is a newtype wrapper over Word32, note that in MIDI --- files it is represented as a @varlen@ to save space rather than --- a four byte number. +-- files it is represented as a @varlen@ to potentially save +-- space that would otherwise require a four byte number. -- newtype DeltaTime = DeltaTime { getDeltaTime :: Word32 } deriving (Enum,Eq,Ord,Num,Integral,Real)@@ -68,6 +69,8 @@ instance Show DeltaTime where showsPrec p = showsPrec p . getDeltaTime ++ -- | TagByte is an alias to 'Word8'. -- type TagByte = Word8@@ -213,7 +216,7 @@ | MetaEvent MidiMetaEvent - deriving (Eq,Show,Ord)+ deriving (Eq,Ord,Show) -- | Data events are events with tags from 0x00 to 0x7F. @@ -304,21 +307,43 @@ | PitchBend Word8 Word16 - deriving (Eq,Show,Ord)+ deriving (Eq,Ord,Show) -- | \SysEx\ - system exclusive event. -- data MidiSysExEvent- -- | SysEx event.+ + -- | Single SysEx event. -- -- > F0 * length * data -- -- An uninterpreted sys-ex event. --- = SysEx Word32 [Word8]- deriving (Eq,Show,Ord)+ = SysExSingle Word32 [Word8] + -- | SysEx sent as (non-standard) multiple continuation + -- packets.+ --+ -- > F0 * length * packet1 ... [SysExContPacket]+ --+ | SysExCont Word32 [Word8] [MidiSysExContPacket] + -- | Escape sequence of one-or-more SysEx events.+ --+ -- > F7 * length * data+ --+ | SysExEscape Word32 [Word8]+ deriving (Eq,Ord,Show)++-- | Continuation packet for a (non-standard) multi-part SysEx +-- event.+--+-- Apprently this format is use by Casio. +--+data MidiSysExContPacket = MidiSysExContPacket DeltaTime Word32 [Word8]+ deriving (Eq,Ord,Show)++ -- | System common event. -- -- Common information for all channels in a system. @@ -380,7 +405,7 @@ -- > F7 -- | EOX- deriving (Eq,Show,Ord)+ deriving (Eq,Ord,Show) -- | System real-time event.@@ -446,7 +471,7 @@ -- > FF -- | SystemReset- deriving (Eq,Show,Ord)+ deriving (Eq,Ord,Show) @@ -468,7 +493,7 @@ -- Free text field (e.g. copyright statement). The contents -- can notionally be any length. --- = TextEvent MidiTextType String+ = TextEvent MidiTextType String -- | Sequence Number -- @@ -483,7 +508,7 @@ -- The sequence number event should occur at the start of a -- track, before any non-zero time events. --- | SequenceNumber Word16+ | SequenceNumber Word16 -- | Channel prefix -- @@ -491,9 +516,7 @@ -- -- Relay all meta and sys-ex events to the given channel. --- -- The first byte should always be 1.- -- - | ChannelPrefix Word8 Word8+ | ChannelPrefix Word8 -- | Midi port -- @@ -513,7 +536,7 @@ -- -- > FF 51 03 * microseconds_per_quarter_note --- | SetTempo Word32+ | SetTempo Word32 -- | SMPTE offest -- @@ -523,13 +546,13 @@ -- should occur at the start of a track, before any non-zero -- time events. --- | SMPTEOffset Word8 Word8 Word8 Word8 Word8+ | SMPTEOffset Word8 Word8 Word8 Word8 Word8 -- | Time signature -- -- > FF 58 04 * numerator * denominator * metro * num_32nd_notes --- | TimeSignature Word8 Word8 Word8 Word8+ | TimeSignature Word8 Word8 Word8 Word8 -- | Key signature --@@ -540,7 +563,7 @@ -- -- @scale_type@ indicates major or minor. --- | KeySignature Int8 MidiScaleType+ | KeySignature Int8 MidiScaleType -- | SSME -- @@ -548,15 +571,16 @@ -- -- Sequencer specific meta-event - uninterpreted. --- | SSME Word32 [Word8]+ | SSME Word32 [Word8] -- | Unrecognized Meta Event -- -- > FF * type * length * data --- | MetaOther Word8 Word32 [Word8]+ | MetaOther Word8 Word32 [Word8] - deriving (Eq,Show,Ord)+ deriving (Eq,Ord,Show)+ -- | Scale type - @major@ or @minor@ or @SCALE_OTHER@. --
src/ZMidi/Core/Internal/ExtraTypes.hs view
@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : ZMidi.Core.Internal.ExtraTypes--- Copyright : (c) Stephen Tetley 2010+-- Copyright : (c) Stephen Tetley 2010-2013 -- License : BSD3 -- -- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>
src/ZMidi/Core/Internal/ParserMonad.hs view
@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : ZMidi.Core.Internal.ParseMonad--- Copyright : (c) Stephen Tetley 2010-2012+-- Copyright : (c) Stephen Tetley 2010-2013 -- License : BSD3 -- -- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>@@ -29,6 +29,7 @@ , setRunningEvent , peek+ , cond , dropW8 , word8 , int8@@ -38,6 +39,7 @@ , word32be , char8 + , (<??>) , fatalError @@ -45,7 +47,7 @@ , gencount , text , boundRepeat-+ , pair ) where@@ -155,6 +157,16 @@ Nothing -> (Left (ParseErr n "peek - no more data."), s) Just (a,_) -> (Right a, ParserState n rs bs) +-- | Conditionally get a Word8. Fails if input is finished.+-- Consumes data on if predicate succeeds, does not consume if+-- predicate fails.+--+cond :: (Word8 -> Bool) -> ParserM (Maybe Word8)+cond pf = ParserM $ \s@(ParserState n rs bs) -> case L.uncons bs of + Nothing -> (Left (ParseErr n "peek - no more data."), s)+ Just (a,bs1) -> if pf a then (Right $ Just a, ParserState (n+1) rs bs1)+ else (Right Nothing, ParserState n rs bs)+ -- | Drop a Word8. --@@ -278,21 +290,30 @@ } +-- | Run a parser twice, pairing the result.+--+pair :: ParserM a -> ParserM (a,a)+pair p = (,) <$> p <*> p -------------------------------------------------------------------------------- -- helpers -+-- | Take two elements from the ByteString.+-- uncons2 :: L.ByteString -> Maybe (Word8,Word8,L.ByteString) uncons2 bs = L.uncons bs >>= \(a,bs1) -> L.uncons bs1 >>= \(b,bs2) -> return (a,b,bs2) +-- | Take three elements from the ByteString.+-- uncons3 :: L.ByteString -> Maybe (Word8,Word8,Word8,L.ByteString) uncons3 bs = L.uncons bs >>= \(a,bs1) -> L.uncons bs1 >>= \(b,bs2) -> L.uncons bs2 >>= \(c,bs3) -> return (a,b,c,bs3) +-- | Take four elements from the ByteString.+-- uncons4 :: L.ByteString -> Maybe (Word8,Word8,Word8,Word8,L.ByteString) uncons4 bs = L.uncons bs >>= \(a,bs1) -> L.uncons bs1 >>= \(b,bs2) -> @@ -300,15 +321,20 @@ L.uncons bs3 >>= \(d,bs4) -> return (a,b,c,d,bs4) +-- | Build a Word16 (big endian).+-- w16be :: Word8 -> Word8 -> Word16 w16be a b = (shiftL `flip` 8 $ fromIntegral a) + fromIntegral b +-- | Build a Word24 (big endian).+-- w24be :: Word8 -> Word8 -> Word8 -> Word32 w24be a b c = (shiftL `flip` 16 $ fromIntegral a) + (shiftL `flip` 8 $ fromIntegral b) + fromIntegral c -+-- | Build a Word16 (big endian).+-- w32be :: Word8 -> Word8 -> Word8 -> Word8 -> Word32 w32be a b c d = (shiftL `flip` 24 $ fromIntegral a) + (shiftL `flip` 16 $ fromIntegral b)
src/ZMidi/Core/Internal/SimpleFormat.hs view
@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : ZMidi.Core.Internal.SimpleFormat--- Copyright : (c) Stephen Tetley 2010-2012+-- Copyright : (c) Stephen Tetley 2010-2013 -- License : BSD3 -- -- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>@@ -17,11 +17,27 @@ module ZMidi.Core.Internal.SimpleFormat ( - Doc+ ColumnSpecs(..) + , ColumnSpec(..)+ , Table+ , runTable+ , execTable+ , tellFree+ , tellRow+ , tellBlank+ , tellBreak+ , localColumns+ , nextTrack+ , arbTrack+ , incrDelta++ , WString+ + , width- , output+ , outputDoc - , cat+ , (<+>) , sep , char , text@@ -31,10 +47,14 @@ , padr , hex2 , hex4+ , int , integral ) where +++import Control.Applicative import Data.Monoid import Data.Word import Numeric@@ -47,20 +67,201 @@ type HString = H Char+type HLines = H String + -- | Make a HString of spaces. -- spaceH :: Int -> HString spaceH n = showString $ replicate n ' ' -+-- | Materialize a Hughes list.+-- fromH :: H a -> [a] fromH = ($ []) +-- | Empty Hughes list.+--+emptyH :: H a +emptyH = id+++-- | Snoc an element to the right end.+--+snocH :: H a -> a -> H a+snocH f a = f . (a:)++++--------------------------------------------------------------------------------++-- | Column formats for table printing.+--+data ColumnSpecs = ColumnSpecs { col_sep :: Char, col_fmts :: [ColumnSpec] }+ deriving (Eq,Show) ++-- | Print a column with left or right padding.+-- +data ColumnSpec = PadL Int | PadR Int+ deriving (Eq,Ord,Show)++-- | Internal state.+--+data St = St { get_tracknum :: !Int, get_acctime :: Integer }++-- | Initial state.+--+state_zero :: St+state_zero = St { get_tracknum = 0 + , get_acctime = 0+ }+ +-- | Monad for generating output as a table.+--+newtype Table a = Table { + getTable :: ColumnSpecs -> St -> HLines -> (St,HLines,a) }+++instance Functor Table where+ fmap f ma = Table $ \r s ac -> + let (s1,ac1,a) = getTable ma r s ac in (s1, ac1, f a)+++instance Applicative Table where+ pure a = Table $ \_ s ac -> (s,ac,a)+ mf <*> ma = Table $ \r s ac -> + let (s1,ac1,f) = getTable mf r s ac+ (s2,ac2,a) = getTable ma r s1 ac1+ in (s2,ac2,f a)++++instance Monad Table where+ return = pure+ ma >>= k = Table $ \r s ac -> + let (s1,ac1,a) = getTable ma r s ac in getTable (k a) r s1 ac1+++-- | Run the Table monad, returning both output and answer.+--+runTable :: ColumnSpecs -> Table a -> ([String],a)+runTable hdrs ma = + let (_,hf,a) = getTable ma hdrs state_zero emptyH in (fromH hf,a)+++-- | Exec the Table monad, returning just the output.+--+execTable :: ColumnSpecs -> Table a -> [String]+execTable hdrs = fst . runTable hdrs+++++-- | Tell a row with free formatting.+--+-- Row is actually a function : track_num * running_time -> WString+-- +tellFree :: (Int -> Integer -> WString) -> Table ()+tellFree wf = Table $ \_ s ac -> + let next = fromH $ doch $ wf (get_tracknum s) (get_acctime s)+ in (s, ac `snocH` next, ())+++-- | Tell a row with column formatting.+--+-- Row is actually a function : track_num * running_time -> [WString]+-- +tellRow :: (Int -> Integer -> [WString]) -> Table ()+tellRow wsf = Table $ \r s ac -> + let next = formatRow r $ wsf (get_tracknum s) (get_acctime s)+ in (s, ac `snocH` next, ())++-- | Tell a blank line.+--+tellBlank :: Table ()+tellBlank = Table $ \_ s ac -> let next = ""+ in (s, ac `snocH` next, ())++-- | Tell a breaking line (formatted as a dashed line). +--+tellBreak :: Table ()+tellBreak = Table $ \r s ac -> let next = formatBreak r+ in (s, ac `snocH` next, ())++-- | Run the Table monad with a local ColumnSpecs, cf. the+-- @local@ function of the Reader monad class.+--+localColumns :: ColumnSpecs -> Table a -> Table a+localColumns r1 ma = Table $ \_ s ac -> getTable ma r1 s ac+++-- | Proceed to the next track - reset running time.+--+nextTrack :: Table ()+nextTrack = Table $ \_ s ac -> (upd s, ac, ())+ where+ upd = (\s n -> s { get_tracknum = n+1, get_acctime = 0}) <*> get_tracknum++++-- | Proceed to an arbitrary track - reset running time.+--+arbTrack :: Int -> Table ()+arbTrack n = Table $ \_ _ ac -> + (St { get_tracknum = n, get_acctime = 0}, ac, ())++++-- | Increment runninf time.+--+incrDelta :: Integer -> Table ()+incrDelta dt = Table $ \_ s ac -> (upd s, ac, ())+ where+ upd = (\s n -> s { get_acctime = n + dt }) <*> get_acctime++-- | Helper for generating a line break+--+formatBreak :: ColumnSpecs -> String+formatBreak spec = replicate (lineLength spec) '-'+++-- | Helper for generating a row.+--+formatRow :: ColumnSpecs -> [WString] -> String+formatRow (ColumnSpecs ch fmts) ws = fromH $ doch $ step fmts ws+ where+ fmt1 = PadL 9+ -- if run out of formats use default...+ step [] xs = step [fmt1] xs+ step _ [] = mempty+ step (c:_) [x] = format1 c x+ step (c:cs) (x:xs) = let d1 = format1 c x; ds = step cs xs+ in sep ch d1 ds++-- | Helper for generating a single column.+--+format1 :: ColumnSpec -> WString -> WString+format1 (PadL n) w = if n > width w then padl n w else w+format1 (PadR n) w = if n > width w then padr n w else w+++-- | Calculate the line length.+--+lineLength :: ColumnSpecs -> Int+lineLength (ColumnSpecs _ fmts) = step 0 fmts+ where+ step w [] = w+ step w [x] = w + size x+ step w (x:xs) = step (w + size x + 1) xs++ size (PadL i) = i+ size (PadR i) = i++ -- | Docs represent a single line - they should not contain -- newlines. ---data Doc = Doc { +data WString = WString { -- | Width of the doc. width :: !Int, @@ -69,79 +270,87 @@ -- | Make a literal Doc from a String. ---doc :: String -> Doc-doc s = Doc (length s) (showString s) +wstring :: String -> WString+wstring s = WString (length s) (showString s) -- | Unwrap a Doc making a String. ---output :: Doc -> String-output = fromH . doch+outputDoc :: WString -> String+outputDoc = fromH . doch +-- | Concatenation is /directly next to/ i.e. no space.+--+instance Monoid WString where+ mempty = WString 0 id+ WString w1 f1 `mappend` WString w2 f2 = WString (w1+w2) (f1 . f2) -instance Monoid Doc where- mempty = Doc 0 id- Doc i1 f1 `mappend` Doc i2 f2 = Doc (i1+i2) (f1 . f2) -infixr 6 `cat`+infixr 6 <+> --- | Concatenate - no space.+-- | Concatenate two WStrings with a space between them. ---cat :: Doc -> Doc -> Doc-cat = mappend+(<+>) :: WString -> WString -> WString+(<+>) = sep ' ' -infixr 6 `sep` --- | Concatenate - with space.+-- | Concatenate - with a single character separator. ---sep :: Doc -> Doc -> Doc-sep (Doc i1 f1) (Doc i2 f2) = Doc (1+i1+i2) (f1 . (' ':) . f2)+sep :: Char -> WString -> WString -> WString+sep ch (WString w1 f1) (WString w2 f2) = WString (1+w1+w2) (f1 . (ch:) . f2) --- | Make a Doc from a Char.+-- | Make a WString from a Char. ---char :: Char -> Doc -char c = Doc 1 (c:)+char :: Char -> WString +char c = WString 1 (c:) --- | Make a Doc from a String.+-- | Make a WString from a String. ---text :: String -> Doc-text = doc +text :: String -> WString+text = wstring --- | Repeat the Char /n/ times to make a Doc.+-- | Repeat the Char /n/ times to make a WString. ---repeatChar :: Int -> Char -> Doc-repeatChar n c = Doc n (showString $ replicate n c)+repeatChar :: Int -> Char -> WString+repeatChar n c = WString 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+padl :: Int -> WString -> WString+padl i d@(WString n f) | i > n = WString 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+padr :: Int -> WString -> WString+padr i d@(WString n f) | i > n = WString 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) +hex2 :: Word8 -> WString+hex2 n | n < 0x10 = WString 2 (('0' :) . showHex n)+ | otherwise = WString 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) +hex4 :: Word16 -> WString+hex4 n | n < 0x10 = WString 4 (('0':) . ('0':) . ('0':) . showHex n)+ | n < 0x100 = WString 4 (('0':) . ('0':) . showHex n)+ | n < 0x1000 = WString 4 (('0':) . showHex n)+ | otherwise = WString 4 (showHex n) ++-- | Show an Int as a base 10 number.+--+int :: Int -> WString+int = wstring . show ++ -- | Show an Integral value as a base 10 number. ---integral :: (Show a, Integral a) => a -> Doc-integral = doc . show +integral :: (Show a, Integral a) => a -> WString+integral = wstring . show
src/ZMidi/Core/Pretty.hs view
@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : ZMidi.Core.Pretty--- Copyright : (c) Stephen Tetley 2010-2012+-- Copyright : (c) Stephen Tetley 2010-2013 -- License : BSD3 -- -- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>@@ -24,8 +24,8 @@ module ZMidi.Core.Pretty ( - printMidi-+ putMidi+ , printMidi , printMidiHeader , printMidiTrack @@ -33,25 +33,29 @@ import ZMidi.Core.Datatypes import ZMidi.Core.Internal.SimpleFormat+import ZMidi.Core.Pretty.Internal+import ZMidi.Core.Pretty.Interp -import Data.Char-import Data.List import Data.Monoid-import Data.Word +-- | Print the MIDI file to stdout.+--+-- One event is printed per line, so the output may be large.+--+putMidi :: MidiFile -> IO ()+putMidi = mapM_ putStrLn . printMidi --- | Print the MIDI file to std-out.++-- | Print the MIDI file to a list of Strings. ----- One event is printed per line, so the output may be huge.+-- Results are returned as a list of String to avoid extraneous+-- concatenation. ---printMidi :: MidiFile -> IO ()-printMidi (MidiFile hdr tracks) = do- column_break- mapM_ putStrLn (printMidiHeader hdr) - mapM_ (\t -> column_break >> putTrack t) tracks- where- putTrack = (mapM_ putStrLn) . printMidiTrack- column_break = putStrLn $ replicate 60 '-'+printMidi :: MidiFile -> [String]+printMidi (MidiFile hdr tracks) = execTable body_columns $ do + tellBreak+ tellMidiHeader hdr+ mapM_ (\t -> tellBreak >> tellTrack t) $ tracks -- | Print the MIDI header.@@ -59,190 +63,225 @@ -- Results are returned as a list of String to avoid extraneous -- concatenation. -- -printMidiHeader :: MidiHeader -> [String]-printMidiHeader (MidiHeader fmt tcount td) = - map output [ppFormat fmt, ppNumTracks tcount, ppTimeDivision td] +printMidiHeader :: MidiFile -> [String]+printMidiHeader (MidiFile hdr _) = execTable body_columns $ tellMidiHeader hdr + -- | Print a track. -- -- Results are returned as a list of String to avoid extraneous -- concatenation. ---printMidiTrack :: MidiTrack -> [String]-printMidiTrack = snd . mapAccumL fn 0 . getTrackMessages +printMidiTrack :: Int -> MidiFile -> [String]+printMidiTrack track_num (MidiFile _ trks) = + case findTrack track_num trks of+ Just trk -> execTable body_columns $ tellArbTrack track_num trk+ Nothing -> ["*** ERROR *** cannot find track " ++ show track_num ] where- fn acc b = msnd output $ message acc b- msnd f (a,b) = (a,f b)+ -- Numbering starts from 1..+ findTrack 1 (t:_) = Just t+ findTrack n (_:ts) | n > 1 = findTrack (n-1) ts+ findTrack _ _ = Nothing --------------------------------------------------------------------------------- -column2 :: String -> Doc -> Doc-column2 s d2 = padr 20 (text s) `cat` char '|' `sep` d2 -ppFormat :: MidiFormat -> Doc-ppFormat = column2 "MIDI Format" . step - where- step MF0 = text "Type 0 MIDI File"- step MF1 = text "Type 1 MIDI File"- step MF2 = text "Type 2 MIDI File"+--------------------------------------------------------------------------------+-- -ppNumTracks :: Word16 -> Doc-ppNumTracks = column2 "Number of tracks" . integral+-- | Helper for printing arbitrary tracks.+--+tellArbTrack :: Int -> MidiTrack -> Table ()+tellArbTrack track_num (MidiTrack xs) = arbTrack track_num >> mapM_ message xs -ppTimeDivision :: MidiTimeDivision -> Doc-ppTimeDivision = column2 "Time Division" . step- where- step (FPS i) = text "fps" `sep` integral i- step (TPB i) = text "ticks" `sep` integral i -infixr 7 `dashsep`+-- | Increment the track number (in the monad) and write a track.+--+tellTrack :: MidiTrack -> Table ()+tellTrack (MidiTrack xs) = nextTrack >> mapM_ message xs -dashsep :: Doc -> Doc -> Doc-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 - acctime = padl 12 (integral n)- dtime = padl 6 (integral delta)+-- | Column specs for the track tables.+--+body_columns :: ColumnSpecs+body_columns = + ColumnSpecs '|' [ PadR 3, PadL 14, PadL 11, PadR 23, PadR 23 ] -ppEvent :: MidiEvent -> Doc-ppEvent (MidiEventOther e) = ppMidiDataOther e-ppEvent (VoiceEvent rs e) = ppVoiceEvent rs e-ppEvent (SysExEvent e) = ppSysExEvent e-ppEvent (SysCommonEvent e) = ppSysCommonEvent e-ppEvent (SysRealTimeEvent e) = ppSysRealTimeEvent e-ppEvent (MetaEvent e) = ppMetaEvent e +-- | Log a message using the internal Writer of the Table monad.+--+message :: MidiMessage -> Table ()+message (delta,evt) = do + incrDelta $ fromIntegral delta+ tellRow $ \track_num acctime -> [ integral track_num+ , integral acctime+ , integral delta+ , descEvent evt+ , valEvent evt ]+ -event :: String -> Doc -> Doc-event s d = padr 18 (text s) `dashsep` d+--------------------------------------------------------------------------------+-- Description column -ppMidiDataOther :: MidiDataOther -> Doc-ppMidiDataOther (MidiDataOther n) = event "midi data other" (hex2 n)+-- | Get description text.+--+descEvent :: MidiEvent -> WString+descEvent (MidiEventOther e) = descDataOther e+descEvent (VoiceEvent rs e) = descVoiceEvent rs e+descEvent (SysExEvent e) = descSysExEvent e+descEvent (SysCommonEvent e) = descSysCommonEvent e+descEvent (SysRealTimeEvent e) = descSysRealTimeEvent e+descEvent (MetaEvent e) = descMetaEvent e --- | Voice event needs RunningStatus...+-- | Get description text.+--+descDataOther :: MidiDataOther -> WString+descDataOther (MidiDataOther {}) = text "midi data other" -ppVoiceEvent :: MidiRunningStatus -> MidiVoiceEvent -> Doc-ppVoiceEvent _ (Controller c n v) = - event "controller" (hex2 c `sep` hex2 n `sep` hex2 v) -ppVoiceEvent _ (ProgramChange c n) = - event "program-change" (hex2 c `sep` hex2 n)+-- | Get description text.+--+descVoiceEvent :: MidiRunningStatus -> MidiVoiceEvent -> WString+descVoiceEvent _ (Controller {}) = text "controller"+descVoiceEvent _ (ProgramChange {}) = text "program-change"+descVoiceEvent _ (NoteOff {}) = text "note-off" +descVoiceEvent rs (NoteOn _ _ v) + | rs == RS_ON && v == 0 = text "note-on *RS,V0*"+ | otherwise = text "note-on" -ppVoiceEvent _ (NoteOff c n v) =- event "note-off" (hex2 c `sep` hex2 n `sep` hex2 v) -ppVoiceEvent rs (NoteOn c n v) - | rs == RS_ON && v == 0 = event "note-off (RS,V0)" - (hex2 c `sep` hex2 n `sep` hex2 v)- | otherwise = event "note-on" (hex2 c `sep` hex2 n `sep` hex2 v)+-- | Get description text.+--+descVoiceEvent _ (NoteAftertouch {}) = text "note-aftertouch"+descVoiceEvent _ (ChanAftertouch {}) = text "channel-aftertouch"+descVoiceEvent _ (PitchBend {}) = text "pitch-bend" -ppVoiceEvent _ (NoteAftertouch c n v) =- event "note-aftertouch" (hex2 c `sep` hex2 n `sep` hex2 v)+-- | Get description text.+--+descSysExEvent :: MidiSysExEvent -> WString+descSysExEvent (SysExSingle {}) = text "sys-ex"+descSysExEvent (SysExCont {}) = text "sys-ex cont"+descSysExEvent (SysExEscape {}) = text "sys-ex F7" -ppVoiceEvent _ (ChanAftertouch c v) = - event "channel-aftertouch" (hex2 c `sep` hex2 v) -ppVoiceEvent _ (PitchBend c v) =- event "pitch-bend" (hex2 c `sep` hex4 v)+-- | Get description text.+--+descSysCommonEvent :: MidiSysCommonEvent -> WString+descSysCommonEvent (QuarterFrame {}) = text "time-code-1/4-frame"+descSysCommonEvent (SongPosPointer {}) = text "song position ptr"+descSysCommonEvent (SongSelect {}) = text "song-select"+descSysCommonEvent (UndefinedF4) = text "undefined 0xF4"+descSysCommonEvent (UndefinedF5) = text "undefined 0xF5"+descSysCommonEvent (TuneRequest) = text "tune-request"+descSysCommonEvent (EOX) = text "end-of-sys-ex" -ppSysExEvent :: MidiSysExEvent -> Doc-ppSysExEvent (SysEx n ws) = event "sys-ex" $ byteList n ws+-- | Get description text.+--+descSysRealTimeEvent :: MidiSysRealTimeEvent -> WString+descSysRealTimeEvent (TimingClock) = text "sysRT timing-clock"+descSysRealTimeEvent (UndefinedF9) = text "sysRT 0xF9"+descSysRealTimeEvent (StartSequence) = text "sysRT start seq."+descSysRealTimeEvent (ContinueSequence) = text "sysRT continue"+descSysRealTimeEvent (StopSequence) = text "sysRT stop seq."+descSysRealTimeEvent (UndefinedFD) = text "sysRT 0xFD"+descSysRealTimeEvent (ActiveSensing) = text "sysRT active sensing"+descSysRealTimeEvent (SystemReset) = text "sysRT reset" -ppSysCommonEvent :: MidiSysCommonEvent -> Doc-ppSysCommonEvent (QuarterFrame sb) = - event "time-code-quarter-frame" (hex2 sb)+-- | Get description text.+--+descMetaEvent :: MidiMetaEvent -> WString+descMetaEvent (TextEvent ty _) = text $ textType ty+descMetaEvent (SequenceNumber {}) = text "sequence-number"+descMetaEvent (ChannelPrefix {}) = text "channel-prefix"+descMetaEvent (MidiPort {}) = text "midi-port"+descMetaEvent (EndOfTrack) = text "end-of-track"+descMetaEvent (SetTempo {}) = text "set-tempo"+descMetaEvent (SMPTEOffset {}) = text "smpte-offest"+descMetaEvent (TimeSignature {}) = text "time-signature"+descMetaEvent (KeySignature {}) = text "key-signature"+descMetaEvent (SSME {}) = text "sequencer-specific"+descMetaEvent (MetaOther {}) = text "meta-other" -ppSysCommonEvent (SongPosPointer a b) = - event "sys-common song pos. pointer" (hex2 a `sep` hex2 b) -ppSysCommonEvent (SongSelect w) = event "song-select" (hex2 w)+--------------------------------------------------------------------------------+-- Value column -ppSysCommonEvent (UndefinedF4) = text "undefined 0xF4"+-- | Get formatted value.+--+valEvent :: MidiEvent -> WString+valEvent (MidiEventOther e) = valDataOther e+valEvent (VoiceEvent _ e) = valVoiceEvent e+valEvent (SysExEvent e) = valSysExEvent e+valEvent (SysCommonEvent e) = valSysCommonEvent e+valEvent (SysRealTimeEvent e) = valSysRealTimeEvent e+valEvent (MetaEvent e) = valMetaEvent e -ppSysCommonEvent (UndefinedF5) = text "undefined 0xF5" -ppSysCommonEvent (TuneRequest) = text "tune-request"+-- | Get formatted value.+--+valDataOther :: MidiDataOther -> WString+valDataOther (MidiDataOther n) = hex2 n -ppSysCommonEvent (EOX) = text "end-of-sys-ex" +-- | Get formatted value.+--+valVoiceEvent :: MidiVoiceEvent -> WString+valVoiceEvent (Controller c n v) = hex2 c <+> hex2 n <+> hex2 v+valVoiceEvent (ProgramChange c n) = hex2 c <+> hex2 n+valVoiceEvent (NoteOff c n v) = hex2 c <+> hex2 n <+> hex2 v+valVoiceEvent (NoteOn c n v) = hex2 c <+> hex2 n <+> hex2 v+valVoiceEvent (NoteAftertouch c n v) = hex2 c <+> hex2 n <+> hex2 v+valVoiceEvent (ChanAftertouch c v) = hex2 c <+> hex2 v+valVoiceEvent (PitchBend c v) = hex2 c <+> hex4 v -ppSysRealTimeEvent :: MidiSysRealTimeEvent -> Doc-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" +-- | Get formatted value.+--+valSysExEvent :: MidiSysExEvent -> WString+valSysExEvent (SysExSingle n ws) = byteList n ws+valSysExEvent (SysExCont n ws _) = byteList n ws+valSysExEvent (SysExEscape n ws) = byteList n ws -ppMetaEvent :: MidiMetaEvent -> Doc-ppMetaEvent (TextEvent ty s) = event (textType ty) (text $ safeString s) -ppMetaEvent (SequenceNumber w) = event "sequence-number" (hex4 w)+-- | Get formatted value.+--+valSysCommonEvent :: MidiSysCommonEvent -> WString+valSysCommonEvent (QuarterFrame sb) = hex2 sb+valSysCommonEvent (SongPosPointer a b) = hex2 a <+> hex2 b+valSysCommonEvent (SongSelect w) = hex2 w+valSysCommonEvent (UndefinedF4) = mempty+valSysCommonEvent (UndefinedF5) = mempty+valSysCommonEvent (TuneRequest) = mempty+valSysCommonEvent (EOX) = mempty -ppMetaEvent (ChannelPrefix a b) = - event "channel-prefix" (hex2 a `sep` hex2 b) -ppMetaEvent (MidiPort w) = event "midi-port" (hex2 w)--ppMetaEvent (EndOfTrack) = text "end-of-track"--ppMetaEvent (SetTempo w) = event "set-tempo" (integral w) --ppMetaEvent (SMPTEOffset h m s f sf) = - event "smpte-offest" (mconcat $ map hex2 [h,m,s,f,sf])--ppMetaEvent (TimeSignature n d m t) = - event "time-signature" (mconcat $ map hex2 [n,d,m,t])--ppMetaEvent (KeySignature n 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 `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` repeatChar 10 '.'+-- | Get formatted value.+--+valSysRealTimeEvent :: MidiSysRealTimeEvent -> WString+valSysRealTimeEvent _ = mempty -textType :: MidiTextType -> String-textType GENERIC_TEXT = "generic-text" -textType COPYRIGHT_NOTICE = "copyright-notice" -textType SEQUENCE_NAME = "sequence-name"-textType INSTRUMENT_NAME = "instrument-name"-textType LYRICS = "lyrics"-textType MARKER = "marker"-textType CUE_POINT = "cue-point"- --ppScale :: MidiScaleType -> Doc-ppScale (MAJOR) = text "major"-ppScale (MINOR) = text "minor"-ppScale (SCALE_OTHER i) = text "unrecognized scale" `sep` hex2 i+-- | Get formatted value.+--+valMetaEvent :: MidiMetaEvent -> WString+valMetaEvent (TextEvent _ s) = text $ safeString s+valMetaEvent (SequenceNumber w) = hex4 w+valMetaEvent (ChannelPrefix ch) = hex2 ch+valMetaEvent (MidiPort w) = hex2 w+valMetaEvent (EndOfTrack) = mempty+valMetaEvent (SetTempo w) = integral w+valMetaEvent (SMPTEOffset h m s f sf) = mconcat $ map hex2 [h,m,s,f,sf]+valMetaEvent (TimeSignature n d m t) = + let tsig = text $ timeSignatureName (fromIntegral n) (fromIntegral d)+ in tsig <+> hex2 m <+> hex2 t +valMetaEvent (KeySignature n sc) = + maybe (text "unrecognized") text $ midiScaleName sc (fromIntegral n) --- | This is a temporary hack - characters above ASCII 163--- cause an (invalid character) error when written to stdout.------ Make the string safe.----safeString :: String -> String-safeString = map (f . ord) - where- f i | i < 164 = chr i- | otherwise = '#'+valMetaEvent (SSME n ws) = byteList n ws+valMetaEvent (MetaOther ty len ws) = hex2 ty <+> byteList len ws
+ src/ZMidi/Core/Pretty/Ascii.hs view
@@ -0,0 +1,222 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : ZMidi.Core.Pretty.Ascii+-- Copyright : (c) Stephen Tetley 2013+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- Stability : unstable+-- Portability : As per dependencies.+--+-- Pretty print MIDI in format based on the /ASCII format/+-- in the book /Beyond MIDI/.+-- +--------------------------------------------------------------------------------+++module ZMidi.Core.Pretty.Ascii+ (++ putAscii+ , printAscii++ ) where++import ZMidi.Core.Datatypes+import ZMidi.Core.Internal.SimpleFormat+import ZMidi.Core.Pretty.Internal+import ZMidi.Core.Pretty.Interp++import Data.Monoid+import Data.Word+++-- | Print the MIDI file to stdout (ASCII format based on +-- output in the book Beyond MIDI).+--+-- One event is printed per line, so the output may be large.+--+putAscii :: MidiFile -> IO ()+putAscii = mapM_ putStrLn . printAscii+++-- | Print the MIDI file to a list of Strings (ASCII format based+-- on output in the book Beyond MIDI).+--+-- Results are returned as a list of String to avoid extraneous+-- concatenation.+--+printAscii :: MidiFile -> [String]+printAscii (MidiFile hdr tracks) = execTable body_columns $ do + tellBreak+ tellMidiHeader hdr+ tellBreak+ mapM_ (\t -> columnHeaders >> tellBreak >> tellTrack t >> tellBlank ) + tracks+++++--------------------------------------------------------------------------------+++-- | Increment the track number (in the monad) and write a track.+--+tellTrack :: MidiTrack -> Table ()+tellTrack (MidiTrack xs) = nextTrack >> mapM_ message xs+ ++-- | Column specs for the track tables.+--+body_columns :: ColumnSpecs+body_columns = + ColumnSpecs ' ' [ PadR 3 -- track no+ , PadR 15 -- event type+ , PadR 7 -- note name+ , PadL 7 -- key no+ , PadL 11 -- delta time+ , PadL 13 -- elapsed time+ , PadL 9 -- dynamic level (velocity) + ]+-- Note +-- Numbers generally look better PadL.+++-- | Log a message using the internal Writer of the Table monad.+--+message :: MidiMessage -> Table ()+message (delta,evt) = do + incrDelta $ fromIntegral delta+ tellRow $ \track_num acctime -> [ integral track_num+ , descEvent evt+ , eventNoteName evt+ , eventKeyNumber evt+ , integral delta+ , integral acctime+ , eventVelocity evt+ ]++-- | Log column headers.+--+columnHeaders :: Table ()+columnHeaders = tellRow $ \_ _ -> + map text [ "Trk"+ , "Event Type"+ , "Note" + , "Key no"+ , "Delta Time"+ , "Elapsed Time"+ , "Velocity" + ]++--------------------------------------------------------------------------------+-- Event type+++-- | Get the event type (description).+--+descEvent :: MidiEvent -> WString+descEvent (VoiceEvent rs e) = descVoiceEvent rs e+descEvent (MetaEvent e) = descMetaEvent e+descEvent _ = mempty+++-- | Get the event type (description).+--+descVoiceEvent :: MidiRunningStatus -> MidiVoiceEvent -> WString+descVoiceEvent _ (Controller {}) = text "Controller"+descVoiceEvent _ (ProgramChange {}) = text "Program change"+descVoiceEvent _ (NoteOff {}) = text "Note off" +descVoiceEvent rs (NoteOn _ _ v) + | rs == RS_ON && v == 0 = text "Note on*"+ | otherwise = text "Note on"++descVoiceEvent _ (NoteAftertouch {}) = text "Note aftertouch"+descVoiceEvent _ (ChanAftertouch {}) = text "Channel aftertouch"+descVoiceEvent _ (PitchBend {}) = text "Pitch bend"+++-- | Get the event type (description).+--+descMetaEvent :: MidiMetaEvent -> WString+descMetaEvent (TextEvent ty _) = text $ textType ty+descMetaEvent (SequenceNumber {}) = text "Sequence number"+descMetaEvent (ChannelPrefix {}) = text "Channel prefix"+descMetaEvent (MidiPort {}) = text "Midi port"+descMetaEvent (EndOfTrack) = text "End of track"+descMetaEvent (SetTempo {}) = text "Set tempo"+descMetaEvent (SMPTEOffset {}) = text "SMTPE offest"+descMetaEvent (TimeSignature {}) = text "Time signature"+descMetaEvent (KeySignature {}) = text "Key signature"+descMetaEvent (SSME {}) = text "SSME"+descMetaEvent (MetaOther {}) = text "Meta other"+++--------------------------------------------------------------------------------+-- Note Name++-- | Get the symbolic note name.+--+eventNoteName :: MidiEvent -> WString+eventNoteName (VoiceEvent _ e) = voiceEventNoteName e+eventNoteName _ = mempty++-- | Helper.+--+noteName :: Word8 -> WString+noteName = text . simpleNoteName . fromIntegral++-- | Get the symbolic note name.+--+voiceEventNoteName :: MidiVoiceEvent -> WString+voiceEventNoteName (Controller _ n _) = noteName n+voiceEventNoteName (ProgramChange _ n) = noteName n+voiceEventNoteName (NoteOff _ n _) = noteName n+voiceEventNoteName (NoteOn _ n _) = noteName n+voiceEventNoteName (NoteAftertouch _ n _) = noteName n+voiceEventNoteName (ChanAftertouch _ _) = mempty+voiceEventNoteName (PitchBend _ _) = mempty+++--------------------------------------------------------------------------------+-- Key Number++-- | Get the key number (aka MIDI pitch).+--+eventKeyNumber :: MidiEvent -> WString+eventKeyNumber (VoiceEvent _ e) = voiceEventKeyNumber e+eventKeyNumber _ = mempty++-- | Get the key number (aka MIDI pitch).+--+voiceEventKeyNumber :: MidiVoiceEvent -> WString+voiceEventKeyNumber (Controller _ n _) = integral n+voiceEventKeyNumber (ProgramChange _ n) = integral n +voiceEventKeyNumber (NoteOff _ n _) = integral n +voiceEventKeyNumber (NoteOn _ n _) = integral n+voiceEventKeyNumber (NoteAftertouch _ n _) = integral n+voiceEventKeyNumber (ChanAftertouch _ _) = mempty+voiceEventKeyNumber (PitchBend _ _) = mempty++--------------------------------------------------------------------------------+-- Velocity++-- | Get the velocity.+--+eventVelocity :: MidiEvent -> WString+eventVelocity (VoiceEvent _ e) = voiceEventVelocity e+eventVelocity _ = mempty+++-- | Get the velocity.+--+voiceEventVelocity :: MidiVoiceEvent -> WString+voiceEventVelocity (Controller _ _ v) = integral v+voiceEventVelocity (ProgramChange _ _) = mempty+voiceEventVelocity (NoteOff _ _ v) = integral v +voiceEventVelocity (NoteOn _ _ v) = integral v+voiceEventVelocity (NoteAftertouch _ _ v) = integral v+voiceEventVelocity (ChanAftertouch _ v) = integral v+voiceEventVelocity (PitchBend _ v) = integral v
+ src/ZMidi/Core/Pretty/Csv.hs view
@@ -0,0 +1,234 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : ZMidi.Core.Pretty.Csv+-- Copyright : (c) Stephen Tetley 2013+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- Stability : unstable+-- Portability : As per dependencies.+--+-- Pretty print MIDI to CVS format based on @midicsv@.+--+--------------------------------------------------------------------------------+++module ZMidi.Core.Pretty.Csv+ (++ putCsv+ , printCsv++ ) where++import ZMidi.Core.Datatypes+import ZMidi.Core.Internal.SimpleFormat+import ZMidi.Core.Pretty.Internal+++import Data.Monoid+++-- | Print the MIDI file to stdout (CSV format).+--+-- One event is printed per line, so the output may be large.+--+putCsv :: MidiFile -> IO ()+putCsv = mapM_ putStrLn . printCsv++++-- | Print the MIDI file to a list of Strings (CSV format).+--+-- Results are returned as a list of String to avoid extraneous+-- concatenation.+--+printCsv :: MidiFile -> [String]+printCsv (MidiFile hdr tracks) = execTable body_columns $ do + tellHeader hdr+ mapM_ tellTrack tracks+++++--------------------------------------------------------------------------------++infixr 6 <%>++-- | Concatenate with a comma-space.+--+(<%>) :: WString -> WString -> WString+a <%> b = a <> char ',' <+> b+++-- | Tell MidiHeader.+--+tellHeader :: MidiHeader -> Table ()+tellHeader (MidiHeader fmt ntrks tdiv) = + tellFree $ \track_num acctime -> + int track_num <%> integral acctime <%> text "Header" + <%> int (fromEnum fmt) <%> integral ntrks + <%> division tdiv+ where+ division (FPS n) = integral n+ division (TPB n) = integral n++++-- | Tell a track.+--+tellTrack :: MidiTrack -> Table ()+tellTrack (MidiTrack xs) = nextTrack >> mapM_ message xs+ ++-- | Body is free-text (not tabular) so specify and arbitrary +-- long column.+--+body_columns :: ColumnSpecs+body_columns = + ColumnSpecs ' ' [ PadR 60 ]+++-- | Log a message.+--+message :: MidiMessage -> Table ()+message (delta,evt) = do+ incrDelta $ fromIntegral delta+ tellFree $ \track_num acctime -> + int track_num <%> integral acctime <%> ppEvent evt+++-- | Decode an Event.+--+ppEvent :: MidiEvent -> WString+ppEvent (MidiEventOther _) = text "Unrecognized_event_other"+ppEvent (VoiceEvent _ e) = ppVoiceEvent e+ppEvent (SysExEvent e) = ppSysExEvent e+ppEvent (SysCommonEvent e) = ppSysCommonEvent e+ppEvent (SysRealTimeEvent e) = ppSysRealTimeEvent e+ppEvent (MetaEvent e) = ppMetaEvent e++-- | Decode a VoiceEvent.+--+ppVoiceEvent :: MidiVoiceEvent -> WString+ppVoiceEvent (Controller c n v) = + text "Control_c" <%> integral c <%> integral n <%> integral v++ppVoiceEvent (ProgramChange c n) =+ text "Program_c" <%> integral c <%> integral n++ppVoiceEvent (NoteOff c n v) =+ text "Note_off_c" <%> integral c <%> integral n <%> integral v++ppVoiceEvent (NoteOn c n v) =+ text "Note_on_c" <%> integral c <%> integral n <%> integral v++ppVoiceEvent (NoteAftertouch c n v) =+ text "Poly_aftertouch_c" <%> integral c <%> integral n <%> integral v++ppVoiceEvent (ChanAftertouch c v) =+ text "Channel_aftertouch_c" <%> integral c <%> integral v++ppVoiceEvent (PitchBend c v) = + text "Pitch_bend_c" <%> integral c <%> integral v++++-- | Decode a SysEx Event.+--+ppSysExEvent :: MidiSysExEvent -> WString+ppSysExEvent (SysExSingle n _) = + text "System_exclusive" <%> integral n <%> text "..."++ppSysExEvent (SysExCont n _ _) =+ text "System_exclusive_continuation" <%> integral n <%> text "..."++ppSysExEvent (SysExEscape n _) =+ text "System_exclusive_escape" <%> integral n <%> text "..."+++-- | Decode a SysCommon Event.+--+ppSysCommonEvent :: MidiSysCommonEvent -> WString+ppSysCommonEvent (QuarterFrame sb) = + text "Quarter_frame_s" <%> integral sb++ppSysCommonEvent (SongPosPointer a b) =+ text "Song_position_pointer_s" <%> integral a <%> integral b+ +ppSysCommonEvent (SongSelect w) =+ text "Song_select_s" <%> integral w++ppSysCommonEvent (UndefinedF4) = + text "Undefined_s" <%> text "0xF4"++ppSysCommonEvent (UndefinedF5) = + text "Undefined_s" <%> text "0xF5"++ppSysCommonEvent (TuneRequest) = + text "Tune_request_s"++ppSysCommonEvent (EOX) = + text "EOX_s"++++-- | Decode a SysRealTime Event.+--+ppSysRealTimeEvent :: MidiSysRealTimeEvent -> WString+ppSysRealTimeEvent (TimingClock) = text "Timing_clock_s"+ppSysRealTimeEvent (UndefinedF9) = text "Undefined_s" <%> text "0xF9"+ppSysRealTimeEvent (StartSequence) = text "Start_sequence_s" +ppSysRealTimeEvent (ContinueSequence) = text "Continue_sequence_s"+ppSysRealTimeEvent (StopSequence) = text "Stop_sequence_s"+ppSysRealTimeEvent (UndefinedFD) = text "Undefined_s" <%> text "0xFD"+ppSysRealTimeEvent (ActiveSensing) = text "Active_sensing_s"+ppSysRealTimeEvent (SystemReset) = text "System_reset_s"++-- | Decode a Meta Event.+--+ppMetaEvent :: MidiMetaEvent -> WString+ppMetaEvent (TextEvent ty s) = ppTextEvent ty s+ppMetaEvent (SequenceNumber w) = text "Sequence_number" <%> integral w+ppMetaEvent (ChannelPrefix ch) = text "Channel_prefix" <%> integral ch+ppMetaEvent (MidiPort w) = text "MIDI_port" <%> integral w+ppMetaEvent (EndOfTrack) = text "End_track"+ppMetaEvent (SetTempo w) = text "Tempo" <%> integral w+ppMetaEvent (SMPTEOffset h m s f sf) = + text "SMTPE_offset" <%> integral h <%> integral m <%> integral s+ <%> integral f <%> integral sf++ppMetaEvent (TimeSignature n d m t) = + text "Time_signature" <%> integral n <%> integral d + <%> integral m <%> integral t++ppMetaEvent (KeySignature n sc) = + let scale = case sc of { MAJOR -> "major"+ ; MINOR -> "minor" + ; _ -> "unrecognized" }+ in text "Key_signature" <%> integral n <%> text scale++ppMetaEvent (SSME n _) = + text "Sequencer_specific" <%> integral n <%> text "..."++ppMetaEvent (MetaOther ty len _) = + text "Unknown_meta_event" <%> integral ty <%> integral len <%> text "..."+++-- | Avoid pernicious ASCII characters e.g. the copyright symbol.+--+safetext :: String -> WString+safetext = text . safeString++-- | Decode MIDI text.+--+ppTextEvent :: MidiTextType -> String -> WString+ppTextEvent GENERIC_TEXT s = text "Text_t" <%> safetext s+ppTextEvent COPYRIGHT_NOTICE s = text "Copyright_t" <%> safetext s+ppTextEvent SEQUENCE_NAME s = text "Sequence_name_t" <%> safetext s+ppTextEvent INSTRUMENT_NAME s = text "Instrument_name_t" <%> safetext s+ppTextEvent LYRICS s = text "Lyric_t" <%> safetext s+ppTextEvent MARKER s = text "marker" <%> safetext s+ppTextEvent CUE_POINT s = text "cue-point" <%> safetext s
+ src/ZMidi/Core/Pretty/Internal.hs view
@@ -0,0 +1,107 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : ZMidi.Core.Pretty.Internal+-- Copyright : (c) Stephen Tetley 2013+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- Stability : unstable+-- Portability : As per dependencies.+--+-- Helper functions to pretty print MIDI as text.+--+-- The functionality is unstable and may change between +-- releases however it is still exposed as it may be useful+-- for writing a custom pretty printer. +--+--------------------------------------------------------------------------------+++module ZMidi.Core.Pretty.Internal+ (++ midi_header_columns+ , tellMidiHeader++ , byteList+ , safeString+ , textType++ ) where++import ZMidi.Core.Datatypes+import ZMidi.Core.Internal.SimpleFormat+++import Data.Char+import Data.Monoid+import Data.Word++-- | Column specs for Header - Header is printed as simple +-- name-value pairs (2 columns).+--+midi_header_columns :: ColumnSpecs +midi_header_columns = ColumnSpecs '|' [ PadR 21, PadR 38 ] ++-- | Log the MidiHeader in the Table monad (cf. Writer).+--+tellMidiHeader :: MidiHeader -> Table ()+tellMidiHeader (MidiHeader fmt tcount td) = + localColumns midi_header_columns $ do+ tellRow $ \_ _ -> [ text "MIDI Format", ppFormat fmt ]+ tellRow $ \_ _ -> [ text "Number of tracks", integral tcount ]+ tellRow $ \_ _ -> [ text "Time Division", ppTimeDivision td ]+++-- | Decode MidiFormat.+--+ppFormat :: MidiFormat -> WString+ppFormat MF0 = text "Type 0 MIDI File"+ppFormat MF1 = text "Type 1 MIDI File"+ppFormat MF2 = text "Type 2 MIDI File"++-- | Decode TimeDivision.+--+ppTimeDivision :: MidiTimeDivision -> WString+ppTimeDivision (FPS i) = text "FPS" <+> integral i+ppTimeDivision (TPB i) = text "Ticks" <+> integral i+++--------------------------------------------------------------------------------+-- Helpers+++-- | Print a short byte-list as Hex. Byte-lists longer than +-- 10 chars are printed as ellipses.+--+byteList :: (Show a, Integral a) => a -> [Word8] -> WString+byteList n ws | n < 10 = integral n <+> mconcat (map hex2 ws)+ | otherwise = integral n <+> repeatChar 10 '.'+++-- | Decode Text Type+--+textType :: MidiTextType -> String+textType GENERIC_TEXT = "generic-text" +textType COPYRIGHT_NOTICE = "copyright-notice" +textType SEQUENCE_NAME = "sequence-name"+textType INSTRUMENT_NAME = "instrument-name"+textType LYRICS = "lyrics"+textType MARKER = "marker"+textType CUE_POINT = "cue-point"+ ++-- | Make a string safe for stdout.+-- +-- This is a temporary hack - characters above ASCII 163+-- cause an (invalid character) error when written to stdout +-- on Windows (Cygwin).+--+safeString :: String -> String+safeString = map (f . ord) + where+ f i | i < 164 = chr i+ | otherwise = '#'+
+ src/ZMidi/Core/Pretty/Interp.hs view
@@ -0,0 +1,141 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : ZMidi.Core.Pretty.Interp+-- Copyright : (c) Stephen Tetley 2013+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- Stability : unstable+-- Portability : As per dependencies.+--+-- Helper functions to pretty print MIDI as text.+--+-- The functionality is unstable and may change between +-- releases however it is still exposed as it may be useful+-- for writing a custom pretty printer. +--+--------------------------------------------------------------------------------+++module ZMidi.Core.Pretty.Interp+ (++ ScaleMap+ , scale_map++ , majorScaleName+ , minorScaleName++ , midiScaleName++ , simpleNoteName++ , timeSignature+ , timeSignatureName++ ) where+++import ZMidi.Core.Datatypes++import qualified Data.IntMap as IM+import Data.Ratio+++-- | Representation of scales mapping the number of accidentals +-- to (major,minor) key names.+--+type ScaleMap = IM.IntMap (String,String)++-- | Populated ScaleMap.+--+-- Positive numbers are number of sharps+-- Negative numbers are number of flats.+--+scale_map :: ScaleMap+scale_map = IM.fromList $ + [ (0, ("C", "A" ))+ , (1, ("G", "E" ))+ , (2, ("D", "B" ))+ , (3, ("A", "F#"))+ , (4, ("E", "C#"))+ , (5, ("B", "G#"))+ , (6, ("F#", "D#"))+ , (7, ("C#", "A#"))+ , (-1, ("F", "D" ))+ , (-2, ("Bb", "G" ))+ , (-3, ("Eb", "C" ))+ , (-4, ("Ab", "F" ))+ , (-5, ("Db", "Bb"))+ , (-6, ("Gb", "Eb"))+ , (-7, ("Cb", "Ab"))+ ] ++-- | Decode major scale name.+--+majorScaleName :: Int -> Maybe String+majorScaleName n = fmap (\(ss,_) -> ss ++ " major") $ IM.lookup n scale_map++ +-- | Decode minor scale name.+--+minorScaleName :: Int -> Maybe String+minorScaleName n = fmap (\(_,ss) -> ss ++ " minor") $ IM.lookup n scale_map+++-- | Decode scale name.+--+midiScaleName :: MidiScaleType -> Int -> Maybe String+midiScaleName (MAJOR) n = majorScaleName n+midiScaleName (MINOR) n = minorScaleName n+midiScaleName _ _ = Nothing++++-- | Decode simple note name.+--+-- Follows the example of the book /Beyond MIDI/ - there is +-- no enharmonic spelling, all black key notes are named as +-- their respective sharp note.+-- +simpleNoteName :: Int -> String+simpleNoteName n = + let (o,l) = n `divMod` 12 + ove = show $ o - 1+ in pch l ++ ove+ where+ pch 0 = "C"+ pch 1 = "C#"+ pch 2 = "D"+ pch 3 = "D#"+ pch 4 = "E"+ pch 5 = "F"+ pch 6 = "F#"+ pch 7 = "G"+ pch 8 = "G#"+ pch 9 = "A"+ pch 10 = "A#"+ pch 11 = "B"+ pch _ = "ERROR - simpleNoteName - impossible "+++-- | Decode a time signature.+-- +-- Returned as (numerator, denoimator) pair.+-- +timeSignature :: Int -> Int -> (Int,Int)+timeSignature nn dd = (nn, d1)+ where+ ddi :: Integer+ ddi = fromIntegral dd+ d1 :: Int+ d1 = fromIntegral $ denominator $ (2::Rational) ^^ (negate ddi)+++-- | Decode a time signature - and print.+--+timeSignatureName :: Int -> Int -> String+timeSignatureName nn dd = + let (ni,di) = timeSignature nn dd in show ni ++ "/" ++ show di
src/ZMidi/Core/ReadFile.hs view
@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : ZMidi.Core.ReadFile--- Copyright : (c) Stephen Tetley 2010-2012+-- Copyright : (c) Stephen Tetley 2010-2013 -- License : BSD3 -- -- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>@@ -110,6 +110,7 @@ step n | n == 0xFF = MetaEvent <$> (dropW8 *> (word8 >>= metaEvent)) | n >= 0xF8 = SysRealTimeEvent <$> (dropW8 *> sysRealTimeEvent n)+ | n == 0xF7 = SysExEvent <$> (dropW8 *> sysExEscape) | n >= 0xF1 = SysCommonEvent <$> (dropW8 *> sysCommonEvent n) | n == 0xF0 = SysExEvent <$> (dropW8 *> sysExEvent) | n >= 0x80 = VoiceEvent RS_OFF <$> (dropW8 *> voiceEvent (splitByte n))@@ -237,9 +238,26 @@ -- | 0xF0 has been parsed, SysEx is uninterpreted. -- sysExEvent :: ParserM MidiSysExEvent-sysExEvent = "sys-ex" <??> getVarlenBytes SysEx+sysExEvent = "sys-ex" <??> body+ where+ body = getVarlenBytes (,) >>= \(n,xs) -> + if isTerminated xs then return $ SysExSingle n xs+ else sysExContPackets >>= \ks -> + return $ SysExCont n xs ks +sysExContPackets :: ParserM [MidiSysExContPacket]+sysExContPackets = + deltaTime >>= \dt -> getVarlenBytes (,) >>= \(n,xs) -> + let ans1 = MidiSysExContPacket dt n xs+ in if isTerminated xs then return [ans1]+ else sysExContPackets >>= \ks -> + return $ ans1:ks +++sysExEscape :: ParserM MidiSysExEvent+sysExEscape = "sys-ex" <??> getVarlenBytes SysExEscape+ -- | 0xFF and the "type" byte already parsed, input to this -- function is the type byte. --@@ -259,10 +277,10 @@ metaEvent 0x07 = "cue point" <??> textEvent CUE_POINT metaEvent 0x20 = - "channel prefix" <??> ChannelPrefix <$> word8 <*> word8+ "channel prefix" <??> ChannelPrefix <$> (assertWord8 0x01 *> word8) metaEvent 0x21 = - "MIDI port" <??> MidiPort <$> (assertWord8 1 *> word8)+ "MIDI port" <??> MidiPort <$> (assertWord8 0x01 *> word8) metaEvent 0x2F = "end of track" <??> EndOfTrack <$ assertWord8 0 @@ -351,16 +369,20 @@ getVarlenBytes = gencount getVarlen word8 +msbHigh :: Word8 -> Bool+msbHigh w = w `testBit` 7++-- msbLow :: Word8 -> Bool+-- msbLow = not . msbHigh+ getVarlen :: ParserM Word32 getVarlen = liftM fromVarlen step1 where- high a = a `testBit` 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) }- else return (V3 a b c) + step1 = word8 >>= \a -> if msbHigh a then step2 a else return (V1 a)+ step2 a = word8 >>= \b -> if msbHigh b then step3 a b else return (V2 a b)+ step3 a b = word8 >>= \c -> if msbHigh c then do { d <- word8+ ; return (V4 a b c d) }+ else return (V3 a b c) @@ -371,3 +393,21 @@ postCheck :: ParserM a -> (a -> Bool) -> String -> ParserM a postCheck p check msg = p >>= \ans -> if check ans then return ans else fatalError msg++isTerminated :: [Word8] -> Bool+isTerminated [] = False+isTerminated [0xF7] = True+isTerminated (_:xs) = isTerminated xs++-- | Read a list of databytes.+-- A stream of databytes is signalled by elements having +-- continuous low most-significant bits.+--++-- databytesMsbLow :: ParserM [Word8]+-- databytesMsbLow = step+-- where+-- step = cond msbLow >>= \mb -> case mb of +-- Nothing -> return [] +-- Just x -> do { xs <- step; return (x:xs) }+
src/ZMidi/Core/VersionNumber.hs view
@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : ZMidi.Core.VersionNumber--- Copyright : (c) Stephen Tetley 2010-2012+-- Copyright : (c) Stephen Tetley 2010-2013 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com@@ -22,7 +22,7 @@ -- | Version number ----- > (0,6,0)+-- > (0,7,0) -- zmidi_core_version :: (Int,Int,Int)-zmidi_core_version = (0,6,0)+zmidi_core_version = (0,7,0)
src/ZMidi/Core/WriteFile.hs view
@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : ZMidi.Core.WriteFile--- Copyright : (c) Stephen Tetley 2010-2012+-- Copyright : (c) Stephen Tetley 2010-2013 -- License : BSD3 -- -- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>@@ -70,9 +70,11 @@ putTimeDivision (TPB n) = putWord16be (n `clearBit` 15) +putDeltaTime :: DeltaTime -> PutM ()+putDeltaTime = putVarlen . fromIntegral putMessage :: MidiMessage -> PutM () -putMessage (dt,evt) = putVarlen (fromIntegral dt) *> putEvent evt+putMessage (dt,evt) = putDeltaTime dt *> putEvent evt putEvent :: MidiEvent -> PutM () putEvent (MidiEventOther e) = putMidiDataOther e@@ -93,53 +95,74 @@ -- constructor and channel. -- putVoiceEvent :: MidiRunningStatus -> MidiVoiceEvent -> PutM ()-putVoiceEvent rs (NoteOff c n v) = +putVoiceEvent rs (NoteOff c n v) = optTagByte rs (0x8 `u4l4` c) *> putWord8 n *> putWord8 v -putVoiceEvent rs (NoteOn c n v) = +putVoiceEvent rs (NoteOn c n v) = optTagByte rs (0x9 `u4l4` c) *> putWord8 n *> putWord8 v -putVoiceEvent rs (NoteAftertouch c n v) = +putVoiceEvent rs (NoteAftertouch c n v) = optTagByte rs (0xA `u4l4` c) *> putWord8 n *> putWord8 v -putVoiceEvent rs (Controller c n v) = +putVoiceEvent rs (Controller c n v) = optTagByte rs (0xB `u4l4` c) *> putWord8 n *> putWord8 v -putVoiceEvent rs (ProgramChange c n) = +putVoiceEvent rs (ProgramChange c n) = optTagByte rs (0xC `u4l4` c) *> putWord8 n -putVoiceEvent rs (ChanAftertouch c v) = +putVoiceEvent rs (ChanAftertouch c v) = optTagByte rs (0xD `u4l4` c) *> putWord8 v -putVoiceEvent rs (PitchBend c v) = +putVoiceEvent rs (PitchBend c v) = optTagByte rs (0xE `u4l4` c) *> putWord16be v +-- Note - F7 (terminator) should be the last byte in the +-- payload (ws) for SysExSingle.+-- +-- It should be the last byte of the last continuation packet+-- for SysExCont.+--+-- The payload for SysExEscape should not be terminated +-- (with F7).+-- putSysExEvent :: MidiSysExEvent -> PutM ()-putSysExEvent (SysEx n ws) = +putSysExEvent (SysExSingle n ws) = putWord8 0xF0 *> putVarlen n *> mapM_ putWord8 ws +putSysExEvent (SysExCont n ws ks) = + putWord8 0xF0 *> putVarlen n *> mapM_ putWord8 ws + *> mapM_ putSysExContPacket ks +putSysExEvent (SysExEscape n ws) = + putWord8 0xF7 *> putVarlen n *> mapM_ putWord8 ws+++putSysExContPacket :: MidiSysExContPacket -> PutM ()+putSysExContPacket (MidiSysExContPacket dt n ws) = + putDeltaTime dt *> putWord8 0xF7 *> putVarlen n *> mapM_ putWord8 ws+ + putSysCommonEvent :: MidiSysCommonEvent -> PutM ()-putSysCommonEvent (QuarterFrame sb) = +putSysCommonEvent (QuarterFrame sb) = putWord8 0xF1 *> putWord8 sb -putSysCommonEvent (SongPosPointer lsb msb) = +putSysCommonEvent (SongPosPointer lsb msb) = putWord8 0xF2 *> putWord8 lsb *> putWord8 msb -putSysCommonEvent (SongSelect w) = +putSysCommonEvent (SongSelect w) = putWord8 0xF3 *> putWord8 w -putSysCommonEvent (UndefinedF4) = +putSysCommonEvent (UndefinedF4) = putWord8 0xF4 -putSysCommonEvent (UndefinedF5) = +putSysCommonEvent (UndefinedF5) = putWord8 0xF5 -putSysCommonEvent TuneRequest = +putSysCommonEvent TuneRequest = putWord8 0xF6 -putSysCommonEvent (EOX) = +putSysCommonEvent (EOX) = putWord8 0xF7 @@ -163,8 +186,8 @@ putMetaEvent (SequenceNumber n) = putWord8 0xFF *> putWord8 0x00 *> prefixLen 2 (putWord16be n) -putMetaEvent (ChannelPrefix i ch) = - putWord8 0xFF *> putWord8 0x20 *> prefixLen i (putWord8 ch)+putMetaEvent (ChannelPrefix ch) = + putWord8 0xFF *> putWord8 0x20 *> putWord8 0x01 *> putWord8 ch putMetaEvent (MidiPort pn) = putWord8 0xFF *> putWord8 0x21 *> putWord8 0x01 *> putWord8 pn
zmidi-core.cabal view
@@ -1,5 +1,5 @@ name: zmidi-core-version: 0.6.0+version: 0.7.0 license: BSD3 license-file: LICENSE copyright: Stephen Tetley <stephen.tetley@gmail.com>@@ -10,10 +10,29 @@ description: . Minimalist library to read and write MIDI files, with - dependencies only on ByteString and Data.Binary.+ dependencies only on ByteString, Containers and Data.Binary. . Changelog: .+ v0.6.0 to v0.7.0:+ .+ * Changed @ChannelPrefix@ constructor to have a single + argument - channel number (previously it stored a constant + tag 0x01 as well as channel number).+ .+ * Added @SysExCont@ and @SysExEscape@ constructors to the + @MidiSysExEvent@ data type.+ .+ * Added new pretty printers - @Csv@ based on @midicsv@ and + @Ascii@ based on the ASCII MIDI representation in the book + Beyond Midi (the zmidi ASCII representation is simplified).+ The demo application @MidiPrint@ now allows choice of pretty+ printer.+ .+ * @printMidiHeader@ and @printMidiTrack@ from @Pretty@ changed+ to MidiFiles as arguments, @printMidi@ has now become + @putMidi@.+ . v0.5.0 to v0.6.0: . * Extended the parser and changed the syntax tree to interpret @@ -29,57 +48,7 @@ chars greater than 164 causing an error when printing to stdout. .- v0.4.0 to v0.5.0:- .- * Changed order of @MidiVoiceEvent@ 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:- .- * 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.- .- v0.2.1 to v0.3.0:- .- * Revised naming of the MIDI data types. All data types now have - the prefix Midi (previously only MidiFile followed this scheme).- The rationale for this is client software, that might want a - higher-level representation, is then free to use the more - generic names Track, Message, etc.- .- * @DeltaTime@ made a newtype wrapper rather than a type synonym.- .- * Renamed the pretty print functions @track@ to @printMidiTrack@ - and @header@ to @printMidiHeader@.- .- * Moved internal dataypes (SplitByte, Varlen) into a private - module.- .- v0.2.0 to v0.2.1:- . - * Added Show class constraints to various type signatures to - accommodate changes to Num superclass hierarchy in GHC 7.4.- Thanks to Remy Moueza for the patches.- . - v0.1.0 to v0.2.0:- .- * Added a top-level /shim/ module to import all the exposed- modules. Added a version number module- .+ For older changes see - CHANGES file. . build-type: Simple stability: unstable@@ -96,6 +65,7 @@ hs-source-dirs: src build-depends: base < 5, bytestring,+ containers, binary >= 0.5 exposed-modules:@@ -103,6 +73,10 @@ ZMidi.Core.Canonical, ZMidi.Core.Datatypes, ZMidi.Core.Pretty,+ ZMidi.Core.Pretty.Ascii,+ ZMidi.Core.Pretty.Csv,+ ZMidi.Core.Pretty.Internal,+ ZMidi.Core.Pretty.Interp, ZMidi.Core.ReadFile, ZMidi.Core.VersionNumber, ZMidi.Core.WriteFile