1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
open Core_kernel
open Vangstrom
open Types.Ast
module Make (Metasyntax : Types.Metasyntax.S) (External : Types.External.S) = struct
module Parser = Rule.Make (Metasyntax) (External)
type spec = Specification.t
[@@deriving sexp]
type op =
| And
| Or
| Not
[@@deriving sexp]
type exp =
| Exp of op * exp list
| Spec of spec
[@@deriving sexp]
type t = exp list
[@@deriving sexp]
let ignore p =
p *> return ()
let spaces = many @@ satisfy (function ' ' | '\n' | '\r' | '\t' -> true | _ -> false)
let spaces1 = many1 @@ satisfy (function ' ' | '\n' | '\r' | '\t' -> true | _ -> false)
let optional s = option () (ignore @@ string s)
let chainl1 e op =
let rec parse acc = (lift2 (fun f x -> f acc x) op e >>= parse) <|> return acc in
e >>= fun init -> parse init
let parens p = char '(' *> (p <|> return []) <* char ')'
let template_parser until =
choice
[ (lift Parser.to_atom Parser.quoted_parser)
; (lift (fun v -> Parser.to_atom (String.of_char_list v)) (Omega_parser_helper.many1_till any_char until))
]
let spec =
let match_rewrite_parser =
both
(spaces *> template_parser (spaces *> string "->"))
(option None (spaces *> string Syntax.arrow *> spaces *> template_parser (spaces1 *> string "where" *> spaces1) >>| fun v -> Some v))
in
match_rewrite_parser >>= fun (match_template_atom, rewrite_template_atom) ->
(option None (spaces1 *> Parser.parse >>| fun x -> Some x)) >>= fun rule ->
let match_template = Sexplib.Sexp.to_string_hum (sexp_of_atom match_template_atom) in
let rewrite_template =
match rewrite_template_atom with
| Some rewrite_template_atom -> Some (Sexplib.Sexp.to_string_hum (sexp_of_atom rewrite_template_atom))
| None -> None
in
return [(Spec (Specification.{ match_template; rule; rewrite_template }))]
let unop syntax exp_parser =
choice (List.map ~f:string syntax) *> spaces *> exp_parser >>| fun exp -> [Exp (Not, exp)]
let binop syntax op =
spaces *> choice (List.map ~f:string syntax) *> spaces *> return (fun left right -> [Exp (op, left@right)])
let exp_parser =
fix (fun exp ->
let exp_parser = fix (fun exp' -> parens exp <|> unop ["NOT"; "not"] exp' <|> spec) in
let and_parser = chainl1 exp_parser @@ binop ["AND"; "and"] And in
let seq_parser = chainl1 and_parser @@ binop ["OR"; "or"] Or in
sep_by1 (spaces *> string Syntax.separator <* spaces) seq_parser >>| List.concat)
let parser =
spaces *> optional Syntax.separator *>
exp_parser <* optional Syntax.separator <* spaces <* end_of_input
let parse script =
parse_string ~consume:All parser script
let to_string exp =
Sexplib.Sexp.to_string_hum (sexp_of_t exp)
end