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 old mode 100755 new mode 100644 index 4f32686..3e9bf6f --- a/src/ZMidi/Internal/ParserMonad.fs +++ b/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,6 +41,7 @@ module ParserMonad = type State = { Position: Pos RunningStatus: VoiceEvent + Input: MidiData #if DEBUG_LASTPARSE LastParse : obj #endif @@ -47,6 +49,7 @@ module ParserMonad = 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> 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> = 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 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,16 +196,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 @@ -266,12 +213,12 @@ module ParserMonad = 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))) @@ -279,15 +226,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,30 +242,30 @@ 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 -> + 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 = 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. 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 8b6c8ad..b313ccd 100644 --- a/src/ZMidi/Read.fs +++ b/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") 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 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 @@ + + + +