(*---------------------------------------------------------------------------*
  IMPLEMENTATION  cf_message.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 substring = string * int * int and t = substring list

let sub_invariant_ (s, pos, len) =
    let size = String.length s in
    pos >= 0 && pos < size && len > 0 && pos + len <= size

let rec test_invariant_ = function
    | [] -> true
    | hd :: tl -> if sub_invariant_ hd then test_invariant_ tl else false

let rec filter_for_invariant_ acc = function
    | [] ->
        List.rev acc
    | hd :: tl ->
        filter_for_invariant_ (if sub_invariant_ hd then hd :: acc else acc) tl

let normalize m =
    if test_invariant_ m then m else filter_for_invariant_ [] m

let rec sub_blit_loop_ ?(i = 0) dest =
    function
    | [] ->
        ()
    | (s, pos, len) :: tl ->
        assert (sub_invariant_ (dest, i, len));
        String.blit s pos dest i len;
        let i = i + len in
        sub_blit_loop_ ~i dest tl

let create s =
    let n = String.length s in
    if n > 0 then [ s, 0, n ] else []

let length =
    let f acc (_, _, len as sub) =
        assert (sub_invariant_ sub);
        acc + len
    in
    List.fold_left f 0

let contents =
    function
    | [] ->
        ""
    | tl ->
        let n = length tl in
        let s = String.create n in
        sub_blit_loop_ s tl;
        s

let copy m = create (contents m)

let flatten = function
    | _ :: _ :: _ as m -> copy m
    | m -> m

let x_pos_negative_ = "pos < 0"
let x_pos_range_ = "pos > length"

let rec split_aux_ (i, l1, l2) =
    function
    | [] ->
        if i > 0 then invalid_arg x_pos_range_;
        List.rev l1, List.rev l2
    | hd :: tl ->
        assert (sub_invariant_ hd);
        let acc =
            let s, pos, len = hd in
            match i with
            | 0 ->
                0, l1, hd :: l2
            | _ when i < len ->
                0, (s, pos, i) :: l1, (s, pos + i, len - i) :: l2
            | _ ->
                i - len, hd :: l1, []
        in
        split_aux_ acc tl

let split ~pos =
    match pos with
    | pos when pos < 0 -> invalid_arg x_pos_negative_
    | pos when pos > 0 -> split_aux_ (pos, [], [])
    | _ -> (fun m -> [], m)

let rec truncate_aux_ l0 i =
    function
    | [] ->
        if i > 0 then invalid_arg x_pos_range_;
        List.rev l0
    | hd :: tl ->
        assert (sub_invariant_ hd);
        let s, pos, len = hd in
        match i with
        | 0 -> List.rev l0
        | _ when i < len -> List.rev ((s, pos, i) :: l0)
        | _ -> truncate_aux_ (hd :: l0) (i - len) tl

let truncate ~pos =
    match pos with
    | pos when pos < 0 -> invalid_arg x_pos_negative_
    | pos when pos > 0 -> truncate_aux_ [] pos
    | _ -> (fun _ -> [])

let rec shift_aux_ i =
    function
    | [] ->
        if i > 0 then invalid_arg x_pos_range_;
        []
    | hd :: tl ->
        assert (sub_invariant_ hd);
        let s, pos, len = hd in
        if i < len then
            (s, pos + i, len - i) :: tl
        else
            shift_aux_ (i - len) tl

let shift ~pos =
    match pos with
    | 0 -> (fun x -> x)
    | pos when pos < 0 -> invalid_arg x_pos_negative_
    | pos -> shift_aux_ pos

let rec insert_aux_ l0 l1 i =
    function
    | [] ->
        if i > 0 then invalid_arg x_pos_range_;
        List.rev_append l0 l1
    | hd :: tl ->
        assert (sub_invariant_ hd);
        let s, pos, len = hd in
        if i = 0 then begin
            assert (not true); []
        end
        else if i < len then begin
            let sub1 = s, pos, i and sub2 = s, pos + i, len - i in
            let l0 = sub1 :: l0 and tl = sub2 :: tl in
            insert_aux_ l0 (l1 @ tl) 0 []
        end
        else
            insert_aux_ (hd :: l0) l1 (i - len) tl

let insert ~pos =
    match pos with
    | 0 -> (fun ~m m0 -> m @ m0)
    | pos when pos < 0 -> invalid_arg x_pos_negative_
    | pos -> (fun ~m -> insert_aux_ [] m pos)

let push m q =
    List.fold_left begin fun q s ->
        if sub_invariant_ s then
            Cf_deque.A.push s q
        else
            q
    end q m

let unsafe_push m q = List.fold_left (fun q s -> Cf_deque.A.push s q) q m

let drain q = Cf_deque.B.to_list q

let drain_seq ?x =
    let rec aux (buf, pos, len) =
        Cf_seq.limit ?x len (Cf_seq.of_substring buf pos)
    in
    fun q ->
        Cf_seq.flatten (Cf_seq.map aux (Cf_deque.B.to_seq q))

let rec pop_aux_ m x q =
    if x > 0 then
        match Cf_deque.B.pop q with
        | Some ((buf, pos, len), tl) when len > x ->
            let hd1 = buf, pos + x, len - x and hd0 = buf, pos, x in
            pop_aux_ (hd0 :: m) 0 (Cf_deque.B.push hd1 tl)
        | Some ((_, _, len as hd), tl) ->
            pop_aux_ (hd :: m) (x - len) tl
        | None ->
            List.rev m, q
    else
        List.rev m, q

let pop ~len q = pop_aux_ [] len q

let rec shiftq_aux_ x q =
    if x > 0 then
        match Cf_deque.B.pop q with
        | Some ((buf, pos, len), tl) when len > x ->
            let hd1 = buf, pos + x, len - x in
            shiftq_aux_ 0 (Cf_deque.B.push hd1 tl)
        | Some ((_, _, len), tl) ->
            shiftq_aux_ (x - len) tl
        | None ->
            q
    else
        q

let shiftq ~len q = shiftq_aux_ len q

let rec unsafe_shift1 = function
    | (buf, pos, len) :: tl when len > 1 -> (buf, pos + 1, len - 1) :: tl
    | _ :: tl -> tl
    | [] -> []

let rec unsafe_to_seq ?x m =
    lazy begin
        match m with
        | (buf, pos, _) :: _ as m ->
            let hd = String.unsafe_get buf pos in
            let tl = unsafe_to_seq ?x (unsafe_shift1 m) in
            Cf_seq.P (hd, tl)
        | [] ->
            match x with None -> Cf_seq.Z | Some x -> raise x
    end

let unsafe_to_function ?x m =
    let r = ref m in
    let rec loop () =
        match !r with
        | [] ->
            raise (match x with None -> End_of_file | Some x -> x)
        | (buf, pos, _) :: _ as m ->
            r := unsafe_shift1 m;
            String.unsafe_get buf pos
    in
    loop

let to_seq ?x m = unsafe_to_seq ?x (normalize m)
let to_function ?x m = unsafe_to_function ?x (normalize m)

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