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
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 '-'
printMidiHeader :: MidiHeader -> [String]
printMidiHeader (MidiHeader fmt tcount td) =
map output [ppFormat fmt, ppNumTracks tcount, ppTimeDivision td]
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)
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
safeString :: String -> String
safeString = map (f . ord)
where
f i | i < 164 = chr i
| otherwise = '#'