Use StateT from F#+

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 
 

src/ZMidi/Internal/ParserMonad.fs

@@ -4,8 +4,9 @@ namespace ZMidi.Internal
 module ParserMonad = 
 
     open System.IO
-
-    open ZMidi.Internal.Utils
+    open FSharpPlus
+    open FSharpPlus.Data
+    open FSharpPlus.Math.Generic
 
     /// Status is either OFF or the previous VoiceEvent * Channel.
     type VoiceEvent = 
@@ -40,13 +41,15 @@ module ParserMonad =
     type State = 
         { Position: Pos 
           RunningStatus: VoiceEvent
+          Input: MidiData
           #if DEBUG_LASTPARSE
           LastParse : obj
           #endif
         }
         static member initial =
             { Position = 0
               RunningStatus = VoiceEvent.StatusOff
+              Input = [||]
               #if DEBUG_LASTPARSE
               LastParse = null
               #endif
@@ -66,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(
@@ -85,8 +90,7 @@ module ParserMonad =
         #endif
       )
 
-    type ParserMonad<'a> = 
-        ParserMonad of (MidiData -> State -> Result<'a * State, ParseError> )
+    type ParserMonad<'a> = StateT<State, Result<'a * State, ParseError>>
 
     let nullOut = new StreamWriter(Stream.Null) :> TextWriter
     let mutable debug = false
@@ -97,12 +101,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 
+        let (StateT fn) = parser 
         try
-            let result = fn midiData state
+            let result = fn state
             let oldState = state
             match result with
             | Ok (r, state) ->
@@ -129,61 +132,19 @@ module ParserMonad =
                                 )
                   )
 
-    let inline mreturn (x:'a) : ParserMonad<'a> = 
-        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
-            | Error msg -> Error msg
-            | Ok (ans, st1) -> apply1 (next ans) input st1
+    let inline mreturn (x:'a) : ParserMonad<'a> = result x
 
     let mzero () : ParserMonad<'a> = 
-        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
-            | Ok res -> Ok res
+        StateT <| fun state -> Error (mkParseError state (EOF "mzero"))
 
-    let inline private delayM (fn:unit -> ParserMonad<'a>) : ParserMonad<'a> = 
-        bindM (mreturn ()) fn 
+    let inline mplus (parser1 : ParserMonad<'a>) (parser2 : ParserMonad<'a>) : ParserMonad<'a> = parser1 <|> parser2
 
     let inline mfor (items: #seq<'a>) (fn: 'a -> ParserMonad<'b>) : ParserMonad<seq<'b>> = failwithf ""
-
-
-    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 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 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 input initialState
+      apply1 ma { initialState with Input = input}
       |> Result.map fst
 
     /// Run the parser on a file.
@@ -193,11 +154,11 @@ 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 input state -> 
-            match apply1 parser input state with
+        StateT <| fun state -> 
+            match apply1 parser state with
             | Error err -> Error err
             | Ok (a, st2) -> Ok (modify a, st2)
 
@@ -206,26 +167,12 @@ 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> = 
-        ParserMonad <| fun input st -> 
-            match apply1 parser input 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 </catch/> fun (ParseError (pos, _)) -> throw <| ParseError (pos, Other (genMessage pos))
 
     ///
-    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.
@@ -249,76 +196,76 @@ module ParserMonad =
 
 
     let fatalError err =
-      ParserMonad <| fun _ st -> Error (mkParseError st err)
+      StateT <| fun st -> Error (mkParseError st err)
 
     let getRunningEvent : ParserMonad<VoiceEvent> = 
-        ParserMonad <| fun _ st -> Ok (st.RunningStatus , st)
+        StateT <| fun st -> Ok (st.RunningStatus , st)
 
     let inline setRunningEvent (runningStatus : VoiceEvent) : ParserMonad<unit> = 
-        ParserMonad <| fun _ st -> Ok ((),  { st with RunningStatus = runningStatus })
+        StateT <| fun st -> Ok ((),  { st with RunningStatus = runningStatus })
 
     let getPos : ParserMonad<int> =
-        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
         PositionValid
       else
         PositionInvalid
 
-    let inline private checkedParseM (name: string) (f: MidiData -> State -> Result<('a * State), ParseError>) =
-        ParserMonad 
-            (fun input state -> 
+    let inline private checkedParseM (name: string) (f: State -> Result<('a * State), ParseError>) =
+        StateT 
+            (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)))
             )
 
     let peek : ParserMonad<byte> =
         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<byte option> = 
         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)
 
     /// Repeats a given <see paramref="parser"/> <see paramref="length"/> times.
     /// Fails with accumulated errors when any encountered.
     let inline count (length : ^T) (parser : ParserMonad<'a>) : ParserMonad<'a []> =
-        ParserMonad <| fun input state ->
+        StateT <| fun state ->
             let rec work (i : 'T) 
                          (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 input st with
+                    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))
 
     /// 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 -> 
+        StateT <| 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 +289,13 @@ module ParserMonad =
     /// Drop a byte (word8).
     let dropByte : ParserMonad<unit> = 
         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<byte> = 
         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.

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]"

src/ZMidi/Read.fs

@@ -1,5 +1,6 @@
 namespace ZMidi
 
+open FSharpPlus
 open ZMidi.DataTypes
 
 module ReadFile =
@@ -156,7 +157,6 @@ module ReadFile =
       }
 
     let metaEvent i =
-      let konst k _ = k
       parseMidi {
         match i with
         | 0x00uy -> return! metaEventSequenceNumber    <??> (konst "sequence number")