Switch to StateT

Author: gusty

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<State, Result<'a * State, ParseError>>
 
     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,31 +158,6 @@ 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 runParser (ma:ParserMonad<'a>) input initialState =
       apply1 ma { initialState with Input = input}
       |> Result.map fst
@@ -194,11 +169,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)
 
     /// 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 ->
@@ -207,13 +182,13 @@ module ParserMonad =
 
     ///
     let fmap (f: 'a -> 'b) (p: ParserMonad<'a>) : ParserMonad<'b> =
-      parseMidi {
+      monad {
         let! a = p
         return (f a)
       }
     let inline ( <~> (* <$> *) ) (a) b = fmap a b
     let ( *> ) (a: ParserMonad<'a>) (b: 'a -> ParserMonad<'b>) : ParserMonad<'b> = 
-      parseMidi {
+      monad {
         let! a = a
         return! (b a)
       }
@@ -240,16 +215,16 @@ 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
@@ -258,7 +233,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
@@ -286,7 +261,7 @@ module ParserMonad =
     /// 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 state ->
+        StateT <| fun state ->
             let rec work (i : 'T) 
                          (st : State) 
                          (fk : ParseError -> Result<'a list * State, ParseError>) 
@@ -305,7 +280,7 @@ module ParserMonad =
 
     /// Run a parser within a bounded section of the input stream.
     let repeatTillPosition (maxPosition: Pos) (p: ParserMonad<'a>) : ParserMonad<'a array> =
-        ParserMonad(fun state ->
+        StateT(fun state ->
             let results = ResizeArray()
             let mutable firstError = Ok (Array.empty, state) 
             let mutable lastState = state
@@ -328,7 +303,7 @@ module ParserMonad =
         )
 
     let inline boundRepeat (n: ^T) (p: ParserMonad<'a>) : ParserMonad<'a array> =
-        ParserMonad(fun state ->
+        StateT (fun state ->
             let result = Array.zeroCreate (int n)
             let mutable lastState = state
 // revisit with a fold?
@@ -357,7 +332,7 @@ module ParserMonad =
     /// Apply the parser for /count/ times, derive the final answer
     /// from the intermediate list with the supplied function.
     let inline gencount (plen: ParserMonad<'T>) (p: ParserMonad<'a>) (constr: ^T -> 'a array -> 'answer) : ParserMonad<'answer> =
-        parseMidi {
+        monad {
           let! l = plen
           logf "gen count: l: %i" l
           let! items = boundRepeat l p
@@ -378,22 +353,22 @@ module ParserMonad =
 
     /// Parse a single byte char.
     let readChar : ParserMonad<char> = 
-        parseMidi { 
+        monad { 
             let! a = readByte
             return (char a)
         }
 
     /// Parse a string of the given length.
     let readString (length : int) : ParserMonad<string> = 
-        parseMidi { 
+        monad { 
             let! arr = count length readChar
             return (System.String arr)
         }
         <??> sprintf "readString failed at %i"
     open ZMidi.Internal.DataTypes.FromBytes
     /// Parse a uint16 (big endian).
     let readUInt16be : ParserMonad<uint16>= 
-        parseMidi { 
+        monad { 
             let! a = readByte
             let! b = readByte
             return word16be a b
@@ -402,7 +377,7 @@ module ParserMonad =
 
     /// Parse a word14 (big endian) from 2 consecutive bytes.
     let readWord14be = 
-        parseMidi {
+        monad {
             let! a = readByte
             let! b = readByte
             return (word14be a b)
@@ -411,7 +386,7 @@ module ParserMonad =
 
     /// Parse a word32 (big endian).
     let readUInt32be =
-      parseMidi {
+      monad {
         let! a = readByte
         let! b = readByte
         let! c = readByte
@@ -421,9 +396,9 @@ module ParserMonad =
 
     /// Parse a word24 (big endian).
     let readWord24be =
-        parseMidi {
+        monad {
             let! a = readByte
             let! b = readByte
             let! c = readByte
             return (word24be a b c)
-        }
+        }