Source file parser_config.ml
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
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
open Elpi_util
open Elpi_lexer_config.Lexer_config
exception ParseError of Util.Loc.t * string
module type ParseFile = sig
val parse_file : ?cwd:string -> string -> (Digest.t * Ast.Program.decl list) list
end
let rec substrings i len_s s =
if len_s - i >= 0 then
String.sub s 0 i :: substrings (i+1) len_s s
else []
let substrings s = List.rev @@ substrings 1 (String.length s) s
let find_sub tab s =
let rec aux = function
| [] -> raise Not_found
| x :: xs ->
try Hashtbl.find tab x
with Not_found -> aux xs
in
aux (substrings s)
let precedence_of, umax_precedence, appl_precedence, inf_precedence =
let tab = Hashtbl.create 21 in
List.iteri (fun level { tokens; fixity } ->
List.iter (function
| Extensible { start; fixed; _ } ->
Hashtbl.add tab start (fixity,level);
List.iter (fun tok -> Hashtbl.add tab tok (fixity,level)) fixed
| Fixed { the_token; _ } ->
Hashtbl.add tab the_token (fixity,level)
) tokens;
) mixfix_symbols;
let umax_precedence = List.length mixfix_symbols in
let appl_precedence = umax_precedence + 1 in
let inf_precedence = appl_precedence + 1 in
(fun s ->
try
let fixity, prec = find_sub tab s in
Some fixity, prec
with Not_found ->
None, appl_precedence),
umax_precedence, appl_precedence, inf_precedence
let comma_precedence = 1 + (snd @@ precedence_of ",")
let min_precedence = -1
let lam_precedence = -1
let umin_precedence = 0
let pp_fixed fmt l =
l |> List.iter (fun x -> Format.fprintf fmt "%s @ " x)
let pp_non_enclosed fmt = function
| false -> ()
| true -> Format.fprintf fmt " [*]"
let pp_tok_list fmt l =
List.iter (function
| Extensible { start; fixed; non_enclosed; _ } -> Format.fprintf fmt "%a%s..%a @ " pp_fixed fixed start pp_non_enclosed non_enclosed
| Fixed { the_token; _ } -> Format.fprintf fmt "%s @ " the_token)
l
let legacy_parser_compat_error =
let open Format in
let b = Buffer.create 80 in
let fmt = formatter_of_buffer b in
fprintf fmt "@[<v>";
fprintf fmt "%s@;" "Mixfix directives are not supported by this parser.";
fprintf fmt "%s@;" "";
fprintf fmt "%s@;" "The parser is based on token families.";
fprintf fmt "%s@;" "A family is identified by some starting characters, for example";
fprintf fmt "%s@;" "a token '+-->' belongs to the family of '+'. There is no need";
fprintf fmt "%s@;" "to declare it.";
fprintf fmt "%s@;" "";
fprintf fmt "%s@;" "All the tokens of a family are parsed with the same precedence and";
fprintf fmt "%s@;" "associativity, for example 'x +--> y *--> z' is parsed as";
fprintf fmt "%s@;" "'x +--> (y *--> z)' since the family of '*' has higher precedence";
fprintf fmt "%s@;" "than the family of '+'.";
fprintf fmt "%s@;" "";
fprintf fmt "%s@;" "Here the table of tokens and token families.";
fprintf fmt "%s@;" "Token families are represented by the start symbols followed by '..'.";
fprintf fmt "%s@;" "Tokens of families marked with [*] cannot end with the starting symbol,";
fprintf fmt "%s@;" "eg `foo` is not an infix, while `foo is.";
fprintf fmt "%s@;" "The listing is ordered by increasing precedence.";
fprintf fmt "%s@;" "";
pp_open_tbox fmt ();
pp_set_tab fmt ();
fprintf fmt "%-25s " "fixity";
pp_set_tab fmt ();
fprintf fmt "| %s" "tokens / token families";
pp_print_tab fmt ();
let col1 = "--------------------------" in
fprintf fmt "%s" col1;
pp_print_tab fmt ();
fprintf fmt "+ -----------------------------------";
pp_print_tab fmt ();
List.iter (fun { tokens; fixity; _ } ->
fprintf fmt "%a" pp_fixity fixity;
pp_print_tab fmt ();
let s =
let b = Buffer.create 80 in
let fmt = formatter_of_buffer b in
pp_set_margin fmt 40;
fprintf fmt "| ";
pp_open_hovbox fmt 1;
fprintf fmt "%a" pp_tok_list tokens;
pp_close_box fmt ();
pp_print_flush fmt ();
let s = Buffer.contents b in
let pad = "\n" ^ String.(make (length col1) ' ') in
Re.Str.(global_replace (regexp_string "\n") pad s)
in
fprintf fmt "%s" s;
pp_print_tab fmt ();
) mixfix_symbols;
pp_close_tbox fmt ();
fprintf fmt "%s@;" "";
fprintf fmt "%s@;" "If the token is a valid mixfix, and you want the file to stay compatible";
fprintf fmt "%s@;" "with Teyjus, you can ask Elpi to skip the directive. Eg:";
fprintf fmt "%s@;" "";
fprintf fmt "%s@;" "% elpi:skip 2 // skips the next two lines";
fprintf fmt "%s@;" "infixr ==> 120.";
fprintf fmt "%s@;" "infixr || 120.";
fprintf fmt "%s@;" "";
fprintf fmt "%s@;" "As a debugging facility one can ask Elpi to print the AST in order to";
fprintf fmt "%s@;" "verify how the text was parsed. Eg:";
fprintf fmt "%s@;" "";
fprintf fmt "%s@;" "echo 'MyFormula = a || b ==> c && d' | elpi -parse-term";
fprintf fmt "@]";
pp_print_flush fmt ();
Buffer.contents b
;;
let error_mixfix loc =
raise (ParseError(loc,legacy_parser_compat_error))