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