Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 93 lines (83 sloc) 3.574 kB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 module B = Base
19 let (<|) f a = f a
20 let (|>) a f = f a
21 let ( @* ) g f x = g(f(x))
22 module O = Ocaml
23 module Cons = O.Cons
24 module G = Grammar
25 module T = Tools
26 module L = B.List
27 module A = B.Array
28 module S = B.String
29 module C = B.Char
30
31 let rec pr = function
32 G.Prevent s -> "(Prevent "^s^")"
33 | G.Literal (s,mod_opt) -> "(Literal ("^s^(match mod_opt with Some _mod -> ","^_mod | None -> "")^"))"
34 | G.SubPattern (name,c,sub) -> "(SubPattern ("^name^","^c^","^(S.concat " " (L.map pr sub))^"))"
35 | G.Ident name -> "(Ident "^name^")"
36 | _ -> "blurb"
37
38 let rewrite_ident prevents = function
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
39 | G.Literal (s,mod_opt) :: _ -> Printf.sprintf " ((%s !%s%s .)+ $_)" prevents s (Option.default "" mod_opt)
40 | l when prevents <> "" or l = [] -> Printf.sprintf " ((%s .)+ $_) " prevents
fccc685 Initial open-source release
MLstate authored
41 | _ -> raise T.LiteralRequired
42
43 let rewrite_pattern var_lst lst =
44 let rec aux lst = function
45 | [] -> ""
46 | G.Prevent s :: tail -> aux (s :: lst) tail
47 | G.Literal (s,mod_opt) :: tail when lst = [] -> s ^ (Option.default "" mod_opt) ^ " " ^ (aux [] tail)
48 | G.SubPattern (name, c, sub) :: tail when lst = [] ->
49 let lst = (L.rev_map snd @* snd) <| L.fold_left T.bruijnise (0, []) sub in
50 let tuplized = S.concat ", " <| L.map (T.prefix "__") lst in
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
51 Printf.sprintf " (%s {{ %s }})%s %s" (aux [] sub) tuplized c (aux [] tail)
fccc685 Initial open-source release
MLstate authored
52 | G.Ident name :: tail ->
53 let t = try T.type_to_str <| L.assoc name var_lst with Not_found -> name in
54 let acc = L.fold_left (fun acc s -> acc ^ " !" ^ s) "" lst in
55 let str =
56 if t = "string" then rewrite_ident acc tail
57 else acc ^ " " ^ t
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
58 in Printf.sprintf " %s %s" str <| aux [] tail
fccc685 Initial open-source release
MLstate authored
59 | _ -> assert false
60 in aux [] lst
61
62 let rewrite_defines = function
63 | G.Define (G.Constr (name, lst), pat) -> (
64 try
65 let var_lst = L.map T.tuple_of_var lst in
66 let rule = rewrite_pattern var_lst pat in
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
67 if L.is_empty var_lst then Printf.sprintf "%s {{ %s }}" rule name
fccc685 Initial open-source release
MLstate authored
68 else
69 let tuplized =
70 let lst = snd <| L.fold_left T.bruijnise (0, []) pat in
71 let lst = L.map (fun x ->
72 try L.assoc (fst x) lst with
73 | Not_found ->
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
74 failwith (Printf.sprintf
fccc685 Initial open-source release
MLstate authored
75 "Fatal Error : %s is not bound when defining %s"
76 (fst x) name)) var_lst
77 in S.concat ", " <| L.map (T.prefix "__") lst
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
78 in Printf.sprintf "%s {{ %s (%s) }}" rule name tuplized
fccc685 Initial open-source release
MLstate authored
79 with T.LiteralRequired -> failwith <|
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
80 Printf.sprintf "Error when trying to generate the teerex rule for the message: %s" name
fccc685 Initial open-source release
MLstate authored
81 )
82 | _ -> assert false
83
84 let do_it types lst =
85 let rules = S.concat "\n /" <| L.map rewrite_defines lst in
86 O.Verbatim "%%memoization=none\n\ninclude default.trx\ntypes:{{\n"
87 :: types
88 @ [ O.Verbatim "\n}}\nmsg <- "
89 ; O.Verbatim rules
90 ; O.Verbatim "\n+msgs : {msg list} <- msg*"
91 ; O.Verbatim "\n+msg1 : {msg} <- msg"
92 ]
Something went wrong with that request. Please try again.