(*---------------------------------------------------------------------------*
  IMPLEMENTATION  cf_parser.ml

  Copyright (c) 2002-2006, James H. Woodyatt
  All rights reserved.

  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions
  are met:

    Redistributions of source code must retain the above copyright
    notice, this list of conditions and the following disclaimer.

    Redistributions in binary form must reproduce the above copyright
    notice, this list of conditions and the following disclaimer in
    the documentation and/or other materials provided with the
    distribution

  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
  OF THE POSSIBILITY OF SUCH DAMAGE. 
 *---------------------------------------------------------------------------*)

type ('s, 'a) t = 's Cf_seq.t -> ('a * 's Cf_seq.t) option

exception Error

let nil _ = None

let err_aux_ _ = Error

let err ?(f = err_aux_) () s = raise (f s)

let req ?f p s = match p s with None -> err ?f () s | x -> x

let fin s =
    match Lazy.force s with
    | Cf_seq.Z -> Some ((), s)
    | _ -> None

let rec alt a s =
    match a with
    | [] -> None
    | hd :: tl ->
        match hd s with
        | None -> alt tl s
        | v -> v

let rec altz pz s =
    match Lazy.force pz with
    | Cf_seq.Z -> None
    | Cf_seq.P (hd, tl) ->
        match hd s with
        | None -> altz tl s
        | v -> v

let sat f s =
    match Lazy.force s with
    | Cf_seq.P (i, tl) when f i -> Some (i, tl)
    | _ -> None

let tok f s =
    match Lazy.force s with
    | Cf_seq.Z -> None
    | Cf_seq.P (hd, tl) ->
        match f hd with
        | None -> None
        | Some x -> Some (x, tl)

let lit k x =
    let klen = String.length k in
    let rec loop i s =
        if i < klen then
            match Lazy.force s with
            | Cf_seq.P (hd, tl) when String.unsafe_get k i = hd ->
                loop (succ i) tl
            | _ ->
                None
        else
            Some (x, s)
    in
    fun s ->
        loop 0 s

let rec unfold p s =
    lazy begin
        match p s with
        | None -> Cf_seq.Z
        | Some (x, s) -> Cf_seq.P (x, unfold p s)
    end

