Skip to content

Commit dabb99e

Browse files
smoothdevelopersmoothdeveloper
committed
fiddling with getVarlen tests (broken broken)
1 parent 882574b commit dabb99e

File tree

5 files changed

+247
-23
lines changed

5 files changed

+247
-23
lines changed

‎demo/scratch.fsx

Lines changed: 72 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,72 @@
1+
#load "../src/zmidi/datatypes.fs"
2+
#load "../src/zmidi/extratypes.fs"
3+
#load "../src/zmidi/internal/utils.fs"
4+
#load "../src/zmidi/internal/parsermonad.fs"
5+
#load "../src/zmidi/read.fs"
6+
//#r "../build/Debug/AnyCPU/net45/zmidi-fs-core.dll"
7+
open System.IO
8+
open ZMidi.Internal.ParserMonad
9+
(*
10+
let folder =
11+
Path.Combine(__SOURCE_DIRECTORY__ , ".." , "data", "midifiles")
12+
|> DirectoryInfo
13+
14+
for file in folder.EnumerateFiles() do
15+
let buffer = File.ReadAllBytes file.FullName
16+
17+
let parseResult =
18+
ZMidi.Internal.ParserMonad.runParser
19+
ZMidi.ReadFile.midiFile
20+
buffer
21+
State.initial
22+
23+
24+
printfn "%s" file.FullName
25+
26+
match parseResult with
27+
| Ok result ->
28+
29+
printfn "%i tracks" result.tracks.Length
30+
for t in result.tracks do
31+
t.Length
32+
printfn "track: %A" t
33+
()
34+
| Error something -> printfn "ERR: %s %A" file.FullName something
35+
36+
*)
37+
let cases =
38+
[|
39+
{| expected = 0x00000000u; input = [|0x00uy|] |}
40+
{| expected = 0x00000040u; input = [|0x40uy|] |}
41+
{| expected = 0x0000007fu; input = [|0x7fuy|] |}
42+
{| expected = 0x00000080u; input = [|0x81uy; 0x00uy|] |}
43+
{| expected = 0x00002000u; input = [|0xc0uy; 0x00uy|] |}
44+
{| expected = 0x00003fffu; input = [|0xffuy; 0x7fuy|] |}
45+
{| expected = 0x00004000u; input = [|0x81uy; 0x80uy; 0x00uy|] |}
46+
{| expected = 0x00100000u; input = [|0xc0uy; 0x80uy; 0x00uy|] |}
47+
{| expected = 0x001fffffu; input = [|0xffuy; 0xffuy; 0x7fuy|] |}
48+
{| expected = 0x00200000u; input = [|0x81uy; 0x80uy; 0x80uy; 0x00uy|] |}
49+
{| expected = 0x08000000u; input = [|0xc0uy; 0x80uy; 0x80uy; 0x00uy|] |}
50+
{| expected = 0x0fffffffu; input = [|0xffuy; 0xffuy; 0xffuy; 0x7fuy|] |}
51+
|]
52+
for case in cases do
53+
let state = State.initial
54+
55+
let result = runParser ZMidi.ReadFile.getVarlen case.input state
56+
printfn "%A" result
57+
58+
59+
60+
let inline (|TestBit|_|) (bit: int) (i: ^T) =
61+
let mask = LanguagePrimitives.GenericOne <<< bit
62+
if mask &&& i = mask then Some () else None
63+
64+
let inline clearBit (bit: int) (i: ^T) =
65+
let mask = ~~~ (LanguagePrimitives.GenericOne <<< bit)
66+
i &&& mask
67+
let inline msbHigh i =
68+
match i with
69+
| TestBit 7 -> true
70+
| _ -> false
71+
72+
msbHigh 0x80uy &&& 0x7fuy

‎src/ZMidi/ExtraTypes.fs

Lines changed: 29 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,29 @@
1+
module ZMidi.Internal.ExtraTypes
2+
3+
4+
5+
// --------------------------------------------------------------------------------
6+
// -- Helper for varlen
7+
// --------------------------------------------------------------------------------
8+
9+
/// Space efficient representation of length fields.
10+
///
11+
/// This data type is not used directly in the syntax tree where
12+
/// it would be cumbersome. But it is used as an intermediate type
13+
/// in the parser and emitter.
14+
///
15+
type Varlen = V1 of byte
16+
| V2 of byte * byte
17+
| V3 of byte * byte * byte
18+
| V4 of byte * byte * byte * byte
19+
20+
21+
let inline up v = 0x7fuy &&& v
22+
let inline left7 v = v <<< 7
23+
let inline left14 v = v <<< 14
24+
let inline left21 v = v <<< 21
25+
let fromVarlen =
26+
function | V1 a -> uint32 (up a)
27+
| V2 (a, b) -> (left7 (uint32 (up a))) + (uint32 (up b))
28+
| V3 (a, b, c) -> (left14 (uint32 (up a))) + (left7 (uint32 (up b))) + uint32 (up c)
29+
| V4 (a, b, c, d) -> (left21 (uint32 (up a))) + (left14 (uint32 (up b))) + (left7 (uint32 (up c))) + uint32 (up d)

