PageRenderTime 114ms CodeModel.GetById 16ms app.highlight 90ms RepoModel.GetById 1ms app.codeStats 0ms

/fparsec/main/FParsec/Primitives.fs

http://github.com/sandersn/fing
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