tokenType.ml 5.12 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
      let module P = 
	Printer.Make (struct 
			let f = open_out (Settings.base ^ ".mli")
			let locate_stretches = None 
		      end) 
      in
117
      P.interface [
118
        IIFunctor (grammar.parameters, i)
119
      ];
120 121 122 123 124 125
      let module P = 
	Printer.Make (struct 
			let f = open_out (Settings.base ^ ".ml")
			let locate_stretches = None 
		      end) 
      in
126
      P.program [
127 128 129
        SIFunctor (grammar.parameters,
          interface_to_structure i
        )
130
      ];
131
      exit 0
132 133 134 135 136

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

137
(* Define [tokentypedef] and [tokengadtdef], [tokenprefix]. *)
138

139 140 141 142 143 144 145 146 147 148 149 150
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 =
151 152 153 154
  match Settings.token_type_mode with
  | Settings.CodeOnly _ ->
      []
  | Settings.TokenTypeAndCode ->
155
      tokengadtdef grammar
156 157 158 159 160 161 162
  | 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
163
  | Settings.CodeOnly m ->
164
      m ^ "." ^ id
165
  | Settings.TokenTypeAndCode ->
166 167 168
      id
  | Settings.TokenTypeOnly ->
      id (* irrelevant, really *)
169 170 171 172 173 174 175 176 177 178

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

let tctoken =
  tokenprefix tctoken

let ttoken =
  TypApp (tctoken, [])

179 180 181
let tokendata =
  tokenprefix

182 183
let tctokengadt =
  tokenprefix tctokengadt
184

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

POTTIER Francois's avatar
POTTIER Francois committed
188 189 190
let tokengadtdata token =
  tokenprefix (ttokengadtdata token)