106 lines
2.3 KiB
OCaml
106 lines
2.3 KiB
OCaml
|
(* camlp4r *)
|
||
|
|
(* Id *)
|
||
|
|
(* Copyright 2001 INRIA *)
|
||
|
|
|
||
|
|
(* Extensible Functions *)
|
||
|
|
|
||
|
|
type ('a, 'b) t = ('a, 'b) matching list
|
||
|
|
and ('a, 'b) matching = { patt : patt; has_when : bool; expr : ('a, 'b) expr }
|
||
|
|
and patt =
|
||
|
|
Eapp of patt list
|
||
|
|
| Eacc of patt list
|
||
|
|
| Econ of string
|
||
|
|
| Estr of string
|
||
|
|
| Eint of string
|
||
|
|
| Etup of patt list
|
||
|
|
| Evar of unit
|
||
|
|
and ('a, 'b) expr = 'a -> 'b option
|
||
|
|
;;
|
||
|
|
|
||
|
|
exception Failure;;
|
||
|
|
|
||
|
|
let empty = [];;
|
||
|
|
|
||
|
|
(*** Apply ***)
|
||
|
|
|
||
|
|
let rec apply_matchings a =
|
||
|
|
function
|
||
|
|
m :: ml ->
|
||
|
|
begin match m.expr a with
|
||
|
|
None -> apply_matchings a ml
|
||
|
|
| x -> x
|
||
|
|
end
|
||
|
|
| [] -> None
|
||
|
|
;;
|
||
|
|
|
||
|
|
let apply ef a =
|
||
|
|
match apply_matchings a ef with
|
||
|
|
Some x -> x
|
||
|
|
| None -> raise Failure
|
||
|
|
;;
|
||
|
|
|
||
|
|
(*** Trace ***)
|
||
|
|
|
||
|
|
let rec list_iter_sep f s =
|
||
|
|
function
|
||
|
|
[] -> ()
|
||
|
|
| [x] -> f x
|
||
|
|
| x :: l -> f x; s (); list_iter_sep f s l
|
||
|
|
;;
|
||
|
|
|
||
|
|
let rec print_patt =
|
||
|
|
function
|
||
|
|
Eapp pl -> list_iter_sep print_patt2 (fun () -> print_string " ") pl
|
||
|
|
| p -> print_patt2 p
|
||
|
|
and print_patt2 =
|
||
|
|
function
|
||
|
|
Eacc pl -> list_iter_sep print_patt1 (fun () -> print_string ".") pl
|
||
|
|
| p -> print_patt1 p
|
||
|
|
and print_patt1 =
|
||
|
|
function
|
||
|
|
Econ s -> print_string s
|
||
|
|
| Estr s -> print_string "\""; print_string s; print_string "\""
|
||
|
|
| Eint s -> print_string s
|
||
|
|
| Evar () -> print_string "_"
|
||
|
|
| Etup pl ->
|
||
|
|
print_string "(";
|
||
|
|
list_iter_sep print_patt (fun () -> print_string ", ") pl;
|
||
|
|
print_string ")"
|
||
|
|
| Eapp _ | Eacc _ as p -> print_string "("; print_patt p; print_string ")"
|
||
|
|
;;
|
||
|
|
|
||
|
|
let print ef =
|
||
|
|
List.iter
|
||
|
|
(fun m ->
|
||
|
|
print_patt m.patt;
|
||
|
|
if m.has_when then print_string " when ...";
|
||
|
|
print_newline ())
|
||
|
|
ef
|
||
|
|
;;
|
||
|
|
|
||
|
|
(*** Extension ***)
|
||
|
|
|
||
|
|
let insert_matching matchings (patt, has_when, expr) =
|
||
|
|
let m1 = {patt = patt; has_when = has_when; expr = expr} in
|
||
|
|
let rec loop =
|
||
|
|
function
|
||
|
|
m :: ml as gml ->
|
||
|
|
if m1.has_when && not m.has_when then m1 :: gml
|
||
|
|
else if not m1.has_when && m.has_when then m :: loop ml
|
||
|
|
else
|
||
|
|
let c = compare m1.patt m.patt in
|
||
|
|
if c < 0 then m1 :: gml
|
||
|
|
else if c > 0 then m :: loop ml
|
||
|
|
else if m.has_when then m1 :: gml
|
||
|
|
else m1 :: ml
|
||
|
|
| [] -> [m1]
|
||
|
|
in
|
||
|
|
loop matchings
|
||
|
|
;;
|
||
|
|
|
||
|
|
(* available extension function *)
|
||
|
|
|
||
|
|
let extend ef matchings_def =
|
||
|
|
List.fold_left insert_matching ef matchings_def
|
||
|
|
;;
|