tokenType.ml 4.46 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
(* 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 Syntax
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"

17 18 19 20 21 22 23 24 25 26 27 28
(* 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

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

32
let tokentypedef grammar =
33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53
  let datadefs =
    StringMap.fold (fun token properties defs ->

      (* Pseudo-tokens (used in %prec declarations, but never
	 declared using %token) are filtered out. *)

      if properties.tk_is_declared then
	let params =
	  match properties.tk_ocamltype with
	  | None ->
	      []
	  | Some t ->
	      [ TypTextual t ]
	in
	{
	  dataname = token;
	  datavalparams = params;
	  datatypeparams = None
	} :: defs
      else
	defs
54
    ) grammar.tokens []
55
  in
56 57 58 59 60 61 62 63 64
  [
    IIComment "The type of tokens.";
    IITypeDecls [{
      typename = tctoken;
      typeparams = [];
      typerhs = TDefSum datadefs;
      typeconstraint = None
    }]
  ]
65

66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88
(* This is the definition of the token GADT. Here, the data
   constructors have no value argument, but have a type index. *)

let tokengadtdef grammar =
  let datadefs =
    StringMap.fold (fun token properties defs ->
      if properties.tk_is_declared then
	let index =
	  match properties.tk_ocamltype with
	  | None ->
	      tunit
	  | Some t ->
	      TypTextual t
	in
	{
	  dataname = ttokengadtdata token;
	  datavalparams = [];
	  datatypeparams = Some [ index ]
	} :: defs
      else
	defs
    ) grammar.tokens []
  in
89 90 91 92 93 94 95 96 97
  [
    IIComment "The indexed type of terminal symbols.";
    IITypeDecls [{
      typename = tctokengadt;
      typeparams = [ "_" ];
      typerhs = TDefSum datadefs;
      typeconstraint = None
    }]
  ]
98 99 100 101 102 103 104

(* The token type is always needed. The token GADT is needed only in
   [--table] mode. This ensures that, when [--table] is off, we remain
   compatible with old versions of OCaml, without GADTs. *)

let typedefs grammar =
  if Settings.table then
105
    tokentypedef grammar @ tokengadtdef grammar
106
  else
107
    tokentypedef grammar
108

109 110
(* If we were asked to only produce a type definition, then
   do so and stop. *)
111

112
let produce_tokentypes grammar =
113 114 115 116 117 118 119
  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. *)

120
      let i = typedefs grammar in
121

122 123 124 125 126 127 128
      let module P = 
	Printer.Make (struct 
			let f = open_out (Settings.base ^ ".mli")
			let raw_stretch_action = false
			let locate_stretches = None 
		      end) 
      in
129
      P.interface [
130
        IIFunctor (grammar.parameters, i)
131
      ];
132 133 134 135 136 137 138
      let module P = 
	Printer.Make (struct 
			let f = open_out (Settings.base ^ ".ml")
			let raw_stretch_action = false
			let locate_stretches = None 
		      end) 
      in
139
      P.program [
140 141 142
        SIFunctor (grammar.parameters,
          interface_to_structure i
        )
143
      ];
144
      exit 0
145 146 147 148 149

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

150 151 152
(* Define [tokentypedefs], and define [tokenprefix], so as to tell the code
   generator whether it should include a definition of the token types in the
   code and how the token types are called. *)
153

154
let tokentypedefs grammar =
155 156 157 158
  match Settings.token_type_mode with
  | Settings.CodeOnly _ ->
      []
  | Settings.TokenTypeAndCode ->
159
      typedefs grammar
160 161 162 163 164 165 166
  | 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
167
  | Settings.CodeOnly m ->
168
      m ^ "." ^ id
169
  | Settings.TokenTypeAndCode ->
170 171 172
      id
  | Settings.TokenTypeOnly ->
      id (* irrelevant, really *)
173 174 175 176 177 178 179 180 181 182

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

let tctoken =
  tokenprefix tctoken

let ttoken =
  TypApp (tctoken, [])

183 184
let tctokengadt =
  tokenprefix tctokengadt
185

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