From 86c7272a28d9467f52e4d40e079cabcda2e42121 Mon Sep 17 00:00:00 2001 From: Gustavo Leon <1261319+gusty@users.noreply.github.com> Date: Fri, 31 Jan 2020 09:39:41 +0100 Subject: [PATCH 1/6] Include F# --- src/ZMidi/zmidi-fs-core.fsproj | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/ZMidi/zmidi-fs-core.fsproj b/src/ZMidi/zmidi-fs-core.fsproj index 7e58909..eb59bb0 100644 --- a/src/ZMidi/zmidi-fs-core.fsproj +++ b/src/ZMidi/zmidi-fs-core.fsproj @@ -21,4 +21,8 @@ + + + + From 1fc56d5e4e86c8429baf2d77f1a0b0735a8b1158 Mon Sep 17 00:00:00 2001 From: Gustavo Leon <1261319+gusty@users.noreply.github.com> Date: Fri, 31 Jan 2020 09:49:13 +0100 Subject: [PATCH 2/6] Include Input in State --- src/ZMidi/Internal/ParserMonad.fs | 77 ++++++++++++++++--------------- 1 file changed, 39 insertions(+), 38 deletions(-) mode change 100755 => 100644 src/ZMidi/Internal/ParserMonad.fs diff --git a/src/ZMidi/Internal/ParserMonad.fs b/src/ZMidi/Internal/ParserMonad.fs old mode 100755 new mode 100644 index 4f32686..b2fa16c --- a/src/ZMidi/Internal/ParserMonad.fs +++ b/src/ZMidi/Internal/ParserMonad.fs @@ -40,6 +40,7 @@ module ParserMonad = type State = { Position: Pos RunningStatus: VoiceEvent + Input: MidiData #if DEBUG_LASTPARSE LastParse : obj #endif @@ -47,6 +48,7 @@ module ParserMonad = static member initial = { Position = 0 RunningStatus = VoiceEvent.StatusOff + Input = [||] #if DEBUG_LASTPARSE LastParse = null #endif @@ -86,7 +88,7 @@ module ParserMonad = ) type ParserMonad<'a> = - ParserMonad of (MidiData -> State -> Result<'a * State, ParseError> ) + ParserMonad of (State -> Result<'a * State, ParseError> ) let nullOut = new StreamWriter(Stream.Null) :> TextWriter let mutable debug = false @@ -97,12 +99,11 @@ module ParserMonad = fprintfn nullOut format //Unchecked.defaultof<_> - let inline private apply1 (parser : ParserMonad<'a>) - (midiData : byte[]) + let inline private apply1 (parser : ParserMonad<'a>) (state : State) : Result<'a * State, ParseError> = let (ParserMonad fn) = parser try - let result = fn midiData state + let result = fn state let oldState = state match result with | Ok (r, state) -> @@ -130,22 +131,22 @@ module ParserMonad = ) let inline mreturn (x:'a) : ParserMonad<'a> = - ParserMonad <| fun _ st -> Ok (x, st) + ParserMonad <| fun st -> Ok (x, st) let inline private bindM (parser : ParserMonad<'a>) (next : 'a -> ParserMonad<'b>) : ParserMonad<'b> = - ParserMonad <| fun input state -> - match apply1 parser input state with + ParserMonad <| fun state -> + match apply1 parser state with | Error msg -> Error msg - | Ok (ans, st1) -> apply1 (next ans) input st1 + | Ok (ans, st1) -> apply1 (next ans) st1 let mzero () : ParserMonad<'a> = - ParserMonad <| fun _ state -> Error (mkParseError state (EOF "mzero")) + ParserMonad <| fun state -> Error (mkParseError state (EOF "mzero")) let inline mplus (parser1 : ParserMonad<'a>) (parser2 : ParserMonad<'a>) : ParserMonad<'a> = - ParserMonad <| fun input state -> - match apply1 parser1 input state with - | Error _ -> apply1 parser2 input state + ParserMonad <| fun state -> + match apply1 parser1 state with + | Error _ -> apply1 parser2 state | Ok res -> Ok res let inline private delayM (fn:unit -> ParserMonad<'a>) : ParserMonad<'a> = @@ -161,7 +162,7 @@ module ParserMonad = 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 inline self.Zero a = ParserMonad (fun state -> Ok(a, state)) //member self.Combine (ma, mb) = ma >>= mb // inspired from http://www.fssnip.net/7UJ/title/ResultBuilder-Computational-Expression @@ -183,7 +184,7 @@ module ParserMonad = let (parseMidi:ParserBuilder) = new ParserBuilder() let runParser (ma:ParserMonad<'a>) input initialState = - apply1 ma input initialState + apply1 ma { initialState with Input = input} |> Result.map fst /// Run the parser on a file. @@ -193,11 +194,11 @@ module ParserMonad = /// Throw a parse error let parseError (genMessage : Pos -> string) : ParserMonad<'a> = - ParserMonad <| fun _ st -> Error (mkOtherParseError st genMessage) + ParserMonad <| fun st -> Error (mkOtherParseError st genMessage) let fmapM (modify: 'a -> 'b) (parser : ParserMonad<'a>) : ParserMonad<'b> = - ParserMonad <| fun input state -> - match apply1 parser input state with + ParserMonad <| fun state -> + match apply1 parser state with | Error err -> Error err | Ok (a, st2) -> Ok (modify a, st2) @@ -207,8 +208,8 @@ module ParserMonad = /// Run the parser, if it fails swap the error message. let inline ( ) (parser : ParserMonad<'a>) (genMessage : Pos -> string) : ParserMonad<'a> = - ParserMonad <| fun input st -> - match apply1 parser input st with + ParserMonad <| fun st -> + match apply1 parser st with | Ok result -> Ok result | Error e -> logf "oops : e:%A" e @@ -249,16 +250,16 @@ module ParserMonad = let fatalError err = - ParserMonad <| fun _ st -> Error (mkParseError st err) + ParserMonad <| fun st -> Error (mkParseError st err) let getRunningEvent : ParserMonad = - ParserMonad <| fun _ st -> Ok (st.RunningStatus , st) + ParserMonad <| fun st -> Ok (st.RunningStatus , st) let inline setRunningEvent (runningStatus : VoiceEvent) : ParserMonad = - ParserMonad <| fun _ st -> Ok ((), { st with RunningStatus = runningStatus }) + ParserMonad <| fun st -> Ok ((), { st with RunningStatus = runningStatus }) let getPos : ParserMonad = - ParserMonad <| fun _ st -> Ok (st.Position, st) + ParserMonad <| fun st -> Ok (st.Position, st) let inline private (|PositionValid|PositionInvalid|) (input: MidiData, state: State) = if state.Position >= 0 && state.Position < input.Length then @@ -266,12 +267,12 @@ module ParserMonad = else PositionInvalid - let inline private checkedParseM (name: string) (f: MidiData -> State -> Result<('a * State), ParseError>) = + let inline private checkedParseM (name: string) (f: State -> Result<('a * State), ParseError>) = ParserMonad - (fun input state -> + (fun state -> try - match input,state with - | PositionValid -> f input state + match state.Input, state with + | PositionValid -> f state | PositionInvalid -> Error (mkParseError state (EOF name)) with | e -> Error (mkParseError state (Other (sprintf "%s %A" name e))) @@ -279,15 +280,15 @@ module ParserMonad = let peek : ParserMonad = checkedParseM "peek" <| - fun input st -> Ok (input.[st.Position], st) + fun st -> Ok (st.Input.[st.Position], st) /// Conditionally gets a byte (word8). Fails if input is finished. /// Consumes data on if predicate succeeds, does not consume if /// predicate fails. let cond (test : byte -> bool) : ParserMonad = checkedParseM "cond" <| - fun input st -> - let a1 = input.[st.Position] + fun st -> + let a1 = st.Input.[st.Position] if test a1 then Ok (Some a1, st) else Ok (None, st) @@ -295,7 +296,7 @@ module ParserMonad = /// Repeats a given times. /// Fails with accumulated errors when any encountered. let inline count (length : ^T) (parser : ParserMonad<'a>) : ParserMonad<'a []> = - ParserMonad <| fun input state -> + ParserMonad <| fun state -> let rec work (i : 'T) (st : State) (fk : ParseError -> Result<'a list * State, ParseError>) @@ -303,7 +304,7 @@ module ParserMonad = if i <= LanguagePrimitives.GenericZero then sk st [] else - match apply1 parser input st with + match apply1 parser st with | Error msg -> fk msg | Ok (a1, st1) -> work (i - LanguagePrimitives.GenericOne) st1 fk (fun st2 ac -> @@ -313,12 +314,12 @@ module ParserMonad = /// Run a parser within a bounded section of the input stream. let repeatTillPosition (maxPosition: Pos) (parser: ParserMonad<'a>) : ParserMonad<'a array> = - ParserMonad <| fun input state -> + ParserMonad <| fun state -> let limit = maxPosition let rec work (st : State) (fk : ParseError -> Result<'a list * State, ParseError>) (sk : State -> 'a list -> Result<'a list * State, ParseError>) = - match apply1 parser input st with + match apply1 parser st with | Error a -> fk a | Ok(a1, st1) -> match compare st1.Position limit with @@ -342,13 +343,13 @@ module ParserMonad = /// Drop a byte (word8). let dropByte : ParserMonad = checkedParseM "dropByte" <| - fun input st -> Ok ((), { st with Position = st.Position + 1 }) + fun st -> Ok ((), { st with Position = st.Position + 1 }) /// Parse a byte (Word8). let readByte : ParserMonad = checkedParseM "readByte" <| - fun input st -> - let a1 = input.[st.Position] + fun st -> + let a1 = st.Input.[st.Position] Ok (a1, { st with Position = st.Position + 1 }) /// Parse a single byte char. @@ -401,4 +402,4 @@ module ParserMonad = let! b = readByte let! c = readByte return (word24be a b c) - } \ No newline at end of file + } From 636445cf57e8e1b771a7dff5496aadcf57c80487 Mon Sep 17 00:00:00 2001 From: Gusty <1261319+gusty@users.noreply.github.com> Date: Fri, 31 Jan 2020 10:01:24 +0100 Subject: [PATCH 3/6] Switch to StateT --- src/ZMidi/Internal/ParserMonad.fs | 63 ++++++++++--------------------- src/ZMidi/Read.fs | 1 + 2 files changed, 21 insertions(+), 43 deletions(-) diff --git a/src/ZMidi/Internal/ParserMonad.fs b/src/ZMidi/Internal/ParserMonad.fs index b2fa16c..3782205 100644 --- a/src/ZMidi/Internal/ParserMonad.fs +++ b/src/ZMidi/Internal/ParserMonad.fs @@ -4,7 +4,8 @@ namespace ZMidi.Internal module ParserMonad = open System.IO - + open FSharpPlus + open FSharpPlus.Data open ZMidi.Internal.Utils /// Status is either OFF or the previous VoiceEvent * Channel. @@ -87,8 +88,7 @@ module ParserMonad = #endif ) - type ParserMonad<'a> = - ParserMonad of (State -> Result<'a * State, ParseError> ) + type ParserMonad<'a> = StateT> let nullOut = new StreamWriter(Stream.Null) :> TextWriter let mutable debug = false @@ -101,7 +101,7 @@ module ParserMonad = let inline private apply1 (parser : ParserMonad<'a>) (state : State) : Result<'a * State, ParseError> = - let (ParserMonad fn) = parser + let (StateT fn) = parser try let result = fn state let oldState = state @@ -131,20 +131,20 @@ module ParserMonad = ) let inline mreturn (x:'a) : ParserMonad<'a> = - ParserMonad <| fun st -> Ok (x, st) + StateT <| fun st -> Ok (x, st) let inline private bindM (parser : ParserMonad<'a>) (next : 'a -> ParserMonad<'b>) : ParserMonad<'b> = - ParserMonad <| fun state -> + StateT <| fun state -> match apply1 parser state with | Error msg -> Error msg | Ok (ans, st1) -> apply1 (next ans) st1 let mzero () : ParserMonad<'a> = - ParserMonad <| fun state -> Error (mkParseError state (EOF "mzero")) + StateT <| fun state -> Error (mkParseError state (EOF "mzero")) let inline mplus (parser1 : ParserMonad<'a>) (parser2 : ParserMonad<'a>) : ParserMonad<'a> = - ParserMonad <| fun state -> + StateT <| fun state -> match apply1 parser1 state with | Error _ -> apply1 parser2 state | Ok res -> Ok res @@ -158,30 +158,7 @@ module ParserMonad = let (>>=) (m: ParserMonad<'a>) (k: 'a -> ParserMonad<'b>) : ParserMonad<'b> = bindM m k - type ParserBuilder() = - 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 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 inline self.TryFinally(m, compensation) = - try self.ReturnFrom(m) - finally compensation() - - //member self.Delay(f: unit -> ParserMonad<'a>) : ParserMonad<'a> = f () - //member self.Using(res:#System.IDisposable, body) = - // self.TryFinally(body res, fun () -> if not (isNull res) then res.Dispose()) - //member self.While(guard, f) = - // if not (guard()) then self.Zero () else - // do f() |> ignore - // self.While(guard, f) - //member self.For(sequence:seq<_>, body) = - // self.Using(sequence.GetEnumerator(), fun enum -> self.While(enum.MoveNext, fun () -> self.Delay(fun () -> body enum.Current))) - - let (parseMidi:ParserBuilder) = new ParserBuilder() + let parseMidi = monad let runParser (ma:ParserMonad<'a>) input initialState = apply1 ma { initialState with Input = input} @@ -194,10 +171,10 @@ module ParserMonad = /// Throw a parse error let parseError (genMessage : Pos -> string) : ParserMonad<'a> = - ParserMonad <| fun st -> Error (mkOtherParseError st genMessage) + StateT <| fun st -> Error (mkOtherParseError st genMessage) let fmapM (modify: 'a -> 'b) (parser : ParserMonad<'a>) : ParserMonad<'b> = - ParserMonad <| fun state -> + StateT <| fun state -> match apply1 parser state with | Error err -> Error err | Ok (a, st2) -> Ok (modify a, st2) @@ -208,7 +185,7 @@ module ParserMonad = /// Run the parser, if it fails swap the error message. let inline ( ) (parser : ParserMonad<'a>) (genMessage : Pos -> string) : ParserMonad<'a> = - ParserMonad <| fun st -> + StateT <| fun st -> match apply1 parser st with | Ok result -> Ok result | Error e -> @@ -250,16 +227,16 @@ module ParserMonad = let fatalError err = - ParserMonad <| fun st -> Error (mkParseError st err) + StateT <| fun st -> Error (mkParseError st err) let getRunningEvent : ParserMonad = - ParserMonad <| fun st -> Ok (st.RunningStatus , st) + StateT <| fun st -> Ok (st.RunningStatus , st) let inline setRunningEvent (runningStatus : VoiceEvent) : ParserMonad = - ParserMonad <| fun st -> Ok ((), { st with RunningStatus = runningStatus }) + StateT <| fun st -> Ok ((), { st with RunningStatus = runningStatus }) let getPos : ParserMonad = - ParserMonad <| fun st -> Ok (st.Position, st) + StateT <| fun st -> Ok (st.Position, st) let inline private (|PositionValid|PositionInvalid|) (input: MidiData, state: State) = if state.Position >= 0 && state.Position < input.Length then @@ -268,7 +245,7 @@ module ParserMonad = PositionInvalid let inline private checkedParseM (name: string) (f: State -> Result<('a * State), ParseError>) = - ParserMonad + StateT (fun state -> try match state.Input, state with @@ -296,7 +273,7 @@ module ParserMonad = /// Repeats a given times. /// Fails with accumulated errors when any encountered. let inline count (length : ^T) (parser : ParserMonad<'a>) : ParserMonad<'a []> = - ParserMonad <| fun state -> + StateT <| fun state -> let rec work (i : 'T) (st : State) (fk : ParseError -> Result<'a list * State, ParseError>) @@ -314,7 +291,7 @@ module ParserMonad = /// Run a parser within a bounded section of the input stream. let repeatTillPosition (maxPosition: Pos) (parser: ParserMonad<'a>) : ParserMonad<'a array> = - ParserMonad <| fun state -> + StateT <| fun state -> let limit = maxPosition let rec work (st : State) (fk : ParseError -> Result<'a list * State, ParseError>) @@ -402,4 +379,4 @@ module ParserMonad = let! b = readByte let! c = readByte return (word24be a b c) - } + } \ No newline at end of file diff --git a/src/ZMidi/Read.fs b/src/ZMidi/Read.fs index 8b6c8ad..c50fea1 100644 --- a/src/ZMidi/Read.fs +++ b/src/ZMidi/Read.fs @@ -1,5 +1,6 @@ namespace ZMidi +open FSharpPlus open ZMidi.DataTypes module ReadFile = From 907f45468288db009dd2a6edfe17567d187643a4 Mon Sep 17 00:00:00 2001 From: Gusty <1261319+gusty@users.noreply.github.com> Date: Sat, 1 Feb 2020 01:48:21 +0100 Subject: [PATCH 4/6] Remove / change redundant code --- src/ZMidi/ExtraTypes.fs | 10 +++++----- src/ZMidi/Internal/ParserMonad.fs | 29 ++--------------------------- src/ZMidi/Internal/Utils.fs | 17 ++++++++--------- src/ZMidi/Read.fs | 1 - src/ZMidi/Write.fs | 12 +++++------- 5 files changed, 20 insertions(+), 49 deletions(-) diff --git a/src/ZMidi/ExtraTypes.fs b/src/ZMidi/ExtraTypes.fs index d0cee23..7ffbbed 100644 --- a/src/ZMidi/ExtraTypes.fs +++ b/src/ZMidi/ExtraTypes.fs @@ -1,5 +1,5 @@ module ZMidi.Internal.ExtraTypes -open ZMidi.DataTypes +open FSharpPlus.Math.Generic @@ -31,8 +31,8 @@ let fromVarlen = let inline encodeVarlen (myValue) = let inline initMask nBits = [|0 .. nBits - 1|] - |> Array.map (fun shift -> LanguagePrimitives.GenericOne <<< shift) - |> Array.fold ((|||)) LanguagePrimitives.GenericZero + |> Array.map (fun shift -> 1G <<< shift) + |> Array.fold ((|||)) 0G let nBits = 7 let maxBits = let nMaxBytes = System.Runtime.InteropServices.Marshal.SizeOf(myValue.GetType()) @@ -50,7 +50,7 @@ let inline encodeVarlen (myValue) = shiftAnd7Bits |> Array.rev - |> Array.skipWhile ((=) LanguagePrimitives.GenericZero) - |> function | [||] -> [|LanguagePrimitives.GenericZero|] + |> Array.skipWhile ((=) 0G) + |> function | [||] -> [|0G|] | bytes -> bytes diff --git a/src/ZMidi/Internal/ParserMonad.fs b/src/ZMidi/Internal/ParserMonad.fs index 3782205..ee30168 100644 --- a/src/ZMidi/Internal/ParserMonad.fs +++ b/src/ZMidi/Internal/ParserMonad.fs @@ -6,7 +6,6 @@ module ParserMonad = open System.IO open FSharpPlus open FSharpPlus.Data - open ZMidi.Internal.Utils /// Status is either OFF or the previous VoiceEvent * Channel. type VoiceEvent = @@ -130,15 +129,7 @@ module ParserMonad = ) ) - let inline mreturn (x:'a) : ParserMonad<'a> = - StateT <| fun st -> Ok (x, st) - - let inline private bindM (parser : ParserMonad<'a>) - (next : 'a -> ParserMonad<'b>) : ParserMonad<'b> = - StateT <| fun state -> - match apply1 parser state with - | Error msg -> Error msg - | Ok (ans, st1) -> apply1 (next ans) st1 + let inline mreturn (x:'a) : ParserMonad<'a> = result x let mzero () : ParserMonad<'a> = StateT <| fun state -> Error (mkParseError state (EOF "mzero")) @@ -149,14 +140,7 @@ module ParserMonad = | Error _ -> apply1 parser2 state | Ok res -> Ok res - let inline private delayM (fn:unit -> ParserMonad<'a>) : ParserMonad<'a> = - bindM (mreturn ()) fn - let inline mfor (items: #seq<'a>) (fn: 'a -> ParserMonad<'b>) : ParserMonad> = failwithf "" - - - let (>>=) (m: ParserMonad<'a>) (k: 'a -> ParserMonad<'b>) : ParserMonad<'b> = - bindM m k let parseMidi = monad @@ -193,17 +177,8 @@ module ParserMonad = Error(mkOtherParseError st genMessage) /// - let fmap (f: 'a -> 'b) (p: ParserMonad<'a>) : ParserMonad<'b> = - parseMidi { - let! a = p - return (f a) - } + let fmap (f: 'a -> 'b) (p: ParserMonad<'a>) : ParserMonad<'b> = map f p let inline ( <~> (* <$> *) ) (a) b = fmap a b - let ( *> ) (a: ParserMonad<'a>) (b: 'a -> ParserMonad<'b>) : ParserMonad<'b> = - parseMidi { - let! a = a - return! (b a) - } // http://hackage.haskell.org/package/base-4.12.0.0/docs/src/GHC.Base.html#%3C%24 /// Replace all locations in the input with the same value. diff --git a/src/ZMidi/Internal/Utils.fs b/src/ZMidi/Internal/Utils.fs index 021ba0c..bb07659 100755 --- a/src/ZMidi/Internal/Utils.fs +++ b/src/ZMidi/Internal/Utils.fs @@ -1,8 +1,7 @@ namespace ZMidi.Internal open ZMidi.DataTypes +open FSharpPlus -module Evil = - let inline uncurry4 f = fun (a,b,c,d) -> f a b c d module DataTypes = module FromBytes = @@ -39,21 +38,21 @@ module DataTypes = module Iso = let reverse iso = snd iso, fst iso - let word32be : Iso<_,_> = (ToBytes.word32be), (Evil.uncurry4 FromBytes.word32be) + let word32be : Iso<_,_> = (ToBytes.word32be), (uncurryN FromBytes.word32be) module Utils = - open System.IO + open FSharpPlus.Math.Generic let inline (|TestBit|_|) (bit: int) (i: ^T) = - let mask = LanguagePrimitives.GenericOne <<< bit + let mask = 1G <<< bit if mask &&& i = mask then Some () else None let inline clearBit (bit: int) (i: ^T) = - let mask = ~~~ (LanguagePrimitives.GenericOne <<< bit) + let mask = ~~~ (1G <<< bit) i &&& mask let inline setBit (bit: int) (i: ^T) = - let mask = (LanguagePrimitives.GenericOne <<< bit) + let mask = (1G <<< bit) i ||| mask let inline msbHigh i = match i with @@ -86,8 +85,8 @@ module Utils = [|0 .. (maxSize - 1)|] |> Array.rev |> Array.map (fun shift -> - let mask = LanguagePrimitives.GenericOne <<< shift - if (number &&& mask <> LanguagePrimitives.GenericZero) then "■" else " " + let mask = 1G <<< shift + if (number &&& mask <> 0G) then "■" else " " ) |> String.concat "" |> sprintf "[%s]" diff --git a/src/ZMidi/Read.fs b/src/ZMidi/Read.fs index c50fea1..b313ccd 100644 --- a/src/ZMidi/Read.fs +++ b/src/ZMidi/Read.fs @@ -157,7 +157,6 @@ module ReadFile = } let metaEvent i = - let konst k _ = k parseMidi { match i with | 0x00uy -> return! metaEventSequenceNumber (konst "sequence number") diff --git a/src/ZMidi/Write.fs b/src/ZMidi/Write.fs index 56ca9ea..6f1118b 100644 --- a/src/ZMidi/Write.fs +++ b/src/ZMidi/Write.fs @@ -3,19 +3,17 @@ open ZMidi.DataTypes open ZMidi.Internal.Utils open ZMidi.Internal.WriterMonad open System.Text +open FSharpPlus + module WriteFile = module PutOps = - let putAscii (text: string) = text |> Encoding.ASCII.GetBytes |> PutBytes + let putAscii (text: string) = String.getBytes Encoding.ASCII text |> PutBytes - let putWord32be (value: uint32) = PutBytes [| byte (value >>> 24) - byte (value >>> 16) - byte (value >>> 8) - byte (value >>> 0) |] + let putWord32be (value: uint32) = PutBytes (toBytesBE value) - let putWord16be (value: uint16) = PutBytes [| byte (value >>> 8) - byte (value >>> 0) |] + let putWord16be (value: uint16) = PutBytes (toBytesBE value) let putFormat = putWord16be << function | MidiFormat0 -> 0us | MidiFormat1 -> 1us From f5d8b19f0e619a7b8781e93400f8571f2de2c52e Mon Sep 17 00:00:00 2001 From: Gusty <1261319+gusty@users.noreply.github.com> Date: Sun, 2 Feb 2020 18:40:54 +0100 Subject: [PATCH 5/6] Use more numeric stuff --- src/ZMidi/Internal/ParserMonad.fs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/src/ZMidi/Internal/ParserMonad.fs b/src/ZMidi/Internal/ParserMonad.fs index ee30168..1685d72 100644 --- a/src/ZMidi/Internal/ParserMonad.fs +++ b/src/ZMidi/Internal/ParserMonad.fs @@ -6,6 +6,7 @@ module ParserMonad = open System.IO open FSharpPlus open FSharpPlus.Data + open FSharpPlus.Math.Generic /// Status is either OFF or the previous VoiceEvent * Channel. type VoiceEvent = @@ -68,6 +69,8 @@ module ParserMonad = #if DEBUG_LASTPARSE * lastToken : obj // need top level type, picking System.Object for now #endif + with + static member (+) (_: ParseError, y: ParseError) = y let inline mkOtherParseError st (genMessage : Pos -> string) = ParseError( @@ -134,11 +137,7 @@ module ParserMonad = let mzero () : ParserMonad<'a> = StateT <| fun state -> Error (mkParseError state (EOF "mzero")) - let inline mplus (parser1 : ParserMonad<'a>) (parser2 : ParserMonad<'a>) : ParserMonad<'a> = - StateT <| fun state -> - match apply1 parser1 state with - | Error _ -> apply1 parser2 state - | Ok res -> Ok res + let inline mplus (parser1 : ParserMonad<'a>) (parser2 : ParserMonad<'a>) : ParserMonad<'a> = parser1 <|> parser2 let inline mfor (items: #seq<'a>) (fn: 'a -> ParserMonad<'b>) : ParserMonad> = failwithf "" @@ -253,13 +252,13 @@ module ParserMonad = (st : State) (fk : ParseError -> Result<'a list * State, ParseError>) (sk : State -> 'a list -> Result<'a list * State, ParseError>) = - if i <= LanguagePrimitives.GenericZero then + if i <= 0G then sk st [] else match apply1 parser st with | Error msg -> fk msg | Ok (a1, st1) -> - work (i - LanguagePrimitives.GenericOne) st1 fk (fun st2 ac -> + work (i - 1G) st1 fk (fun st2 ac -> sk st2 (a1 :: ac)) work length state (fun msg -> Error msg) (fun st ac -> Ok (ac, st)) |> Result.map (fun (ans, st) -> (List.toArray ans, st)) From bf8c2216ffb5cc3b9cf8bd73702e46d1d2c4444c Mon Sep 17 00:00:00 2001 From: Gusty <1261319+gusty@users.noreply.github.com> Date: Sun, 2 Feb 2020 18:49:59 +0100 Subject: [PATCH 6/6] Use catch in definition --- src/ZMidi/Internal/ParserMonad.fs | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/src/ZMidi/Internal/ParserMonad.fs b/src/ZMidi/Internal/ParserMonad.fs index 1685d72..3e9bf6f 100644 --- a/src/ZMidi/Internal/ParserMonad.fs +++ b/src/ZMidi/Internal/ParserMonad.fs @@ -167,13 +167,8 @@ module ParserMonad = fmapM modify parser /// Run the parser, if it fails swap the error message. - let inline ( ) (parser : ParserMonad<'a>) (genMessage : Pos -> string) : ParserMonad<'a> = - StateT <| fun st -> - match apply1 parser st with - | Ok result -> Ok result - | Error e -> - logf "oops : e:%A" e - Error(mkOtherParseError st genMessage) + let inline ( ) (parser : ParserMonad<'a>) (genMessage : Pos -> string) : ParserMonad<'a> = + parser fun (ParseError (pos, _)) -> throw <| ParseError (pos, Other (genMessage pos)) /// let fmap (f: 'a -> 'b) (p: ParserMonad<'a>) : ParserMonad<'b> = map f p