Source file cstruct.ml

(*
 * Copyright (c) 2012 Anil Madhavapeddy <anil@recoil.org>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

type buffer = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t

(* Note:
 *
 * We try to maintain the property that no constructed [t] can ever point out of
 * its underlying buffer. This property is guarded by all of the constructing
 * functions and the fact that the type is private, and used by various
 * functions that would otherwise be completely unsafe.
 *
 * Furthermore, no operation on [t] is allowed to extend the view on the
 * underlying Bigarray structure, only narrowing is allowed.
 *
 * All well-intended souls are kindly invited to cross-check that the code
 * indeed maintains this invariant.
 *)

type t = {
  buffer: buffer;
  off   : int;
  len   : int;
}

let pp_t ppf t =
  Format.fprintf ppf "[%d,%d](%d)" t.off t.len (Bigarray.Array1.dim t.buffer)
let string_t ppf str =
  Format.fprintf ppf "[%d]" (String.length str)
let bytes_t ppf str =
  Format.fprintf ppf "[%d]" (Bytes.length str)

let err fmt =
  let b = Buffer.create 20 in                         (* for thread safety. *)
  let ppf = Format.formatter_of_buffer b in
  let k ppf = Format.pp_print_flush ppf (); invalid_arg (Buffer.contents b) in
  Format.kfprintf k ppf fmt

let err_of_bigarray t = err "Cstruct.of_bigarray off=%d len=%d" t
let err_sub t = err "Cstruct.sub: %a off=%d len=%d" pp_t t
let err_shift t = err "Cstruct.shift %a %d" pp_t t
let err_shiftv n = err "Cstruct.shiftv short by %d" n
let err_copy_to_string caller t = err "Cstruct.%s %a off=%d len=%d" caller pp_t t
let err_to_hex_string t = err "Cstruct.to_hex_string %a off=%d len=%d" pp_t t
let err_blit_src src dst =
  err "Cstruct.blit src=%a dst=%a src-off=%d len=%d" pp_t src pp_t dst
let err_blit_dst src dst =
  err "Cstruct.blit src=%a dst=%a dst-off=%d len=%d" pp_t src pp_t dst
let err_blit_from_string_src src dst =
  err "Cstruct.blit_from_string src=%a dst=%a src-off=%d len=%d"
    string_t src pp_t dst
let err_blit_from_string_dst src dst =
  err "Cstruct.blit_from_string src=%a dst=%a dst-off=%d len=%d"
    string_t src pp_t dst
let err_blit_from_bytes_src src dst =
  err "Cstruct.blit_from_bytes src=%a dst=%a src-off=%d len=%d"
    bytes_t src pp_t dst
let err_blit_from_bytes_dst src dst =
  err "Cstruct.blit_from_bytes src=%a dst=%a dst-off=%d len=%d"
    bytes_t src pp_t dst
let err_blit_to_bytes_src src dst =
  err "Cstruct.blit_to_bytes src=%a dst=%a src-off=%d len=%d"
    pp_t src bytes_t dst
let err_blit_to_bytes_dst src dst=
  err "Cstruct.blit_to_bytes src=%a dst=%a dst-off=%d len=%d"
    pp_t src bytes_t dst
let err_invalid_bounds f =
  err "invalid bounds in Cstruct.%s %a off=%d len=%d" f pp_t [@@inline never]
let err_split t = err "Cstruct.split %a start=%d off=%d" pp_t t
let err_iter t = err "Cstruct.iter %a i=%d len=%d" pp_t t

let of_bigarray ?(off=0) ?len buffer =
  let dim = Bigarray.Array1.dim buffer in
  let len =
    match len with
    | None     -> dim - off
    | Some len -> len in
  if off < 0 || len < 0 || off + len < 0 || off + len > dim then err_of_bigarray off len
  else { buffer; off; len }

let to_bigarray buffer =
  Bigarray.Array1.sub buffer.buffer buffer.off buffer.len

let create_unsafe len =
  let buffer = Bigarray.(Array1.create char c_layout len) in
  { buffer ; len ; off = 0 }

let check_bounds t len =
  len >= 0 && Bigarray.Array1.dim t.buffer >= len

let empty = create_unsafe 0

external check_alignment_bigstring : buffer -> int -> int -> bool = "caml_check_alignment_bigstring"

let check_alignment t alignment =
  if alignment > 0 then
    check_alignment_bigstring t.buffer t.off alignment
  else invalid_arg "check_alignment must be positive integer"

type byte = char

let byte (i:int) : byte = Char.chr i
let byte_to_int (b:byte) = int_of_char b

type uint8 = int
type uint16 = int
type uint32 = int32
type uint64 = int64

let debug t =
  let max_len = Bigarray.Array1.dim t.buffer in
  if t.off+t.len > max_len || t.len < 0 || t.off < 0 then (
    Format.printf "ERROR: t.off+t.len=%d %a\n%!" (t.off+t.len) pp_t t;
    assert false;
  ) else
    Format.asprintf "%a" pp_t t

let sub t off len =
  (* from https://github.com/mirage/ocaml-cstruct/pull/245

     Cstruct.sub should select what a programmer intuitively expects a
     sub-cstruct to be. I imagine holding out my hands, with the left
     representing the start offset and the right the end. I think of a
     sub-cstruct as any span within this range. If I move my left hand only to
     the right (new_start >= t.off), and my right hand only to the left
     (new_end <= old_end), and they don't cross (new_start <= new_end), then I
     feel sure the result will be a valid sub-cstruct. And if I violate any one
     of these constraints (e.g. moving my left hand further left), then I feel
     sure that the result wouldn't be something I'd consider to be a sub-cstruct.

     Wrapping considerations in modular arithmetic:

     Note that if x is non-negative, and x + y wraps, then x + y must be
     negative. This is easy to see with modular arithmetic because if y is
     negative then the two arguments will cancel to some degree the result
     cannot be further from zero than one of the arguments. If y is positive
     then x + y can wrap, but even max_int + max_int doesn't wrap all the way to
     zero.

     The three possibly-wrapping operations are:

     new_start = t.off + off. t.off is non-negative so if this wraps then
     new_start will be negative and will fail the new_start >= t.off test.

     new_end = new_start + len. The above test ensures that new_start is
     non-negative in any successful return. So if this wraps then new_end will
     be negative and will fail the new_start <= new_end test.

     old_end = t.off + t.len. This uses only the existing trusted values. It
     could only wrap if the underlying bigarray had a negative length!  *)
  let new_start = t.off + off in
  let new_end = new_start + len in
  let old_end = t.off + t.len in
  if new_start >= t.off && new_end <= old_end && new_start <= new_end then
    { t with off = new_start ; len }
  else
    err_sub t off len

let shift t amount =
  let off = t.off + amount in
  let len = t.len - amount in
  if amount < 0 || amount > t.len || not (check_bounds t (off+len)) then
    err_shift t amount
  else { t with off; len }

let rec skip_empty = function
  | t :: ts when t.len = 0 -> skip_empty ts
  | x -> x

let rec shiftv ts = function
  | 0 -> skip_empty ts
  | n ->
    match ts with
    | [] -> err_shiftv n
    | t :: ts when n >= t.len -> shiftv ts (n - t.len)
    | t :: ts -> shift t n :: ts

external unsafe_blit_bigstring_to_bigstring : buffer -> int -> buffer -> int -> int -> unit = "caml_blit_bigstring_to_bigstring" [@@noalloc]

external unsafe_blit_string_to_bigstring : string -> int -> buffer -> int -> int -> unit = "caml_blit_string_to_bigstring" [@@noalloc]

external unsafe_blit_bytes_to_bigstring : Bytes.t -> int -> buffer -> int -> int -> unit = "caml_blit_string_to_bigstring" [@@noalloc]

external unsafe_blit_bigstring_to_bytes : buffer -> int -> Bytes.t -> int -> int -> unit = "caml_blit_bigstring_to_string" [@@noalloc]

external unsafe_compare_bigstring : buffer -> int -> buffer -> int -> int -> int = "caml_compare_bigstring" [@@noalloc]

external unsafe_fill_bigstring : buffer -> int -> int -> int -> unit = "caml_fill_bigstring" [@@noalloc]

let copy_to_string caller src srcoff len =
  if len < 0 || srcoff < 0 || src.len - srcoff < len then
    err_copy_to_string caller src srcoff len
  else
    let b = Bytes.create len in
    unsafe_blit_bigstring_to_bytes src.buffer (src.off+srcoff) b 0 len;
    (* The following call is safe, since b is not visible elsewhere. *)
    Bytes.unsafe_to_string b

let copy = copy_to_string "copy"

let blit src srcoff dst dstoff len =
  if len < 0 || srcoff < 0 || src.len - srcoff < len then
    err_blit_src src dst srcoff len
  else if dstoff < 0 || dst.len - dstoff < len then
    err_blit_dst src dst dstoff len
  else
    unsafe_blit_bigstring_to_bigstring src.buffer (src.off+srcoff) dst.buffer
      (dst.off+dstoff) len

let sub_copy cstr off len : t =
  let cstr2 = create_unsafe len in
  blit cstr off cstr2 0 len;
  cstr2

let blit_from_string src srcoff dst dstoff len =
  if len < 0 || srcoff < 0 || dstoff < 0 || String.length src - srcoff < len then
    err_blit_from_string_src src dst srcoff len
  else if dst.len - dstoff < len then
    err_blit_from_string_dst src dst dstoff len
  else
    unsafe_blit_string_to_bigstring src srcoff dst.buffer (dst.off+dstoff) len

let blit_from_bytes src srcoff dst dstoff len =
  if len < 0 || srcoff < 0 || dstoff < 0 || Bytes.length src - srcoff < len then
    err_blit_from_bytes_src src dst srcoff len
  else if dst.len - dstoff < len then
    err_blit_from_bytes_dst src dst dstoff len
  else
    unsafe_blit_bytes_to_bigstring src srcoff dst.buffer (dst.off+dstoff) len

let blit_to_bytes src srcoff dst dstoff len =
  if len < 0 || srcoff < 0 || dstoff < 0 || src.len - srcoff < len then
    err_blit_to_bytes_src src dst srcoff len
  else if Bytes.length dst - dstoff < len then
    err_blit_to_bytes_dst src dst dstoff len
  else
    unsafe_blit_bigstring_to_bytes src.buffer (src.off+srcoff) dst dstoff len

let compare t1 t2 =
  let l1 = t1.len
  and l2 = t2.len in
  match compare l1 l2 with
  | 0 ->
    ( match unsafe_compare_bigstring t1.buffer t1.off t2.buffer t2.off l1 with
      | 0 -> 0
      | r -> if r < 0 then -1 else 1 )
  | r -> r

let equal t1 t2 = compare t1 t2 = 0

(* Note that this is only safe as long as all [t]s are coherent. *)
let memset t x = unsafe_fill_bigstring t.buffer t.off t.len x

let create len =
  let t = create_unsafe len in
  memset t 0;
  t

let set_uint8 t i c =
  if i >= t.len || i < 0 then err_invalid_bounds "set_uint8" t i 1
  else Bigarray.Array1.set t.buffer (t.off+i) (Char.unsafe_chr c)

let set_char t i c =
  if i >= t.len || i < 0 then err_invalid_bounds "set_char" t i 1
  else Bigarray.Array1.set t.buffer (t.off+i) c

let get_uint8 t i =
  if i >= t.len || i < 0 then err_invalid_bounds "get_uint8" t i 1
  else Char.code (Bigarray.Array1.get t.buffer (t.off+i))

let get_char t i =
  if i >= t.len || i < 0 then err_invalid_bounds "get_char" t i 1
  else Bigarray.Array1.get t.buffer (t.off+i)


external ba_set_int16 : buffer -> int -> uint16 -> unit = "%caml_bigstring_set16u"
external ba_set_int32 : buffer -> int -> uint32 -> unit = "%caml_bigstring_set32u"
external ba_set_int64 : buffer -> int -> uint64 -> unit = "%caml_bigstring_set64u"
external ba_get_int16 : buffer -> int -> uint16 = "%caml_bigstring_get16u"
external ba_get_int32 : buffer -> int -> uint32 = "%caml_bigstring_get32u"
external ba_get_int64 : buffer -> int -> uint64 = "%caml_bigstring_get64u"

external swap16 : int -> int = "%bswap16"
external swap32 : int32 -> int32 = "%bswap_int32"
external swap64 : int64 -> int64 = "%bswap_int64"

let set_uint16 swap p t i c =
  if i > t.len - 2 || i < 0 then err_invalid_bounds (p ^ ".set_uint16") t i 2
  else ba_set_int16 t.buffer (t.off+i) (if swap then swap16 c else c) [@@inline]

let set_uint32 swap p t i c =
  if i > t.len - 4 || i < 0 then err_invalid_bounds (p ^ ".set_uint32") t i 4
  else ba_set_int32 t.buffer (t.off+i) (if swap then swap32 c else c) [@@inline]

let set_uint64 swap p t i c =
  if i > t.len - 8 || i < 0 then err_invalid_bounds (p ^ ".set_uint64") t i 8
  else ba_set_int64 t.buffer (t.off+i) (if swap then swap64 c else c) [@@inline]

let get_uint16 swap p t i =
  if i > t.len - 2 || i < 0 then err_invalid_bounds (p ^ ".get_uint16") t i 2
  else
    let r = ba_get_int16 t.buffer (t.off+i) in
    if swap then swap16 r else r [@@inline]

let get_uint32 swap p t i =
  if i > t.len - 4 || i < 0 then err_invalid_bounds (p ^ ".get_uint32") t i 4
  else
    let r = ba_get_int32 t.buffer (t.off+i) in
    if swap then swap32 r else r [@@inline]

let get_uint64 swap p t i =
  if i > t.len - 8 || i < 0 then err_invalid_bounds (p ^ ".get_uint64") t i 8
  else
    let r = ba_get_int64 t.buffer (t.off+i) in
    if swap then swap64 r else r [@@inline]

module BE = struct
  let set_uint16 t i c = set_uint16 (not Sys.big_endian) "BE" t i c [@@inline]
  let set_uint32 t i c = set_uint32 (not Sys.big_endian) "BE" t i c [@@inline]
  let set_uint64 t i c = set_uint64 (not Sys.big_endian) "BE" t i c [@@inline]
  let get_uint16 t i = get_uint16 (not Sys.big_endian) "BE" t i [@@inline]
  let get_uint32 t i = get_uint32 (not Sys.big_endian) "BE" t i [@@inline]
  let get_uint64 t i = get_uint64 (not Sys.big_endian) "BE" t i [@@inline]
end

module LE = struct
  let set_uint16 t i c = set_uint16 Sys.big_endian "LE" t i c [@@inline]
  let set_uint32 t i c = set_uint32 Sys.big_endian "LE" t i c [@@inline]
  let set_uint64 t i c = set_uint64 Sys.big_endian "LE" t i c [@@inline]
  let get_uint16 t i = get_uint16 Sys.big_endian "LE" t i [@@inline]
  let get_uint32 t i = get_uint32 Sys.big_endian "LE" t i [@@inline]
  let get_uint64 t i = get_uint64 Sys.big_endian "LE" t i [@@inline]
end

module HE = struct
  let set_uint16 t i c = set_uint16 false "HE" t i c [@@inline]
  let set_uint32 t i c = set_uint32 false "HE" t i c [@@inline]
  let set_uint64 t i c = set_uint64 false "HE" t i c [@@inline]
  let get_uint16 t i = get_uint16 false "HE" t i [@@inline]
  let get_uint32 t i = get_uint32 false "HE" t i [@@inline]
  let get_uint64 t i = get_uint64 false "HE" t i [@@inline]
end

let length { len ; _ } = len

(** [sum_lengths ~caller acc l] is [acc] plus the sum of the lengths
    of the elements of [l].  Raises [Invalid_argument caller] if
    arithmetic overflows. *)
let rec sum_lengths_aux ~caller acc = function
  | [] -> acc
  | h :: t ->
     let sum = length h + acc in
     if sum < acc then invalid_arg caller
     else sum_lengths_aux ~caller sum t

let sum_lengths ~caller l = sum_lengths_aux ~caller 0 l

let lenv l = sum_lengths ~caller:"Cstruct.lenv" l

let copyv ts =
  let sz = sum_lengths ~caller:"Cstruct.copyv" ts in
  let dst = Bytes.create sz in
  let _ = List.fold_left
    (fun off src ->
      let x = length src in
      unsafe_blit_bigstring_to_bytes src.buffer src.off dst off x;
      off + x
    ) 0 ts in
  (* The following call is safe, since dst is not visible elsewhere. *)
  Bytes.unsafe_to_string dst

let fillv ~src ~dst =
  let rec aux dst n = function
    | [] -> n, []
    | hd::tl ->
        let avail = length dst in
        let first = length hd in
        if first <= avail then (
          blit hd 0 dst 0 first;
          aux (shift dst first) (n + first) tl
        ) else (
          blit hd 0 dst 0 avail;
          let rest_hd = shift hd avail in
          (n + avail, rest_hd :: tl)
        ) in
  aux dst 0 src

let to_string ?(off=0) ?len:sz t =
  let len = match sz with None -> length t - off | Some l -> l in
  copy_to_string "to_string" t off len

let to_hex_string ?(off=0) ?len:sz t : string =
  let[@inline] nibble_to_char (i:int) : char =
    if i < 10 then
      Char.chr (i + Char.code '0')
    else
      Char.chr (i - 10 + Char.code 'a')
  in

  let len = match sz with None -> length t - off | Some l -> l in
  if len < 0 || off < 0 || t.len - off < len then
    err_to_hex_string t off len
  else (
    let out = Bytes.create (2 * len) in
    for i=0 to len-1 do
      let c = Char.code @@ Bigarray.Array1.get t.buffer (i+t.off+off) in
      Bytes.set out (2*i) (nibble_to_char (c lsr 4));
      Bytes.set out (2*i+1) (nibble_to_char (c land 0xf));
    done;
    Bytes.unsafe_to_string out
  )


let to_bytes ?off ?len t =
  Bytes.unsafe_of_string (to_string ?off ?len t)

let [@inline always] of_data_abstract blitfun lenfun ?allocator ?(off=0) ?len buf =
  let buflen =
    match len with
    | None -> lenfun buf - off
    | Some len -> len in
  match allocator with
  | None ->
    let c = create_unsafe buflen in
    blitfun buf off c 0 buflen;
    c
  | Some fn ->
    let c = fn buflen in
    blitfun buf off c 0 buflen;
    { c with len = buflen }

let of_string ?allocator ?off ?len buf =
  of_data_abstract blit_from_string String.length ?allocator ?off ?len buf

let of_bytes ?allocator ?off ?len buf =
  of_data_abstract blit_from_bytes Bytes.length ?allocator ?off ?len buf

let of_hex ?(off=0) ?len str =
  let str =
    let l = match len with None -> String.length str - off | Some l -> l in
    String.sub str off l
  in
  let string_fold ~f ~z str =
    let st = ref z in
    ( String.iter (fun c -> st := f !st c) str  ; !st )
  in
  let hexdigit p = function
    | 'a' .. 'f' as x -> int_of_char x - 87
    | 'A' .. 'F' as x -> int_of_char x - 55
    | '0' .. '9' as x -> int_of_char x - 48
    | x ->
      Format.ksprintf invalid_arg "of_hex: invalid character at pos %d: %C" p x
  in
  let whitespace = function
    | ' ' | '\t' | '\r' | '\n' -> true
    | _ -> false
  in
  match
    string_fold
      ~f:(fun (cs, i, p, acc) ->
          let p' = succ p in
          function
          | char when whitespace char -> (cs, i, p', acc)
          | char ->
            match acc, hexdigit p char with
            | (None  , x) -> (cs, i, p', Some (x lsl 4))
            | (Some y, x) -> set_uint8 cs i (x lor y) ; (cs, succ i, p', None))
      ~z:(create_unsafe (String.length str lsr 1), 0, 0, None)
      str
  with
  | _ , _, _, Some _ ->
    Format.ksprintf invalid_arg "of_hex: odd numbers of characters"
  | cs, i, _, _ -> sub cs 0 i

let hexdump_pp fmt t =
  let before fmt =
    function
    | 0 -> ()
    | 8 -> Format.fprintf fmt "  ";
    | _ -> Format.fprintf fmt " "
  in
  let after fmt =
    function
    | 15 -> Format.fprintf fmt "@;"
    |  _ -> ()
  in
  Format.pp_open_vbox fmt 0 ;
  for i = 0 to length t - 1 do
    let column = i mod 16 in
    let c = Char.code (Bigarray.Array1.get t.buffer (t.off+i)) in
    Format.fprintf fmt "%a%.2x%a" before column c after column
  done ;
  Format.pp_close_box fmt ()

let hexdump = Format.printf "@\n%a@." hexdump_pp

let hexdump_to_buffer buf t =
  let f = Format.formatter_of_buffer buf in
  Format.fprintf f "@\n%a@." hexdump_pp t

let split ?(start=0) t off =
  try
    let header =sub t start off in
    let body = sub t (start+off) (length t - off - start) in
    header, body
  with Invalid_argument _ -> err_split t start off

type 'a iter = unit -> 'a option
let iter lenfn pfn t =
  let body = ref (Some t) in
  let i = ref 0 in
  fun () ->
    match !body with
      |Some buf when length buf = 0 ->
        body := None;
        None
      |Some buf -> begin
        match lenfn buf with
        |None ->
          body := None;
          None
        |Some plen ->
          incr i;
          let p,rest =
            try split buf plen with Invalid_argument _ -> err_iter buf !i plen
          in
          body := Some rest;
          Some (pfn p)
      end
      |None -> None

let rec fold f next acc = match next () with
  | None -> acc
  | Some v -> fold f next (f acc v)

let append cs1 cs2 =
  let l1 = length cs1 and l2 = length cs2 in
  let cs = create_unsafe (l1 + l2) in
  blit cs1 0 cs 0  l1 ;
  blit cs2 0 cs l1 l2 ;
  cs

let concat = function
  | []   -> create_unsafe 0
  | [cs] -> cs
  | css  ->
      let result = create_unsafe (sum_lengths ~caller:"Cstruct.concat" css) in
      let aux off cs =
        let n = length cs in
        blit cs 0 result off n ;
        off + n in
      ignore @@ List.fold_left aux 0 css ;
      result

let rev t =
  let n = length t in
  let out = create_unsafe n in
  for i_src = 0 to n - 1 do
    let byte = get_uint8 t i_src in
    let i_dst = n - 1 - i_src in
    set_uint8 out i_dst byte
  done;
  out

(* Convenience function. *)

external unsafe_blit_string_to_bigstring
  : string -> int -> buffer -> int -> int -> unit
  = "caml_blit_string_to_bigstring"
[@@noalloc]

let get { buffer; off; len; } zidx =
  if zidx < 0 || zidx >= len then invalid_arg "index out of bounds" ;
  Bigarray.Array1.get buffer (off + zidx)

let get_byte { buffer; off; len; } zidx =
  if zidx < 0 || zidx >= len then invalid_arg "index out of bounds" ;
  Char.code (Bigarray.Array1.get buffer (off + zidx))

let string ?(off= 0) ?len str =
  let str_len = String.length str in
  let len = match len with None -> str_len | Some len -> len in
  if off < 0 || len < 0 || off + len > str_len then invalid_arg "index out of bounds" ;
  let buffer = Bigarray.(Array1.create char c_layout str_len) in
  unsafe_blit_string_to_bigstring str 0 buffer 0 str_len ;
  of_bigarray ~off ~len buffer

let buffer ?(off= 0) ?len buffer =
  let buffer_len = Bigarray.Array1.dim buffer in
  let len = match len with None -> buffer_len - off | Some len -> len in
  if off < 0 || len < 0 || off + len > buffer_len then invalid_arg "index out of bounds" ;
  of_bigarray ~off ~len buffer

let start_pos { off; _ } = off
let stop_pos { off; len; _ } = off + len

let head ?(rev= false) ({ len; _ } as cs) =
  if len = 0 then None
  else Some (get_char cs (if rev then len - 1 else 0))

let tail ?(rev= false) ({ buffer; off; len; } as cs) =
  if len = 0 then cs
  else if rev then of_bigarray ~off ~len:(len - 2) buffer
  else of_bigarray ~off:(off + 1) ~len:(len - 1) buffer

let is_empty { len; _ } = len = 0

let is_prefix ~affix:({ len= alen; _ } as affix)
    ({ len; _ } as cs) =
  if alen > len then false
  else
    let max_zidx = alen - 1 in
    let rec loop i =
      if i > max_zidx then true
      else if get_char affix i <> get_char cs i
      then false else loop (succ i) in
    loop 0

let is_infix ~affix:({ len= alen; _ } as affix)
    ({ len; _ } as cs) =
  if alen > len then false
  else
    let max_zidx_a = alen - 1 in
    let max_zidx_s = len - alen in
    let rec loop i k =
      if i > max_zidx_s then false
      else if k > max_zidx_a then true
      else if k > 0 then
        if get_char affix k = get_char cs (i + k)
        then loop i (succ k)
        else loop (succ i) 0
      else if get_char affix 0 = get_char cs i
      then loop i 1
      else loop (succ i) 0 in
    loop 0 0

let is_suffix ~affix:({ len= alen; _ } as affix)
    ({ len; _ } as cs) =
  if alen > len then false
  else
    let max_zidx = alen - 1 in
    let max_zidx_a = alen - 1 in
    let max_zidx_s = len - 1 in
    let rec loop i =
      if i > max_zidx then true
      else if get_char affix (max_zidx_a - i) <> get_char cs (max_zidx_s - i)
      then false else loop (succ i) in
    loop 0

let for_all sat cs =
  let rec go acc i =
    if i < length cs
    then go (sat (get_char cs i) && acc) (succ i)
    else acc in
  go true 0

let exists sat cs =
  let rec go acc i =
    if i < length cs
    then go (sat (get_char cs i) || acc) (succ i)
    else acc in
  go false 0

let start { buffer; off; _ } =
  of_bigarray buffer ~off ~len:0

let stop { buffer; off; len; } =
  of_bigarray buffer ~off:(off + len) ~len:0

let is_white = function ' ' | '\t' .. '\r' -> true | _ -> false

let trim ?(drop = is_white) ({ buffer; off; len; } as cs) =
  if len = 0 then cs
  else
    let max_zpos = len in
    let max_zidx = len - 1 in
    let rec left_pos i =
      if i > max_zidx then max_zpos
      else if drop (get_char cs i) then left_pos (succ i) else i in
    let rec right_pos i =
      if i < 0 then 0
      else if drop (get_char cs i) then right_pos (pred i) else succ i in
    let left = left_pos 0 in
    if left = max_zpos
    then of_bigarray buffer ~off:((off * 2 + len) / 2) ~len:0
    else
      let right = right_pos max_zidx in
      if left = 0 && right = max_zpos then cs
      else of_bigarray buffer ~off:(off + left) ~len:(right - left)

let fspan ~min ~max ~sat ({ buffer= v; off; len; } as cs) =
  if min < 0 then invalid_arg "span: negative min" ;
  if max < 0 then invalid_arg "span: negative max" ;
  if min > max || max = 0 then (buffer ~off:off ~len:0 v, cs)
  else
    let max_zidx = len - 1 in
    let max_zidx =
      let k = max - 1 in
      if k > max_zidx || k < 0 then max_zidx else k in
    let need_zidx = min in
    let rec loop i =
      if i <= max_zidx && sat (get_char cs i) then loop (i + 1)
      else if i < need_zidx || i = 0 then buffer ~off:off ~len:0 v, cs
      else if i = len then (cs, buffer ~off:(off + len) ~len:0 v)
      else buffer ~off:off ~len:i v, buffer ~off:(off + i) ~len:(len - i) v in
    loop 0

let rspan ~min ~max ~sat ({ buffer= v; off; len; } as cs) =
  if min < 0 then invalid_arg "span: negative min" ;
  if max < 0 then invalid_arg "span: negative max" ;
  if min > max || max = 0 then (cs, buffer ~off:(off + len) ~len:0 v)
  else
    let max_zidx = len - 1 in
    let min_zidx =
      let k = len - max in if k < 0 then 0 else k in
    let need_zidx = len - min - 1 in
    let rec loop i =
      if i >= min_zidx && sat (get_char cs i) then loop (i - 1)
      else if i > need_zidx || i = max_zidx then (cs, buffer ~off:(off + len) ~len:0 v)
      else if i < 0 then (buffer ~off:off ~len:0 v, cs)
      else (buffer ~off:off ~len:(i + 1) v, buffer ~off:(off + i + 1) ~len:(len - (i + 1)) v) in
    loop max_zidx

let span ?(rev= false) ?(min= 0) ?(max= max_int) ?(sat= fun _ -> true) cs =
  match rev with
  | true  -> rspan ~min ~max ~sat cs
  | false -> fspan ~min ~max ~sat cs

let take ?(rev= false) ?min ?max ?sat cs =
  (if rev then snd else fst) @@ span ~rev ?min ?max ?sat cs

let drop ?(rev= false) ?min ?max ?sat cs =
  (if rev then fst else snd) @@ span ~rev ?min ?max ?sat cs

let fcut ~sep:({ len= sep_len; _ } as sep)
    ({ buffer= v; off; len; } as cs) =
  if sep_len = 0 then invalid_arg "cut: empty separator" ;
  let max_sep_zidx = sep_len - 1 in
  let max_s_zidx = len - sep_len in
  let rec check_sep i k =
    if k > max_sep_zidx
    then Some (buffer ~off:off ~len:i v,
               buffer ~off:(off + i + sep_len) ~len:(len - i - sep_len) v)
    else if get_char cs (i + k) = get_char sep k
    then check_sep i (k + 1)
    else scan (i + 1)
  and scan i =
    if i > max_s_zidx then None
    else if get_char cs i = get_char sep 0
    then check_sep i 1
    else scan (i + 1) in
  scan 0

let rcut ~sep:({ len= sep_len; _ } as sep) ({ buffer= v; off; len; } as cs) =
  if sep_len = 0 then invalid_arg "cut: empty separator" ;
  let max_sep_zidx = sep_len - 1 in
  let max_s_zidx = len - 1 in
  let rec check_sep i k =
    if k > max_sep_zidx then Some (buffer ~off:off ~len:i v,
                                   buffer ~off:(off + i + sep_len) ~len:(len - i - sep_len) v)
    else if get_char cs (i + k) = get_char sep k
    then check_sep i (k + 1)
    else rscan (i - 1)
  and rscan i =
    if i < 0 then None
    else if get_char cs i = get_char sep 0
    then check_sep i 1
    else rscan (i - 1) in
  rscan (max_s_zidx - max_sep_zidx)

let cut ?(rev= false) ~sep cs = match rev with
  | true  -> rcut ~sep cs
  | false -> fcut ~sep cs

let add_sub ~no_empty buf ~off ~len acc =
  if len = 0
  then ( if no_empty then acc else buffer ~off ~len buf :: acc )
  else buffer ~off ~len buf :: acc

let fcuts ~no_empty ~sep:({ len= sep_len; _ } as sep)
      ({ buffer; off; len; } as cs) =
  if sep_len = 0 then invalid_arg "cuts: empty separator" ;
  let max_sep_zidx = sep_len - 1 in
  let max_s_zidx = len - sep_len in
  let rec check_sep zanchor i k acc =
    if k > max_sep_zidx
    then
      let new_start = i + sep_len in
      scan new_start new_start (add_sub ~no_empty buffer ~off:(off + zanchor) ~len:(i - zanchor) acc)
    else
      if get_char cs (i + k) = get_char sep k
      then check_sep zanchor i (k + 1) acc
      else scan zanchor (i + 1) acc
  and scan zanchor i acc =
    if i > max_s_zidx
    then
      if zanchor = 0 then (if no_empty && len = 0 then [] else [ cs ])
      else List.rev (add_sub ~no_empty buffer ~off:(off + zanchor) ~len:(len - zanchor) acc)
    else
      if get_char cs i = get_char sep 0
      then check_sep zanchor i 1 acc
      else scan zanchor (i + 1) acc in
  scan 0 0 []

let rcuts ~no_empty ~sep:({ len= sep_len; _ } as sep)
      ({ buffer; len; _ } as cs) =
  if sep_len = 0 then invalid_arg "cuts: empty separator" ;
  let s_len = len in
  let max_sep_zidx = sep_len - 1 in
  let max_s_zidx = len - 1 in
  let rec check_sep zanchor i k acc =
    if k > max_sep_zidx
    then let off = i + sep_len in
         rscan i (i - sep_len) (add_sub ~no_empty buffer ~off ~len:(zanchor - off) acc)
    else
      if get_char cs (i + k) = get_char cs k
      then check_sep zanchor i (k + 1) acc
      else rscan zanchor (i - 1) acc
  and rscan zanchor i acc =
    if i < 0 then
      if zanchor = s_len then ( if no_empty && s_len = 0 then [] else [ cs ])
      else add_sub ~no_empty buffer ~off:0 ~len:zanchor acc
    else
      if get_char cs i = get_char sep 0
      then check_sep zanchor i 1 acc
      else rscan zanchor (i - 1) acc in
  rscan s_len (max_s_zidx - max_sep_zidx) []

let cuts ?(rev= false) ?(empty= true) ~sep cs = match rev with
  | true  -> rcuts ~no_empty:(not empty) ~sep cs
  | false -> fcuts ~no_empty:(not empty) ~sep cs

let fields ?(empty= false) ?(is_sep= is_white) ({ buffer; off; len; } as cs) =
  let no_empty = not empty in
  let max_pos = len in
  let rec loop i end_pos acc =
    if i < 0 then begin
        if end_pos = len
        then ( if no_empty && len = 0 then [] else [ cs ])
        else add_sub ~no_empty buffer ~off:off ~len:(end_pos - (i + 1)) acc
      end else begin
        if not (is_sep (get_char cs i))
        then loop (i - 1) end_pos acc
        else loop (i - 1) i (add_sub ~no_empty buffer ~off:(off + i + 1) ~len:(end_pos - (i + 1)) acc)
      end in
  loop (max_pos - 1) max_pos []

let ffind sat ({ buffer= v; len; _ } as cs) =
  let max_idx = len - 1 in
  let rec loop i =
    if i > max_idx then None
    else if sat (get_char cs i)
    then Some (buffer ~off:i ~len:1 v)
    else loop (i + 1) in
  loop 0

let rfind sat ({ buffer= v; len; _ } as cs) =
  let rec loop i =
    if i < 0 then None
    else if sat (get_char cs i)
    then Some (buffer ~off:i ~len:1 v)
    else loop (i - 1) in
  loop (len - 1)

let find ?(rev= false) sat cs = match rev with
  | true  -> rfind sat cs
  | false -> ffind sat cs

let ffind_sub ~sub:({ len= sub_len; _ } as sub) ({ buffer= v; off; len; } as cs) =
  if sub_len > len then None
  else
    let max_zidx_sub = sub_len - 1 in
    let max_zidx_s = len - sub_len in
    let rec loop i k =
      if i > max_zidx_s then None
      else if k > max_zidx_sub then Some (buffer v ~off:(off + i) ~len:sub_len)
      else if k > 0
      then ( if get_char sub k = get_char cs (i + k)
             then loop i (k + 1)
             else loop (i + 1) 0 )
      else if get_char sub 0 = get_char cs i
      then loop i 1
      else loop (i + 1) 0 in
    loop 0 0

let rfind_sub ~sub:({ len= sub_len; _ } as sub) ({ buffer= v; len; _ } as cs) =
  if sub_len > len then None
  else
    let max_zidx_sub = sub_len - 1 in
    let rec loop i k =
      if i < 0 then None
      else if k > max_zidx_sub then Some (buffer v ~off:i ~len:sub_len)
      else if k > 0
      then ( if get_char sub k = get_char cs (i + k)
             then loop i (k + 1)
             else loop (i - 1) 0 )
      else if get_char sub 0 = get_char cs i
      then loop i 1
      else loop (i - 1) 0 in
    loop (len - sub_len) 0

let find_sub ?(rev= false) ~sub cs = match rev with
  | true  -> rfind_sub ~sub cs
  | false -> ffind_sub ~sub cs

let filter sat ({ len; _ } as cs) =
  if len = 0 then empty
  else
    let b = create len in
    let max_zidx = len - 1 in
    let rec loop b k i =
      if i > max_zidx
      then (if k = len then b else sub b 0 k)
      else
        let chr = get_char cs i in
        if sat chr then ( set_char b k chr ; loop b (k + 1) (i + 1))
        else loop b k (i + 1) in
    loop b 0 0

let filter_map f ({ len; _ } as cs) =
  if len = 0 then empty
  else
    let b = create len in
    let max_zidx = len - 1 in
    let rec loop b k i =
      if i > max_zidx
      then (if k = len then b else sub b 0 k)
      else match f (get_char cs i) with
           | Some chr ->
              set_char b i chr ;
              loop b (k + 1) (i + 1)
           | None ->
              loop b k (i + 1) in
    loop b 0 0

let map f ({ len; _ } as cs) =
  if len = 0 then empty
  else
    let b = create len in
    for i = 0 to len - 1 do
      set_char b i (f (get_char cs i))
    done ; b

let mapi f ({ len; _ } as cs) =
  if len = 0 then empty
  else
    let b = create len in
    for i = 0 to len - 1 do
      set_char b i (f i (get_char cs i))
    done ; b