package atd

  1. Overview
  2. Docs

Source file util.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
open Printf

let syntax_error (lexbuf : Lexing.lexbuf) =
  let pos = lexbuf.lex_curr_p in
  let msg = sprintf "Syntax error:\n%s" (Ast.string_of_loc (pos, pos)) in
  Ast.error msg

let read_lexbuf
    ?annot_schema
    ?(expand = false)
    ?keep_builtins
    ?keep_poly
    ?(xdebug = false)
    ?(inherit_fields = false)
    ?(inherit_variants = false)
    ?(pos_fname = "")
    ?(pos_lnum = 1)
    lexbuf =

  Lexer.init_fname lexbuf pos_fname pos_lnum;
  let module_ =
    try Parser.module_ Lexer.token lexbuf
    with Parser.Error -> syntax_error lexbuf
  in
  Check.check module_;
  (* Validate import declarations and check all type references. *)
  let locals = Imports.load module_.imports in
  Imports.check_type_refs locals module_.type_defs;
  Imports.warn_unused_imports locals module_.type_defs;
  let type_defs =
    if inherit_fields || inherit_variants then
      Inherit.expand_module_body ~inherit_fields ~inherit_variants
        module_.imports module_.type_defs
    else
      module_.type_defs
  in
  let type_defs =
    if expand then
      Expand.expand_type_defs ?keep_builtins ?keep_poly ~debug: xdebug
        type_defs
    else
      type_defs
  in
  let module_ =
    { module_ with type_defs }
  in
  (match annot_schema with
   | None -> ()
   | Some schema ->
       Annot.validate schema (Ast.Module module_)
  );
  module_

let read_channel
    ?annot_schema ?expand ?keep_builtins ?keep_poly ?xdebug
    ?inherit_fields ?inherit_variants
    ?pos_fname ?pos_lnum
    ic =
  let lexbuf = Lexing.from_channel ic in
  let pos_fname =
    if pos_fname = None && ic == stdin then
      Some "<stdin>"
    else
      pos_fname
  in
  read_lexbuf ?annot_schema ?expand ?keep_builtins ?keep_poly ?xdebug
    ?inherit_fields ?inherit_variants ?pos_fname ?pos_lnum lexbuf

let load_file
    ?annot_schema ?expand ?keep_builtins ?keep_poly ?xdebug
    ?inherit_fields ?inherit_variants
    ?pos_fname ?pos_lnum
    file =
  let ic = open_in file in
  let finally () = close_in_noerr ic in
  try
    let pos_fname =
      match pos_fname with
          None -> Some file
        | Some _ -> pos_fname
    in
    let ast =
      read_channel
        ?annot_schema ?expand ?keep_builtins ?keep_poly ?xdebug
        ?inherit_fields ?inherit_variants ?pos_fname ?pos_lnum ic
    in
    finally ();
    ast
  with e ->
    finally ();
    raise e

let load_string
    ?annot_schema ?expand ?keep_builtins ?keep_poly ?xdebug
    ?inherit_fields ?inherit_variants
    ?pos_fname ?pos_lnum
    s =
  let lexbuf = Lexing.from_string s in
  read_lexbuf ?annot_schema ?expand ?keep_builtins ?keep_poly ?xdebug
    ?inherit_fields ?inherit_variants ?pos_fname ?pos_lnum lexbuf

module Tsort = Sort.Make (
  struct
    type t = Ast.type_def
    type id = Ast.type_name
    let id (x : t) = x.name
    let to_string name = Print.tn name
  end
)

let tsort ?(all_rec = false) type_defs0 =
  let ignorable : Ast.type_name list = [
    TN ["unit"];
    TN ["bool"];
    TN ["int"];
    TN ["float"];
    TN ["string"];
    TN ["abstract"]
  ] in
  if all_rec then
    [(true, type_defs0)]
  else
    let type_defs =
      List.map (fun (x : Ast.type_def) ->
        let deps = Ast.extract_type_names ~ignorable x.value in
        (x, deps)
      ) type_defs0
    in
    List.rev (Tsort.sort type_defs)