various optimisations

* simplify event and voiceEvent
* remove some usage of *printf / %A in inner loops
* print parsing time in scratch script

seems to parse properly now

Author: smoothdeveloper

demo/scratch.fsx

@@ -5,7 +5,7 @@
 //#load "../src/zmidi/internal/utils.fs"
 //#load "../src/zmidi/internal/parsermonad.fs"
 //#load "../src/zmidi/read.fs"
-#r "../build/Debug/AnyCPU/net45/zmidi-fs-core.dll"
+#r "../build/Release/AnyCPU/net45/zmidi-fs-core.dll"
 open System.IO
 open ZMidi.Internal.ParserMonad
 open ZMidi
@@ -33,13 +33,13 @@ let folder =
 for file in folder.EnumerateFiles() do
   let buffer = File.ReadAllBytes file.FullName
   printfn "======================= %s" file.FullName 
-
+  let watch = System.Diagnostics.Stopwatch.StartNew()
   let parseResult = 
     ZMidi.Internal.ParserMonad.runParser
       ZMidi.ReadFile.midiFile
       buffer
       State.initial
-
+  printfn "ellapsed parse time : %A" watch.Elapsed
   match parseResult with 
   | Ok result -> 
 
@@ -49,7 +49,7 @@ for file in folder.EnumerateFiles() do
 
   | Error something -> printfn "ERR: %s %A" file.FullName something
 
