Skip to content
This repository
tag: v1394
Fetching contributors…

Cannot retrieve contributors at this time

file 92 lines (83 sloc) 3.574 kb
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"
       ]
Something went wrong with that request. Please try again.