unikernel/duniverse/ocaml-re/lib/ast.ml

@@ -0,0 +1,444 @@
+open Import
+
+type ('a, _) ast =
+  | Alternative : 'a list -> ('a, [> `Uncased ]) ast
+  | No_case : 'a -> ('a, [> `Cased ]) ast
+  | Case : 'a -> ('a, [> `Cased ]) ast
+
+let dyn_of_ast f =
+  let open Dyn in
+  function
+  | Alternative xs -> variant "Alternative" (List.map xs ~f)
+  | No_case a -> variant "No_case" [ f a ]
+  | Case a -> variant "Case" [ f a ]
+;;
+
+let empty_alternative : ('a, 'b) ast = Alternative []
+
+let equal_ast (type a) eq (x : (a, [ `Uncased ]) ast) (y : (a, [ `Uncased ]) ast) =
+  match x, y with
+  | Alternative a, Alternative b -> List.equal ~eq a b
+;;
+
+let pp_ast (type a b) f fmt (ast : (a, b) ast) =
+  let open Fmt in
+  let var s re = sexp fmt s f re in
+  match ast with
+  | Alternative alt -> sexp fmt "Alternative" (list f) alt
+  | Case c -> var "Case" c
+  | No_case c -> var "No_case" c
+;;
+
+type cset =
+  | Cset of Cset.t
+  | Intersection of cset list
+  | Complement of cset list
+  | Difference of cset * cset
+  | Cast of (cset, [ `Cased | `Uncased ]) ast
+
+let rec dyn_of_cset =
+  let open Dyn in
+  function
+  | Cset cset -> variant "Cset" [ Cset.to_dyn cset ]
+  | Intersection xs -> variant "Intersection" (List.map xs ~f:dyn_of_cset)
+  | Complement xs -> variant "Complement" (List.map xs ~f:dyn_of_cset)
+  | Difference (x, y) -> variant "Difference" [ dyn_of_cset x; dyn_of_cset y ]
+  | Cast c -> variant "Cast" [ dyn_of_ast dyn_of_cset c ]
+;;
+
+type ('a, 'case) gen =
+  | Set of 'a
+  | Ast of (('a, 'case) gen, 'case) ast
+  | Sequence of ('a, 'case) gen list
+  | Repeat of ('a, 'case) gen * int * int option
+  | Beg_of_line
+  | End_of_line
+  | Beg_of_word
+  | End_of_word
+  | Not_bound
+  | Beg_of_str
+  | End_of_str
+  | Last_end_of_line
+  | Start
+  | Stop
+  | Group of string option * ('a, 'case) gen
+  | No_group of ('a, 'case) gen
+  | Nest of ('a, 'case) gen
+  | Pmark of Pmark.t * ('a, 'case) gen
+  | Sem of Automata.Sem.t * ('a, 'case) gen
+  | Sem_greedy of Automata.Rep_kind.t * ('a, 'case) gen
+
+let rec dyn_of_gen f =
+  let open Dyn in
+  function
+  | Set a -> variant "Set" [ f a ]
+  | Ast ast -> variant "Ast" [ dyn_of_ast (dyn_of_gen f) ast ]
+  | Sequence xs -> variant "Sequence" (List.map xs ~f:(dyn_of_gen f))
+  | Repeat (gen, min, max) ->
+    let base =
+      match max with
+      | None -> []
+      | Some x -> [ int x ]
+    in
+    variant "Repeat" (dyn_of_gen f gen :: int min :: base)
+  | Beg_of_line -> enum "Beg_of_line"
+  | End_of_line -> enum "End_of_line"
+  | Beg_of_word -> enum "Beg_of_word"
+  | End_of_word -> enum "End_of_word"
+  | Not_bound -> enum "Not_bound"
+  | Beg_of_str -> enum "Beg_of_str"
+  | End_of_str -> enum "End_of_str"
+  | Last_end_of_line -> enum "Last_end_of_line"
+  | Start -> enum "Start"
+  | Stop -> enum "Stop"
+  | Group (name, t) ->
+    let args =
+      let args = [ dyn_of_gen f t ] in
+      match name with
+      | None -> args
+      | Some name -> string name :: args
+    in
+    variant "Group" args
+  | No_group x -> variant "No_group" [ dyn_of_gen f x ]
+  | Nest x -> variant "Nest" [ dyn_of_gen f x ]
+  | Pmark (pmark, t) -> variant "Pmark" [ Pmark.to_dyn pmark; dyn_of_gen f t ]
+  | Sem (sem, t) -> variant "Sem" [ Automata.Sem.to_dyn sem; dyn_of_gen f t ]
+  | Sem_greedy (rep, t) ->
+    variant "Sem_greedy" [ Automata.Rep_kind.to_dyn rep; dyn_of_gen f t ]
+;;
+
+let rec pp_gen pp_cset fmt t =
+  let open Format in
+  let open Fmt in
+  let pp = pp_gen pp_cset in
+  let var s re = sexp fmt s pp re in
+  let seq s rel = sexp fmt s (list pp) rel in
+  match t with
+  | Set cset -> pp_cset fmt cset
+  | Sequence sq -> seq "Sequence" sq
+  | Repeat (re, start, stop) ->
+    let pp' fmt () = fprintf fmt "%a@ %d%a" pp re start optint stop in
+    sexp fmt "Repeat" pp' ()
+  | Beg_of_line -> str fmt "Beg_of_line"
+  | End_of_line -> str fmt "End_of_line"
+  | Beg_of_word -> str fmt "Beg_of_word"
+  | End_of_word -> str fmt "End_of_word"
+  | Not_bound -> str fmt "Not_bound"
+  | Beg_of_str -> str fmt "Beg_of_str"
+  | End_of_str -> str fmt "End_of_str"
+  | Last_end_of_line -> str fmt "Last_end_of_line"
+  | Start -> str fmt "Start"
+  | Stop -> str fmt "Stop"
+  | Group (None, c) -> var "Group" c
+  | Group (Some n, c) -> sexp fmt "Named_group" (pair str pp) (n, c)
+  | Nest c -> var "Nest" c
+  | Pmark (m, r) -> sexp fmt "Pmark" (pair Pmark.pp pp) (m, r)
+  | Ast a -> pp_ast pp fmt a
+  | Sem (sem, a) -> sexp fmt "Sem" (pair Automata.Sem.pp pp) (sem, a)
+  | Sem_greedy (k, re) -> sexp fmt "Sem_greedy" (pair Automata.Rep_kind.pp pp) (k, re)
+  | No_group c -> var "No_group" c
+;;
+
+let rec pp_cset fmt cset =
+  let open Fmt in
+  let seq s rel = sexp fmt s (list pp_cset) rel in
+  match cset with
+  | Cast s -> pp_ast pp_cset fmt s
+  | Cset s -> sexp fmt "Set" Cset.pp s
+  | Intersection c -> seq "Intersection" c
+  | Complement c -> seq "Complement" c
+  | Difference (a, b) -> sexp fmt "Difference" (pair pp_cset pp_cset) (a, b)
+;;
+
+let rec equal cset x1 x2 =
+  match x1, x2 with
+  | Set s1, Set s2 -> cset s1 s2
+  | Sequence l1, Sequence l2 -> List.equal ~eq:(equal cset) l1 l2
+  | Repeat (x1', i1, j1), Repeat (x2', i2, j2) ->
+    Int.equal i1 i2 && Option.equal Int.equal j1 j2 && equal cset x1' x2'
+  | Beg_of_line, Beg_of_line
+  | End_of_line, End_of_line
+  | Beg_of_word, Beg_of_word
+  | End_of_word, End_of_word
+  | Not_bound, Not_bound
+  | Beg_of_str, Beg_of_str
+  | End_of_str, End_of_str
+  | Last_end_of_line, Last_end_of_line
+  | Start, Start
+  | Stop, Stop -> true
+  | Group _, Group _ ->
+    (* Do not merge groups! *)
+    false
+  | Pmark (m1, r1), Pmark (m2, r2) -> Pmark.equal m1 m2 && equal cset r1 r2
+  | Nest x, Nest y -> equal cset x y
+  | Ast x, Ast y -> equal_ast (equal cset) x y
+  | Sem (sem, a), Sem (sem', a') -> Poly.equal sem sem' && equal cset a a'
+  | Sem_greedy (rep, a), Sem_greedy (rep', a') -> Poly.equal rep rep' && equal cset a a'
+  | _ -> false
+;;
+
+type t = (cset, [ `Cased | `Uncased ]) gen
+type no_case = (Cset.t, [ `Uncased ]) gen
+
+let to_dyn = dyn_of_gen dyn_of_cset
+let pp = pp_gen pp_cset
+let cset cset = Set (Cset cset)
+
+let rec handle_case_cset ign_case = function
+  | Cset s -> if ign_case then Cset.case_insens s else s
+  | Cast (Alternative l) -> List.map ~f:(handle_case_cset ign_case) l |> Cset.union_all
+  | Complement l ->
+    List.map ~f:(handle_case_cset ign_case) l |> Cset.union_all |> Cset.diff Cset.cany
+  | Difference (r, r') ->
+    Cset.inter
+      (handle_case_cset ign_case r)
+      (Cset.diff Cset.cany (handle_case_cset ign_case r'))
+  | Intersection l -> List.map ~f:(handle_case_cset ign_case) l |> Cset.intersect_all
+  | Cast (No_case a) -> handle_case_cset true a
+  | Cast (Case a) -> handle_case_cset false a
+;;
+
+let rec handle_case ign_case : t -> (Cset.t, [ `Uncased ]) gen = function
+  | Set s -> Set (handle_case_cset ign_case s)
+  | Sequence l -> Sequence (List.map ~f:(handle_case ign_case) l)
+  | Ast (Alternative l) ->
+    let l = List.map ~f:(handle_case ign_case) l in
+    Ast (Alternative l)
+  | Repeat (r, i, j) -> Repeat (handle_case ign_case r, i, j)
+  | ( Beg_of_line
+    | End_of_line
+    | Beg_of_word
+    | End_of_word
+    | Not_bound
+    | Beg_of_str
+    | End_of_str
+    | Last_end_of_line
+    | Start
+    | Stop ) as r -> r
+  | Sem (k, r) -> Sem (k, handle_case ign_case r)
+  | Sem_greedy (k, r) -> Sem_greedy (k, handle_case ign_case r)
+  | Group (n, r) -> Group (n, handle_case ign_case r)
+  | No_group r -> No_group (handle_case ign_case r)
+  | Nest r -> Nest (handle_case ign_case r)
+  | Ast (Case r) -> handle_case false r
+  | Ast (No_case r) -> handle_case true r
+  | Pmark (i, r) -> Pmark (i, handle_case ign_case r)
+;;
+
+module Export = struct
+  type nonrec t = t
+
+  let pp = pp
+
+  let seq = function
+    | [ r ] -> r
+    | l -> Sequence l
+  ;;
+
+  let char =
+    let f = Dense_map.make ~size:256 ~f:(fun i -> cset (Cset.csingle (Char.chr i))) in
+    fun c -> f (Char.code c)
+  ;;
+
+  let any = cset Cset.cany
+
+  let str s : t =
+    let l = ref [] in
+    for i = String.length s - 1 downto 0 do
+      l := char s.[i] :: !l
+    done;
+    seq !l
+  ;;
+
+  let as_set_elems elems =
+    match
+      List.map elems ~f:(function
+        | Set e -> e
+        | _ -> raise_notrace Exit)
+    with
+    | exception Exit -> None
+    | e -> Some e
+  ;;
+
+  let empty : t = Ast empty_alternative
+
+  let alt (elems : t list) : t =
+    match elems with
+    | [] -> empty
+    | [ x ] -> x
+    | _ ->
+      (match as_set_elems elems with
+       | None -> Ast (Alternative elems)
+       | Some elems -> Set (Cast (Alternative elems)))
+  ;;
+
+  let epsilon = seq []
+
+  let repn r i j =
+    if i < 0 then invalid_arg "Re.repn";
+    match j, i with
+    | Some j, _ when j < i -> invalid_arg "Re.repn"
+    | Some 0, 0 -> epsilon
+    | Some 1, 1 -> r
+    | _ -> Repeat (r, i, j)
+  ;;
+
+  let rep r = repn r 0 None
+  let rep1 r = repn r 1 None
+  let opt r = repn r 0 (Some 1)
+  let bol = Beg_of_line
+  let eol = End_of_line
+  let bow = Beg_of_word
+  let eow = End_of_word
+  let word r = seq [ bow; r; eow ]
+  let not_boundary = Not_bound
+  let bos = Beg_of_str
+  let eos = End_of_str
+  let whole_string r = seq [ bos; r; eos ]
+  let leol = Last_end_of_line
+  let start = Start
+  let stop = Stop
+
+  type 'b f = { f : 'a. 'a -> ('a, 'b) ast }
+
+  let make_set f t =
+    match t with
+    | Set x -> Set (Cast (f.f x))
+    | _ -> Ast (f.f t)
+  ;;
+
+  let preserve_set f t =
+    match t with
+    | Set _ -> t
+    | _ -> f t
+  ;;
+
+  let longest = preserve_set (fun t -> Sem (`Longest, t))
+  let shortest = preserve_set (fun t -> Sem (`Shortest, t))
+  let first = preserve_set (fun t -> Sem (`First, t))
+  let greedy = preserve_set (fun t -> Sem_greedy (`Greedy, t))
+  let non_greedy = preserve_set (fun t -> Sem_greedy (`Non_greedy, t))
+  let group ?name r = Group (name, r)
+  let no_group = preserve_set (fun t -> No_group t)
+  let nest r = Nest r
+  let set str = cset (Cset.set str)
+
+  let mark r =
+    let i = Pmark.gen () in
+    i, Pmark (i, r)
+  ;;
+
+  (**** Character sets ****)
+  let as_set_or_error name elems =
+    match as_set_elems elems with
+    | None -> invalid_arg name
+    | Some s -> s
+  ;;
+
+  let inter elems = Set (Intersection (as_set_or_error "Re.inter" elems))
+  let compl elems = Set (Complement (as_set_or_error "Re.compl" elems))
+
+  let diff r r' =
+    match r, r' with
+    | Set r, Set r' -> Set (Difference (r, r'))
+    | _, _ -> invalid_arg "Re.diff"
+  ;;
+
+  let case =
+    let f = { f = (fun r -> Case r) } in
+    fun t -> make_set f t
+  ;;
+
+  let no_case =
+    let f = { f = (fun r -> No_case r) } in
+    fun t -> make_set f t
+  ;;
+
+  let witness t =
+    let rec witness (t : no_case) =
+      match t with
+      | Set c -> String.make 1 (Cset.to_char (Cset.pick c))
+      | Sequence xs -> String.concat "" (List.map ~f:witness xs)
+      | Ast (Alternative (x :: _)) -> witness x
+      | Ast (Alternative []) -> assert false
+      | Repeat (r, from, _to) ->
+        let w = witness r in
+        let b = Buffer.create (String.length w * from) in
+        for _i = 1 to from do
+          Buffer.add_string b w
+        done;
+        Buffer.contents b
+      | No_group r -> witness r
+      | Sem_greedy (_, r) | Sem (_, r) | Nest r | Pmark (_, r) | Group (_, r) -> witness r
+      | Beg_of_line
+      | End_of_line
+      | Beg_of_word
+      | End_of_word
+      | Not_bound
+      | Beg_of_str
+      | Last_end_of_line
+      | Start
+      | Stop
+      | End_of_str -> ""
+    in
+    witness (handle_case false t)
+  ;;
+end
+
+open Export
+
+let rec merge_sequences = function
+  | [] -> []
+  | Ast (Alternative l') :: r -> merge_sequences (l' @ r)
+  | Sequence (x :: y) :: r ->
+    (match merge_sequences r with
+     | Sequence (x' :: y') :: r' when equal Cset.equal x x' ->
+       Sequence [ x; Ast (Alternative [ seq y; seq y' ]) ] :: r'
+     | r' -> Sequence (x :: y) :: r')
+  | x :: r -> x :: merge_sequences r
+;;
+
+(*XXX Use a better algorithm allowing non-contiguous regions? *)
+
+let colorize color_map (regexp : no_case) =
+  let lnl = ref false in
+  let rec colorize regexp =
+    match (regexp : no_case) with
+    | Set s -> Color_map.split color_map s
+    | Sequence l -> List.iter ~f:colorize l
+    | Ast (Alternative l) -> List.iter ~f:colorize l
+    | Repeat (r, _, _) -> colorize r
+    | Beg_of_line | End_of_line -> Color_map.split color_map Cset.nl
+    | Beg_of_word | End_of_word | Not_bound -> Color_map.split color_map Cset.cword
+    | Beg_of_str | End_of_str | Start | Stop -> ()
+    | Last_end_of_line -> lnl := true
+    | No_group r | Group (_, r) | Nest r | Pmark (_, r) -> colorize r
+    | Sem (_, r) | Sem_greedy (_, r) -> colorize r
+  in
+  colorize regexp;
+  !lnl
+;;
+
+let rec anchored_ast : (t, _) ast -> bool = function
+  | Alternative als -> List.for_all ~f:anchored als
+  | No_case r | Case r -> anchored r
+
+and anchored : t -> bool = function
+  | Ast a -> anchored_ast a
+  | Sequence l -> List.exists ~f:anchored l
+  | Repeat (r, i, _) -> i > 0 && anchored r
+  | No_group r | Sem (_, r) | Sem_greedy (_, r) | Group (_, r) | Nest r | Pmark (_, r) ->
+    anchored r
+  | Set _
+  | Beg_of_line
+  | End_of_line
+  | Beg_of_word
+  | End_of_word
+  | Not_bound
+  | End_of_str
+  | Last_end_of_line
+  | Stop -> false
+  | Beg_of_str | Start -> true
+;;
+
+let t_of_cset x = Set x