Project

General

Profile

Download (6 KB) Statistics
| Branch: | Tag: | Revision:
1
open Basetypes
2
open Cmdliner
3
open Datatype
4
open Json_parser
5
open Sys
6

    
7
module ParseExt = struct
8
  open Yojson.Basic
9

    
10
  let remove_quotes s =
11
    let len = String.length s in
12
    if String.get s 0 = '"' && String.get s (len - 1) = '"' then
13
      String.sub s 1 (len - 2)
14
    else (
15
      Format.eprintf "No quotes in string %s@.@?" s;
16
      assert false)
17

    
18
  let get_vars json =
19
    let get_vdecls key json =
20
      let s = json |> Util.member key |> to_string in
21
      try
22
        let s' = remove_quotes s in
23
        if s' = "" then []
24
        else
25
          let lexbuf = Lexing.from_string s' in
26
          Parser_lustre.vdecl_list Lexer_lustre.token lexbuf
27
      with _ ->
28
        Format.eprintf "Issues parsing decls for %s: %s@.@?" key s;
29
        assert false
30
    in
31

    
32
    let inputs = get_vdecls "inputs" json in
33
    let outputs = get_vdecls "outputs" json in
34
    let variables = get_vdecls "variables" json in
35
    inputs, outputs, variables
36

    
37
  (* Protecting the generation of condition/action in case of an empty string
38
     instead of a subtree *)
39
  let protect default parse_fun embed_fun json =
40
    try
41
      let vars = get_vars json in
42
      let actions = json |> Util.member "actions" |> to_string in
43
      if actions = "[]" || actions = "" then default (* should not happen *)
44
      else (
45
        Format.eprintf "Parsing string: %s@." actions;
46
        let lexbuf = Lexing.from_string (remove_quotes actions) in
47
        try
48
          let content = parse_fun Lexer_lustre.token lexbuf in
49
          Parsing.clear_parser ();
50
          embed_fun content vars
51
        with Parsing.Parse_error ->
52
          let loc = Location.dummy_loc in
53
          raise (Parse.Error (loc, Parse.String_Syntax_error actions)))
54
    with Util.Type_error _ ->
55
      Format.eprintf "Unable to explore json subtree: empty string %s@."
56
        (to_string json);
57
      default
58

    
59
  let parse_condition =
60
    protect Condition.tru Parser_lustre.expr (fun e (in_, out_, locals_) ->
61
        (* let vars = Corelang.get_expr_vars e in *)
62
        Condition.cquote
63
          { expr = e; cinputs = in_; coutputs = out_; cvariables = locals_ })
64

    
65
  let parse_action =
66
    protect Action.nil Parser_lustre.stmt_list
67
      (fun (stmts, asserts, annots) (in_, out_, locals_) ->
68
        if asserts != [] || annots != [] then assert false
69
          (* Stateflow equations should not use asserts nor define annotations *)
70
        else
71
          Action.aquote
72
            {
73
              defs = stmts;
74
              ainputs = in_;
75
              aoutputs = out_;
76
              avariables = locals_;
77
            })
78

    
79
  let parse_event json = Some Yojson.Basic.(json |> to_string)
80
end
81

    
82
module JParse = Parser (ParseExt)
83

    
84
(* setup for logging *)
85
let setup_log style_renderer level =
86
  Fmt_tty.setup_std_outputs ?style_renderer ();
87
  Logs.set_level level;
88
  Logs.set_reporter (Logs_fmt.reporter ());
89
  ()
90

    
91
let modular = ref 0
92

    
93
(* function representing the program to execute *)
94
let json_parse _ file pp =
95
  try
96
    let prog = JParse.parse_prog (Yojson.Basic.from_file file) in
97
    if pp then SF.pp_prog Format.std_formatter prog;
98

    
99
    let module Model = struct
100
      let model = prog
101

    
102
      let name = "toto"
103
      (* TODO find a meaningful name *)
104

    
105
      let traces = []
106
      (* TODO: shall we remove the traces field? *)
107
    end in
108
    let modularmode =
109
      match !modular with
110
      | 2 ->
111
        true, true, true
112
      | 1 ->
113
        false, true, false
114
      | _ (* 0 *) ->
115
        false, false, false
116
    in
117
    let state_vars = Datatype.SF.states Model.model in
118
    let global_vars = Datatype.SF.global_vars Model.model in
119

    
120
    let module T = CPS_lustre_generator.LustrePrinter (struct
121
      let state_vars = state_vars
122

    
123
      let global_vars = global_vars
124
    end) in
125
    let module Sem = CPS.Semantics (T) (Model) in
126
    let prog = Sem.code_gen modularmode in
127
    let header =
128
      List.map Corelang.mktop
129
        [
130
          LustreSpec.Open (false, "lustrec_math");
131
          LustreSpec.Open (false, "conv");
132
          LustreSpec.Open (true, "locallib");
133
        ]
134
    in
135
    let prog = header @ prog in
136
    Options.print_dec_types := true;
137

    
138
    (* Format.printf "%a@." Printers.pp_prog prog; *)
139
    let auto_file = "sf_gen_test_auto.lus" in
140
    (* Could be changed *)
141
    let auto_out = open_out auto_file in
142
    let auto_fmt = Format.formatter_of_out_channel auto_out in
143
    Format.fprintf auto_fmt "%a@." Printers.pp_prog prog;
144
    Format.eprintf
145
      "Print initial lustre model with automaton in sf_gen_test_auto.lus@.";
146

    
147
    let prog, deps = Compiler_stages.stage1 prog "" "" in
148

    
149
    (* Format.printf "%a@." Printers.pp_prog prog; *)
150
    let noauto_file = "sf_gen_test_noauto.lus" in
151
    (* Could be changed *)
152
    let noauto_out = open_out noauto_file in
153
    let noauto_fmt = Format.formatter_of_out_channel noauto_out in
154
    Format.fprintf noauto_fmt "%a@." Printers.pp_prog prog;
155
    Format.eprintf "Print expanded lustre model in sf_gen_test_noauto.lus@.";
156
    ()
157
  with Parse.Error (l, err) ->
158
    Format.eprintf "Parse error at loc %a : %a@.@?" Location.pp_loc l
159
      Parse.pp_error err
160

    
161
(* term representing argument for file *)
162
let file =
163
  let doc = "The file to parse." in
164
  let env = Arg.env_var "JSON_FILE" ~doc in
165
  let doc = "The file to parse." in
166
  Arg.(required & pos 0 (some string) None & info [] ~env ~docv:"FILE" ~doc)
167

    
168
(* term representing argument for flag for pretty printing the program *)
169
let pp =
170
  let doc = "Pretty print the resulting program" in
171
  Arg.(value & flag & info [ "pp"; "pretty-print" ] ~docv:"PP" ~doc)
172

    
173
(* term for argument for logging *)
174
let setup_log_arg =
175
  let env = Arg.env_var "TOOL_VERBOSITY" in
176
  Term.(const setup_log $ Fmt_cli.style_renderer () $ Logs_cli.level ~env ())
177

    
178
(* term representing the program to execute *)
179
let json_parse_t = Term.(const json_parse $ setup_log_arg $ file $ pp)
180

    
181
(* term info for manpages etc. *)
182
let info =
183
  let doc = "parse a JSON file representing a Stateflow model" in
184
  let man = [ `S Manpage.s_bugs; `P "Report bug to Github issues tracking." ] in
185
  Term.info "parse_json_file" ~doc ~exits:Term.default_exits ~man
186

    
187
(* program *)
188
let _ = Term.exit @@ Term.eval (json_parse_t, info)
(2-2/3)