445 lines
13 KiB
OCaml
445 lines
13 KiB
OCaml
|
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
|