forked from MLstate/opalang
-
Notifications
You must be signed in to change notification settings - Fork 1
/
gen_trx.ml
92 lines (83 loc) · 3.49 KB
/
gen_trx.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
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
module B = Base
let (<|) f a = f a
let (|>) a f = f a
let ( @* ) g f x = g(f(x))
module O = Ocaml
module Cons = O.Cons
module G = Grammar
module T = Tools
module L = B.List
module A = B.Array
module S = B.String
module C = B.Char
let rec pr = function
G.Prevent s -> "(Prevent "^s^")"
| G.Literal (s,mod_opt) -> "(Literal ("^s^(match mod_opt with Some _mod -> ","^_mod | None -> "")^"))"
| G.SubPattern (name,c,sub) -> "(SubPattern ("^name^","^c^","^(S.concat " " (L.map pr sub))^"))"
| G.Ident name -> "(Ident "^name^")"
| _ -> "blurb"
let rewrite_ident prevents = function
| G.Literal (s,mod_opt) :: _ -> Printf.sprintf " ((%s !%s%s .)+ $_)" prevents s (Option.default "" mod_opt)
| l when prevents <> "" or l = [] -> Printf.sprintf " ((%s .)+ $_) " prevents
| _ -> raise T.LiteralRequired
let rewrite_pattern var_lst lst =
let rec aux lst = function
| [] -> ""
| G.Prevent s :: tail -> aux (s :: lst) tail
| G.Literal (s,mod_opt) :: tail when lst = [] -> s ^ (Option.default "" mod_opt) ^ " " ^ (aux [] tail)
| G.SubPattern (name, c, sub) :: tail when lst = [] ->
let lst = (L.rev_map snd @* snd) <| L.fold_left T.bruijnise (0, []) sub in
let tuplized = S.concat ", " <| L.map (T.prefix "__") lst in
Printf.sprintf " (%s {{ %s }})%s %s" (aux [] sub) tuplized c (aux [] tail)
| G.Ident name :: tail ->
let t = try T.type_to_str <| L.assoc name var_lst with Not_found -> name in
let acc = L.fold_left (fun acc s -> acc ^ " !" ^ s) "" lst in
let str =
if t = "string" then rewrite_ident acc tail
else acc ^ " " ^ t
in Printf.sprintf " %s %s" str <| aux [] tail
| _ -> assert false
in aux [] lst
let rewrite_defines = function
| G.Define (G.Constr (name, lst), pat) -> (
try
let var_lst = L.map T.tuple_of_var lst in
let rule = rewrite_pattern var_lst pat in
if L.is_empty var_lst then Printf.sprintf "%s {{ %s }}" rule name
else
let tuplized =
let lst = snd <| L.fold_left T.bruijnise (0, []) pat in
let lst = L.map (fun x ->
try L.assoc (fst x) lst with
| Not_found ->
failwith (Printf.sprintf
"Fatal Error : %s is not bound when defining %s"
(fst x) name)) var_lst
in S.concat ", " <| L.map (T.prefix "__") lst
in Printf.sprintf "%s {{ %s (%s) }}" rule name tuplized
with T.LiteralRequired -> failwith <|
Printf.sprintf "Error when trying to generate the teerex rule for the message: %s" name
)
| _ -> assert false
let do_it types lst =
let rules = S.concat "\n /" <| L.map rewrite_defines lst in
O.Verbatim "%%memoization=none\n\ninclude default.trx\ntypes:{{\n"
:: types
@ [ O.Verbatim "\n}}\nmsg <- "
; O.Verbatim rules
; O.Verbatim "\n+msgs : {msg list} <- msg*"
; O.Verbatim "\n+msg1 : {msg} <- msg"
]