Project

General

Profile

« Previous | Next » 

Revision ca7ff3f7

Added by LĂ©lio Brun 7 months ago

reformatting

View differences:

src/tools/stateflow/json-parser/json_parser.ml
6 6
open Yojson
7 7
open Basic
8 8

  
9
module type ParseExt =
10
sig
9
module type ParseExt = sig
11 10
  val parse_condition : json -> Condition.t
12
  val parse_action    : json -> Action.t
13
  val parse_event     : json -> Basetypes.event_t
11

  
12
  val parse_action : json -> Action.t
13

  
14
  val parse_event : json -> Basetypes.event_t
14 15
end
15 16

  
16
module Parser (Ext : ParseExt) =
17
struct
17
module Parser (Ext : ParseExt) = struct
18 18
  exception JSON_parse_error of string
19 19

  
20 20
  let path_split = String.split_on_char '/'
21

  
21 22
  let path_concat = String.concat (String.make 1 '/')
22 23

  
23 24
  open Util
24 25

  
25
  let to_list json =
26
    try
27
      json |> to_list
28
    with
29
      Type_error _ -> [ json ]
26
  let to_list json = try json |> to_list with Type_error _ -> [ json ]
30 27

  
31 28
  let rec parse_prog json : prog_t =
32
    Logs.info  (fun m -> m "parse_prog %s" (json |> member "name" |> to_string));
33
    Program (
34
      json |> member "name"        |> to_string,
35
     (json |> member "states"      |> to_list |> List.map parse_state) @
36
     (json |> member "junctions"   |> to_list |> List.map parse_junction)
37
     @
38
     (json |> member "sffunctions" |> to_list |> List.map
39
        (fun res -> SFFunction (parse_prog res))),
40
      json |> member "data"        |> to_list |> List.map parse_variable
41
    )
29
    Logs.info (fun m -> m "parse_prog %s" (json |> member "name" |> to_string));
30
    Program
31
      ( json |> member "name" |> to_string,
32
        (json |> member "states" |> to_list |> List.map parse_state)
33
        @ (json |> member "junctions" |> to_list |> List.map parse_junction)
34
        @ (json |> member "sffunctions" |> to_list
35
          |> List.map (fun res -> SFFunction (parse_prog res))),
36
        json |> member "data" |> to_list |> List.map parse_variable )
37

  
42 38
  and parse_state json =
43 39
    Logs.debug (fun m -> m "parse_state");
44
    State (
45
      json |> member "path" |> parse_path,
46
      json |> parse_state_def
47
    )
40
    State (json |> member "path" |> parse_path, json |> parse_state_def)
41

  
48 42
  and parse_path json =
49 43
    Logs.debug (fun m -> m "parse_path %s" (json |> to_string));
50 44
    json |> to_string |> path_split
45

  
51 46
  and parse_state_def json =
52 47
    Logs.debug (fun m -> m "parse_state_def");
53 48
    {
54
      state_actions        = json |> member "state_actions"        |> parse_state_actions;
55
      outer_trans          = json |> member "outer_trans"          |> to_list |> List.map parse_transition;
56
      inner_trans          = json |> member "inner_trans"          |> to_list |> List.map parse_transition;
57
      internal_composition = json |> member "internal_composition" |> parse_internal_composition
49
      state_actions = json |> member "state_actions" |> parse_state_actions;
50
      outer_trans =
51
        json |> member "outer_trans" |> to_list |> List.map parse_transition;
52
      inner_trans =
53
        json |> member "inner_trans" |> to_list |> List.map parse_transition;
54
      internal_composition =
55
        json |> member "internal_composition" |> parse_internal_composition;
58 56
    }
57

  
59 58
  and parse_state_actions json =
60 59
    Logs.debug (fun m -> m "parse_state_actions");
61 60
    {
62
      entry_act  = json |> member "entry_act"  |> Ext.parse_action;
61
      entry_act = json |> member "entry_act" |> Ext.parse_action;
63 62
      during_act = json |> member "during_act" |> Ext.parse_action;
64
      exit_act   = json |> member "exit_act"   |> Ext.parse_action;
63
      exit_act = json |> member "exit_act" |> Ext.parse_action;
65 64
    }
65

  
66 66
  and parse_transition json =
67 67
    Logs.debug (fun m -> m "parse_transition");