-
+(*
 let cases = 
   [|
     {| expected = 0x00000000u; input = [|0x00uy|] |}
@@ -154,4 +154,4 @@ let pp = parseMidi {
 
 let (Ok(ParserMonad f)) = (ZMidi.Internal.ParserMonad.runParser pp [|1uy..5uy|] State.initial)
 
-f [|1uy..5uy|] State.initial
+f [|1uy..5uy|] State.initial*)

src/ZMidi/Internal/ParserMonad.fs

@@ -17,8 +17,17 @@ module ParserMonad =
         | Program           of byte
         | ChannelAftertouch of byte
         | PitchBend         of byte
+        override x.ToString() =
+          match x with
+          | StatusOff           -> "StatusOff"
+          | NoteOn            o -> "NoteOn "            + string o
+          | NoteOff           o -> "NoteOff "           + string o
+          | NoteAftertoucuh   o -> "NoteAftertoucuh "   + string o
+          | Control           o -> "Control "           + string o
+          | Program           o -> "Program "           + string o
+          | ChannelAftertouch o -> "ChannelAftertouch " + string o
+          | PitchBend         o -> "PitchBend "         + string o
 
-  
     type MidiData = byte array
 
     type Pos = int
@@ -48,7 +57,7 @@ module ParserMonad =
 
                 (sprintf "%A" x.LastParse)
             #else
-            sprintf "(Pos:%i;Status:%30s)" x.Position (sprintf "%A" x.RunningStatus)
+            System.String.Format("(Pos:{0};Status:{1})", x.Position, string x.RunningStatus)
             #endif
     type ParseError = 
       ParseError of 
@@ -93,9 +102,12 @@ module ParserMonad =
         let (ParserMonad fn) = parser 
         try
             let result = fn midiData state
+            let oldState = state
             match result with
             | Ok (r, state) ->
-              logf "parse ok: %50s %O" (sprintf "%O" r) state
+              if debug then
+                if state <> oldState then
+                    logf "parse ok: %O" state
               #if DEBUG_LASTPARSE
               let state = { state with LastParse = r }
               #endif
@@ -145,15 +157,15 @@ module ParserMonad =
       bindM m k
 
     type ParserBuilder() = 
-        member self.ReturnFrom (ma:ParserMonad<'a>) : ParserMonad<'a> = ma
-        member self.Return x         = mreturn x
-        member self.Bind (p,f)       = bindM p f
-        member self.Zero a          = ParserMonad (fun input state -> Ok(a, state))
+        member inline self.ReturnFrom (ma:ParserMonad<'a>) : ParserMonad<'a> = ma
+        member inline self.Return x         = mreturn x
+        member inline self.Bind (p,f)       = bindM p f
+        member inline self.Zero a          = ParserMonad (fun input state -> Ok(a, state))
         //member self.Combine (ma, mb) = ma >>= mb
 
         // inspired from http://www.fssnip.net/7UJ/title/ResultBuilder-Computational-Expression
         // probably broken
-        member self.TryFinally(m, compensation) =
+        member inline self.TryFinally(m, compensation) =
              try self.ReturnFrom(m)
              finally compensation()
 
@@ -183,7 +195,7 @@ module ParserMonad =
         ParserMonad <| fun _ st -> Error (mkOtherParseError st genMessage)
 
     /// Run the parser, if it fails swap the error message.
-    let ( <??> ) (parser : ParserMonad<'a>) (genMessage : Pos -> string) : ParserMonad<'a> = 
+    let inline ( <??> ) (parser : ParserMonad<'a>) (genMessage : Pos -> string) : ParserMonad<'a> = 
         ParserMonad <| fun input st -> 
             match apply1 parser input st with
             | Ok result -> Ok result
@@ -231,7 +243,7 @@ module ParserMonad =
     let getRunningEvent : ParserMonad<VoiceEvent> = 
         ParserMonad <| fun _ st -> Ok (st.RunningStatus , st)
 
-    let setRunningEvent (runningStatus : VoiceEvent) : ParserMonad<unit> = 
+    let inline setRunningEvent (runningStatus : VoiceEvent) : ParserMonad<unit> = 
         ParserMonad <| fun _ st -> Ok ((),  { st with RunningStatus = runningStatus })
 
     let getPos : ParserMonad<int> =

src/ZMidi/Read.fs

@@ -329,22 +329,25 @@ module ReadFile =
 
 
     let voiceEvent n =
-      match n with
-      | SB(0x80uy, ch) -> parseMidi { do! setRunningEvent (NoteOff ch)
-                                      return! noteOff ch }
-      | SB(0x90uy, ch) -> parseMidi { do! setRunningEvent (NoteOn ch)
-                                      return! noteOn ch }
-      | SB(0xa0uy, ch) -> parseMidi { do! setRunningEvent (NoteAftertoucuh ch)
-                                      return! noteAftertouch ch }
-      | SB(0xb0uy, ch) -> parseMidi { do! setRunningEvent (Control ch)
-                                      return! controller ch }
-      | SB(0xc0uy, ch) -> parseMidi { do! setRunningEvent (Program ch)
-                                      return! programChange ch }
-      | SB(0xd0uy, ch) -> parseMidi { do! setRunningEvent (ChannelAftertouch ch)
-                                      return! channelAftertouch ch }
-      | SB(0xe0uy, ch) -> parseMidi { do! setRunningEvent (PitchBend ch)
-                                      return! pitchBend ch }
-      | otherwise -> impossibleMatch (sprintf "voiceEvent: %x" otherwise)
+      parseMidi {
+        match n with
+        | SB(0x80uy, ch) -> do! setRunningEvent (NoteOff ch)
+                            return! noteOff ch
+        | SB(0x90uy, ch) -> do! setRunningEvent (NoteOn ch)
+                            return! noteOn ch
+        | SB(0xa0uy, ch) -> do! setRunningEvent (NoteAftertoucuh ch)
+                            return! noteAftertouch ch
+        | SB(0xb0uy, ch) -> do! setRunningEvent (Control ch)
+                            return! controller ch
+        | SB(0xc0uy, ch) -> do! setRunningEvent (Program ch)
+                            return! programChange ch
+        | SB(0xd0uy, ch) -> do! setRunningEvent (ChannelAftertouch ch)
+                            return! channelAftertouch ch
+        | SB(0xe0uy, ch) -> do! setRunningEvent (PitchBend ch)
+                            return! pitchBend ch
+        | otherwise      -> return! impossibleMatch (sprintf "voiceEvent: %x" otherwise)
+      }
+
     let runningStatus (event: VoiceEvent) : ParserMonad<MidiEvent> = 
       let mVoiceEvent e = mreturn (VoiceEvent(MidiRunningStatus.ON, e))
       match event with
@@ -384,40 +387,34 @@ event = peek >>= step
     /// can cause fatal parse errors.
     
     let event : ParserMonad<MidiEvent> = 
-      let step n : ParserMonad<MidiEvent> = 
-        parseMidi {
-          match n with
-          | 0xffuy -> 
-            do! dropByte
-            let! event = readByte >>= metaEvent
-            return MetaEvent event
-          | 0xf7uy -> 
-            do! dropByte
-            let! sysexEvent = sysExEscape
-            return SysExEvent sysexEvent
-          | 0xf0uy ->
-            do! dropByte
-            let! sysexEvent = sysExEvent
-            return SysExEvent sysexEvent
-          | x when x >= 0xf8uy ->
-            do! dropByte
-            let! event = sysRealtimeEvent x
-            return SysRealtimeEvent event
-          | x when x >= 0xf1uy ->
-            do! dropByte
-            let! event = sysCommonEvent x
-            return SysCommonEvent event
-          | x when x >= 0x80uy ->
-            do! dropByte
-            let! voiceEvent = voiceEvent x
-            return VoiceEvent(MidiRunningStatus.OFF, voiceEvent)
-          | otherwise ->
-            return! (getRunningEvent >>= runningStatus)
-
-        }
       parseMidi {
-        let! p = peek
-        return! step p 
+        match! peek with
+        | 0xffuy -> 
+          do! dropByte
+          let! event = readByte >>= metaEvent
+          return MetaEvent event
+        | 0xf7uy -> 
+          do! dropByte
+          let! sysexEvent = sysExEscape
+          return SysExEvent sysexEvent
+        | 0xf0uy ->
+          do! dropByte
+          let! sysexEvent = sysExEvent
+          return SysExEvent sysexEvent
+        | x when x >= 0xf8uy ->
+          do! dropByte
+          let! event = sysRealtimeEvent x
+          return SysRealtimeEvent event
+        | x when x >= 0xf1uy ->
+          do! dropByte
+          let! event = sysCommonEvent x
+          return SysCommonEvent event
+        | x when x >= 0x80uy ->
+          do! dropByte
+          let! voiceEvent = voiceEvent x
+          return VoiceEvent(MidiRunningStatus.OFF, voiceEvent)
+        | otherwise ->
+          return! (getRunningEvent >>= runningStatus)
       }
 
     let message =