tokenType.ml 5.18 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
(* This module deals with a few details regarding the definition of
   the [token] type. In particular, if [--only-tokens] was specified,
   it emits the type definition and exits. *)

open UnparameterizedSyntax
open IL
open CodeBits

(* This is the conventional name of the [token] type, with no
   prefix. A prefix is possibly appended to it below, where
   [tctoken] is redefined before being exported. *)

let tctoken =
  "token"

16 17 18 19 20 21 22 23 24 25 26 27
(* This is the conventional name of the token GADT, which describes
   the tokens. Same setup as above. *)

let tctokengadt =
  "terminal"

(* This is the conventional name of the data constructors of
   the token GADT. *)

let ttokengadtdata token =
  "T_" ^ token

28 29
(* This is the definition of the type of tokens. (Regardless of
   [Settings.token_type_mode], which is examined below.) *)
30

31
let tokentypedef grammar =
32
  let datadefs =
33 34 35 36 37
    List.map (fun (token, typo) -> {
      dataname = token;
      datavalparams = (match typo with None -> [] | Some t -> [ TypTextual t ]);
      datatypeparams = None
    }) (typed_tokens grammar)
38
  in
39 40 41 42 43 44 45 46 47
  [
    IIComment "The type of tokens.";
    IITypeDecls [{
      typename = tctoken;
      typeparams = [];
      typerhs = TDefSum datadefs;
      typeconstraint = None
    }]
  ]
48

49 50 51
(* This is the definition of the token GADT. Here, the data
   constructors have no value argument, but have a type index. *)

52 53 54
(* The token GADT is produced only when [Settings.inspection] is true. Thus,
   when [Settings.inspection] is false, we remain compatible with old versions
   of OCaml, without GADTs. *)
55

56 57 58 59 60
(* Although the [token] type does not include the [error] token (because this
   token is never produced by the lexer), the token GADT must include the
   [error] token (because this GADT must describe all of the tokens that are
   allowed to appear in a production). *)

61
let tokengadtdef grammar =
62
  assert Settings.inspection;
63 64 65 66 67 68
  let errordata = {
    dataname = ttokengadtdata "error";
    datavalparams = [];
    datatypeparams = Some [ tunit ]
      (* the [error] token has a semantic value of type [unit] *)
  } in
69
  let datadefs =
70 71 72 73 74 75
    (* The ordering of this list matters. We want the data constructors
       to respect the internal ordering (as determined by [typed_tokens]
       in [UnparameterizedSyntax]) of the terminal symbols. This may be
       exploited in the table back-end to allow an unsafe conversion
       of a data constructor to an integer code. See [t2i] in
       [InspectionTableInterpreter]. *)
76 77 78 79 80 81
    errordata ::
    List.map (fun (token, typo) -> {
      dataname = ttokengadtdata token;
      datavalparams = [];
      datatypeparams = Some [ match typo with None -> tunit | Some t -> TypTextual t ]
    }) (typed_tokens grammar)
82 83 84 85 86 87 88 89 90 91
  in
  [
    IIComment "The indexed type of terminal symbols.";
    IITypeDecls [{
      typename = tctokengadt;
      typeparams = [ "_" ];
      typerhs = TDefSum datadefs;
      typeconstraint = None
    }]
  ]
92

93 94
(* If we were asked to only produce a type definition, then
   do so and stop. *)
95

96
let produce_tokentypes grammar =
97 98 99 100 101 102 103
  match Settings.token_type_mode with
  | Settings.TokenTypeOnly ->

      (* Create both an .mli file and an .ml file. This is made
	 necessary by the fact that the two can be different
	 when there are functor parameters. *)

104 105
      let i =
        tokentypedef grammar @
106
        listiflazy Settings.inspection (fun () ->
107 108
          tokengadtdef grammar
        )
109
      in
110

111 112 113 114 115 116 117
      let module P = 
	Printer.Make (struct 
			let f = open_out (Settings.base ^ ".mli")
			let raw_stretch_action = false
			let locate_stretches = None 
		      end) 
      in
118
      P.interface [
119
        IIFunctor (grammar.parameters, i)
120
      ];
121 122 123 124 125 126 127
      let module P = 
	Printer.Make (struct 
			let f = open_out (Settings.base ^ ".ml")
			let raw_stretch_action = false
			let locate_stretches = None 
		      end) 
      in
128
      P.program [
129 130 131
        SIFunctor (grammar.parameters,
          interface_to_structure i
        )
132
      ];
133
      exit 0
134 135 136 137 138

  | Settings.CodeOnly _
  | Settings.TokenTypeAndCode ->
      ()

139
(* Define [tokentypedef] and [tokengadtdef], [tokenprefix]. *)
140

141 142 143 144 145 146 147 148 149 150 151 152
let tokentypedef grammar =
  match Settings.token_type_mode with
  | Settings.CodeOnly _ ->
      []
  | Settings.TokenTypeAndCode ->
      tokentypedef grammar
  | Settings.TokenTypeOnly ->
      (* This should not happen, as [produce_tokentype] should
         have been called first. *)
      assert false

let tokengadtdef grammar =
153 154 155 156
  match Settings.token_type_mode with
  | Settings.CodeOnly _ ->
      []
  | Settings.TokenTypeAndCode ->
157
      tokengadtdef grammar
158 159 160 161 162 163 164
  | Settings.TokenTypeOnly ->
      (* This should not happen, as [produce_tokentype] should
         have been called first. *)
      assert false

let tokenprefix id =
  match Settings.token_type_mode with
165
  | Settings.CodeOnly m ->
166
      m ^ "." ^ id
167
  | Settings.TokenTypeAndCode ->
168 169 170
      id
  | Settings.TokenTypeOnly ->
      id (* irrelevant, really *)
171 172 173 174 175 176 177 178 179 180

(* Redefine the name of the [token] type to take a possible
   prefix into account. *)

let tctoken =
  tokenprefix tctoken

let ttoken =
  TypApp (tctoken, [])

181 182 183
let tokendata =
  tokenprefix

184 185
let tctokengadt =
  tokenprefix tctokengadt
186

187 188
let ttokengadt a =
  TypApp (tctokengadt, [ a ])
189

190 191 192
let tokengadtdata token =
  tokenprefix (ttokengadtdata token)