68 68
    {
69
      event          = json |> member "event"          |> Ext.parse_event;
70
      condition      = json |> member "condition" |> Ext.parse_condition;
71
      condition_act  = json |> member "condition_act"  |> Ext.parse_action;
69
      event = json |> member "event" |> Ext.parse_event;
70
      condition = json |> member "condition" |> Ext.parse_condition;
71
      condition_act = json |> member "condition_act" |> Ext.parse_action;
72 72
      transition_act = json |> member "transition_act" |> Ext.parse_action;
73
      dest           = json |> member "dest"           |> parse_dest
73
      dest = json |> member "dest" |> parse_dest;
74 74
    }
75

  
75 76
  and parse_dest json =
76 77
    Logs.debug (fun m -> m "parse_dest");
77 78
    let dest_type = json |> member "type" |> to_string in
78
    (dest_type |>
79
	(function
80
	| "State"    -> (fun p -> DPath p)
81
	| "Junction" -> (fun j -> DJunction (path_concat j))
82
	| _ -> raise (JSON_parse_error ("Invalid destination type: " ^ dest_type))))
79
    (dest_type |> function
80
     | "State" ->
81
       fun p -> DPath p
82
     | "Junction" ->
83
       fun j -> DJunction (path_concat j)
84
     | _ ->
85
       raise (JSON_parse_error ("Invalid destination type: " ^ dest_type)))
83 86
      (json |> member "name" |> parse_path)
87

  
84 88
  and parse_internal_composition json =
85 89
    Logs.debug (fun m -> m "parse_internal_composition");
86 90
    let state_type = json |> member "type" |> to_string in
87
    (state_type |>
88
	(function
89
	| "EXCLUSIVE_OR" -> (fun tinit substates ->                      Or  (tinit, substates))
90
	| "PARALLEL_AND" -> (fun tinit substates -> assert (tinit = []); And (substates))
91
        | _ -> raise (JSON_parse_error ("Invalid state type: " ^ state_type))))
92
      (json |> member "tinit"     |> parse_tinit)
91
    (state_type |> function
92
     | "EXCLUSIVE_OR" ->
93
       fun tinit substates -> Or (tinit, substates)
94
     | "PARALLEL_AND" ->
95
       fun tinit substates ->
96
         assert (tinit = []);
97
         And substates
98
     | _ ->
99
       raise (JSON_parse_error ("Invalid state type: " ^ state_type)))
100
      (json |> member "tinit" |> parse_tinit)
93 101
      (json |> member "substates" |> to_list |> List.map to_string)
102

  
94 103
  and parse_tinit json =
95 104
    Logs.debug (fun m -> m "parse_tinit");
96 105
    json |> to_list |> List.map parse_transition
106

  
97 107
  and parse_junction json =
98 108
    Logs.debug (fun m -> m "parse_junction");
99
    Junction (
100
      json |> member "path"        |> to_string,
101
      json |> member "outer_trans" |> to_list |> List.map parse_transition
102
    )
109
    Junction
110
      ( json |> member "path" |> to_string,
111
        json |> member "outer_trans" |> to_list |> List.map parse_transition )
112

  
103 113
  and scope_of_string s =
104 114
    match s with
105
    | "Constant"  -> Constant
106
    | "Input"     -> Input
107
    | "Local"     -> Local
108
    | "Output"    -> Output
109
    | "Parameter" -> Parameter
110
    | _           -> raise (JSON_parse_error ("Invalid scope for variable: " ^ s))
115
    | "Constant" ->
116
      Constant
117
    | "Input" ->
118
      Input
119
    | "Local" ->
120
      Local
121
    | "Output" ->
122
      Output
123
    | "Parameter" ->
124
      Parameter
125
    | _ ->
126
      raise (JSON_parse_error ("Invalid scope for variable: " ^ s))
127

  
111 128
  and parse_real_value s =
112 129
    Logs.debug (fun m -> m "parse_real_value %s" s);
113 130
    let real_regexp_simp = regexp "\\(-?[0-9][0-9]*\\)\\.\\([0-9]*\\)" in
114
    let real_regexp_e    = regexp "\\(-?[0-9][0-9]*\\)\\.\\([0-9]*\\)\\(E\\|e\\)\\(\\(\\+\\|\\-\\)[0-9][0-9]*\\)" in