class ['a] cursor init =
    object
        val position_: int = init
        
        method advance (_: 'a) = {< position_ = succ position_ >}
        method position = position_
    end

module type X = sig
    type ('c, 'i, 'o) t = 'z Cf_seq.t -> ('o * 'z Cf_seq.t) option
        constraint 'z = 'i * 'c
        constraint 'c = 'x #cursor

    exception Error of int

    val err: ?f:(('i * 'c) Cf_seq.t -> exn) -> unit -> ('c, 'i, 'o) t
    val req: ?f:(('i * 'c) Cf_seq.t -> exn) -> ('c, 'i, 'o) t -> ('c, 'i, 'o) t
    val sat: ('i -> bool) -> ('c, 'i, 'i) t
    val tok: ('i -> 'o option) -> ('c, 'i, 'o) t
    val lit: string -> 'o -> ('c, char, 'o) t
    
    val weave: c:('i #cursor as 'c) -> 'i Cf_seq.t -> ('i * 'c) Cf_seq.t
    val unfold: ('c, 'i, 'o) t -> ('i * 'c) Cf_seq.t -> ('o * 'c) Cf_seq.t
end

module X: X = struct
    type ('c, 'i, 'o) t = 'z Cf_seq.t -> ('o * 'z Cf_seq.t) option
        constraint 'z = 'i * 'c
        constraint 'c = 'x #cursor
    
    exception Error of int
    
    let err_aux_ s =
        Error begin
            match Lazy.force s with
            | Cf_seq.Z -> (-1)
            | Cf_seq.P ((_, c), _) -> c#position
        end

    let err ?(f = err_aux_) () s = raise (f s)

    let req ?f p s = match p s with None -> err ?f () s | x -> x

    let sat f s =
        match Lazy.force s with
        | Cf_seq.P ((i, _), tl) when f i -> Some (i, tl)
        | _ -> None

    let tok f s =
        match Lazy.force s with
        | Cf_seq.Z -> None
        | Cf_seq.P ((hd, _), tl) ->
            match f hd with
            | None -> None
            | Some x -> Some (x, tl)

    let lit k x =
        let klen = String.length k in
        let rec loop i s =
            if i < klen then
                match Lazy.force s with
                | Cf_seq.P ((hd, _), tl) when String.unsafe_get k i = hd ->
                    loop (succ i) tl
                | _ ->
                    None
            else
                Some (x, s)
        in
        fun s ->
            loop 0 s
    
    let rec weave ~c s =
        lazy begin
            match Lazy.force s with
            | Cf_seq.P (hd, tl) ->
                Cf_seq.P ((hd, c), weave ~c:(c#advance hd) tl)
            | Cf_seq.Z ->
                Cf_seq.Z
        end

    let rec unfold p s =
        lazy begin
            match Lazy.force s with
            | Cf_seq.Z -> Cf_seq.Z
            | Cf_seq.P ((_, c), _) ->
                match p s with
                | None -> Cf_seq.Z
                | Some (x, s) -> Cf_seq.P ((x, c), unfold p s)
        end
end

module Op = struct
    let ( >>= ) m f s = match m s with None -> None | Some (a, s) -> f a s

    let ( ~: ) a s = Some (a, s)
    
    let ( ?. ) i0 s =
        match Lazy.force s with
        | Cf_seq.P (i, tl) when i = i0 -> Some (i0, tl)
        | _ -> None
    
    let ( ?: ) i0 s =
        match Lazy.force s with
        | Cf_seq.P ((i, _), tl) when i = i0 -> Some (i0, tl)
        | _ -> None

    let ( ?/ ) p c =
        Some (match p c with None -> None, c | Some (y, c) -> Some y, c)

    let ( ?* ) p =
        let rec loop stack c =
            match p c with
            | None -> Some (List.rev stack, c)
            | Some (x, c) -> loop (x :: stack) c
        in
        fun c ->
            loop [] c
    
    let ( ?+ ) p = p >>= fun hd -> ?*p >>= fun tl -> ~: (hd, tl)
    
    let ( %= ) p q seq =
        match Lazy.force seq with
        | Cf_seq.Z ->
            begin
                match q (X.unfold p Cf_seq.nil) with
                | None -> None
                | Some (x, _) -> Some (x, Cf_seq.nil)
            end
        | Cf_seq.P ((_, c0), _) ->
            match q (X.unfold p seq) with
            | None -> None
            | Some (x, seq') ->
                let seq'' =
                    match Lazy.force seq' with
                    | Cf_seq.Z ->
                        Cf_seq.nil
                    | Cf_seq.P ((_, c1), _) ->
                        Cf_seq.shift (c1#position - c0#position) seq
                in
                Some (x, seq'')
end

let rec filter f p s =
    match p s with
    | None -> None
    | Some (x, s) as v -> if f x then v else filter f p s

let map f p s =
    match p s with
    | None -> None
    | Some (x, s) -> Some (f x, s)

let rec optmap f p s =
    match p s with
    | None -> None
    | Some (x, s) ->
        match f x with
        | None -> optmap f p s
        | Some y -> Some (y, s)

let rec to_extended_aux_ n fin s =
    let z = Lazy.force s in
    if fin == z then
        n
    else
        match z with
        | Cf_seq.P (_, tl) -> to_extended_aux_ (succ n) fin tl
        | Cf_seq.Z -> assert (not true); n

let to_extended p s =
    let s0 = Cf_seq.first s in
    match p s0 with
    | Some (x, s1) ->
        let fin = Lazy.force s1 in
        Some (x, Cf_seq.shift (to_extended_aux_ 0 fin s0) s)
    | None -> None

let of_extended c p s =
    match p (X.weave ~c s) with
    | Some (x, s) -> Some (x, Cf_seq.first s)
    | None -> None

(*--- End of File [ cf_parser.ml ] ---*)