swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Browse source
This commit is contained in:
swrup 2025-11-11 02:07:51 +01:00
parent aa2ff7b2f0
commit 2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

749
unikernel/duniverse/angstrom/lib/angstrom.ml Normal file
View file

@ -0,0 +1,749 @@
(*----------------------------------------------------------------------------
Copyright (c) 2016 Inhabited Type LLC.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. 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.
3. Neither the name of the author nor the names of his contributors
may be used to endorse or promote products derived from this software
without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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.
----------------------------------------------------------------------------*)
module Bigarray = struct
(* Do not access Bigarray operations directly. If anything's needed, refer to
* the internal Bigstring module. *)
end
type bigstring = Bigstringaf.t
module Unbuffered = struct
include Parser
include Exported_state
type more = More.t =
| Complete
| Incomplete
end
include Unbuffered
include Parser.Monad
include Parser.Choice
module Buffered = struct
type unconsumed = Buffering.unconsumed =
{ buf : bigstring
; off : int
; len : int }
type input =
[ `Bigstring of bigstring
| `String of string ]
type 'a state =
| Partial of ([ input | `Eof ] -> 'a state)
| Done of unconsumed * 'a
| Fail of unconsumed * string list * string
let from_unbuffered_state ~f buffering = function
| Unbuffered.Partial p -> Partial (f p)
| Unbuffered.Done(consumed, v) ->
let unconsumed = Buffering.unconsumed ~shift:consumed buffering in
Done(unconsumed, v)
| Unbuffered.Fail(consumed, marks, msg) ->
let unconsumed = Buffering.unconsumed ~shift:consumed buffering in
Fail(unconsumed, marks, msg)
let parse ?(initial_buffer_size=0x1000) p =
if initial_buffer_size < 1 then
failwith "parse: invalid argument, initial_buffer_size < 1";
let buffering = Buffering.create initial_buffer_size in
let rec f p input =
Buffering.shift buffering p.committed;
let more : More.t =
match input with
| `Eof -> Complete
| #input as input ->
Buffering.feed_input buffering input;
Incomplete
in
let for_reading = Buffering.for_reading buffering in
p.continue for_reading ~off:0 ~len:(Bigstringaf.length for_reading) more
|> from_unbuffered_state buffering ~f
in
Unbuffered.parse p
|> from_unbuffered_state buffering ~f
let feed state input =
match state with
| Partial k -> k input
| Fail(unconsumed, marks, msg) ->
begin match input with
| `Eof -> state
| #input as input ->
let buffering = Buffering.of_unconsumed unconsumed in
Buffering.feed_input buffering input;
Fail(Buffering.unconsumed buffering, marks, msg)
end
| Done(unconsumed, v) ->
begin match input with
| `Eof -> state
| #input as input ->
let buffering = Buffering.of_unconsumed unconsumed in
Buffering.feed_input buffering input;
Done(Buffering.unconsumed buffering, v)
end
let state_to_option = function
| Done(_, v) -> Some v
| Partial _ -> None
| Fail _ -> None
let state_to_result = function
| Partial _ -> Error "incomplete input"
| Done(_, v) -> Ok v
| Fail(_, marks, msg) -> Error (Unbuffered.fail_to_string marks msg)
let state_to_unconsumed = function
| Done(unconsumed, _)
| Fail(unconsumed, _, _) -> Some unconsumed
| Partial _ -> None
end
(** BEGIN: getting input *)
let rec prompt input pos fail succ =
(* [prompt] should only call [succ] if it has received more input. If there
* is no chance that the input will grow, i.e., [more = Complete], then
* [prompt] should call [fail]. Otherwise (in the case where the input
* hasn't grown but [more = Incomplete] just prompt again. *)
let parser_uncommitted_bytes = Input.parser_uncommitted_bytes input in
let parser_committed_bytes = Input.parser_committed_bytes input in
(* The continuation should not hold any references to input above. *)
let continue input ~off ~len more =
if len < parser_uncommitted_bytes then
failwith "prompt: input shrunk!";
let input = Input.create input ~off ~len ~committed_bytes:parser_committed_bytes in
if len = parser_uncommitted_bytes then
match (more : More.t) with
| Complete -> fail input pos More.Complete
| Incomplete -> prompt input pos fail succ
else
succ input pos more
in
State.Partial { committed = Input.bytes_for_client_to_commit input; continue }
let demand_input =
{ run = fun input pos more fail succ ->
match (more : More.t) with
| Complete -> fail input pos more [] "not enough input"
| Incomplete ->
let succ' input' pos' more' = succ input' pos' more' ()
and fail' input' pos' more' = fail input' pos' more' [] "not enough input" in
prompt input pos fail' succ'
}
let ensure_suspended n input pos more fail succ =
let rec go =
{ run = fun input' pos' more' fail' succ' ->
if pos' + n <= Input.length input' then
succ' input' pos' more' ()
else
(demand_input *> go).run input' pos' more' fail' succ'
}
in
(demand_input *> go).run input pos more fail succ
let unsafe_apply len ~f =
{ run = fun input pos more _fail succ ->
succ input (pos + len) more (Input.apply input pos len ~f)
}
let unsafe_apply_opt len ~f =
{ run = fun input pos more fail succ ->
match Input.apply input pos len ~f with
| Error e -> fail input pos more [] e
| Ok x -> succ input (pos + len) more x
}
let ensure n p =
{ run = fun input pos more fail succ ->
if pos + n <= Input.length input
then p.run input pos more fail succ
else
let succ' input' pos' more' () = p.run input' pos' more' fail succ in
ensure_suspended n input pos more fail succ' }
(** END: getting input *)
let at_end_of_input =
{ run = fun input pos more _ succ ->
if pos < Input.length input then
succ input pos more false
else match more with
| Complete -> succ input pos more true
| Incomplete ->
let succ' input' pos' more' = succ input' pos' more' false
and fail' input' pos' more' = succ input' pos' more' true in
prompt input pos fail' succ'
}
let end_of_input =
at_end_of_input
>>= function
| true -> return ()
| false -> fail "end_of_input"
let advance n =
if n < 0
then fail "advance"
else
let p =
{ run = fun input pos more _fail succ -> succ input (pos + n) more () }
in
ensure n p
let pos =
{ run = fun input pos more _fail succ -> succ input pos more pos }
let available =
{ run = fun input pos more _fail succ ->
succ input pos more (Input.length input - pos)
}
let commit =
{ run = fun input pos more _fail succ ->
Input.commit input pos;
succ input pos more () }
(* Do not use this if [p] contains a [commit]. *)
let unsafe_lookahead p =
{ run = fun input pos more fail succ ->
let succ' input' _ more' v = succ input' pos more' v in
p.run input pos more fail succ' }
let peek_char =
{ run = fun input pos more _fail succ ->
if pos < Input.length input then
succ input pos more (Some (Input.unsafe_get_char input pos))
else if more = Complete then
succ input pos more None
else
let succ' input' pos' more' =
succ input' pos' more' (Some (Input.unsafe_get_char input' pos'))
and fail' input' pos' more' =
succ input' pos' more' None in
prompt input pos fail' succ'
}
(* This parser is too important to not be optimized. Do a custom job. *)
let rec peek_char_fail =
{ run = fun input pos more fail succ ->
if pos < Input.length input
then succ input pos more (Input.unsafe_get_char input pos)
else
let succ' input' pos' more' () =
peek_char_fail.run input' pos' more' fail succ in
ensure_suspended 1 input pos more fail succ' }
let satisfy f =
{ run = fun input pos more fail succ ->
if pos < Input.length input then
let c = Input.unsafe_get_char input pos in
if f c
then succ input (pos + 1) more c
else Printf.ksprintf (fail input pos more []) "satisfy: %C" c
else
let succ' input' pos' more' () =
let c = Input.unsafe_get_char input' pos' in
if f c
then succ input' (pos' + 1) more' c
else Printf.ksprintf (fail input' pos' more' []) "satisfy: %C" c
in
ensure_suspended 1 input pos more fail succ' }
let char c =
let p =
{ run = fun input pos more fail succ ->
if Input.unsafe_get_char input pos = c
then succ input (pos + 1) more c
else fail input pos more [] (Printf.sprintf "char %C" c) }
in
ensure 1 p
let not_char c =
let p =
{ run = fun input pos more fail succ ->
let c' = Input.unsafe_get_char input pos in
if c <> c'
then succ input (pos + 1) more c'
else fail input pos more [] (Printf.sprintf "not char %C" c) }
in
ensure 1 p
let any_char =
let p =
{ run = fun input pos more _fail succ ->
succ input (pos + 1) more (Input.unsafe_get_char input pos) }
in
ensure 1 p
let int8 i =
let p =
{ run = fun input pos more fail succ ->
let c = Char.code (Input.unsafe_get_char input pos) in
if c = i land 0xff
then succ input (pos + 1) more c
else fail input pos more [] (Printf.sprintf "int8 %d" i) }
in
ensure 1 p
let any_uint8 =
let p =
{ run = fun input pos more _fail succ ->
let c = Input.unsafe_get_char input pos in
succ input (pos + 1) more (Char.code c) }
in
ensure 1 p
let any_int8 =
(* https://graphics.stanford.edu/~seander/bithacks.html#VariableSignExtendRisky *)
let s = Sys.int_size - 8 in
let p =
{ run = fun input pos more _fail succ ->
let c = Input.unsafe_get_char input pos in
succ input (pos + 1) more ((Char.code c lsl s) asr s) }
in
ensure 1 p
let skip f =
let p =
{ run = fun input pos more fail succ ->
if f (Input.unsafe_get_char input pos)
then succ input (pos + 1) more ()
else fail input pos more [] "skip" }
in
ensure 1 p
let rec count_while ~init ~f ~with_buffer =
{ run = fun input pos more fail succ ->
let len = Input.count_while input (pos + init) ~f in
let input_len = Input.length input in
let init' = init + len in
(* Check if the loop terminated because it reached the end of the input
* buffer. If so, then prompt for additional input and continue. *)
if pos + init' < input_len || more = Complete
then succ input (pos + init') more (Input.apply input pos init' ~f:with_buffer)
else
let succ' input' pos' more' =
(count_while ~init:init' ~f ~with_buffer).run input' pos' more' fail succ
and fail' input' pos' more' =
succ input' (pos' + init') more' (Input.apply input' pos' init' ~f:with_buffer)
in
prompt input pos fail' succ'
}
let rec count_while1 ~f ~with_buffer =
{ run = fun input pos more fail succ ->
let len = Input.count_while input pos ~f in
let input_len = Input.length input in
(* Check if the loop terminated because it reached the end of the input
* buffer. If so, then prompt for additional input and continue. *)
if len < 1
then
if pos < input_len || more = Complete
then fail input pos more [] "count_while1"
else
let succ' input' pos' more' =
(count_while1 ~f ~with_buffer).run input' pos' more' fail succ
and fail' input' pos' more' =
fail input' pos' more' [] "count_while1"
in
prompt input pos fail' succ'
else if pos + len < input_len || more = Complete
then succ input (pos + len) more (Input.apply input pos len ~f:with_buffer)
else
let succ' input' pos' more' =
(count_while ~init:len ~f ~with_buffer).run input' pos' more' fail succ
and fail' input' pos' more' =
succ input' (pos' + len) more' (Input.apply input' pos' len ~f:with_buffer)
in
prompt input pos fail' succ'
}
let string_ f s =
(* XXX(seliopou): Inefficient. Could check prefix equality to short-circuit
* the io. *)
let len = String.length s in
ensure len (unsafe_apply_opt len ~f:(fun buffer ~off ~len ->
let i = ref 0 in
while !i < len && Char.equal (f (Bigstringaf.unsafe_get buffer (off + !i)))
(f (String.unsafe_get s !i))
do
incr i
done;
if len = !i
then Ok (Bigstringaf.substring buffer ~off ~len)
else Error "string"))
let string s = string_ (fun x -> x) s
let string_ci s = string_ Char.lowercase_ascii s
let skip_while f =
count_while ~init:0 ~f ~with_buffer:(fun _ ~off:_ ~len:_ -> ())
let take n =
if n < 0
then fail "take: n < 0"
else
let n = max n 0 in
ensure n (unsafe_apply n ~f:Bigstringaf.substring)
let take_bigstring n =
if n < 0
then fail "take_bigstring: n < 0"
else
let n = max n 0 in
ensure n (unsafe_apply n ~f:Bigstringaf.copy)
let take_bigstring_while f =
count_while ~init:0 ~f ~with_buffer:Bigstringaf.copy
let take_bigstring_while1 f =
count_while1 ~f ~with_buffer:Bigstringaf.copy
let take_bigstring_till f =
take_bigstring_while (fun c -> not (f c))
let peek_string n =
unsafe_lookahead (take n)
let take_while f =
count_while ~init:0 ~f ~with_buffer:Bigstringaf.substring
let take_while1 f =
count_while1 ~f ~with_buffer:Bigstringaf.substring
let take_till f =
take_while (fun c -> not (f c))
let choice ?(failure_msg="no more choices") ps =
List.fold_right (<|>) ps (fail failure_msg)
let notset = { run = fun _buf _pos _more _fail _succ -> failwith "Angstrom.fix_direct not set" }
let fix_direct f =
let rec p = ref notset
and r = { run = fun buf pos more fail succ ->
(!p).run buf pos more fail succ }
in
p := f r;
r
let fix_lazy ~max_steps f =
let steps = ref max_steps in
let rec p = lazy (f r)
and r = { run = fun buf pos more fail succ ->
decr steps;
if !steps < 0
then (
steps := max_steps;
State.Lazy (lazy ((Lazy.force p).run buf pos more fail succ)))
else
(Lazy.force p).run buf pos more fail succ
}
in
r
let fix = match Sys.backend_type with
| Native -> fix_direct
| Bytecode -> fix_direct
| Other _ -> fun f -> fix_lazy ~max_steps:20 f
let option x p =
p <|> return x
let cons x xs = x :: xs
let rec list ps =
match ps with
| [] -> return []
| p::ps -> lift2 cons p (list ps)
let count n p =
if n < 0
then fail "count: n < 0"
else
let rec loop = function
| 0 -> return []
| n -> lift2 cons p (loop (n - 1))
in
loop n
let many p =
fix (fun m ->
(lift2 cons p m) <|> return [])
let many1 p =
lift2 cons p (many p)
let many_till p t =
fix (fun m ->
(t *> return []) <|> (lift2 cons p m))
let sep_by1 s p =
fix (fun m ->
lift2 cons p ((s *> m) <|> return []))
let sep_by s p =
(lift2 cons p ((s *> sep_by1 s p) <|> return [])) <|> return []
let skip_many p =
fix (fun m ->
((p >>| fun _ -> true) <|> return false) >>= function
| true -> m
| false -> return ()
)
let skip_many1 p =
p *> skip_many p
let end_of_line =
(char '\n' *> return ()) <|> (string "\r\n" *> return ()) <?> "end_of_line"
let scan_ state f ~with_buffer =
{ run = fun input pos more fail succ ->
let state = ref state in
let parser =
count_while ~init:0 ~f:(fun c ->
match f !state c with
| None -> false
| Some state' -> state := state'; true)
~with_buffer
>>| fun x -> x, !state
in
parser.run input pos more fail succ }
let scan state f =
scan_ state f ~with_buffer:Bigstringaf.substring
let scan_state state f =
scan_ state f ~with_buffer:(fun _ ~off:_ ~len:_ -> ())
>>| fun ((), state) -> state
let scan_string state f =
scan state f >>| fst
let consume_with p f =
{ run = fun input pos more fail succ ->
let start = pos in
let parser_committed_bytes = Input.parser_committed_bytes input in
let succ' input' pos' more' _ =
if parser_committed_bytes <> Input.parser_committed_bytes input'
then fail input' pos' more' [] "consumed: parser committed"
else (
let len = pos' - start in
let consumed = Input.apply input' start len ~f in
succ input' pos' more' consumed)
in
p.run input pos more fail succ'
}
let consumed p = consume_with p Bigstringaf.substring
let consumed_bigstring p = consume_with p Bigstringaf.copy
let both a b = lift2 (fun a b -> a, b) a b
let map t ~f = t >>| f
let bind t ~f = t >>= f
let map2 a b ~f = lift2 f a b
let map3 a b c ~f = lift3 f a b c
let map4 a b c d ~f = lift4 f a b c d
module Let_syntax = struct
let return = return
let ( >>| ) = ( >>| )
let ( >>= ) = ( >>= )
module Let_syntax = struct
let return = return
let map = map
let bind = bind
let both = both
let map2 = map2
let map3 = map3
let map4 = map4
end
end
let ( let+ ) = ( >>| )
let ( let* ) = ( >>= )
let ( and+ ) = both
module BE = struct
(* XXX(seliopou): The pattern in both this module and [LE] are a compromise
* between efficiency and code reuse. By inlining [ensure] you can recover
* about 2 nanoseconds on average. That may add up in certain applications.
*
* This pattern does not allocate in the fast (success) path.
* *)
let int16 n =
let bytes = 2 in
let p =
{ run = fun input pos more fail succ ->
if Input.unsafe_get_int16_be input pos = (n land 0xffff)
then succ input (pos + bytes) more ()
else fail input pos more [] "BE.int16" }
in
ensure bytes p
let int32 n =
let bytes = 4 in
let p =
{ run = fun input pos more fail succ ->
if Int32.equal (Input.unsafe_get_int32_be input pos) n
then succ input (pos + bytes) more ()
else fail input pos more [] "BE.int32" }
in
ensure bytes p
let int64 n =
let bytes = 8 in
let p =
{ run = fun input pos more fail succ ->
if Int64.equal (Input.unsafe_get_int64_be input pos) n
then succ input (pos + bytes) more ()
else fail input pos more [] "BE.int64" }
in
ensure bytes p
let any_uint16 =
ensure 2 (unsafe_apply 2 ~f:(fun bs ~off ~len:_ -> Bigstringaf.unsafe_get_int16_be bs off))
let any_int16 =
ensure 2 (unsafe_apply 2 ~f:(fun bs ~off ~len:_ -> Bigstringaf.unsafe_get_int16_sign_extended_be bs off))
let any_int32 =
ensure 4 (unsafe_apply 4 ~f:(fun bs ~off ~len:_ -> Bigstringaf.unsafe_get_int32_be bs off))
let any_int64 =
ensure 8 (unsafe_apply 8 ~f:(fun bs ~off ~len:_ -> Bigstringaf.unsafe_get_int64_be bs off))
let any_float =
ensure 4 (unsafe_apply 4 ~f:(fun bs ~off ~len:_ -> Int32.float_of_bits (Bigstringaf.unsafe_get_int32_be bs off)))
let any_double =
ensure 8 (unsafe_apply 8 ~f:(fun bs ~off ~len:_ -> Int64.float_of_bits (Bigstringaf.unsafe_get_int64_be bs off)))
end
module LE = struct
let int16 n =
let bytes = 2 in
let p =
{ run = fun input pos more fail succ ->
if Input.unsafe_get_int16_le input pos = (n land 0xffff)
then succ input (pos + bytes) more ()
else fail input pos more [] "LE.int16" }
in
ensure bytes p
let int32 n =
let bytes = 4 in
let p =
{ run = fun input pos more fail succ ->
if Int32.equal (Input.unsafe_get_int32_le input pos) n
then succ input (pos + bytes) more ()
else fail input pos more [] "LE.int32" }
in
ensure bytes p
let int64 n =
let bytes = 8 in
let p =
{ run = fun input pos more fail succ ->
if Int64.equal (Input.unsafe_get_int64_le input pos) n
then succ input (pos + bytes) more ()
else fail input pos more [] "LE.int64" }
in
ensure bytes p
let any_uint16 =
ensure 2 (unsafe_apply 2 ~f:(fun bs ~off ~len:_ -> Bigstringaf.unsafe_get_int16_le bs off))
let any_int16 =
ensure 2 (unsafe_apply 2 ~f:(fun bs ~off ~len:_ -> Bigstringaf.unsafe_get_int16_sign_extended_le bs off))
let any_int32 =
ensure 4 (unsafe_apply 4 ~f:(fun bs ~off ~len:_ -> Bigstringaf.unsafe_get_int32_le bs off))
let any_int64 =
ensure 8 (unsafe_apply 8 ~f:(fun bs ~off ~len:_ -> Bigstringaf.unsafe_get_int64_le bs off))
let any_float =
ensure 4 (unsafe_apply 4 ~f:(fun bs ~off ~len:_ -> Int32.float_of_bits (Bigstringaf.unsafe_get_int32_le bs off)))
let any_double =
ensure 8 (unsafe_apply 8 ~f:(fun bs ~off ~len:_ -> Int64.float_of_bits (Bigstringaf.unsafe_get_int64_le bs off)))
end
module Unsafe = struct
let take n f =
let n = max n 0 in
ensure n (unsafe_apply n ~f)
let peek n f =
unsafe_lookahead (take n f)
let take_while check f =
count_while ~init:0 ~f:check ~with_buffer:f
let take_while1 check f =
count_while1 ~f:check ~with_buffer:f
let take_till check f =
take_while (fun c -> not (check c)) f
end
module Consume = struct
type t =
| Prefix
| All
end
let parse_bigstring ~consume p bs =
let p =
match (consume : Consume.t) with
| Prefix -> p
| All -> p <* end_of_input
in
Unbuffered.parse_bigstring p bs
let parse_string ~consume p s =
let len = String.length s in
let bs = Bigstringaf.create len in
Bigstringaf.unsafe_blit_from_string s ~src_off:0 bs ~dst_off:0 ~len;
parse_bigstring ~consume p bs

688
unikernel/duniverse/angstrom/lib/angstrom.mli Normal file
View file

@ -0,0 +1,688 @@
(*----------------------------------------------------------------------------
Copyright (c) 2016 Inhabited Type LLC.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. 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.
3. Neither the name of the author nor the names of his contributors
may be used to endorse or promote products derived from this software
without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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.
----------------------------------------------------------------------------*)
(** Parser combinators built for speed and memory-efficiency.
Angstrom is a parser-combinator library that provides monadic and
applicative interfaces for constructing parsers with unbounded lookahead.
Its parsers can consume input incrementally, whether in a blocking or
non-blocking environment. To achieve efficient incremental parsing,
Angstrom offers both a buffered and unbuffered interface to input streams,
with the {!module:Unbuffered} interface enabling zero-copy IO. With these
features and low-level iteration parser primitives like {!take_while} and
{!skip_while}, Angstrom makes it easy to write efficient, expressive, and
reusable parsers suitable for high-performance applications. *)
type +'a t
(** A parser for values of type ['a]. *)
type bigstring = Bigstringaf.t
(** {2 Basic parsers} *)
val peek_char : char option t
(** [peek_char] accepts any char and returns it, or returns [None] if the end
of input has been reached.
This parser does not advance the input. Use it for lookahead. *)
val peek_char_fail : char t
(** [peek_char_fail] accepts any char and returns it. If end of input has been
reached, it will fail.
This parser does not advance the input. Use it for lookahead. *)
val peek_string : int -> string t
(** [peek_string n] accepts exactly [n] characters and returns them as a
string. If there is not enough input, it will fail.
This parser does not advance the input. Use it for lookahead. *)
val char : char -> char t
(** [char c] accepts [c] and returns it. *)
val not_char : char -> char t
(** [not_char] accepts any character that is not [c] and returns the matched
character. *)
val any_char : char t
(** [any_char] accepts any character and returns it. *)
val satisfy : (char -> bool) -> char t
(** [satisfy f] accepts any character for which [f] returns [true] and
returns the accepted character. In the case that none of the parser
succeeds, then the parser will fail indicating the offending
character. *)
val string : string -> string t
(** [string s] accepts [s] exactly and returns it. *)
val string_ci : string -> string t
(** [string_ci s] accepts [s], ignoring case, and returns the matched string,
preserving the case of the original input. *)
val skip : (char -> bool) -> unit t
(** [skip f] accepts any character for which [f] returns [true] and discards
the accepted character. [skip f] is equivalent to [satisfy f] but discards
the accepted character. *)
val skip_while : (char -> bool) -> unit t
(** [skip_while f] accepts input as long as [f] returns [true] and discards
the accepted characters. *)
val take : int -> string t
(** [take n] accepts exactly [n] characters of input and returns them as a
string. *)
val take_while : (char -> bool) -> string t
(** [take_while f] accepts input as long as [f] returns [true] and returns the
accepted characters as a string.
This parser does not fail. If [f] returns [false] on the first character,
it will return the empty string. *)
val take_while1 : (char -> bool) -> string t
(** [take_while1 f] accepts input as long as [f] returns [true] and returns the
accepted characters as a string.
This parser requires that [f] return [true] for at least one character of
input, and will fail otherwise. *)
val take_till : (char -> bool) -> string t
(** [take_till f] accepts input as long as [f] returns [false] and returns the
accepted characters as a string.
This parser does not fail. If [f] returns [true] on the first character, it
will return the empty string. *)
val consumed : _ t -> string t
(** [consumed p] runs [p] and returns the contents that were consumed during the
parsing as a string *)
val take_bigstring : int -> bigstring t
(** [take_bigstring n] accepts exactly [n] characters of input and returns them
as a newly allocated bigstring. *)
val take_bigstring_while : (char -> bool) -> bigstring t
(** [take_bigstring_while f] accepts input as long as [f] returns [true] and
returns the accepted characters as a newly allocated bigstring.
This parser does not fail. If [f] returns [false] on the first character,
it will return the empty bigstring. *)
val take_bigstring_while1 : (char -> bool) -> bigstring t
(** [take_bigstring_while1 f] accepts input as long as [f] returns [true] and
returns the accepted characters as a newly allocated bigstring.
This parser requires that [f] return [true] for at least one character of
input, and will fail otherwise. *)
val take_bigstring_till : (char -> bool) -> bigstring t
(** [take_bigstring_till f] accepts input as long as [f] returns [false] and
returns the accepted characters as a newly allocated bigstring.
This parser does not fail. If [f] returns [true] on the first character, it
will return the empty bigstring. *)
val consumed_bigstring : _ t -> bigstring t
(** [consumed p] runs [p] and returns the contents that were consumed during the
parsing as a bigstring *)
val advance : int -> unit t
(** [advance n] advances the input [n] characters, failing if the remaining
input is less than [n]. *)
val end_of_line : unit t
(** [end_of_line] accepts either a line feed [\n], or a carriage return
followed by a line feed [\r\n] and returns unit. *)
val at_end_of_input : bool t
(** [at_end_of_input] returns whether the end of the end of input has been
reached. This parser always succeeds. *)
val end_of_input : unit t
(** [end_of_input] succeeds if all the input has been consumed, and fails
otherwise. *)
val scan : 'state -> ('state -> char -> 'state option) -> (string * 'state) t
(** [scan init f] consumes until [f] returns [None]. Returns the final state
before [None] and the accumulated string *)
val scan_state : 'state -> ('state -> char -> 'state option) -> 'state t
(** [scan_state init f] is like {!scan} but only returns the final state before
[None]. Much more efficient than {!scan}. *)
val scan_string : 'state -> ('state -> char -> 'state option) -> string t
(** [scan_string init f] is like {!scan} but discards the final state and returns
the accumulated string. *)
val int8 : int -> int t
(** [int8 i] accepts one byte that matches the lower-order byte of [i] and
returns unit. *)
val any_uint8 : int t
(** [any_uint8] accepts any byte and returns it as an unsigned int8. *)
val any_int8 : int t
(** [any_int8] accepts any byte and returns it as a signed int8. *)
(** Big endian parsers *)
module BE : sig
val int16 : int -> unit t
(** [int16 i] accept two bytes that match the two lower order bytes of [i]
and returns unit. *)
val int32 : int32 -> unit t
(** [int32 i] accept four bytes that match the four bytes of [i]
and returns unit. *)
val int64 : int64 -> unit t
(** [int64 i] accept eight bytes that match the eight bytes of [i] and
returns unit. *)
val any_int16 : int t
val any_int32 : int32 t
val any_int64 : int64 t
(** [any_intN] reads [N] bits and interprets them as big endian signed integers. *)
val any_uint16 : int t
(** [any_uint16] reads [16] bits and interprets them as a big endian unsigned
integer. *)
val any_float : float t
(** [any_float] reads 32 bits and interprets them as a big endian floating
point value. *)
val any_double : float t
(** [any_double] reads 64 bits and interprets them as a big endian floating
point value. *)
end
(** Little endian parsers *)
module LE : sig
val int16 : int -> unit t
(** [int16 i] accept two bytes that match the two lower order bytes of [i]
and returns unit. *)
val int32 : int32 -> unit t
(** [int32 i] accept four bytes that match the four bytes of [i]
and returns unit. *)
val int64 : int64 -> unit t
(** [int32 i] accept eight bytes that match the eight bytes of [i] and
returns unit. *)
val any_int16 : int t
val any_int32 : int32 t
val any_int64 : int64 t
(** [any_intN] reads [N] bits and interprets them as little endian signed
integers. *)
val any_uint16 : int t
(** [uint16] reads [16] bits and interprets them as a little endian unsigned
integer. *)
val any_float : float t
(** [any_float] reads 32 bits and interprets them as a little endian floating
point value. *)
val any_double : float t
(** [any_double] reads 64 bits and interprets them as a little endian floating
point value. *)
end
(** {2 Combinators} *)
val option : 'a -> 'a t -> 'a t
(** [option v p] runs [p], returning the result of [p] if it succeeds and [v]
if it fails. *)
val both : 'a t -> 'b t -> ('a * 'b) t
(** [both p q] runs [p] followed by [q] and returns both results in a tuple *)
val list : 'a t list -> 'a list t
(** [list ps] runs each [p] in [ps] in sequence, returning a list of results of
each [p]. *)
val count : int -> 'a t -> 'a list t
(** [count n p] runs [p] [n] times, returning a list of the results. *)
val many : 'a t -> 'a list t
(** [many p] runs [p] {i zero} or more times and returns a list of results from
the runs of [p]. *)
val many1 : 'a t -> 'a list t
(** [many1 p] runs [p] {i one} or more times and returns a list of results from
the runs of [p]. *)
val many_till : 'a t -> _ t -> 'a list t
(** [many_till p e] runs parser [p] {i zero} or more times until action [e]
succeeds and returns the list of result from the runs of [p]. *)
val sep_by : _ t -> 'a t -> 'a list t
(** [sep_by s p] runs [p] {i zero} or more times, interspersing runs of [s] in between. *)
val sep_by1 : _ t -> 'a t -> 'a list t
(** [sep_by1 s p] runs [p] {i one} or more times, interspersing runs of [s] in between. *)
val skip_many : _ t -> unit t
(** [skip_many p] runs [p] {i zero} or more times, discarding the results. *)
val skip_many1 : _ t -> unit t
(** [skip_many1 p] runs [p] {i one} or more times, discarding the results. *)
val fix : ('a t -> 'a t) -> 'a t
(** [fix f] computes the fixpoint of [f] and runs the resultant parser. The
argument that [f] receives is the result of [fix f], which [f] must use,
paradoxically, to define [fix f].
[fix] is useful when constructing parsers for inductively-defined types
such as sequences, trees, etc. Consider for example the implementation of
the {!many} combinator defined in this library:
{[let many p =
fix (fun m ->
(cons <$> p <*> m) <|> return [])]}
[many p] is a parser that will run [p] zero or more times, accumulating the
result of every run into a list, returning the result. It's defined by
passing [fix] a function. This function assumes its argument [m] is a
parser that behaves exactly like [many p]. You can see this in the
expression comprising the left hand side of the alternative operator
[<|>]. This expression runs the parser [p] followed by the parser [m], and
after which the result of [p] is cons'd onto the list that [m] produces.
The right-hand side of the alternative operator provides a base case for
the combinator: if [p] fails and the parse cannot proceed, return an empty
list.
Another way to illustrate the uses of [fix] is to construct a JSON parser.
Assuming that parsers exist for the basic types such as [false], [true],
[null], strings, and numbers, the question then becomes how to define a
parser for objects and arrays? Both contain values that are themselves JSON
values, so it seems as though it's impossible to write a parser that will
accept JSON objects and arrays before writing a parser for JSON values as a
whole.
This is the exact situation that [fix] was made for. By defining the
parsers for arrays and objects within the function that you pass to [fix],
you will gain access to a parser that you can use to parse JSON values, the
very parser you are defining!
{[let json =
fix (fun json ->
let arr = char '[' *> sep_by (char ',') json <* char ']' in
let obj = char '{' *> ... json ... <* char '}' in
choice [str; num; arr json, ...])]} *)
(** [fix_lazy] is like [fix], but after the function reaches [max_steps]
deep, it wraps up the remaining computation and yields
back to the root of the parsing loop where it continues from there.
This is an effective way to break up the stack trace into more managable
chunks, which is important for Js_of_ocaml due to the lack of tailrec
optimizations for CPS-style tail calls. When compiling for Js_of_ocaml,
[fix] itself is defined as [fix_lazy ~max_steps:20]. *)
val fix_lazy : max_steps:int -> ('a t -> 'a t) -> 'a t
(** {2 Alternatives} *)
val (<|>) : 'a t -> 'a t -> 'a t
(** [p <|> q] runs [p] and returns the result if succeeds. If [p] fails, then
the input will be reset and [q] will run instead. *)
val choice : ?failure_msg:string -> 'a t list -> 'a t
(** [choice ?failure_msg ts] runs each parser in [ts] in order until one
succeeds and returns that result. In the case that none of the parser
succeeds, then the parser will fail with the message [failure_msg], if
provided, or a much less informative message otherwise. *)
val (<?>) : 'a t -> string -> 'a t
(** [p <?> name] associates [name] with the parser [p], which will be reported
in the case of failure. *)
val commit : unit t
(** [commit] prevents backtracking beyond the current position of the input,
allowing the manager of the input buffer to reuse the preceding bytes for
other purposes.
The {!module:Unbuffered} parsing interface will report directly to the
caller the number of bytes committed to the when returning a
{!Unbuffered.state.Partial} state, allowing the caller to reuse those bytes
for any purpose. The {!module:Buffered} will keep track of the region of
committed bytes in its internal buffer and reuse that region to store
additional input when necessary. *)
(** {2 Monadic/Applicative interface} *)
val return : 'a -> 'a t
(** [return v] creates a parser that will always succeed and return [v] *)
val fail : string -> _ t
(** [fail msg] creates a parser that will always fail with the message [msg] *)
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
(** [p >>= f] creates a parser that will run [p], pass its result to [f], run
the parser that [f] produces, and return its result. *)
val bind : 'a t -> f:('a -> 'b t) -> 'b t
(** [bind] is a prefix version of [>>=] *)
val (>>|) : 'a t -> ('a -> 'b) -> 'b t
(** [p >>| f] creates a parser that will run [p], and if it succeeds with
result [v], will return [f v] *)
val (<*>) : ('a -> 'b) t -> 'a t -> 'b t
(** [f <*> p] is equivalent to [f >>= fun f -> p >>| f]. *)
val (<$>) : ('a -> 'b) -> 'a t -> 'b t
(** [f <$> p] is equivalent to [p >>| f] *)
val ( *>) : _ t -> 'a t -> 'a t
(** [p *> q] runs [p], discards its result and then runs [q], and returns its
result. *)
val (<* ) : 'a t -> _ t -> 'a t
(** [p <* q] runs [p], then runs [q], discards its result, and returns the
result of [p]. *)
val lift : ('a -> 'b) -> 'a t -> 'b t
val lift2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
val lift3 : ('a -> 'b -> 'c -> 'd) -> 'a t -> 'b t -> 'c t -> 'd t
val lift4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a t -> 'b t -> 'c t -> 'd t -> 'e t
(** The [liftn] family of functions promote functions to the parser monad.
For any of these functions, the following equivalence holds:
{[liftn f p1 ... pn = f <$> p1 <*> ... <*> pn]}
These functions are more efficient than using the applicative interface
directly, mostly in terms of memory allocation but also in terms of speed.
Prefer them over the applicative interface, even when the arity of the
function to be lifted exceeds the maximum [n] for which there is an
implementation for [liftn]. In other words, if [f] has an arity of [5] but
only [lift4] is provided, do the following:
{[lift4 f m1 m2 m3 m4 <*> m5]}
Even with the partial application, it will be more efficient than the
applicative implementation. *)
val map : 'a t -> f:('a -> 'b) -> 'b t
val map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t
val map3 : 'a t -> 'b t -> 'c t -> f:('a -> 'b -> 'c -> 'd) -> 'd t
val map4 : 'a t -> 'b t -> 'c t -> 'd t -> f:('a -> 'b -> 'c -> 'd -> 'e) -> 'e t
(** The [mapn] family of functions are just like [liftn], with a slightly
different interface. *)
(** The [Let_syntax] module is intended to be used with the [ppx_let]
pre-processor, and just contains copies of functions described elsewhere. *)
module Let_syntax : sig
val return : 'a -> 'a t
val ( >>| ) : 'a t -> ('a -> 'b) -> 'b t
val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
module Let_syntax : sig
val return : 'a -> 'a t
val map : 'a t -> f:('a -> 'b) -> 'b t
val bind : 'a t -> f:('a -> 'b t) -> 'b t
val both : 'a t -> 'b t -> ('a * 'b) t
val map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t
val map3 : 'a t -> 'b t -> 'c t -> f:('a -> 'b -> 'c -> 'd) -> 'd t
val map4 : 'a t -> 'b t -> 'c t -> 'd t -> f:('a -> 'b -> 'c -> 'd -> 'e) -> 'e t
end
end
val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
val ( and+ ) : 'a t -> 'b t -> ('a * 'b) t
(** Unsafe Operations on Angstrom's Internal Buffer
These functions are considered {b unsafe} as they expose the input buffer
to client code without any protections against modification, or leaking
references. They are exposed to support performance-sensitive parsers that
want to avoid allocation at all costs. Client code should take care to
write the input buffer callback functions such that they:
{ul
{- do not modify the input buffer {i outside} of the range
[\[off, off + len)];}
{- do not modify the input buffer {i inside} of the range
[\[off, off + len)] if the parser might backtrack; and}
{- do not return any direct or indirect references to the input buffer.}}
If the input buffer callback functions do not do any of these things, then
the client may consider their use safe. *)
module Unsafe : sig
val take : int -> (bigstring -> off:int -> len:int -> 'a) -> 'a t
(** [take n f] accepts exactly [n] characters of input into the parser's
internal buffer then calls [f buffer ~off ~len]. [buffer] is the
parser's internal buffer. [off] is the offset from the start of [buffer]
containing the requested content. [len] is the length of the requested
content. [len] is guaranteed to be equal to [n]. *)
val take_while : (char -> bool) -> (bigstring -> off:int -> len:int -> 'a) -> 'a t
(** [take_while check f] accepts input into the parser's interal buffer as
long as [check] returns [true] then calls [f buffer ~off ~len]. [buffer]
is the parser's internal buffer. [off] is the offset from the start of
[buffer] containing the requested content. [len] is the length of the
content matched by [check].
This parser does not fail. If [check] returns [false] on the first
character, [len] will be [0]. *)
val take_while1 : (char -> bool) -> (bigstring -> off:int -> len:int -> 'a) -> 'a t
(** [take_while1 check f] accepts input into the parser's interal buffer as
long as [check] returns [true] then calls [f buffer ~off ~len]. [buffer]
is the parser's internal buffer. [off] is the offset from the start of
[buffer] containing the requested content. [len] is the length of the
content matched by [check].
This parser requires that [f] return [true] for at least one character of
input, and will fail otherwise. *)
val take_till : (char -> bool) -> (bigstring -> off:int -> len:int -> 'a) -> 'a t
(** [take_till check f] accepts input into the parser's interal buffer as
long as [check] returns [false] then calls [f buffer ~off ~len]. [buffer]
is the parser's internal buffer. [off] is the offset from the start of
[buffer] containing the requested content. [len] is the length of the
content matched by [check].
This parser does not fail. If [check] returns [true] on the first
character, [len] will be [0]. *)
val peek : int -> (bigstring -> off:int -> len:int -> 'a) -> 'a t
(** [peek n ~f] accepts exactly [n] characters and calls [f buffer ~off ~len]
with [len = n]. If there is not enough input, it will fail.
This parser does not advance the input. Use it for lookahead. *)
end
(** {2 Running} *)
module Consume : sig
type t =
| Prefix
| All
end
val parse_bigstring : consume:Consume.t -> 'a t -> bigstring -> ('a, string) result
(** [parse_bigstring ~consume t bs] runs [t] on [bs]. The parser will receive
an [`Eof] after all of [bs] has been consumed. Passing {!Prefix} in the
[consume] argument allows the parse to successfully complete without
reaching eof. To require the parser to reach eof, pass {!All} in the
[consume] argument.
For use-cases requiring that the parser be fed input incrementally, see the
{!module:Buffered} and {!module:Unbuffered} modules below. *)
val parse_string : consume:Consume.t -> 'a t -> string -> ('a, string) result
(** [parse_string ~consume t bs] runs [t] on [bs]. The parser will receive an
[`Eof] after all of [bs] has been consumed. Passing {!Prefix} in the
[consume] argument allows the parse to successfully complete without
reaching eof. To require the parser to reach eof, pass {!All} in the
[consume] argument.
For use-cases requiring that the parser be fed input incrementally, see the
{!module:Buffered} and {!module:Unbuffered} modules below. *)
(** Buffered parsing interface.
Parsers run through this module perform internal buffering of input. The
parser state will keep track of unconsumed input and attempt to minimize
memory allocation and copying. The {!Buffered.state.Partial} parser state
will accept newly-read, incremental input and copy it into the internal
buffer. Users can feed parser states using the {!feed} function. As a
result, the interface is much easier to use than the one exposed by the
{!Unbuffered} module.
On success or failure, any unconsumed input will be returned to the user
for additional processing. The buffer that the unconsumed input is returned
in can also be reused. *)
module Buffered : sig
type unconsumed =
{ buf : bigstring
; off : int
; len : int }
type input =
[ `Bigstring of bigstring
| `String of string ]
type 'a state =
| Partial of ([ input | `Eof ] -> 'a state) (** The parser requires more input. *)
| Done of unconsumed * 'a (** The parser succeeded. *)
| Fail of unconsumed * string list * string (** The parser failed. *)
val parse : ?initial_buffer_size:int -> 'a t -> 'a state
(** [parse ?initial_buffer_size t] runs [t] and awaits input if needed.
[parse] will allocate a buffer of size [initial_buffer_size] (defaulting
to 4k bytes) to do input buffering and automatically grows the buffer as
needed. *)
val feed : 'a state -> [ input | `Eof ] -> 'a state
(** [feed state input] supplies the parser state with more input. If [state] is
[Partial], then parsing will continue where it left off. Otherwise, the
parser is in a [Fail] or [Done] state, in which case the [input] will be
copied into the state's buffer for later use by the caller. *)
val state_to_option : 'a state -> 'a option
(** [state_to_option state] returns [Some v] if the parser is in the
[Done (bs, v)] state and [None] otherwise. This function has no effect on
the current state of the parser. *)
val state_to_result : 'a state -> ('a, string) result
(** [state_to_result state] returns [Ok v] if the parser is in the [Done (bs, v)]
state and [Error msg] if it is in the [Fail] or [Partial] state.
This function has no effect on the current state of the parser. *)
val state_to_unconsumed : _ state -> unconsumed option
(** [state_to_unconsumed state] returns [Some bs] if [state = Done(bs, _)] or
[state = Fail(bs, _, _)] and [None] otherwise. *)
end
(** Unbuffered parsing interface.
Use this module for total control over memory allocation and copying.
Parsers run through this module perform no internal buffering. Instead, the
user is responsible for managing a buffer containing the entirety of the
input that has yet to be consumed by the parser. The
{!Unbuffered.state.Partial} parser state reports to the user how much input
the parser consumed during its last run, via the
{!Unbuffered.partial.committed} field. This area of input must be discarded
before parsing can resume. Once additional input has been collected, the
unconsumed input as well as new input must be passed to the parser state
via the {!Unbuffered.partial.continue} function, together with an
indication of whether there is {!Unbuffered.more} input to come.
The logic that must be implemented in order to make proper use of this
module is intricate and tied to your OS environment. It's advisable to use
the {!Buffered} module when initially developing and testing your parsers.
For production use-cases, consider the Async and Lwt support that this
library includes before attempting to use this module directly. *)
module Unbuffered : sig
type more =
| Complete
| Incomplete
type 'a state =
| Partial of 'a partial (** The parser requires more input. *)
| Done of int * 'a (** The parser succeeded, consuming specified bytes. *)
| Fail of int * string list * string (** The parser failed, consuming specified bytes. *)
and 'a partial =
{ committed : int
(** The number of bytes committed during the last input feeding.
Callers must drop this number of bytes from the beginning of the
input on subsequent calls. See {!commit} for additional details. *)
; continue : bigstring -> off:int -> len:int -> more -> 'a state
(** A continuation of a parse that requires additional input. The input
should include all uncommitted input (as reported by previous partial
states) in addition to any new input that has become available, as
well as an indication of whether there is {!more} input to come. *)
}
val parse : 'a t -> 'a state
(** [parse t] runs [t] and await input if needed. *)
val state_to_option : 'a state -> 'a option
(** [state_to_option state] returns [Some v] if the parser is in the
[Done (bs, v)] state and [None] otherwise. This function has no effect on the
current state of the parser. *)
val state_to_result : 'a state -> ('a, string) result
(** [state_to_result state] returns [Ok v] if the parser is in the
[Done (bs, v)] state and [Error msg] if it is in the [Fail] or [Partial]
state.
This function has no effect on the current state of the parser. *)
end
(** {2 Expert Parsers}
For people that know what they're doing. If you want to use them, read the
code. No further documentation will be provided. *)
val pos : int t
val available : int t

88
unikernel/duniverse/angstrom/lib/buffering.ml Normal file
View file

@ -0,0 +1,88 @@
type t =
{ mutable buf : Bigstringaf.t
; mutable off : int
; mutable len : int }
let of_bigstring ~off ~len buf =
assert (off >= 0);
assert (Bigstringaf.length buf >= len - off);
{ buf; off; len }
let create len =
of_bigstring ~off:0 ~len:0 (Bigstringaf.create len)
let writable_space t =
Bigstringaf.length t.buf - t.len
let trailing_space t =
Bigstringaf.length t.buf - (t.off + t.len)
let compress t =
Bigstringaf.unsafe_blit t.buf ~src_off:t.off t.buf ~dst_off:0 ~len:t.len;
t.off <- 0
let grow t to_copy =
let old_len = Bigstringaf.length t.buf in
let new_len = ref old_len in
let space = writable_space t in
while space + !new_len - old_len < to_copy do
new_len := (3 * !new_len) / 2
done;
let new_buf = Bigstringaf.create !new_len in
Bigstringaf.unsafe_blit t.buf ~src_off:t.off new_buf ~dst_off:0 ~len:t.len;
t.buf <- new_buf;
t.off <- 0
let ensure t to_copy =
if trailing_space t < to_copy then
if writable_space t >= to_copy
then compress t
else grow t to_copy
let write_pos t =
t.off + t.len
let feed_string t ~off ~len str =
assert (off >= 0);
assert (String.length str >= len - off);
ensure t len;
Bigstringaf.unsafe_blit_from_string str ~src_off:off t.buf ~dst_off:(write_pos t) ~len;
t.len <- t.len + len
let feed_bigstring t ~off ~len b =
assert (off >= 0);
assert (Bigstringaf.length b >= len - off);
ensure t len;
Bigstringaf.unsafe_blit b ~src_off:off t.buf ~dst_off:(write_pos t) ~len;
t.len <- t.len + len
let feed_input t = function
| `String s -> feed_string t ~off:0 ~len:(String .length s) s
| `Bigstring b -> feed_bigstring t ~off:0 ~len:(Bigstringaf.length b) b
let shift t n =
assert (t.len >= n);
t.off <- t.off + n;
t.len <- t.len - n
let for_reading { buf; off; len } =
Bigstringaf.sub ~off ~len buf
module Unconsumed = struct
type t =
{ buf : Bigstringaf.t
; off : int
; len : int }
end
let unconsumed ?(shift=0) { buf; off; len } =
assert (len >= shift);
{ Unconsumed.buf; off = off + shift; len = len - shift }
let of_unconsumed { Unconsumed.buf; off; len } =
{ buf; off; len }
type unconsumed = Unconsumed.t =
{ buf : Bigstringaf.t
; off : int
; len : int }

20
unikernel/duniverse/angstrom/lib/buffering.mli Normal file
View file

@ -0,0 +1,20 @@
type t
val create : int -> t
val of_bigstring : off:int -> len:int -> Bigstringaf.t -> t
val feed_string : t -> off:int -> len:int -> string -> unit
val feed_bigstring : t -> off:int -> len:int -> Bigstringaf.t -> unit
val feed_input : t -> [ `String of string | `Bigstring of Bigstringaf.t ] -> unit
val shift : t -> int -> unit
val for_reading : t -> Bigstringaf.t
type unconsumed =
{ buf : Bigstringaf.t
; off : int
; len : int }
val unconsumed : ?shift:int -> t -> unconsumed
val of_unconsumed : unconsumed -> t

6
unikernel/duniverse/angstrom/lib/dune Normal file
View file

@ -0,0 +1,6 @@
(library
(name angstrom)
(public_name angstrom)
(libraries bigstringaf)
(flags :standard -safe-string)
(preprocess future_syntax))

22
unikernel/duniverse/angstrom/lib/exported_state.ml Normal file
View file

@ -0,0 +1,22 @@
type 'a state =
| Partial of 'a partial
| Done of int * 'a
| Fail of int * string list * string
and 'a partial =
{ committed : int
; continue : Bigstringaf.t -> off:int -> len:int -> More.t -> 'a state }
let state_to_option x = match x with
| Done(_, v) -> Some v
| Fail _ -> None
| Partial _ -> None
let fail_to_string marks err =
String.concat " > " marks ^ ": " ^ err
let state_to_result x = match x with
| Done(_, v) -> Ok v
| Partial _ -> Error "incomplete input"
| Fail(_, marks, err) -> Error (fail_to_string marks err)

111
unikernel/duniverse/angstrom/lib/input.ml Normal file
View file

@ -0,0 +1,111 @@
(*----------------------------------------------------------------------------
Copyright (c) 2017 Inhabited Type LLC.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. 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.
3. Neither the name of the author nor the names of his contributors
may be used to endorse or promote products derived from this software
without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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 t =
{ mutable parser_committed_bytes : int
; client_committed_bytes : int
; off : int
; len : int
; buffer : Bigstringaf.t
}
let create buffer ~off ~len ~committed_bytes =
{ parser_committed_bytes = committed_bytes
; client_committed_bytes = committed_bytes
; off
; len
; buffer }
let length t = t.client_committed_bytes + t.len
let client_committed_bytes t = t.client_committed_bytes
let parser_committed_bytes t = t.parser_committed_bytes
let committed_bytes_discrepancy t = t.parser_committed_bytes - t.client_committed_bytes
let bytes_for_client_to_commit t = committed_bytes_discrepancy t
let parser_uncommitted_bytes t = t.len - bytes_for_client_to_commit t
let invariant t =
assert (parser_committed_bytes t + parser_uncommitted_bytes t = length t);
assert (parser_committed_bytes t - client_committed_bytes t = bytes_for_client_to_commit t);
;;
let offset_in_buffer t pos =
t.off + pos - t.client_committed_bytes
let apply t pos len ~f =
let off = offset_in_buffer t pos in
f t.buffer ~off ~len
let unsafe_get_char t pos =
let off = offset_in_buffer t pos in
Bigstringaf.unsafe_get t.buffer off
let unsafe_get_int16_le t pos =
let off = offset_in_buffer t pos in
Bigstringaf.unsafe_get_int16_le t.buffer off
let unsafe_get_int32_le t pos =
let off = offset_in_buffer t pos in
Bigstringaf.unsafe_get_int32_le t.buffer off
let unsafe_get_int64_le t pos =
let off = offset_in_buffer t pos in
Bigstringaf.unsafe_get_int64_le t.buffer off
let unsafe_get_int16_be t pos =
let off = offset_in_buffer t pos in
Bigstringaf.unsafe_get_int16_be t.buffer off
let unsafe_get_int32_be t pos =
let off = offset_in_buffer t pos in
Bigstringaf.unsafe_get_int32_be t.buffer off
let unsafe_get_int64_be t pos =
let off = offset_in_buffer t pos in
Bigstringaf.unsafe_get_int64_be t.buffer off
let count_while t pos ~f =
let buffer = t.buffer in
let off = offset_in_buffer t pos in
let i = ref off in
let limit = t.off + t.len in
while !i < limit && f (Bigstringaf.unsafe_get buffer !i) do
incr i
done;
!i - off
;;
let commit t pos =
t.parser_committed_bytes <- pos
;;

88
unikernel/duniverse/angstrom/lib/input.mli Normal file
View file

@ -0,0 +1,88 @@
(*----------------------------------------------------------------------------
Copyright (c) 2017 Inhabited Type LLC.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. 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.
3. Neither the name of the author nor the names of his contributors
may be used to endorse or promote products derived from this software
without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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.
----------------------------------------------------------------------------*)
(** An [Input.t] represents a series of buffers, of which we only have access
to one, and a pointer to how much has been committed, which is in the
current buffer.
parser commit point
V
+--------------------------------------+
|#################'####################| current buffer
+-----------------+--------------------------------------+-----
|#################|#################'####################|###.. input
+-----------------+--------------------------------------+-----
' ' ' '
|--------------------------------------------------------|
' ' length ' '
|-----------------| ' '
client_committed_bytes ' '
' ' |--------------------|
' ' parser_uncommitted_bytes
' |-----------------|
' bytes_for_client_to_commit
|-----------------------------------|
parser_committed_bytes
Note that a buffer is a subsequence of a [Bigstringaf.t], defined by [off] and [len].
All [int] position arguments should be relative to the beginning of the
whole input. *)
type t
val create : Bigstringaf.t -> off:int -> len:int -> committed_bytes:int -> t
val length : t -> int
val client_committed_bytes : t -> int
val parser_committed_bytes : t -> int
val parser_uncommitted_bytes : t -> int
val bytes_for_client_to_commit : t -> int
val unsafe_get_char : t -> int -> char
val unsafe_get_int16_le : t -> int -> int
val unsafe_get_int32_le : t -> int -> int32
val unsafe_get_int64_le : t -> int -> int64
val unsafe_get_int16_be : t -> int -> int
val unsafe_get_int32_be : t -> int -> int32
val unsafe_get_int64_be : t -> int -> int64
val count_while : t -> int -> f:(char -> bool) -> int
val apply : t -> int -> int -> f:(Bigstringaf.t -> off:int -> len:int -> 'a) -> 'a
val commit : t -> int -> unit
val invariant : t -> unit

3
unikernel/duniverse/angstrom/lib/more.ml Normal file
View file

@ -0,0 +1,3 @@
type t =
| Complete
| Incomplete

3
unikernel/duniverse/angstrom/lib/more.mli Normal file
View file

@ -0,0 +1,3 @@
type t =
| Complete
| Incomplete

173
unikernel/duniverse/angstrom/lib/parser.ml Normal file
View file

@ -0,0 +1,173 @@
module State = struct
type 'a t =
| Partial of 'a partial
| Lazy of 'a t Lazy.t
| Done of int * 'a
| Fail of int * string list * string
and 'a partial =
{ committed : int
; continue : Bigstringaf.t -> off:int -> len:int -> More.t -> 'a t }
end
type 'a with_state = Input.t -> int -> More.t -> 'a
type 'a failure = (string list -> string -> 'a State.t) with_state
type ('a, 'r) success = ('a -> 'r State.t) with_state
type 'a t =
{ run : 'r. ('r failure -> ('a, 'r) success -> 'r State.t) with_state }
let fail_k input pos _ marks msg =
State.Fail(pos - Input.client_committed_bytes input, marks, msg)
let succeed_k input pos _ v =
State.Done(pos - Input.client_committed_bytes input, v)
let rec to_exported_state = function
| State.Partial {committed;continue} ->
Exported_state.Partial
{ committed
; continue =
fun bs ~off ~len more ->
to_exported_state (continue bs ~off ~len more)}
| State.Done (i,x) -> Exported_state.Done (i,x)
| State.Fail (i, sl, s) -> Exported_state.Fail (i, sl, s)
| State.Lazy x -> to_exported_state (Lazy.force x)
let parse p =
let input = Input.create Bigstringaf.empty ~committed_bytes:0 ~off:0 ~len:0 in
to_exported_state (p.run input 0 Incomplete fail_k succeed_k)
let parse_bigstring p input =
let input = Input.create input ~committed_bytes:0 ~off:0 ~len:(Bigstringaf.length input) in
Exported_state.state_to_result (to_exported_state (p.run input 0 Complete fail_k succeed_k))
module Monad = struct
let return v =
{ run = fun input pos more _fail succ ->
succ input pos more v
}
let fail msg =
{ run = fun input pos more fail _succ ->
fail input pos more [] msg
}
let (>>=) p f =
{ run = fun input pos more fail succ ->
let succ' input' pos' more' v = (f v).run input' pos' more' fail succ in
p.run input pos more fail succ'
}
let (>>|) p f =
{ run = fun input pos more fail succ ->
let succ' input' pos' more' v = succ input' pos' more' (f v) in
p.run input pos more fail succ'
}
let (<$>) f m =
m >>| f
let (<*>) f m =
(* f >>= fun f -> m >>| f *)
{ run = fun input pos more fail succ ->
let succ0 input0 pos0 more0 f =
let succ1 input1 pos1 more1 m = succ input1 pos1 more1 (f m) in
m.run input0 pos0 more0 fail succ1
in
f.run input pos more fail succ0 }
let lift f m =
f <$> m
let lift2 f m1 m2 =
{ run = fun input pos more fail succ ->
let succ1 input1 pos1 more1 m1 =
let succ2 input2 pos2 more2 m2 = succ input2 pos2 more2 (f m1 m2) in
m2.run input1 pos1 more1 fail succ2
in
m1.run input pos more fail succ1 }
let lift3 f m1 m2 m3 =
{ run = fun input pos more fail succ ->
let succ1 input1 pos1 more1 m1 =
let succ2 input2 pos2 more2 m2 =
let succ3 input3 pos3 more3 m3 =
succ input3 pos3 more3 (f m1 m2 m3) in
m3.run input2 pos2 more2 fail succ3 in
m2.run input1 pos1 more1 fail succ2
in
m1.run input pos more fail succ1 }
let lift4 f m1 m2 m3 m4 =
{ run = fun input pos more fail succ ->
let succ1 input1 pos1 more1 m1 =
let succ2 input2 pos2 more2 m2 =
let succ3 input3 pos3 more3 m3 =
let succ4 input4 pos4 more4 m4 =
succ input4 pos4 more4 (f m1 m2 m3 m4) in
m4.run input3 pos3 more3 fail succ4 in
m3.run input2 pos2 more2 fail succ3 in
m2.run input1 pos1 more1 fail succ2
in
m1.run input pos more fail succ1 }
let ( *>) a b =
(* a >>= fun _ -> b *)
{ run = fun input pos more fail succ ->
let succ' input' pos' more' _ = b.run input' pos' more' fail succ in
a.run input pos more fail succ'
}
let (<* ) a b =
(* a >>= fun x -> b >>| fun _ -> x *)
{ run = fun input pos more fail succ ->
let succ0 input0 pos0 more0 x =
let succ1 input1 pos1 more1 _ = succ input1 pos1 more1 x in
b.run input0 pos0 more0 fail succ1
in
a.run input pos more fail succ0 }
end
module Choice = struct
let (<?>) p mark =
{ run = fun input pos more fail succ ->
let fail' input' pos' more' marks msg =
fail input' pos' more' (mark::marks) msg in
p.run input pos more fail' succ
}
let (<|>) p q =
{ run = fun input pos more fail succ ->
let fail' input' pos' more' marks msg =
(* The only two constructors that introduce new failure continuations are
* [<?>] and [<|>]. If the initial input position is less than the length
* of the committed input, then calling the failure continuation will
* have the effect of unwinding all choices and collecting marks along
* the way. *)
if pos < Input.parser_committed_bytes input' then
fail input' pos' more marks msg
else
q.run input' pos more' fail succ in
p.run input pos more fail' succ
}
end
module Monad_use_for_debugging = struct
let return = Monad.return
let fail = Monad.fail
let (>>=) = Monad.(>>=)
let (>>|) m f = m >>= fun x -> return (f x)
let (<$>) f m = m >>| f
let (<*>) f m = f >>= fun f -> m >>| f
let lift = (>>|)
let lift2 f m1 m2 = f <$> m1 <*> m2
let lift3 f m1 m2 m3 = f <$> m1 <*> m2 <*> m3
let lift4 f m1 m2 m3 m4 = f <$> m1 <*> m2 <*> m3 <*> m4
let ( *>) a b = a >>= fun _ -> b
let (<* ) a b = a >>= fun x -> b >>| fun _ -> x
end