131
    let real_regexp_e =
132
      regexp
133
        "\\(-?[0-9][0-9]*\\)\\.\\([0-9]*\\)\\(E\\|e\\)\\(\\(\\+\\|\\-\\)[0-9][0-9]*\\)"
134
    in
115 135
    if string_match real_regexp_e s 0 then
116 136
      let l = matched_group 1 s in
117 137
      let r = matched_group 2 s in
118 138
      let e = matched_group 4 s in
119
      Const_real (Num.num_of_string (l ^ r),
120
                  String.length r + (-1 * int_of_string e),
121
                  s)
122
    else
123
    if string_match real_regexp_simp s 0 then
139
      Const_real
140
        (Num.num_of_string (l ^ r), String.length r + (-1 * int_of_string e), s)
141
    else if string_match real_regexp_simp s 0 then
124 142
      let l = matched_group 1 s in
125 143
      let r = matched_group 2 s in
126 144
      Const_real (Num.num_of_string (l ^ r), String.length r, s)
127
    else
128
      raise (JSON_parse_error ("Invalid real constant " ^ s))
145
    else raise (JSON_parse_error ("Invalid real constant " ^ s))
146

  
129 147
  and lustre_datatype_of_json json location =
130
    let datatype      = json |> member "datatype"      |> to_string in
148
    let datatype = json |> member "datatype" |> to_string in
131 149
    let initial_value = json |> member "initial_value" |> to_string in
132 150
    match datatype with
133
    | "bool" -> (Tydec_bool, mkexpr location
134
                   (Expr_const (Const_tag
135
                                  ((fun s -> match s with
136
                                     | "true"  -> tag_true
137
                                     | "false" -> tag_false
138
                                     | _       ->
139
                                       raise (JSON_parse_error ("Invalid constant for
140
     boolean: " ^ s))) initial_value))))
141
    | "int"  -> (Tydec_int, mkexpr location
142
                   (Expr_const (Const_int (int_of_string
143
                                             initial_value))))
144
    | "real" -> (Tydec_real, mkexpr location
145
                   (Expr_const (parse_real_value initial_value)))
146
    | _      -> raise (JSON_parse_error ("Invalid datatype " ^ datatype
147
                                         ^ " for variable " ^ (json |> member "name"
148
                                                               |> to_string)))
151
    | "bool" ->
152
      ( Tydec_bool,
153
        mkexpr location
154
          (Expr_const
155
             (Const_tag
156
                ((fun s ->
157
                   match s with
158
                   | "true" ->
159
                     tag_true
160
                   | "false" ->
161
                     tag_false
162
                   | _ ->
163
                     raise
164
                       (JSON_parse_error
165
                          ("Invalid constant for\n     boolean: " ^ s)))
166
                   initial_value))) )
167
    | "int" ->
168
      ( Tydec_int,
169
        mkexpr location (Expr_const (Const_int (int_of_string initial_value))) )
170
    | "real" ->
171
      Tydec_real, mkexpr location (Expr_const (parse_real_value initial_value))
172
    | _ ->
173
      raise
174
        (JSON_parse_error
175
           ("Invalid datatype " ^ datatype ^ " for variable "
176
           ^ (json |> member "name" |> to_string)))
177

  
149 178
  and parse_variable json =
150
    Logs.debug (fun m -> m "parse_variable %s" (json |> member "name" |> to_string));
151
    let location                  = Location.dummy_loc in
152
    let (datatype, initial_value) = lustre_datatype_of_json json location in
179
    Logs.debug (fun m ->
180
        m "parse_variable %s" (json |> member "name" |> to_string));
181
    let location = Location.dummy_loc in
182
    let datatype, initial_value = lustre_datatype_of_json json location in
153 183
    mkvar_decl location ~orig:true
154 184
      ( json |> member "name" |> to_string,
155
        {ty_dec_desc = datatype;  ty_dec_loc = location},
156
        {ck_dec_desc = Ckdec_any; ck_dec_loc = location},
185
        { ty_dec_desc = datatype; ty_dec_loc = location },
186
        { ck_dec_desc = Ckdec_any; ck_dec_loc = location },
157 187
        true,
158
        Some initial_value
159
      )
188
        Some initial_value )
160 189
end
161

  

Also available in: Unified diff