VisitorsGeneration.ml 19.3 KB
Newer Older
1
open Longident
2
let mknoloc = Location.mknoloc
3 4 5 6
open Asttypes
open Parsetree
open Ast_helper
open Ast_convenience
7
open VisitorsList
8
open VisitorsAnalysis
9
open VisitorsCompatibility
10 11 12 13 14

(* This module offers helper functions for code generation. *)

(* -------------------------------------------------------------------------- *)

15 16
(* Type abbreviations. *)

17 18 19 20 21
type variable = string
type datacon = string
type label = string
type classe = string
type methode = string
22
type tyvar = string
POTTIER Francois's avatar
POTTIER Francois committed
23 24

type variables = variable list
25
type tyvars = tyvar list
POTTIER Francois's avatar
POTTIER Francois committed
26
type core_types = core_type list
27
type patterns = pattern list
28
type expressions = expression list
29

30 31
(* -------------------------------------------------------------------------- *)

POTTIER Francois's avatar
POTTIER Francois committed
32 33 34 35 36
(* We normally place a [Pervasives] prefix in front of OCaml's operators, so as
   to ensure that our code makes sense even if these operators are shadowed by
   the user. (That said, we still run into trouble if the user shadows the name
   [Pervasives] itself.) *)

37
(* When producing code for inclusion in the documentation, we remove the
POTTIER Francois's avatar
POTTIER Francois committed
38 39
   [Pervasives] prefix, just so that things look pretty. We rely on an
   undocumented environment variable to toggle this behavior. *)
40 41 42 43 44 45 46 47 48 49

let pervasive (x : string) : Longident.t =
  try
    let _ = Sys.getenv "VISITORS_BUILDING_DOCUMENTATION" in
    Lident x
      (* danger: the name [x] must not be shadowed. *)
  with Not_found ->
    Ldot (Lident "Pervasives", x)
      (* danger: the name [Pervasives] must not be shadowed. *)

50 51 52 53 54 55 56 57 58 59 60 61 62 63
(* We normally place an improbable prefix in front of our private (local)
   variables, so as to make sure that we do not shadow user variables that
   are used in [@build] code fragments. *)

(* When producing code for inclusion in the documentation, we remove this
   prefix. *)

let improbable (x : string) : string =
  try
    let _ = Sys.getenv "VISITORS_BUILDING_DOCUMENTATION" in
    x
  with Not_found ->
    "_visitors_" ^ x

64 65
(* -------------------------------------------------------------------------- *)

66 67
(* Types. *)

68 69 70 71 72 73
let ty_var (alpha : tyvar) : core_type =
  Typ.var alpha

let ty_vars (alphas : tyvars) : core_types =
  List.map ty_var alphas

74 75 76
let ty_any =
  Typ.any()

77 78 79
let ty_unit =
  tconstr "unit" []

80
(* For [ty_arrow], see [VisitorsCompatibility]. *)
81

82
let ty_arrows : core_types -> core_type -> core_type =
83 84
  List.fold_right ty_arrow

