/fparsec/main/FParsec/Primitives.fs
F# | 884 lines | 752 code | 92 blank | 40 comment | 215 complexity | 1b85325a5836812f67c88819f56a6e82 MD5 | raw file
1// Copyright (c) Stephan Tolksdorf 2007-2009 2// License: Simplified BSD License. See accompanying documentation. 3 4module FParsec.Primitives 5 6open FParsec.Internals 7open FParsec.Error 8 9type ReplyStatus = Ok = 1 10 | Error = 0 11 | FatalError = -1 12 13[<Literal>] 14let Ok = ReplyStatus.Ok 15[<Literal>] 16let Error = ReplyStatus.Error 17[<Literal>] 18let FatalError = ReplyStatus.FatalError 19 20[<System.Diagnostics.DebuggerDisplay("{GetDebuggerDisplay(),nq}")>] 21[<CustomEquality; NoComparison>] 22type Reply<'Result,'UserState> = struct 23 new (result, state) = {State = state; Error = NoErrorMessages; Result = result; Status = Ok} 24 new (status, error, state) = {State = state; Error = error; Result = Unchecked.defaultof<_>; Status = status} 25 new (status, result, error, state) = {State = state; Error = error; Result = result; Status = status} 26 27 // The order of the following fields was chosen to optimize the object layout. 28 // We don't use LayoutKind.Auto because it inhibits JIT optimizations: 29 // http://blogs.msdn.com/clrcodegeneration/archive/2007/11/02/how-are-value-types-implemented-in-the-32-bit-clr-what-has-been-done-to-improve-their-performance.aspx 30 31 val mutable State: State<'UserState> 32 [<System.Diagnostics.DebuggerDisplay("{FParsec.Error.ErrorMessageList.GetDebuggerDisplay(Error),nq}")>] 33 val mutable Error: ErrorMessageList 34 /// If Status <> Ok then the value of the Result field is undefined and may be equal to Unchecked.defaultof<'Result>. 35 val mutable Result: 'Result 36 val mutable Status: ReplyStatus 37 38 override t.Equals(value: obj) = 39 match value with 40 | :? Reply<'Result,'UserState> as r -> 41 t.Status = r.Status 42 && (t.Status <> Ok || LanguagePrimitives.GenericEqualityERComparer.Equals(t.Result, r.Result)) 43 && t.State = r.State 44 && t.Error = r.Error 45 | _ -> false 46 47 override t.GetHashCode() = 48 // GetHashCode() is not required to return different hash codes for unequal instances 49 int t.Status ^^^ t.State.GetHashCode() 50 51 member private t.GetDebuggerDisplay() = 52 let pos = if isNull t.State then "null" else t.State.Position.ToString() 53 if t.Status = Ok && isNull t.Error then 54 if typeof<'Result> = typeof<unit> then "Reply((), " + pos + ")" 55 else sprintf "Reply(%0.5A, %s)" t.Result pos 56 else 57 let e = FParsec.Error.ErrorMessageList.GetDebuggerDisplay(t.Error) 58 if t.Status = Ok then 59 if typeof<'Result> = typeof<unit> then "Reply(Ok, (), " + e + ", " + pos + ")" 60 else sprintf "Reply(Ok, %0.5A, %s, %s)" t.Result e pos 61 else sprintf "Reply(Error, %s, %s)" e pos 62 63end 64 65type Parser<'a, 'u> = State<'u> -> Reply<'a,'u> 66 67// ================================= 68// Parser primitives and combinators 69// ================================= 70 71// The `PrimitiveTests.Reference` module contains simple (but sometimes naive) 72// reference implementations of most of the functions below. 73 74let preturn x = fun state -> Reply(x, state) 75let pzero : Parser<'a,'u> = fun state -> Reply(Error, NoErrorMessages, state) 76 77 78// --------------------------- 79// Chaining and piping parsers 80// --------------------------- 81 82let (>>=) (p: Parser<'a,'u>) (f: 'a -> Parser<'b,'u>) = 83 match box f with 84 // optimization for uncurried functions 85 | :? OptimizedClosures.FSharpFunc<'a, State<'u>, Reply<'b,'u>> as optF -> 86 fun state -> 87 let reply1 = p state 88 if reply1.Status = Ok then 89 let mutable reply2 = optF.Invoke(reply1.Result, reply1.State) 90 if isNotNull reply1.Error && reply2.State == reply1.State then 91 reply2.Error <- concatErrorMessages reply1.Error reply2.Error 92 reply2 93 else 94 Reply(reply1.Status, reply1.Error, reply1.State) 95 | _ -> 96 fun state -> 97 let reply1 = p state 98 if reply1.Status = Ok then 99 let p2 = f reply1.Result 100 let mutable reply2 = p2 reply1.State 101 if isNotNull reply1.Error && reply2.State == reply1.State then 102 reply2.Error <- concatErrorMessages reply1.Error reply2.Error 103 reply2 104 else 105 Reply(reply1.Status, reply1.Error, reply1.State) 106 107let (>>%) (p: Parser<'a,'u>) x = 108 fun state -> 109 let reply = p state 110 Reply(reply.Status, x, reply.Error, reply.State) 111 112let (>>.) (p: Parser<'a,'u>) (q: Parser<'b,'u>) = 113 fun state -> 114 let reply1 = p state 115 if reply1.Status = Ok then 116 let mutable reply2 = q reply1.State 117 if isNotNull reply1.Error && reply2.State == reply1.State then 118 reply2.Error <- concatErrorMessages reply1.Error reply2.Error 119 reply2 120 else 121 Reply(reply1.Status, reply1.Error, reply1.State) 122 123let (.>>) (p: Parser<'a,'u>) (q: Parser<'b,'u>) = 124 fun state -> 125 let mutable reply1 = p state 126 if reply1.Status = Ok then 127 let reply2 = q reply1.State 128 reply1.Error <- mergeErrorsIfNeeded reply1.State reply1.Error reply2.State reply2.Error 129 reply1.State <- reply2.State 130 reply1.Status <- reply2.Status 131 reply1 132 133let between (popen: Parser<_,'u>) (pclose: Parser<_,'u>) (p: Parser<_,'u>) = 134 fun state -> 135 let reply1 = popen state 136 if reply1.Status = Ok then 137 let mutable reply2 = p reply1.State 138 let error = mergeErrorsIfNeeded reply1.State reply1.Error reply2.State reply2.Error 139 if reply2.Status = Ok then 140 let reply3 = pclose reply2.State 141 reply2.Error <- mergeErrorsIfNeeded reply2.State error reply3.State reply3.Error 142 reply2.State <- reply3.State 143 reply2.Status <- reply3.Status 144 else 145 reply2.Error <- error 146 reply2 147 else 148 Reply(reply1.Status, reply1.Error, reply1.State) 149 150let (|>>) (p: Parser<'a,'u>) f = 151 fun state -> 152 let reply = p state 153 Reply(reply.Status, 154 (if reply.Status = Ok then f reply.Result else Unchecked.defaultof<_>), 155 reply.Error, 156 reply.State) 157 158let pipe2 (p1: Parser<'a,'u>) (p2: Parser<'b,'u>) f = 159 let optF = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f) 160 fun state -> 161 let reply1 = p1 state 162 let mutable error = reply1.Error 163 if reply1.Status = Ok then 164 let reply2 = p2 reply1.State 165 error <- mergeErrorsIfNeeded reply1.State error reply2.State reply2.Error 166 if reply2.Status = Ok then 167 Reply(Ok, optF.Invoke(reply1.Result, reply2.Result), error, reply2.State) 168 else Reply(reply2.Status, error, reply2.State) 169 else Reply(reply1.Status, reply1.Error, reply1.State) 170 171let pipe3 (p1: Parser<'a,'u>) (p2: Parser<'b,'u>) (p3: Parser<'c,'u>) f = 172 let optF = OptimizedClosures.FSharpFunc<_,_,_,_>.Adapt(f) 173 fun state -> 174 let reply1 = p1 state 175 let mutable error = reply1.Error 176 if reply1.Status = Ok then 177 let reply2 = p2 reply1.State 178 error <- mergeErrorsIfNeeded reply1.State error reply2.State reply2.Error 179 if reply2.Status = Ok then 180 let reply3 = p3 reply2.State 181 error <- mergeErrorsIfNeeded reply2.State error reply3.State reply3.Error 182 if reply3.Status = Ok then 183 Reply(Ok, optF.Invoke(reply1.Result, reply2.Result, reply3.Result), error, reply3.State) 184 else Reply(reply3.Status, error, reply3.State) 185 else Reply(reply2.Status, error, reply2.State) 186 else Reply(reply1.Status, error, reply1.State) 187 188let pipe4 (p1: Parser<'a,'u>) (p2: Parser<'b,'u>) (p3: Parser<'c,'u>) (p4: Parser<'d,'u>) f = 189 let optF = OptimizedClosures.FSharpFunc<_,_,_,_,_>.Adapt(f) 190 fun state -> 191 let reply1 = p1 state 192 let mutable error = reply1.Error 193 if reply1.Status = Ok then 194 let reply2 = p2 reply1.State 195 error <- mergeErrorsIfNeeded reply1.State error reply2.State reply2.Error 196 if reply2.Status = Ok then 197 let reply3 = p3 reply2.State 198 error <- mergeErrorsIfNeeded reply2.State error reply3.State reply3.Error 199 if reply3.Status = Ok then 200 let reply4 = p4 reply3.State 201 error <- mergeErrorsIfNeeded reply3.State error reply4.State reply4.Error 202 if reply4.Status = Ok then 203 Reply(Ok, optF.Invoke(reply1.Result, reply2.Result, reply3.Result, reply4.Result), error, reply4.State) 204 else Reply(reply4.Status, error, reply4.State) 205 else Reply(reply3.Status, error, reply3.State) 206 else Reply(reply2.Status, error, reply2.State) 207 else Reply(reply1.Status, error, reply1.State) 208 209let pipe5 (p1: Parser<'a,'u>) (p2: Parser<'b,'u>) (p3: Parser<'c,'u>) (p4: Parser<'d,'u>) (p5: Parser<'e,'u>) f = 210 let optF = OptimizedClosures.FSharpFunc<_,_,_,_,_,_>.Adapt(f) 211 fun state -> 212 let reply1 = p1 state 213 let mutable error = reply1.Error 214 if reply1.Status = Ok then 215 let reply2 = p2 reply1.State 216 error <- mergeErrorsIfNeeded reply1.State error reply2.State reply2.Error 217 if reply2.Status = Ok then 218 let reply3 = p3 reply2.State 219 error <- mergeErrorsIfNeeded reply2.State error reply3.State reply3.Error 220 if reply3.Status = Ok then 221 let reply4 = p4 reply3.State 222 error <- mergeErrorsIfNeeded reply3.State error reply4.State reply4.Error 223 if reply4.Status = Ok then 224 let reply5 = p5 reply4.State 225 error <- mergeErrorsIfNeeded reply4.State error reply5.State reply5.Error 226 if reply5.Status = Ok then 227 Reply(Ok, optF.Invoke(reply1.Result, reply2.Result, reply3.Result, reply4.Result, reply5.Result), error, reply5.State) 228 else Reply(reply5.Status, error, reply5.State) 229 else Reply(reply4.Status, error, reply4.State) 230 else Reply(reply3.Status, error, reply3.State) 231 else Reply(reply2.Status, error, reply2.State) 232 else Reply(reply1.Status, error, reply1.State) 233 234 235// ----------------------------------------------- 236// Parsing alternatives and recovering from errors 237// ----------------------------------------------- 238 239let (<|>) (p1: Parser<'a,'u>) (p2: Parser<'a,'u>) : Parser<'a,'u> = 240 fun state -> 241 let reply1 = p1 state 242 if reply1.Status = Error && reply1.State == state then 243 let mutable reply2 = p2 state 244 if reply2.State == reply1.State then 245 reply2.Error <- mergeErrors reply1.Error reply2.Error 246 reply2 247 else reply1 248 249let choice (ps: seq<Parser<'a,'u>>) = 250 match ps with 251 | :? (Parser<'a,'u>[]) as ps -> 252 if ps.Length = 0 then pzero 253 else 254 fun state -> 255 let mutable error = NoErrorMessages 256 let mutable reply = ps.[0] state 257 let mutable i = 1 258 while reply.Status = Error && reply.State == state && i < ps.Length do 259 error <- mergeErrors error reply.Error 260 reply <- ps.[i] state 261 i <- i + 1 262 if reply.State == state then 263 reply.Error <- mergeErrors error reply.Error 264 reply 265 | :? (Parser<'a,'u> list) as ps -> 266 match ps with 267 | [] -> pzero 268 | hd::tl -> 269 fun state -> 270 let mutable error = NoErrorMessages 271 let mutable hd, tl = hd, tl 272 let mutable reply = hd state 273 while reply.Status = Error && reply.State == state 274 && (match tl with 275 | h::t -> hd <- h; tl <- t; true 276 | _ -> false) 277 do 278 error <- mergeErrors error reply.Error 279 reply <- hd state 280 if reply.State == state then 281 reply.Error <- mergeErrors error reply.Error 282 reply 283 | _ -> fun state -> 284 use iter = ps.GetEnumerator() 285 if iter.MoveNext() then 286 let mutable error = NoErrorMessages 287 let mutable reply = iter.Current state 288 while reply.Status = Error && reply.State == state && iter.MoveNext() do 289 error <- mergeErrors error reply.Error 290 reply <- iter.Current state 291 if reply.State == state then 292 reply.Error <- mergeErrors error reply.Error 293 reply 294 else 295 Reply(Error, NoErrorMessages, state) 296 297 298let choiceL (ps: seq<Parser<'a,'u>>) label = 299 let error = expectedError label 300 match ps with 301 | :? (Parser<'a,'u>[]) as ps -> 302 if ps.Length = 0 then pzero 303 else 304 fun state -> 305 let mutable reply = ps.[0] state 306 let mutable i = 1 307 while reply.Status = Error && reply.State == state && i < ps.Length do 308 reply <- ps.[i] state 309 i <- i + 1 310 if reply.State == state then 311 reply.Error <- error 312 reply 313 | :? (Parser<'a,'u> list) as ps -> 314 match ps with 315 | [] -> pzero 316 | hd::tl -> 317 fun state -> 318 let mutable hd, tl = hd, tl 319 let mutable reply = hd state 320 while reply.Status = Error && reply.State == state 321 && (match tl with 322 | h::t -> hd <- h; tl <- t; true 323 | _ -> false) 324 do 325 reply <- hd state 326 if reply.State == state then 327 reply.Error <- error 328 reply 329 | _ -> fun state -> 330 use iter = ps.GetEnumerator() 331 if iter.MoveNext() then 332 let mutable reply = iter.Current state 333 while reply.Status = Error && reply.State == state && iter.MoveNext() do 334 reply <- iter.Current state 335 if reply.State == state then 336 reply.Error <- error 337 reply 338 else 339 Reply(Error, NoErrorMessages, state) 340 341let (<|>%) (p: Parser<'a,'u>) x = 342 fun state -> 343 let mutable reply = p state 344 if reply.Status = Error && reply.State == state then 345 reply.Result <- x 346 reply.Status <- Ok 347 reply 348 349let opt (p: Parser<'a,'u>) : Parser<'a option,'u> = 350 fun state -> 351 let reply = p state 352 if reply.Status = Ok then 353 Reply(Ok, Some reply.Result, reply.Error, reply.State) 354 else 355 // None is represented as null 356 let status = if reply.Status = Error && reply.State == state then Ok else reply.Status 357 Reply(status, reply.Error, reply.State) 358 359let optional (p: Parser<'a,'u>) : Parser<unit,'u> = 360 fun state -> 361 let reply = p state 362 let status = if reply.Status = Error && reply.State == state then Ok else reply.Status 363 // () is represented as null 364 Reply<unit,_>(status, reply.Error, reply.State) 365 366let attempt (p: Parser<'a,'u>) = 367 fun state -> 368 let mutable reply = p state 369 if reply.Status <> Ok then 370 if reply.State != state then 371 reply.Error <- backtrackError reply.State reply.Error 372 reply.State <- state 373 reply.Status <- Error // turns FatalErrors into Errors 374 elif reply.Status = FatalError then 375 reply.Status <- Error 376 reply 377 378let (>>=?) (p: Parser<'a,'u>) (f: 'a -> Parser<'b,'u>) = 379 let optF = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f) 380 fun state -> 381 let reply1 = p state 382 if reply1.Status = Ok then 383 let mutable reply2 = optF.Invoke(reply1.Result, reply1.State) 384 if reply2.State == reply1.State then 385 let error = mergeErrors reply1.Error reply2.Error 386 if reply2.Status = Ok then reply2.Error <- error 387 else 388 if reply1.State == state then reply2.Error <- error 389 else 390 reply2.Error <- backtrackError reply2.State error 391 reply2.State <- state 392 reply2.Status <- Error // turns FatalErrors into Error 393 reply2 394 else 395 Reply(reply1.Status, reply1.Error, reply1.State) 396 397let (>>?) (p: Parser<'a,'u>) (q: Parser<'b,'u>) = 398 fun state -> 399 let reply1 = p state 400 if reply1.Status = Ok then 401 let mutable reply2 = q reply1.State 402 if reply2.State == reply1.State then 403 let error = mergeErrors reply1.Error reply2.Error 404 if reply2.Status = Ok then reply2.Error <- error 405 else 406 if reply1.State == state then reply2.Error <- error 407 else 408 reply2.Error <- backtrackError reply2.State error 409 reply2.State <- state 410 reply2.Status <- Error // turns FatalErrors into Errors 411 reply2 412 else 413 Reply(reply1.Status, reply1.Error, reply1.State) 414 415let (.>>?) (p: Parser<'a,'u>) (q: Parser<'b,'u>) = 416 fun state -> 417 let mutable reply1 = p state 418 if reply1.Status = Ok then 419 let reply2 = q reply1.State 420 if reply2.State == reply1.State then 421 let error = mergeErrors reply1.Error reply2.Error 422 if reply2.Status = Ok then reply1.Error <- error 423 else 424 if reply1.State == state then reply1.Error <- error 425 else 426 reply1.Error <- backtrackError reply1.State error 427 reply1.State <- state 428 reply1.Status <- Error // turns FatalErrors into Errors 429 else 430 reply1.State <- reply2.State 431 reply1.Error <- reply2.Error 432 reply1.Status <- reply2.Status 433 reply1 434 435 436// ------------------------------------- 437// Conditional parsing and looking ahead 438// ------------------------------------- 439 440/// REVIEW: should `followedBy` use the error messages generated by `p`? 441 442let internal followedByE (p: Parser<'a,'u>) error = 443 fun state -> 444 let reply = p state 445 if reply.Status = Ok then Reply((), state) 446 else Reply(Error, error, state) 447 448let followedBy p = followedByE p NoErrorMessages 449let followedByL p label = followedByE p (expectedError label) 450 451let internal notFollowedByE (p: Parser<'a,'u>) error = 452 fun state -> 453 let reply = p state 454 if reply.Status <> Ok then Reply((), state) 455 else Reply(Error, error, state) 456 457let notFollowedBy p = notFollowedByE p NoErrorMessages 458let notFollowedByL p label = notFollowedByE p (unexpectedError label) 459 460let lookAhead (p: Parser<'a,'u>) = 461 fun state -> 462 let mutable reply = p state 463 if reply.Status = Ok then 464 reply.State <- state 465 reply.Error <- NoErrorMessages 466 else 467 if reply.State != state then 468 reply.Error <- backtrackError reply.State reply.Error 469 reply.State <- state 470 reply.Status <- Error // turn FatalErrors into normal Errors 471 reply 472 473 474// -------------------------- 475// Customizing error messages 476// -------------------------- 477 478let (<?>) (p: Parser<'a,'u>) label = 479 let error = expectedError label 480 fun state -> 481 let mutable reply = p state 482 if reply.State == state then 483 reply.Error <- error 484 reply 485 486let (<??>) (p: Parser<'a,'u>) label = 487 let expErr = expectedError label 488 fun state -> 489 let mutable reply = p state 490 if reply.Status = Ok then 491 if reply.State == state then 492 reply.Error <- expErr 493 else 494 if reply.State == state then 495 reply.Error <- match reply.Error with 496 | AddErrorMessage(BacktrackPoint(pos, msgs), NoErrorMessages) 497 -> AddErrorMessage(CompoundError(label, pos, msgs), NoErrorMessages) 498 | _ -> expErr 499 else 500 reply.Error <- compoundError label reply.State reply.Error 501 reply.State <- state // we backtrack ... 502 reply.Status <- FatalError // ... so we need to make sure normal parsing doesn't continue 503 reply 504 505let fail msg : Parser<'a,'u> = 506 let error = messageError msg 507 fun state -> 508 Reply(Error, error, state) 509 510let failFatally msg : Parser<'a,'u> = 511 let error = messageError msg 512 fun state -> Reply(FatalError, error, state) 513 514// ----------------- 515// Parsing sequences 516// ----------------- 517 518let tuple2 p1 p2 = pipe2 p1 p2 (fun a b -> (a, b)) 519let tuple3 p1 p2 p3 = pipe3 p1 p2 p3 (fun a b c -> (a, b, c)) 520let tuple4 p1 p2 p3 p4 = pipe4 p1 p2 p3 p4 (fun a b c d -> (a, b, c, d)) 521let tuple5 p1 p2 p3 p4 p5 = pipe5 p1 p2 p3 p4 p5 (fun a b c d e -> (a, b, c, d, e)) 522 523let parray n (p: Parser<'a,'u>) = 524 if n = 0 then preturn [||] 525 else 526 fun state -> 527 let mutable reply = p state 528 let mutable error = reply.Error 529 let mutable newReply = Unchecked.defaultof<Reply<_,_>> 530 if reply.Status = Ok then 531 let mutable xs = Array.zeroCreate n 532 xs.[0] <- reply.Result 533 let mutable i = 1 534 while i < n do 535 let prevState = reply.State 536 reply <- p prevState 537 error <- mergeErrorsIfNeeded prevState error reply.State reply.Error 538 if reply.Status = Ok then 539 xs.[i] <- reply.Result 540 i <- i + 1 541 else 542 i <- n // break 543 newReply.Result <- xs // we set the result even if there was an error 544 newReply.State <- reply.State 545 newReply.Error <- error 546 newReply.Status <- reply.Status 547 newReply 548 549let skipArray n (p: Parser<'a,'u>) = 550 if n = 0 then preturn () 551 else 552 fun state -> 553 let mutable reply = p state 554 let mutable error = reply.Error 555 let mutable newReply = Unchecked.defaultof<Reply<_,_>> 556 if reply.Status = Ok then 557 let mutable i = 1 558 while i < n do 559 let prevState = reply.State 560 reply <- p prevState 561 error <- mergeErrorsIfNeeded prevState error reply.State reply.Error 562 if reply.Status = Ok then 563 i <- i + 1 564 else 565 i <- n // break 566 // () is represented as null 567 newReply.State <- reply.State 568 newReply.Error <- error 569 newReply.Status <- reply.Status 570 newReply 571let 572#if NOINLINE 573#else 574 inline 575#endif 576 private manyFoldApplyImpl require1 fold1 fold applyF getEmpty (p: Parser<'a,'u>) = 577 fun state -> 578 let mutable reply = p state 579 if reply.Status = Ok then 580 let mutable xs = fold1 reply.Result 581 let mutable error = reply.Error 582 let mutable state = reply.State 583 reply <- p state 584 while reply.Status = Ok do 585 if referenceEquals reply.State state then 586 _raiseInfiniteLoopException "many" state 587 xs <- fold xs reply.Result 588 error <- reply.Error 589 state <- reply.State 590 reply <- p state 591 if reply.Status = Error && reply.State == state then 592 Reply(Ok, applyF xs, mergeErrors error reply.Error, state) 593 else 594 let error = mergeErrorsIfNeeded state error reply.State reply.Error 595 Reply(reply.Status, error, reply.State) 596 elif not require1 && reply.Status = Error && reply.State == state then 597 Reply(Ok, getEmpty(), reply.Error, state) 598 else 599 Reply(reply.Status, reply.Error, reply.State) 600 601let 602#if NOINLINE 603#else 604 inline 605#endif 606 private manyFoldApply2Impl require1 fold1 fold applyF getEmpty (p1: Parser<'a,'u>) (p: Parser<'b,'u>) = 607 fun state -> 608 let reply1 = p1 state 609 if reply1.Status = Ok then 610 let mutable xs = fold1 reply1.Result 611 let mutable error = reply1.Error 612 let mutable state = reply1.State 613 let mutable reply = p state 614 while reply.Status = Ok do 615 if referenceEquals reply.State state then 616 _raiseInfiniteLoopException "many" state 617 xs <- fold xs reply.Result 618 error <- reply.Error 619 state <- reply.State 620 reply <- p state 621 if reply.Status = Error && reply.State == state then 622 Reply(Ok, applyF xs, mergeErrors error reply.Error, state) 623 else 624 let error = mergeErrorsIfNeeded state error reply.State reply.Error 625 Reply(reply.Status, error, reply.State) 626 elif not require1 && reply1.Status = Error && reply1.State == state then 627 Reply(Ok, getEmpty(), reply1.Error, state) 628 else 629 Reply(reply1.Status, reply1.Error, reply1.State) 630 631let 632#if NOINLINE 633#else 634 inline 635#endif 636 manyFoldApply fold1 fold applyF getEmpty p = 637 manyFoldApplyImpl false fold1 fold applyF getEmpty p 638 639let 640#if NOINLINE 641#else 642 inline 643#endif 644 many1FoldApply fold1 fold applyF p = 645 manyFoldApplyImpl true fold1 fold applyF (fun () -> Unchecked.defaultof<_>) p 646 647let 648#if NOINLINE 649#else 650 inline 651#endif 652 manyFoldApply2 fold1 fold applyF getEmpty p1 p = 653 manyFoldApply2Impl false fold1 fold applyF getEmpty p1 p 654 655let 656#if NOINLINE 657#else 658 inline 659#endif 660 many1FoldApply2 fold1 fold applyF p1 p = 661 manyFoldApply2Impl true fold1 fold applyF (fun () -> Unchecked.defaultof<_>) p1 p 662 663 664// it's the sepMayEnd case that's difficult to implement (efficiently) without a specialized parser 665let 666#if NOINLINE 667#else 668 inline 669#endif 670 sepEndByFoldApplyImpl require1 sepMayEnd fold1 fold applyF getEmpty (p: Parser<'a,'u>) (sep: Parser<'b,'u>) = 671 fun state -> 672 let mutable reply1 = p state 673 if reply1.Status = Ok then 674 let mutable xs = fold1 reply1.Result 675 let mutable error = reply1.Error 676 let mutable state = reply1.State 677 let mutable reply2 = sep state 678 while reply2.Status = Ok && (reply1 <- p reply2.State; reply1.Status = Ok) do 679 xs <- fold xs reply1.Result 680 if not (referenceEquals reply1.State reply2.State) then 681 error <- reply1.Error 682 elif not (referenceEquals reply1.State state) then 683 error <- mergeErrors reply2.Error reply1.Error 684 else 685 _raiseInfiniteLoopException "sep(EndBy)" state 686 state <- reply1.State 687 reply2 <- sep state 688 if reply2.Status = Error && reply2.State == state then 689 Reply(Ok, applyF xs, mergeErrors error reply2.Error, state) 690 elif sepMayEnd && reply1.Status = Error && reply1.State == reply2.State then 691 let error = mergeErrors (mergeErrorsIfNeeded state error reply2.State reply2.Error) reply1.Error 692 Reply(Ok, applyF xs, error, reply1.State) 693 elif reply1.Status <> Ok then 694 let error = mergeErrorsIfNeeded3 state error reply2.State reply2.Error reply1.State reply1.Error 695 Reply(reply1.Status, error, reply1.State) 696 else 697 let error = mergeErrorsIfNeeded state error reply2.State reply2.Error 698 Reply(reply2.Status, error, reply2.State) 699 elif not require1 && reply1.Status = Error && reply1.State == state then 700 Reply(Ok, getEmpty(), reply1.Error, state) 701 else 702 Reply(reply1.Status, reply1.Error, reply1.State) 703 704let 705#if NOINLINE 706#else 707 inline 708#endif 709 sepByFoldApply fold1 fold applyF getEmpty p sep = 710 sepEndByFoldApplyImpl false false fold1 fold applyF getEmpty p sep 711 712 713let 714#if NOINLINE 715#else 716 inline 717#endif 718 sepBy1FoldApply fold1 fold applyF p sep = 719 sepEndByFoldApplyImpl true false fold1 fold applyF (fun () -> Unchecked.defaultof<_>) p sep 720 721let 722#if NOINLINE 723#else 724 inline 725#endif 726 sepEndByFoldApply fold1 fold applyF getEmpty p sep = 727 sepEndByFoldApplyImpl false true fold1 fold applyF getEmpty p sep 728 729let 730#if NOINLINE 731#else 732 inline 733#endif 734 sepEndBy1FoldApply fold1 fold applyF p sep = 735 sepEndByFoldApplyImpl true true fold1 fold applyF (fun () -> Unchecked.defaultof<_>) p sep 736 737let 738#if NOINLINE 739#else 740 inline 741#endif 742 manyTillFoldApply fold1 fold applyF getEmpty (p: Parser<'a,'u>) (endp: Parser<'c,'u>) = 743 fun state -> 744 let mutable reply2 = endp state 745 if reply2.Status <> Ok then 746 let mutable reply1 = p state 747 if reply1.Status = Ok then 748 let mutable xs = fold1 reply1.Result 749 let mutable error = reply1.Error 750 let mutable state = reply1.State 751 reply2 <- endp state 752 while reply2.Status <> Ok && (reply1 <- p state; reply1.Status = Ok) do 753 if referenceEquals reply1.State state then 754 _raiseInfiniteLoopException "manyTill" state 755 xs <- fold xs reply1.Result 756 error <- reply1.Error 757 state <- reply1.State 758 reply2 <- endp state 759 if reply2.Status = Ok then 760 let error = mergeErrorsIfNeeded state error reply2.State reply2.Error 761 Reply(Ok, applyF xs reply2.Result, error, reply2.State) 762 elif reply1.Status = Error && reply1.State == state then 763 let error = if reply2.State != state then reply2.Error 764 else mergeErrors (mergeErrors error reply1.Error) reply2.Error 765 Reply(reply2.Status, error, reply2.State) 766 else 767 let error = mergeErrorsIfNeeded state error reply1.State reply1.Error 768 Reply(reply1.Status, error, reply1.State) 769 elif reply1.Status = Error && reply1.State == state then 770 let error = if reply2.State != state then reply2.Error 771 else mergeErrors reply1.Error reply2.Error 772 Reply(reply2.Status, error, reply2.State) 773 else 774 Reply(reply1.Status, reply1.Error, reply1.State) 775 else 776 Reply(Ok, getEmpty reply2.Result, reply2.Error, reply2.State) 777 778 779 780let many p = manyFoldApply (fun x -> [x]) (fun xs x -> x::xs) List.rev (fun () -> []) p 781let manyRev p = manyFoldApply (fun x -> [x]) (fun xs x -> x::xs) (fun xs -> xs) (fun () -> []) p 782let skipMany p = manyFoldApply (fun _ -> ()) (fun _ _ -> ()) (fun xs -> xs) (fun () -> ()) p 783let manyFold acc0 f p = let optF = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f) 784 manyFoldApply (fun x -> optF.Invoke(acc0, x)) (fun acc x -> optF.Invoke(acc, x)) (fun acc -> acc) (fun () -> acc0) p 785let manyReduce f altX p = let optF = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f) 786 manyFoldApply (fun x0 -> x0) (fun x0 x -> optF.Invoke(x0, x)) (fun x0 -> x0) (fun () -> altX) p 787 788let many1 p = many1FoldApply (fun x -> [x]) (fun xs x -> x::xs) List.rev p 789let many1Rev p = many1FoldApply (fun x -> [x]) (fun xs x -> x::xs) (fun xs -> xs) p 790let skipMany1 p = many1FoldApply (fun _ -> ()) (fun _ _ -> ()) (fun xs -> xs) p 791let many1Fold acc0 f p = let optF = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f) 792 many1FoldApply (fun x -> optF.Invoke(acc0, x)) (fun acc x -> optF.Invoke(acc, x)) (fun x -> x) p 793let many1Reduce f p = let optF = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f) 794 many1FoldApply (fun x0 -> x0) (fun x0 x -> optF.Invoke(x0, x)) (fun x0 -> x0) p 795 796 797let sepBy p sep = sepByFoldApply (fun x -> [x]) (fun xs x -> x::xs) List.rev (fun () -> []) p sep 798let sepByRev p sep = sepByFoldApply (fun x -> [x]) (fun xs x -> x::xs) (fun xs -> xs) (fun () -> []) p sep 799let skipSepBy p sep = sepByFoldApply (fun _ -> ()) (fun _ _ -> ()) (fun xs -> xs) (fun _ -> ()) p sep 800let sepByFold acc0 f p sep = let optF = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f) 801 sepByFoldApply (fun x -> optF.Invoke(acc0, x)) (fun acc x -> optF.Invoke(acc, x)) (fun acc -> acc) (fun () -> acc0) p sep 802let sepByReduce f altX p sep = let optF = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f) 803 sepByFoldApply (fun x0 -> x0) (fun x0 x -> optF.Invoke(x0, x)) (fun x0 -> x0) (fun () -> altX) p sep 804 805let sepBy1 p sep = sepBy1FoldApply (fun x -> [x]) (fun xs x -> x::xs) List.rev p sep 806let sepBy1Rev p sep = sepBy1FoldApply (fun x -> [x]) (fun xs x -> x::xs) (fun xs -> xs) p sep 807let skipSepBy1 p sep = sepBy1FoldApply (fun _ -> ()) (fun _ _ -> ()) (fun xs -> xs) p sep 808let sepBy1Fold acc0 f p sep = let optF = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f) 809 sepBy1FoldApply (fun x -> optF.Invoke(acc0, x)) (fun acc x -> optF.Invoke(acc, x)) (fun acc -> acc) p sep 810let sepBy1Reduce f p sep = let optF = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f) 811 sepBy1FoldApply (fun x0 -> x0) (fun x0 x -> optF.Invoke(x0, x)) (fun x0 -> x0) p sep 812 813 814let sepEndBy p sep = sepEndByFoldApply(fun x -> [x]) (fun xs x -> x::xs) List.rev (fun () -> []) p sep 815let sepEndByRev p sep = sepEndByFoldApply(fun x -> [x]) (fun xs x -> x::xs) (fun xs -> xs) (fun () -> []) p sep 816let skipSepEndBy p sep = sepEndByFoldApply(fun _ -> ()) (fun _ _ -> ()) (fun xs -> xs) (fun _ -> ()) p sep 817let sepEndByFold acc0 f p sep = let optF = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f) 818 sepEndByFoldApply (fun x -> optF.Invoke(acc0, x)) (fun acc x -> optF.Invoke(acc, x)) (fun acc -> acc) (fun () -> acc0) p sep 819let sepEndByReduce f altX p sep = let optF = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f) 820 sepEndByFoldApply (fun x0 -> x0) (fun x0 x -> optF.Invoke(x0, x)) (fun x0 -> x0) (fun () -> altX) p sep 821 822let sepEndBy1 p sep = sepEndBy1FoldApply (fun x -> [x]) (fun xs x -> x::xs) List.rev p sep 823let sepEndBy1Rev p sep = sepEndBy1FoldApply (fun x -> [x]) (fun xs x -> x::xs) (fun xs -> xs) p sep 824let skipSepEndBy1 p sep = sepEndBy1FoldApply (fun _ -> ()) (fun _ _ -> ()) (fun xs -> xs) p sep 825let sepEndBy1Fold acc0 f p sep = let optF = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f) 826 sepEndBy1FoldApply (fun x -> optF.Invoke(acc0, x)) (fun acc x -> optF.Invoke(acc, x)) (fun acc -> acc) p sep 827let sepEndBy1Reduce f p sep = let optF = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f) 828 sepEndBy1FoldApply (fun x0 -> x0) (fun x0 x -> optF.Invoke(x0, x)) (fun x0 -> x0) p sep 829 830let manyTill p endp = manyTillFoldApply (fun x -> [x]) (fun xs x -> x::xs) (fun xs _ -> List.rev xs) (fun _ -> []) p endp 831let manyTillRev p endp = manyTillFoldApply (fun x -> [x]) (fun xs x -> x::xs) (fun xs _ -> xs) (fun _ -> []) p endp 832let skipManyTill p endp = manyTillFoldApply (fun _ -> ()) (fun _ _ -> ()) (fun _ _ -> ()) (fun _ -> ()) p endp 833let manyTillFold acc0 f p endp = let optF = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f) 834 manyTillFoldApply (fun x -> optF.Invoke(acc0, x)) (fun acc x -> optF.Invoke(acc, x)) (fun acc _ -> acc) (fun _ -> acc0) p endp 835let manyTillReduce f altX p endp = let optF = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f) 836 manyTillFoldApply (fun x0 -> x0) (fun x0 x -> optF.Invoke(x0, x)) (fun x0 _ -> x0) (fun _ -> altX) p endp 837 838 839let chainl1 p op = 840 many1FoldApply2 (fun x0 -> x0) (fun x (f, y) -> f x y) (fun x -> x) p (tuple2 op p) 841 842let chainl p op altX = 843 manyFoldApply2 (fun x0 -> x0) (fun x (f, y) -> f x y) (fun x -> x) (fun () -> altX) p (tuple2 op p) 844 845let chainr1 p op = 846 pipe2 p (manyRev (tuple2 op p)) (fun x0 opYs -> match opYs with 847 | [] -> x0 848 | (op, y)::tl -> 849 let rec calc op1 y lst = 850 match lst with 851 | (op2, x)::tl -> calc op2 (op1 x y) tl 852 | [] -> op1 x0 y 853 calc op y tl) 854let chainr p op x = chainr1 p op <|>% x 855 856 857// ------------------------------ 858// Computation expression syntax 859// ------------------------------ 860[<Sealed>] 861type ParserCombinator() = 862 member t.Delay(f:(unit -> Parser<'a,'u>)) = fun state -> (f ()) state 863 member t.Return(x) = preturn x 864 member t.Bind(p, f) = p >>= f 865 member t.Zero() : Parser<'a,'u> = pzero 866 // no Combine member by purpose 867 member t.TryWith(p:Parser<'a,'u>, cf:(exn -> Parser<'a,'u>)) = 868 fun state -> 869 (try p state with e -> (cf e) state) 870 member t.TryFinally(p:Parser<'a,'u>, ff:(unit -> unit)) = 871 fun state -> 872 try p state finally ff () 873 874let parse = ParserCombinator() 875 876 877// ---------------------- 878// Other helper functions 879// ---------------------- 880 881let createParserForwardedToRef() = 882 let dummyParser = fun state -> failwith "a parser was not initialized" 883 let r = ref dummyParser 884 (fun state -> !r state), r : Parser<_,'u> * Parser<_,'u> ref