Project

General

Profile

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

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

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

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

    
24
  open Util
25

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

    
32
  let rec parse_prog json : prog_t =
33
    Logs.info  (fun m -> m "parse_prog %s" (json |> member "name" |> to_string));
34
    Program (
35
      json |> member "name"        |> to_string,
36
     (json |> member "states"      |> to_list |> List.map parse_state) @
37
     (json |> member "junctions"   |> to_list |> List.map parse_junction)
38
     @
39
     (json |> member "sffunctions" |> to_list |> List.map
40
        (fun res -> SFFunction (parse_prog res))),
41
      json |> member "data"        |> to_list |> List.map parse_variable
42
    )
43
  and parse_state json =
44
    Logs.debug (fun m -> m "parse_state");
45
    State (
46
      json |> member "path" |> parse_path,
47
      json |> parse_state_def
48
    )
49
  and parse_path json =
50
    Logs.debug (fun m -> m "parse_path %s" (json |> to_string));
51
    json |> to_string |> path_split
52
  and parse_state_def json =
53
    Logs.debug (fun m -> m "parse_state_def");
54
    {
55
      state_actions        = json |> member "state_actions"        |> parse_state_actions;
56
      outer_trans          = json |> member "outer_trans"          |> to_list |> List.map parse_transition;
57
      inner_trans          = json |> member "inner_trans"          |> to_list |> List.map parse_transition;
58
      internal_composition = json |> member "internal_composition" |> parse_internal_composition
59
    }
60
  and parse_state_actions json =
61
    Logs.debug (fun m -> m "parse_state_actions");
62
    {
63
      entry_act  = json |> member "entry_act"  |> Ext.parse_action;
64
      during_act = json |> member "during_act" |> Ext.parse_action;
65
      exit_act   = json |> member "exit_act"   |> Ext.parse_action;
66
    }
67
  and parse_transition json =
68
    Logs.debug (fun m -> m "parse_transition");
69
    {
70
      event          = json |> member "event"          |> Ext.parse_event;
71
      condition      = json |> member "condition" |> Ext.parse_condition;
72
      condition_act  = json |> member "condition_act"  |> Ext.parse_action;
73
      transition_act = json |> member "transition_act" |> Ext.parse_action;
74
      dest           = json |> member "dest"           |> parse_dest
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 |>
80
	(function
81
	| "State"    -> (fun p -> DPath p)
82
	| "Junction" -> (fun j -> DJunction (path_concat j))
83
	| _ -> raise (JSON_parse_error ("Invalid destination type: " ^ dest_type))))
84
      (json |> member "name" |> parse_path)
85
  and parse_internal_composition json =
86
    Logs.debug (fun m -> m "parse_internal_composition");
87
    let state_type = json |> member "type" |> to_string in
88
    (state_type |>
89
	(function
90
	| "EXCLUSIVE_OR" -> (fun tinit substates ->                      Or  (tinit, substates))
91
	| "PARALLEL_AND" -> (fun tinit substates -> assert (tinit = []); And (substates))
92
        | _ -> raise (JSON_parse_error ("Invalid state type: " ^ state_type))))
93
      (json |> member "tinit"     |> parse_tinit)
94
      (json |> member "substates" |> to_list |> List.map to_string)
95
  and parse_tinit json =
96
    Logs.debug (fun m -> m "parse_tinit");
97
    json |> to_list |> List.map parse_transition
98
  and parse_junction json =
99
    Logs.debug (fun m -> m "parse_junction");
100
    Junction (
101
      json |> member "path"        |> to_string,
102
      json |> member "outer_trans" |> to_list |> List.map parse_transition
103
    )
104
  and scope_of_string s =
105
    match s with
106
    | "Constant"  -> Constant
107
    | "Input"     -> Input
108
    | "Local"     -> Local
109
    | "Output"    -> Output
110
    | "Parameter" -> Parameter
111
    | _           -> raise (JSON_parse_error ("Invalid scope for variable: " ^ s))
112
  and parse_real_value s =
113
    Logs.debug (fun m -> m "parse_real_value %s" s);
114
    let real_regexp_simp = regexp "\\(-?[0-9][0-9]*\\)\\.\\([0-9]*\\)" in
115
    let real_regexp_e    = regexp "\\(-?[0-9][0-9]*\\)\\.\\([0-9]*\\)\\(E\\|e\\)\\(\\(\\+\\|\\-\\)[0-9][0-9]*\\)" in
116
    if string_match real_regexp_e s 0 then
117
      let l = matched_group 1 s in
118
      let r = matched_group 2 s in
119
      let e = matched_group 4 s in
120
      Const_real (Real.create (l ^ r) 
121
                    (String.length r + (-1 * int_of_string e))
122
                    s)
123
    else
124
    if string_match real_regexp_simp s 0 then
125
      let l = matched_group 1 s in
126
      let r = matched_group 2 s in
127
      Const_real (Real.create (l ^ r)  (String.length r) s)
128
    else
129
      raise (JSON_parse_error ("Invalid real constant " ^ s))
130
  and lustre_datatype_of_json json location =
131
    let datatype      = json |> member "datatype"      |> to_string in
132
    let initial_value = json |> member "initial_value" |> to_string in
133
    match datatype with
134
    | "bool" -> (Tydec_bool, mkexpr location
135
                   (Expr_const (Const_tag
136
                                  ((fun s -> match s with
137
                                     | "true"  -> tag_true
138
                                     | "false" -> tag_false
139
                                     | _       ->
140
                                       raise (JSON_parse_error ("Invalid constant for
141
     boolean: " ^ s))) initial_value))))
142
    | "int"  -> (Tydec_int, mkexpr location
143
                   (Expr_const (Const_int (int_of_string
144
                                             initial_value))))
145
    | "real" -> (Tydec_real, mkexpr location
146
                   (Expr_const (parse_real_value initial_value)))
147
    | _      -> raise (JSON_parse_error ("Invalid datatype " ^ datatype
148
                                         ^ " for variable " ^ (json |> member "name"
149
                                                               |> to_string)))
150
  and parse_variable json =
151
    Logs.debug (fun m -> m "parse_variable %s" (json |> member "name" |> to_string));
152
    let location                  = Location.dummy_loc in
153
    let (datatype, initial_value) = lustre_datatype_of_json json location in
154
    let vdecl = 
155
      mkvar_decl location ~orig:true
156
        ( json |> member "name" |> to_string,
157
          {ty_dec_desc = datatype;  ty_dec_loc = location},
158
          {ck_dec_desc = Ckdec_any; ck_dec_loc = location},
159
          true,
160
          Some initial_value,
161
          None (* no parentid *)
162
        )
163
    in
164
    { variable = vdecl; init_val = initial_value }
165
end
166

    
(2-2/4)