85 86
(* [decl_type decl] turns a declaration of the type ['a foo] into a the type
   ['a foo]. *)
87

88 89
let decl_type (decl : type_declaration) : core_type =
  tconstr decl.ptype_name.txt (ty_vars (decl_params decl))
90

91 92
(* -------------------------------------------------------------------------- *)

93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108
(* [unit] produces a unit constant. [tuple] produces a tuple. [record]
   produces a record. These functions already exist; we redefine them without
   any optional arguments so as avoid OCaml's warning 48 (implicit elimination
   of optional arguments). *)

let unit() =
  unit()

let tuple es =
  tuple es

let record les =
  record les

(* -------------------------------------------------------------------------- *)

109 110 111 112 113 114 115 116 117 118 119 120 121
(* [number i thing] constructs an English description of "[i] thing(s)". *)

let number i s =
  match i with
  | 0 ->
      Printf.sprintf "zero %s" s
  | 1 ->
      Printf.sprintf "one %s" s
  | _ ->
      Printf.sprintf "%d %ss" i s

(* -------------------------------------------------------------------------- *)

122 123 124 125 126 127 128
(* [eident] converts a (possibly-qualified) identifier to an expression. *)

let eident (id : Longident.t) : expression =
  Exp.ident (mknoloc id)

(* -------------------------------------------------------------------------- *)

129 130
(* [pvars] converts a list of variables to a list of patterns. *)

131
let pvars (xs : variables) : patterns =
132 133
  List.map (fun x -> pvar x) xs

POTTIER Francois's avatar
POTTIER Francois committed
134
(* [evars] converts a list of variables to a list of expressions. *)
135

136
let evars (xs : variables) : expressions =
137 138
  List.map (fun x -> evar x) xs

139 140
(* [pvarss] converts a matrix of variables to a matrix of patterns. *)

141
let pvarss (xss : variables list) : patterns list =
142 143
  List.map pvars xss

144 145
(* [evarss] converts a matrix of variables to a matrix of expressions. *)

146
let evarss (xss : variables list) : expressions list =
147 148
  List.map evars xss

149 150
(* -------------------------------------------------------------------------- *)

POTTIER Francois's avatar
POTTIER Francois committed
151 152 153 154 155 156 157
(* [wildcards] converts a list of anything to a list of wildcard patterns. *)

let wildcards xs =
  List.map (fun _ -> Pat.any()) xs

(* -------------------------------------------------------------------------- *)

158 159
(* [plambda p e] constructs a function [fun p -> e]. *)

160
(* For [plambda], see [VisitorsCompatibility]. *)
161 162 163 164 165 166 167 168

(* [lambda x e] constructs a function [fun x -> e]. *)

let lambda (x : variable) (e : expression) : expression =
  plambda (pvar x) e

(* [plambdas ps e] constructs a multi-argument function [fun ps -> e]. *)

169
let plambdas (ps : patterns) (e : expression) : expression =
170 171 172 173
  List.fold_right plambda ps e

(* [lambdas xs e] constructs a multi-argument function [fun xs -> e]. *)

POTTIER Francois's avatar
POTTIER Francois committed
174
let lambdas (xs : variables) (e : expression) : expression =
175 176 177 178
  List.fold_right lambda xs e

(* -------------------------------------------------------------------------- *)

179 180 181 182 183
(* [app] works like [Ast_convenience.app] (which it shadows), except it avoids
   constructing nested applications of the form [(f x) y], transforming them
   instead into a single application [f x y]. The difference is probably just
   cosmetic. *)

184
let app (e : expression) (es2 : expressions) : expression =
185 186 187 188 189 190 191 192 193
  match e.pexp_desc with
  | Pexp_apply (e1, les1) ->
      let les2 = List.map (fun e -> Label.nolabel, e) es2 in
      { e with pexp_desc = Pexp_apply (e1, les1 @ les2) }
  | _ ->
      app e es2

(* -------------------------------------------------------------------------- *)

194
(* [sequence es] constructs a sequence of the expressions [es]. *)
195

196
let sequence (es : expressions) : expression =
197 198 199 200 201 202 203 204 205
  (* Using [fold_right1] instead of [List.fold_right] allows us to get
     rid of a final [()] constant at the end of the sequence. Cosmetic. *)
  fold_right1
    (fun e accu -> Exp.sequence e accu)
    es
    (unit())

(* -------------------------------------------------------------------------- *)

POTTIER Francois's avatar
POTTIER Francois committed
206
(* [vblet1 vb e] constructs a single [let] binding. *)
207

POTTIER Francois's avatar
POTTIER Francois committed
208
let vblet1 (vb : value_binding) (e : expression) : expression =
209 210
  Exp.let_ Nonrecursive [vb] e

POTTIER Francois's avatar
POTTIER Francois committed
211
(* [let1 x e1 e2] constructs a single [let] binding. *)
212

POTTIER Francois's avatar
POTTIER Francois committed
213 214
let let1 (x : variable) (e1 : expression) (e2 : expression) : expression =
  vblet1 (Vb.mk (pvar x) e1) e2
215

216 217 218 219 220
(* [let1p x y e1 e2] constructs a single [let] binding of a pair. *)

let let1p (x, y : variable * variable) (e1 : expression) (e2 : expression) : expression =
  vblet1 (Vb.mk (ptuple [pvar x; pvar y]) e1) e2

POTTIER Francois's avatar
POTTIER Francois committed
221
(* [vbletn vbs e] constructs a series of nested [let] bindings. *)
222

POTTIER Francois's avatar
POTTIER Francois committed
223 224 225 226 227
let vbletn (vbs : value_binding list) (e : expression) : expression =
  List.fold_right vblet1 vbs e

(* [letn xs es e] constructs a series of nested [let] bindings. *)

228
let letn (xs : variables) (es : expressions) (e : expression) =
POTTIER Francois's avatar
POTTIER Francois committed
229
  List.fold_right2 let1 xs es e
230

231 232
(* [letnp xs ys es e] constructs a series of nested [let] bindings of pairs. *)

233
let letnp (xs : variables) (ys : variables) (es : expressions) (e : expression) =
234 235
  List.fold_right2 let1p (List.combine xs ys) es e

236 237
(* -------------------------------------------------------------------------- *)

238 239 240 241 242
(* [access x label] constructs a record access expression [x.label]. *)

let access (x : variable) (label : label) : expression =
  Exp.field (evar x) (mknoloc (Lident label))

243 244 245
(* [accesses labels xs] constructs a matrix of record access expressions of
   the form [x.label]. There is a row for every [label] and a column for every
   [x]. *)
246

247
let accesses (xs : variables) (labels : label list) : expressions list =
248
  List.map (fun label -> List.map (fun x -> access x label) xs) labels
249 250 251

(* -------------------------------------------------------------------------- *)

252 253
(* [ptuple] is [Ast_convenience.ptuple], deprived of its optional arguments. *)

254
let ptuple (ps : patterns) : pattern =
255 256 257 258
  ptuple ps

(* [ptuples] is [map ptuple]. *)

259
let ptuples (pss : patterns list) : patterns =
260 261 262 263
  List.map ptuple pss

(* -------------------------------------------------------------------------- *)

264 265 266 267 268 269 270 271 272 273 274 275 276
(* The Boolean expressions [false] and [true]. *)

let efalse : expression =
  Exp.construct (mknoloc (Lident "false")) None

let etrue : expression =
  Exp.construct (mknoloc (Lident "true")) None

(* -------------------------------------------------------------------------- *)

(* [conjunction es] constructs a Boolean conjunction of the expressions [es]. *)

let conjunction : expression =
277
  eident (pervasive "&&")
278 279 280 281

let conjunction e1 e2 =
  app conjunction [e1; e2]

282
let conjunction (es : expressions) : expression =
283 284 285 286
  fold_right1 conjunction es etrue

(* -------------------------------------------------------------------------- *)

POTTIER Francois's avatar
POTTIER Francois committed
287 288 289
(* [eassertfalse] is the expression [assert false]. *)

let eassertfalse : expression =
290
  Exp.assert_ efalse
POTTIER Francois's avatar
POTTIER Francois committed
291 292 293

(* -------------------------------------------------------------------------- *)

294 295 296 297 298 299 300 301 302 303 304
(* [eforce e] is the expression [Lazy.force e]. *)

let eforce : expression =
  eident (Longident.parse "Lazy.force")
    (* danger: the module name [Lazy] must not be shadowed. *)

let eforce (e : expression) : expression =
  app eforce [e]

(* -------------------------------------------------------------------------- *)

305 306 307
(* [eqphy e1 e2] is the expression [e1 == e2]. *)

let eqphy : expression =
308
  eident (pervasive "==")
309 310 311 312

let eqphy (e1 : expression) (e2 : expression) : expression =
  app eqphy [e1; e2]

313
(* [eqphys es1 es2] is the conjunction of the expressions [e1 == e2]. *)
314

315
let eqphys (es1 : expressions) (es2 : expressions) : expression =
316 317
  assert (List.length es1 = List.length es2);
  conjunction (List.map2 eqphy es1 es2)
318

319 320
(* -------------------------------------------------------------------------- *)

321 322 323 324 325 326
(* [efail s] generates a call to [VisitorsRuntime.fail]. The parameter [s] is
   a string, which could represent the place where a failure occurred, or the
   reason why a failure occurred. As of now, it is unused. *)

let efail : expression =
  eident (Ldot (Lident "VisitorsRuntime", "fail"))
327
    (* danger: the module name [VisitorsRuntime] must not be shadowed. *)
328 329 330 331 332 333

let efail (_ : string) : expression =
  app efail [ unit() ]

(* -------------------------------------------------------------------------- *)

334 335 336 337 338 339 340 341 342 343 344
(* [letopen m e] produces a single [let open!] binding. The bang character
   indicates intentional shadowing and disables OCaml's warning 44. *)

let letopen (m : Longident.t) (e : expression) : expression =
  Exp.open_ Override (mknoloc m) e

(* [letopen ms e] produces a series of [let open!] bindings. *)

let letopen (ms : Longident.t list) (e : expression) : expression =
  List.fold_right letopen ms e

345 346 347 348 349 350 351 352 353 354
(* [stropen m] produces a single [open!] declaration. *)

let stropen (m : Longident.t) : structure_item =
  Str.open_ (Opn.mk ~override:Override (mknoloc m))

(* [stropen ms] produces a series of [open!] declarations. *)

let stropen (ms : Longident.t list) : structure =
  List.map stropen ms

355 356
(* -------------------------------------------------------------------------- *)

357
(* [include_ e] constructs an [include] declaration. *)
358

359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381
let include_ (e : module_expr) : structure_item =
  Str.include_ {
    pincl_mod = e;
    pincl_loc = Location.none;
    pincl_attributes = [];
  }

(* -------------------------------------------------------------------------- *)

(* [floating s items] produces a floating attribute whose name is [s] and
   whose payload is the list of structure items [items]. *)

let floating (s : string) (items : structure) : structure_item =
  Str.attribute (mknoloc s, PStr items)

(* -------------------------------------------------------------------------- *)

(* [with_warnings w items] wraps the structure items [items] in such a way
   that the warning directive [w] is applied to these items. Technically, this
   is done by emitting [include struct [@@@ocaml.warning <w>] <items> end]. *)

let with_warnings (w : string) (items : structure_item list) : structure_item =
  include_ (Mod.structure (
382
     floating "ocaml.warning" [ Str.eval (Exp.constant (const_string w)) ]
383 384
  :: items
  ))
385 386 387

(* -------------------------------------------------------------------------- *)

388 389 390 391
(* [class1 concrete ancestors params name self fields] builds a class
   declaration and packages it as a structure item. (This implies that it
   cannot be recursive with other class declarations). *)

POTTIER Francois's avatar
POTTIER Francois committed
392
let class1
393
  (concrete : bool)
394 395 396 397
  (params : (core_type * variance) list)
  (name : classe)
  (self : pattern)
  (fields : class_field list)
POTTIER Francois's avatar
POTTIER Francois committed
398 399
  : structure_item =
  Str.class_ [{
400
    pci_virt = if concrete then Concrete else Virtual;
401 402 403 404 405
    pci_params = params;
    pci_name = mknoloc name;
    pci_expr = Cl.structure (Cstr.mk self fields);
    pci_loc = !default_loc;
    pci_attributes = [];
POTTIER Francois's avatar
POTTIER Francois committed
406
  }]
407 408 409

(* -------------------------------------------------------------------------- *)

410 411 412
(* [inherit_ c tys] builds an [inherit] clause, where the superclass is [c]
   and its actual type parameters are [tys]. No [super] identifier is bound. *)

413
let inherit_ (c : Longident.t) (tys : core_types) : class_field =
414
  Cf.inherit_ Fresh (Cl.constr (mknoloc c) tys) None
415 416 417

(* -------------------------------------------------------------------------- *)

418
(* An algebraic data type of the methods that we generate. These include
419
   concrete methods (with code) and virtual methods (without code). They may
420 421
   be public or private. The method type is optional. If omitted, then
   it is inferred by OCaml. If present, it can be a polymorphic type. *)
422

423
type meth =
424
  Meth of private_flag * methode * expression option * core_type option
425

426 427
let concrete_method p m e oty =
  Meth (p, m, Some e, oty)
428

429 430
let virtual_method p m oty =
  Meth (p, m, None, oty)
431 432 433

(* -------------------------------------------------------------------------- *)

434
(* Converting a method description to OCaml abstract syntax. *)
435

436 437 438 439 440
let oe2cfk (oe : expression option) (oty : core_type option) : class_field_kind =
  match oe, oty with
  | Some e, Some _ ->
      Cf.concrete Fresh (Exp.poly e oty)
  | Some e, None ->
441
      Cf.concrete Fresh e
442 443 444
  | None, Some ty ->
      Cf.virtual_ ty
  | None, None ->
445
      Cf.virtual_ ty_any
446

447 448
let meth2cf (Meth (p, m, oe, oty)) : class_field =
  Cf.method_ (mknoloc m) p (oe2cfk oe oty)
POTTIER Francois's avatar
POTTIER Francois committed
449 450 451

(* -------------------------------------------------------------------------- *)

452
(* [method_name] extracts a method name out of a method description. *)
453

454
let method_name (Meth (_, m, _, _)) : string =
455
  m
456 457 458

(* -------------------------------------------------------------------------- *)

459 460
(* [is_virtual] tests whether a method description represents a virtual
   method. *)
461

462
let is_virtual (Meth (_, _, oe, _)) : bool =
463
  oe = None
464 465 466

(* -------------------------------------------------------------------------- *)

POTTIER Francois's avatar
POTTIER Francois committed
467 468
(* [send o m es] produces a call to the method [o#m] with arguments [es]. *)

469
let send (o : variable) (m : methode) (es : expressions) : expression =
470
  app (exp_send (evar o) m) es
471 472 473

(* -------------------------------------------------------------------------- *)

474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510
(* An algebraic data type of the ``hoisted expressions'' that we generate. *)

(* A ``hoisted expression'' is evaluated at most once after the object is
   allocated. Its value is stored in an instance field. We allow such an
   expression to reference [self], as long as it does not actually invoke any
   methods. *)

type hoisted =
  Hoisted of string     (* the name of the instance field *)
           * expression (* the hoisted expression *)

(* -------------------------------------------------------------------------- *)

(* Converting a hoisted field description to OCaml abstract syntax. *)

(* We generate a mutable field declaration, followed with an initialization:

     val mutable x =  lazy (assert false)
     initializer x <- lazy e

   We must do this in two steps because the expression [e] might contain
   references to [self], which are invalid in a field declaration, whereas
   they are allowed in an initializer.

   The potential danger in this idiom lies in forcing [x] before the
   initializer has finished running, leading to an assertion failure.
   This should not happen if [e] does not perform any method calls
   or read any fields. *)

let hoisted2cf (Hoisted (x, e)) : class_field list =
  [
    Cf.val_ (mknoloc x) (Mutable) (Cf.concrete Fresh (Exp.lazy_ eassertfalse));
    Cf.initializer_ (Exp.setinstvar (mknoloc x) (Exp.lazy_ e))
  ]

(* -------------------------------------------------------------------------- *)

511
(* A facility for generating a class. *)
512 513 514

module ClassFieldStore (X : sig end) : sig

515
  (* [generate meth] adds [meth] to the list of methods. *)
516
  val generate: meth -> unit
517

518 519 520 521 522 523
  (* [hoist e] causes the expression [e] to be hoisted, that is, computed
     once after the object is allocated. The result of evaluating [e] is
     stored in a field. The call [hoist e] returns an expression which
     reads this field. *)
  val hoist: expression -> expression

524
  (* [dump concrete ancestors params self c] returns a class definition. *)
525
  val dump:
526
    bool ->
527 528 529 530 531
    Longident.t list ->
    (core_type * variance) list ->
    pattern ->
    classe ->
    structure_item
532 533 534

end = struct

535
  let meths : meth list ref =
536
    ref []
537

538
  let generate meth =
539
    meths := meth :: !meths
540

541
  let dump () : class_field list =
542
    let methods = List.rev !meths in
543 544 545 546
    (* Move all of the virtual methods up front. If two virtual methods have
       the same name, keep only one of them. This is useful because we allow
       a virtual method declaration to be generated several times. In fact,
       OCaml supports this, but it looks tidier if we remove duplicates. *)
547 548 549 550 551
    let virtual_methods, concrete_methods = List.partition is_virtual methods in
    let cmp meth1 meth2 = compare (method_name meth1) (method_name meth2) in
    let virtual_methods = VisitorsList.weed cmp virtual_methods in
    let methods = virtual_methods @ concrete_methods in
    List.map meth2cf methods
552

553 554 555 556 557 558 559 560 561 562 563 564 565 566 567
  let hoisted : hoisted list ref =
    ref []

  let fresh : unit -> int =
    let c = ref 0 in
    fun () ->
      let x = !c in
      c := x + 1;
      x

  let hoist (e : expression) : expression =
    let x = Printf.sprintf "h%d" (fresh()) in
    hoisted := Hoisted (x, e) :: !hoisted;
    eforce (evar x)

568 569
  let dump concrete ancestors params self c : structure_item =
    class1 concrete params c self (
570 571 572
      (* [inherit] clauses. *)
      (* We ARBITRARILY assume that every ancestor class is parameterized
         with ONE type parameter. *)
573
      List.map (fun c -> inherit_ c [ ty_any ]) ancestors @
574 575
      (* Hoisted expressions. *)
      List.flatten (List.map hoisted2cf (List.rev !hoisted)) @
576
      (* Methods. *)
577
      dump()
578
    )
579

580
end
581 582 583 584 585 586 587 588 589 590 591

(* -------------------------------------------------------------------------- *)

(* A facility for emitting preprocessor warnings. *)

(* Warnings must be emitted under the form of [ppwarning] attributes, placed
   in the generated code. This is not very convenient; we must store these
   warnings, waiting for a convenient time to emit them. *)

module WarningStore (X : sig end) : sig

592 593
  (* [warning loc format ...] emits a warning. *)
  val warning: loc -> ('a, unit, string, unit) format4 -> 'a
594 595 596 597 598 599 600 601 602 603 604 605

  (* [warnings()] returns a list of all warnings emitted so far. *)
  val warnings: unit -> structure

end = struct

  let warnings : attribute list ref =
    ref []

  let warning loc msg =
    warnings := Ast_mapper.attribute_of_warning loc msg :: !warnings

606 607 608
  let warning loc format =
    Printf.ksprintf (warning loc) format

609 610 611 612 613 614
  let warnings () =
    let ws = !warnings in
    warnings := [];
    List.map (fun a -> Str.attribute a) (List.rev ws)

end