‎src/ZMidi/Internal/ParserMonad.fs

Lines changed: 39 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -142,7 +142,44 @@ module ParserMonad =
142142
match apply1 parser input st with
143143
| Ok result -> Ok result
144144
| Error _ -> Error(mkOtherParseError st genMessage)
145+
146+
let (>>=) (m: ParserMonad<'a>) (k: 'a -> ParserMonad<'b>) : ParserMonad<'b> =
147+
bindM m k
148+
149+
///
150+
let fmap (f: 'a -> 'b) (p: ParserMonad<'a>) : ParserMonad<'b> =
151+
parseMidi {
152+
let! a = p
153+
return (f a)
154+
}
155+
let inline ( <~> (* <$> *) ) (a) b = fmap a b
156+
let ( *> ) (a: ParserMonad<'a>) (b: 'a -> ParserMonad<'b>) : ParserMonad<'b> =
157+
parseMidi {
158+
let! a = a
159+
return! (b a)
160+
}
161+
162+
// http://hackage.haskell.org/package/base-4.12.0.0/docs/src/GHC.Base.html#%3C%24
163+
/// Replace all locations in the input with the same value.
164+
/// The default definition is @'fmap' . 'const'@, but this may be
165+
/// overridden with a more efficient version.
166+
let inline ( <~ (* <$ *) ) (a: 'a) (b: ParserMonad<'b>) : ParserMonad<'a> =
167+
(*let konst k _ = k
168+
let x = fmap a b
169+
konst x b*)
170+
failwithf ""
171+
//(fmap >> konst) a b
145172

173+
/// Sequence actions, discarding the value of the first argument.
174+
//let liftA2 f x = (<*>) (fmap f x)
175+
176+
//let ( <*> ) = liftA2 id
177+
//let ( *> ) a1 a2 =
178+
//
179+
// (id <~ a1) <*> a2
180+
//
181+
182+
146183
let fatalError err =
147184
ParserMonad <| fun _ st -> Error (mkParseError st err)
148185

@@ -232,8 +269,8 @@ module ParserMonad =
232269
fun input st -> Ok ((), { st with Position = st.Position + 1 })
233270

234271
/// Parse a byte (Word8).
235-
let readByte : ParserMonad<byte>=
236-
checkedParseM "dropByte" <|
272+
let readByte : ParserMonad<byte> =
273+
checkedParseM "readByte" <|
237274
fun input st ->
238275
let a1 = input.[st.Position]
239276
Ok (a1, { st with Position = st.Position + 1 })

‎src/ZMidi/Read.fs

Lines changed: 94 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,9 @@ module ReadFile =
2020
return! fatalError errorMessage
2121
}
2222

23+
24+
25+
2326
let inline (|TestBit|_|) (bit: int) (i: ^T) =
2427
let mask = LanguagePrimitives.GenericOne <<< bit
2528
if mask &&& i = mask then Some () else None
@@ -39,25 +42,64 @@ module ReadFile =
3942

4043
let assertWord8 i =
4144
postCheck readByte ((=) i) (Other (sprintf "assertWord8: expected '%i'" i))
42-
45+
4346
let getVarlen : ParserMonad<word32> =
44-
parseMidi {
45-
let! a = readByte
46-
if msbHigh a then
47+
let rec loop acc =
48+
parseMidi {
4749
let! b = readByte
50+
4851
if msbHigh b then
49-
let! c = readByte
50-
if msbHigh c then
51-
let! d = readByte
52-
return fromVarlen (V4(a,b,c,d))
53-
else
54-
return fromVarlen (V3(a,b,c))
52+
let result = (b &&& 0x7fuy)
53+
return! loop (acc + ((uint64 (result)) * 128UL ))
5554
else
56-
return fromVarlen (V2(a, b))
57-
else
58-
return fromVarlen (V1 a)
59-
60-
}
55+
return (acc + (uint64 b)) }
56+
parseMidi {
57+
let! result = loop 0UL
58+
return (uint32 result) }
59+
60+
61+
(*
62+
let step3 a b =
63+
parseMidi {
64+
let! c = readByte
65+
if msbHigh c then
66+
let! d = readByte
67+
return V4 (a,b,c,d)
68+
else
69+
return V3 (a,b,c) }
70+
let step2 a = parseMidi {
71+
let! b = readByte
72+
if msbHigh b then
73+
return! step3 a b
74+
else
75+
return V2 (a,b) }
76+
77+
parseMidi {
78+
let! a = readByte
79+
if msbHigh a then
80+
let! r = step2 a
81+
return (ZMidi.Internal.ExtraTypes.fromVarlen r)
82+
else
83+
return (ZMidi.Internal.ExtraTypes.fromVarlen (V1 a))
84+
85+
//return result
86+
//>>= (fun a ->)
87+
//let! a = readByte
88+
//if msbHigh a then
89+
// let! b = readByte
90+
// if msbHigh b then
91+
// let! c = readByte
92+
// if msbHigh c then
93+
// let! d = readByte
94+
// return fromVarlen (V4(a,b,c,d))
95+
// else
96+
// return fromVarlen (V3(a,b,c))
97+
// else
98+
// return fromVarlen (V2(a, b))
99+
//else
100+
// return fromVarlen (V1 a)
101+
102+
}*)
61103

62104
let getVarlenText = gencount getVarlen readChar (fun _ b -> System.String b)
63105

@@ -119,9 +161,46 @@ module ReadFile =
119161
| 0x06 -> return! textEvent Marker
120162
| 0x07 -> return! textEvent CuePoint
121163
}
164+
// let (<*>) af ma =
165+
122166

167+
let runningStatus : ParserMonad<MidiRunningStatus> =
168+
parseMidi {
169+
170+
return MidiRunningStatus.ON
171+
}
172+
//let metaEvent n = //: ParserMonad<MetaEvent> =
173+
// match n with
174+
// ///| 0x00uy -> ( SequenceNumber <~> (assertWord8 2uy *> word16be)) <??> (sprintf "sequence number: failed at %i" )
175+
// | 0x01uy -> (textEvent GenericText) <??> (sprintf "generic text: failed at %i")
176+
// | 0x02uy -> (textEvent CopyrightNotice) <??> (sprintf "generic text: failed at %i")
177+
// | 0x03uy -> (textEvent SequenceName) <??> (sprintf "generic text: failed at %i")
178+
// | 0x04uy -> (textEvent InstrumentName) <??> (sprintf "generic text: failed at %i")
179+
// | 0x05uy -> (textEvent Lyrics) <??> (sprintf "generic text: failed at %i")
180+
// | 0x06uy -> (textEvent Marker) <??> (sprintf "generic text: failed at %i")
181+
// | 0x07uy -> (textEvent CuePoint) <??> (sprintf "generic text: failed at %i")
182+
// //| 0x20uy -> (textEvent GenericText) <??> (sprintf "generic text: failed at %i")
183+
// | _ -> failwithf "metaEvent %i" n
184+
185+
//parseMidi {
186+
//
187+
//}
123188
let event : ParserMonad<MidiEvent> =
189+
let step n : ParserMonad<MidiMetaEvent>=
190+
//parseMidi {
191+
match n with
192+
| 0xffuy -> failwithf "" //MetaEvent <~> (dropByte *> (readByte >>= metaEvent))
193+
//| 0xf7uy -> ()//SysexEvent
194+
//| 0xf0uy -> ()//SysexEvent
195+
//| 0x80uy -> ()//VoiceEvent
196+
//| n when n >= 0xf8uy -> ()//SysRealtimeEvent
197+
//| n when n >= 0xf1uy -> ()//SysCommonEvent
198+
//| n when n >= 0x80uy -> ()//VoiceEvent
199+
//| _ -> getRunningEvent >>= runningStatus
200+
//}
124201
parseMidi {
202+
let! p = peek
203+
step p
125204
return! fatalError (Other "event: not implemented") }
126205

127206
let deltaTime =

‎test/tests/Tests.fs

Lines changed: 13 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -7,14 +7,21 @@ let tests =
77
test "parseVarlen" {
88
let cases =
99
[|
10-
{| input = [| 0x00uy |]; expected = 0u |}
11-
{| input = [| 0x7fuy |]; expected = 127u |}
12-
{| input = [| 0x80uy |]; expected = 128u |}
13-
{| input = [| 0x03uy; 0xe8uy |]; expected = 1000u |}
14-
{| input = [| 0x3fuy; 0xffuy |]; expected = 16383u |}
15-
{| input = [| 0x0fuy; 0x42uy; 0x40uy |]; expected = 100000u |}
10+
//{| expected = 0x00000000u; input = [|0x00uy|] |}
11+
//{| expected = 0x00000040u; input = [|0x40uy|] |}
12+
//{| expected = 0x0000007fu; input = [|0x7fuy|] |}
13+
{| expected = 0x00000080u; input = [|0x81uy; 0x00uy|] |}
14+
{| expected = 0x00002000u; input = [|0xc0uy; 0x00uy|] |}
15+
{| expected = 0x00003fffu; input = [|0xffuy; 0x7fuy|] |}
16+
{| expected = 0x00004000u; input = [|0x81uy; 0x80uy; 0x00uy|] |}
17+
{| expected = 0x00100000u; input = [|0xc0uy; 0x80uy; 0x00uy|] |}
18+
{| expected = 0x001fffffu; input = [|0xffuy; 0xffuy; 0x7fuy|] |}
19+
{| expected = 0x00200000u; input = [|0x81uy; 0x80uy; 0x80uy; 0x00uy|] |}
20+
{| expected = 0x08000000u; input = [|0xc0uy; 0x80uy; 0x80uy; 0x00uy|] |}
21+
{| expected = 0x0fffffffu; input = [|0xffuy; 0xffuy; 0xffuy; 0x7fuy|] |}
1622
|]
1723

24+
1825
let state = State.initial
1926

2027
let failures =

0 commit comments

Comments
 (0)