Source file `visitor.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
(****************************************************************************)
(*                                                                          *)
(* This file is part of MOPSA, a Modular Open Platform for Static Analysis. *)
(*                                                                          *)
(* Copyright (C) 2017-2019 The MOPSA Project.                               *)
(*                                                                          *)
(* This program is free software: you can redistribute it and/or modify     *)
(* it under the terms of the GNU Lesser General Public License as published *)
(* by the Free Software Foundation, either version 3 of the License, or     *)
(* (at your option) any later version.                                      *)
(*                                                                          *)
(* This program 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 Lesser General Public License for more details.                      *)
(*                                                                          *)
(* You should have received a copy of the GNU Lesser General Public License *)
(* along with this program.  If not, see <http://www.gnu.org/licenses/>.    *)
(*                                                                          *)
(****************************************************************************)

(** Visitor of configuration files *)


open Mopsa_utils
open Yojson.Basic
open Yojson.Basic.Util


type 'a visitor = {
  leaf : string option -> string -> 'a;
  switch : string option -> Yojson.Basic.t list -> 'a;
  compose : string option -> Yojson.Basic.t list -> 'a;
  union : string option -> Yojson.Basic.t list -> 'a;
  apply : string option -> Yojson.Basic.t -> Yojson.Basic.t -> 'a;
  nonrel : string option -> Yojson.Basic.t -> 'a;
  product : string option -> Yojson.Basic.t list -> string list -> 'a;
}

let get_semantic obj = List.assoc_opt "semantic" obj |> OptionExt.lift to_string

let visit_leaf visitor s = visitor.leaf None s

let visit_domain visitor obj =
  let d = List.assoc "domain" obj |> to_string in
  visitor.leaf (get_semantic obj) d

let visit_seq visitor obj =
  let l = List.assoc "seq" obj |> to_list in
  visitor.switch (get_semantic obj) l

let visit_switch visitor obj =
  let l = List.assoc "switch" obj |> to_list in
  visitor.switch (get_semantic obj) l

let visit_compose visitor obj =
  let l = List.assoc "compose" obj |> to_list in
  visitor.compose (get_semantic obj) l

let visit_apply visitor obj =
  let f = List.assoc "apply" obj in
  let d = List.assoc "on" obj in
  visitor.apply (get_semantic obj) f d

let visit_nonrel visitor obj =
  let v = List.assoc "nonrel" obj in
  visitor.nonrel (get_semantic obj) v

let visit_union visitor obj =
  let l = List.assoc "union" obj |> to_list in
  visitor.union (get_semantic obj) l

let visit_product visitor obj =
  let l = List.assoc "product" obj |> to_list in
  let r = try List.assoc "reductions" obj |> to_list |> List.map to_string with Not_found -> [] in
  visitor.product (get_semantic obj) l r

let rec visit visitor json =
  match json with
  | `String s -> visit_leaf visitor s
  | `Assoc obj when List.mem_assoc "domain" obj -> visit_domain visitor obj
  | `Assoc obj when List.mem_assoc "switch" obj -> visit_switch visitor obj
  | `Assoc obj when List.mem_assoc "compose" obj -> visit_compose visitor obj
  | `Assoc obj when List.mem_assoc "apply" obj -> visit_apply visitor obj
  | `Assoc obj when List.mem_assoc "nonrel" obj -> visit_nonrel visitor obj
  | `Assoc obj when List.mem_assoc "product" obj -> visit_product visitor obj
  | `Assoc obj when List.mem_assoc "union" obj -> visit_union visitor obj
  | _ -> Exceptions.panic "parsing error: configuration not supported@  %a"
           (pretty_print ~std:true) json