package mopsa

  1. Overview
  2. Docs
package mopsa
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file parser.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
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
(****************************************************************************)
(*                                                                          *)
(* 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/>.    *)
(*                                                                          *)
(****************************************************************************)

(** Parser of configuration files *)


open Mopsa_utils
open Yojson.Basic
open Yojson.Basic.Util
open Syntax
open Visitor
open Sig.Abstraction.Stacked
open Sig.Abstraction.Domain
open Sig.Abstraction.Simplified
open Sig.Abstraction.Simplified_functor
open Sig.Abstraction.Stateless
open Sig.Abstraction.Partitioning
open Sig.Abstraction.Value
open Sig.Abstraction.Value_functor
open Sig.Reduction.Exec
open Sig.Reduction.Eval
open Sig.Reduction.Simplified
open Sig.Reduction.Value


(** {2 Configuration file} *)
(** ********************** *)

(** Path to the current configuration *)
let opt_config = ref ""



let all_domains () =
  stacked_domain_names () @
  standard_domain_names () @
  simplified_domain_names () @
  stateless_domain_names () @
  value_abstraction_names () @
  simplified_functor_names () @
  value_functor_names () @
  partitioning_names ()

let all_reductions () =
  simplified_value_reductions () @
  eval_reductions () @
  exec_reductions () @
  simplified_reductions ()

(** {2 Domain parser} *)
(** ***************** *)

let debug fmt = Debug.debug ~channel:"framework.config.abstraction.parser" fmt

let rec parse_domain json : domain =
  json |> visit {
    leaf = (fun semantic name ->
        let d =
          try D_stacked(find_stacked_domain name)     with Not_found ->
          try D_domain(find_standard_domain name)     with Not_found ->
          try D_stateless(find_stateless_domain name) with Not_found ->
          try D_simplified(find_simplified_domain name)
          with Not_found -> Exceptions.panic "Domain '%s' not found@.Available domains: %a" name (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ") Format.pp_print_string) (all_domains ())
        in
        mk_domain d ~semantic
      );
    switch = (fun semantic jsons ->
        mk_domain (D_switch (List.map parse_domain jsons)) ~semantic
      );
    compose = (fun semantic jsons ->
        mk_domain (D_compose (List.map parse_domain jsons)) ~semantic
      );
    product = (fun semantic jsons reductions ->
        mk_domain (D_product (List.map parse_domain jsons, List.map parse_domain_reduction reductions)) ~semantic
      );
    nonrel = (fun semantic json ->
        mk_domain (D_nonrel(parse_value json)) ~semantic
      );
    apply = (fun semantic funct arg ->
        mk_domain (D_functor(parse_domain_functor funct, parse_domain arg)) ~semantic
      );
    union = (fun semantic json -> assert false);
  }

and parse_domain_reduction (name:string) : domain_reduction =
  try DR_eval(find_eval_reduction name) with Not_found ->
  try DR_exec(find_exec_reduction name) with Not_found ->
  try DR_simplified(find_simplified_reduction name)
  with Not_found -> Exceptions.panic "Domain reduction '%s' not found@.Available reductions: %a" name (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ") Format.pp_print_string) (all_reductions ())

and parse_domain_functor (json:t) : domain_functor =
  json |> visit {
    leaf = (fun semantic name ->
        try F_partitioning(find_partitioning name) with Not_found ->
        try F_simplified(find_simplified_functor name) with Not_found ->
        F_stacked(parse_domain json)
      );
    switch = (fun semantic jsons ->
        F_stacked (mk_domain (D_switch (List.map parse_domain jsons)) ~semantic)
      );
    compose = (fun semantic jsons ->
        F_stacked (mk_domain (D_compose (List.map parse_domain jsons)) ~semantic)
      );
    product = (fun semantic jsons reductions ->
        F_stacked(mk_domain (D_product (List.map parse_domain jsons, List.map parse_domain_reduction reductions)) ~semantic)
      );
    nonrel = (fun semantic json -> assert false);
    apply = (fun semantic funct arg -> assert false);
    union = (fun semantic json -> assert false);
  }


and parse_value json : value =
  json |> visit {
    leaf = (fun _ name -> try V_value (find_value_abstraction name) with Not_found -> Exceptions.panic "Value '%s' not found" name);
    union = (fun _ jsons -> V_union (List.map parse_value jsons));
    product = (fun _ jsons reductions -> V_product (List.map parse_value jsons, List.map parse_value_reduction reductions));
    apply = (fun _ funct arg -> V_functor(parse_value_functor funct, parse_value arg));

    switch = (fun _ jsons -> assert false);
    compose = (fun _ jsons -> assert false);
    nonrel = (fun _ json -> assert false);
  }

and parse_value_reduction (name:string) : value_reduction =
  try find_value_reduction name
  with Not_found -> Exceptions.panic "Value reduction '%s' not found" name

and parse_value_functor json : value_functor =
  let name = to_string json in
  try find_value_functor name
  with Not_found -> Exceptions.panic "Value functor '%s' not found" name

(** {2 Toplevel attributes} *)
(** *********************** *)

let get_language json =
  match json with
  | `Assoc(obj) when List.mem_assoc "language" obj ->
    List.assoc "language" obj |> to_string
  | _ -> Exceptions.panic "language declaration not found in configuration file"

let get_domain_json json =
  match json with
  | `Assoc(obj) when List.mem_assoc "domain" obj ->
    List.assoc "domain" obj
  | _ -> Exceptions.panic "domain declaration not found in configuration file"


(** {2 Entry points} *)
(** **************** *)

let parse file : abstraction =
  let json = Yojson.Basic.from_file file in
  let language = get_language json in
  let domain_json = get_domain_json json in
  let domain = parse_domain domain_json in
  { domain; language }

let language file : string =
  let json = Yojson.Basic.from_file file in
  get_language json

let domains file : string list =
  if file = "" then
    all_domains ()
  else
    let json = Yojson.Basic.from_file file in
    let domain = json |> member "domain" in
    let rec name_visitor = Visitor.{
        leaf = (fun _ name -> [name]);
        switch = (fun _ l -> List.map get_names l |> List.flatten);
        nonrel = (fun _ v -> get_names v);
        apply = (fun _ f d -> get_names f @ get_names d);
        compose = (fun _ l -> List.map get_names l |> List.flatten);
        product = (fun _ l r -> List.map get_names l |> List.flatten);
        union = (fun _ l -> List.map get_names l |> List.flatten);
    }
    and get_names json = Visitor.visit name_visitor json in
    get_names domain
OCaml

Innovation. Community. Security.

GitHub Discord Twitter Peertube RSS
About
Changelog Releases Industrial Users Academic Users Why OCaml
Ecosystem
Packages Community Events OCaml Planet Jobs
Resources
Install OCaml Get Started Platform Tools Language Manual Standard Library API Books Exercises Papers OCaml Playground Logo
Policies
Carbon Footprint Governance Privacy Code of Conduct