Project

General

Profile

Download (6.23 KB) Statistics
| Branch: | Tag: | Revision:
1
open Basetypes
2
open Corelang
3
open Datatype
4
open LustreSpec
5
open Str
6
open Yojson
7
open Basic
8

    
9
module type ParseExt = sig
10
  val parse_condition : json -> Condition.t
11

    
12
  val parse_action : json -> Action.t
13

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

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

    
20
  let path_split = String.split_on_char '/'
21

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

    
24
  open Util
25

    
26
  let to_list json = try json |> to_list with Type_error _ -> [ json ]
27

    
28
  let rec parse_prog json : prog_t =
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

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

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

    
46
  and parse_state_def json =
47
    Logs.debug (fun m -> m "parse_state_def");
48
    {
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;
56
    }
57

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

    
66
  and parse_transition json =
67
    Logs.debug (fun m -> m "parse_transition");
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;
72
      transition_act = json |> member "transition_act" |> Ext.parse_action;
73
      dest = json |> member "dest" |> parse_dest;
74
    }
75

    
76
  and parse_dest json =
77
    Logs.debug (fun m -> m "parse_dest");
78
    let dest_type = json |> member "type" |> to_string in
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)))
86
      (json |> member "name" |> parse_path)
87

    
88
  and parse_internal_composition json =
89
    Logs.debug (fun m -> m "parse_internal_composition");
90
    let state_type = json |> member "type" |> to_string in
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)
101
      (json |> member "substates" |> to_list |> List.map to_string)
102

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

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

    
113
  and scope_of_string s =
114
    match s with
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

    
128
  and parse_real_value s =
129
    Logs.debug (fun m -> m "parse_real_value %s" s);
130
    let real_regexp_simp = regexp "\\(-?[0-9][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
135
    if string_match real_regexp_e s 0 then
136
      let l = matched_group 1 s in
137
      let r = matched_group 2 s in
138
      let e = matched_group 4 s in
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
142
      let l = matched_group 1 s in
143
      let r = matched_group 2 s in
144
      Const_real (Num.num_of_string (l ^ r), String.length r, s)
145
    else raise (JSON_parse_error ("Invalid real constant " ^ s))
146

    
147
  and lustre_datatype_of_json json location =
148
    let datatype = json |> member "datatype" |> to_string in
149
    let initial_value = json |> member "initial_value" |> to_string in
150
    match datatype with
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

    
178
  and parse_variable json =
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
183
    mkvar_decl location ~orig:true
184
      ( json |> member "name" |> to_string,
185
        { ty_dec_desc = datatype; ty_dec_loc = location },
186
        { ck_dec_desc = Ckdec_any; ck_dec_loc = location },
187
        true,
188
        Some initial_value )
189
end
(1-1/3)