{-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : ZMidi.Core.Pretty -- Copyright : (c) Stephen Tetley 2010-2012 -- License : BSD3 -- -- Maintainer : Stephen Tetley -- Stability : unstable -- 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. -- -------------------------------------------------------------------------------- module ZMidi.Core.Pretty ( printMidi , printMidiHeader , printMidiTrack ) where import ZMidi.Core.Datatypes import ZMidi.Core.Internal.SimpleFormat import Data.Char import Data.List import Data.Monoid import Data.Word -- | Print the MIDI file to std-out. -- -- One event is printed per line, so the output may be huge. -- 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 '-' -- | Print the MIDI header. -- -- 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] -- | Print a track. -- -- Results are returned as a list of String to avoid extraneous -- concatenation. -- printMidiTrack :: MidiTrack -> [String] printMidiTrack = snd . mapAccumL fn 0 . getTrackMessages where fn acc b = msnd output $ message acc b msnd f (a,b) = (a,f b) -------------------------------------------------------------------------------- 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 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` 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) 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 event :: String -> Doc -> Doc event s d = padr 18 (text s) `dashsep` d ppMidiDataOther :: MidiDataOther -> Doc ppMidiDataOther (MidiDataOther n) = event "midi data other" (hex2 n) -- | Voice event needs RunningStatus... 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) 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) ppVoiceEvent _ (NoteAftertouch c n v) = event "note-aftertouch" (hex2 c `sep` hex2 n `sep` hex2 v) ppVoiceEvent _ (ChanAftertouch c v) = event "channel-aftertouch" (hex2 c `sep` hex2 v) ppVoiceEvent _ (PitchBend c v) = event "pitch-bend" (hex2 c `sep` hex4 v) ppSysExEvent :: MidiSysExEvent -> Doc ppSysExEvent (SysEx n ws) = event "sys-ex" $ byteList n ws ppSysCommonEvent :: MidiSysCommonEvent -> Doc ppSysCommonEvent (QuarterFrame sb) = event "time-code-quarter-frame" (hex2 sb) ppSysCommonEvent (SongPosPointer a b) = event "sys-common song pos. pointer" (hex2 a `sep` hex2 b) ppSysCommonEvent (SongSelect w) = event "song-select" (hex2 w) ppSysCommonEvent (UndefinedF4) = text "undefined 0xF4" ppSysCommonEvent (UndefinedF5) = text "undefined 0xF5" ppSysCommonEvent (TuneRequest) = text "tune-request" ppSysCommonEvent (EOX) = text "end-of-sys-ex" 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" ppMetaEvent :: MidiMetaEvent -> Doc ppMetaEvent (TextEvent ty s) = event (textType ty) (text $ safeString s) ppMetaEvent (SequenceNumber w) = event "sequence-number" (hex4 w) 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 '.' 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 -- | 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 = '#'