Skip to content
This repository
tag: v952
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 437 lines (364 sloc) 14.014 kb
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 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436
(*
Copyright © 2011 MLstate

This file is part of OPA.

OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.

OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.

You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)

(**
The OPA Surface AST.

@author David Rajchenbach-Teller
@author Rudy Sicard
*)

(**
{5 Definitions}
*)
type 'a label = 'a QmlLoc.label

(**
{6 Identifiers}

Not-quite-phantom types used to guarantee that we never confuse
unique identifiers and not-made-unique-yet identifiers.
*)


type uids = Ident.t
(**
A key to determine the (non)-equality of identifiers.

This is useful as the same source code can often contain two
identical identifiers (say [x]) with different definitions (say
[let x = 1 in let x = 2 in e]). While here both identifiers will
be called [x], they will have distinct hashes.
*)

type nonuid = string
    (**A name as parsed in the source*)

let hash : string -> string -> uids =
  fun name description -> Ident.next ~descr:description name
  (** Generate a unique hash for a name.

Usage: [hash name description]. *)

let string_of_hash : uids -> string = Ident.stident

(**
{6 Expressions}
*)

(**
{7 Other expressions}
*)
type bind_directives = QmlAst.userland_visibility_directive (* TODO Move expand here *)

(**
Internal data structures.

Not all of these data structures are visible in the concrete syntax.
For instance, the concrete syntax offers [text] (Unicode ropes)
instead of [string] (character-neutral array-style strings).
*)
type const_expr_node =
  | CInt of Big_int.big_int
  | CFloat of float
(* | CFixed of fixed*)(**This is actually a user-level data structure.*)
  | CString of string (**A UTF-8 encoded string.*)

and const_expr = const_expr_node label (* cf libqmlcompil/qmlLoc.ml *)

type ('ident, 'dir) record = ('ident, 'dir) record_node label
and ('ident, 'dir) record_node = (string * ('ident, 'dir) expr) list

(**
Type of an expression

@param 'ident The type of identifiers: either [nonuid] until identifiers have been made unique or [uids] once they have
@param 'dir The type of directives, i.e. stuff left by the compiler for a further phase to rewrite.
*)
and ('ident, 'dir) expr = ('ident, 'dir) expr_node label
and 'ident bind_ident = {ident :'ident ; directives : bind_directives list}
and ('ident, 'dir) expr_node =
  | Apply of ('ident, 'dir) expr * ('ident, 'dir) record
      (**
We may add a support for labeled arguement.
For now, those records are tuples ("f1", "f2", etc.)
*)

  | Lambda of 'ident pat_record_node * ('ident, 'dir) expr
      (**
cf remark for Apply node, about labeled argument.
*)

  | Const of const_expr_node
  | Ident of 'ident
  | LetIn of bool (* rec *) * ('ident * ('ident, 'dir) expr) list * ('ident, 'dir) expr
  | Match of ('ident, 'dir) expr * ('ident pat * ('ident, 'dir) expr) list
  | Record of ('ident, 'dir) record_node
  | ExtendRecord of ('ident, 'dir) record_node * ('ident, 'dir) expr (**[ExtendRecord r e] extends
the result of [e] with the
fields defined in [r].*)
  | Dot of ('ident, 'dir) expr * string
  | Bypass of BslKey.t (**A primitive, handled through the Bypass Standard Library*)

  | DBPath of ('ident, 'dir) dbelt * QmlAst.Db.kind
  | Directive of ('ident, 'dir) directive

      (**
Instruction for a later compilation phase.

Usage: [Directive (directive, human_readable_name, lazy expr, how_to_type)].

[human_readable_name] is used only for pretty-printing

To obtain the type of the expression, apply [how_to_type] to the
type of [lazy expr] (only if lazy_expr is a one element list).
Expressions which should not be typeable (typically because they
are expected to be rewritten away before reaching the typer) should
have type None.
*)
and ('ident, 'dir) directive = 'dir * ('ident, 'dir) expr list * 'ident ty list

(**
{6 Database}
*)

and ('ident, 'dir) dbelt = ('ident, 'dir) dbelt_node label
and ('ident, 'dir) dbelt_node = ('ident, 'dir) preprocessed_db_element list

and ('ident, 'dir) preprocessed_db_element = ('ident, 'dir) preprocessed_db_element_node label
and ('ident, 'dir) preprocessed_db_element_node =
  | FldKey of string
  | ExprKey of ('ident, 'dir) expr (* not [expr_node], because consecutive labels, but unequal positions, because of brackets *)
  | NewKey

(**
{6 Pattern}
*)

and 'ident pat = 'ident pat_node label

and 'ident pat_node =
  | PatRecord of 'ident pat_record_node * QmlAst.pat_rowvar
  | PatAny
  | PatConst of const_expr_node
  | PatVar of 'ident bind_ident
  | PatCoerce of 'ident pat * 'ident ty
  | PatAs of 'ident pat * 'ident bind_ident

and 'ident pat_record_node = (string * 'ident pat) list

(**
{6 Types}
*)

and 'ident ty = 'ident ty_node label
and 'ident ty_node =
    | TypeConst of const_ty_node
    | TypeVar of 'ident typevar
    | TypeArrow of 'ident arrow_t_node
    | TypeRecord of 'ident row_t_node
    | TypeSumSugar of 'ident sum_t list
    | TypeNamed of 'ident typeinstance_t_node
    | TypeExternal
    | TypeForall of 'ident typeforall
    | TypeModule of 'ident fields_t_node

and 'ident typeforall = 'ident typevar list * 'ident ty

and 'ident typeinstance_t= 'ident typeinstance_t_node label
and 'ident typeinstance_t_node = 'ident typeident * 'ident ty list

and 'ident arrow_t = 'ident arrow_t_node label
and 'ident arrow_t_node = 'ident row_t * 'ident ty (**The type of a function.*)

and 'ident sum_t = 'ident sum_t_node label
and 'ident sum_t_node =
  | SumName of 'ident typeinstance_t_node
  | SumRecord of 'ident row_t_node (* warning: the typer won't be able to deal with row variables in columns *)
  | SumVar of 'ident colvar

and 'ident fields_t_node = (string * 'ident ty) list

and 'ident row_t = 'ident row_t_node label
and 'ident row_t_node = TyRow of 'ident fields_t_node * 'ident rowvar option

and 'ident typevar = Flatvar of 'ident(**Type variables, e.g. ['a], ['b], etc.*)
and 'ident typeident = Typeident of 'ident(**Type identifiers, e.g. [list], [int]*)

and const_ty_node =
  | TyInt
  | TyFloat
  | TyString

and 'ident rowvar = Rowvar of 'ident
and 'ident colvar = Colvar of 'ident

(**
{6 Declarations}
*)

and ('ident, 'dir) code_elt = ('ident, 'dir) code_elt_node label
and ('ident, 'dir) code_elt_node =
  | Database of 'ident * string list * QmlAst.Db.options list
  | NewDbDef of (('ident, 'dir) expr, 'ident ty) QmlAst.Db.db_def
  | NewType of 'ident typedef list
  | NewVal of ('ident pat * ('ident, 'dir) expr) list * bool (* rec *)
      (* after dependency analysis, toplevel mutually recursive functions
* are regrouped in a NewVal *)
  | Package of [`declaration | `import | `import_plugin] * string

and type_def_visibility =
  | TDV_public (** Type definition is public, visible from anywhere. *)
  | TDV_abstract (** Type definition is visible from anywhere but internal
representation is only visible inside the hosting package. Since
at parsing stage we don't know yet the currently compiled package,
the name of the package is not set and its determination is delayed
upon we create a QML visibility information. *)
  | TDV_private (** Type definition is not exported outside the hosting
package, i.e. doesn't appear in the package's interface. Same remark
than above about the package name. *)

and 'ident typedef = 'ident typedef_node label
and 'ident typedef_node = {
  ty_def_options : QmlAst.ty_def_options ;
  ty_def_visibility : type_def_visibility ;
  ty_def_name : 'ident typeident ;
  ty_def_params : 'ident typevar list ;
  ty_def_body :'ident ty
}

type ('ident, 'dir) code = ('ident, 'dir) code_elt list (**One (or more) complete source file(s)*)


(**
{5 The ast for pattern matching on xml }
*)
type 'expr namespace = {namespace : 'expr ; name : string label}
type 'expr xml_suffix =
  | Xml_star
  | Xml_plus
  | Xml_question
  | Xml_number of 'expr
  | Xml_range of 'expr * 'expr
type 'expr xml_pattern_attribute_value =
  | XmlExists
  | XmlName
  | XmlAttrStringParser of 'expr
  | XmlAttrParser of 'expr
type 'expr xml_pattern_attribute =
  (* string is a unique name used by the parser generator *)
  'expr namespace * string option * 'expr xml_pattern_attribute_value
type 'expr xml_pattern =
  | XmlLetIn of (string * 'expr) list * 'expr xml_pattern (* this node allows to bind namespaces *)
  | XmlExpr of 'expr
  | XmlNode of 'expr namespace *
            'expr xml_pattern_attribute list *
            'expr xml_named_pattern list
  | XmlAny
  | XmlParser of 'expr Trx_ast.item list (* no disjunction allowed to avoid parsing ambiguities *)
    (* should we bring a node XmlSuffix -> we can write this in the syntax
already anyway
but then what about <toto a={e}>*
*)
and 'expr xml_named_pattern = string option * 'expr xml_pattern * 'expr xml_suffix label option
and 'expr xml_rule = 'expr xml_named_pattern list * 'expr (* one line of parser *)
type 'expr xml_parser =
  'expr xml_rule list (* the alternatives *)


(**
{5 Various shorthands for directives}
*)
type magic_directive =
    [ `magic_to_string
    | `magic_to_xml

    | `magic_do
        (**
this directive is no longer used for executing a list of funaction,
this is just there for keeping the 'do' syntax when we reprint a parsed
opa code.
this directive is removed during the transformation into QmlAst.
*)

    | `typeof
    | `specialize of [ `strict | `polymorphic ]
    ]

type string_directive = [ `string ]

type internationalization_directive = [
    | `i18n (* indicate a point of translation *)
    | `i18n_lang (* return the current context lang, add a directive to later prune js code pattern matching at running time *)
]

type error_directive =
    [ `assert_
    ]
type coding_directive = [
  | `deprecated
  | `todo
]
type insert_server_directive =
    [ `server_entry_point
    ]
type concurrency_directive =
    [ `spawn
    | `wait
    | `callcc
    | `atomic
    | `thread_context
    | `with_thread_context
    | `no_client_calls
    | `throw
    | `catch
    | `may_cps
    | `async
    ]
type distribution_directive = QmlAst.slicer_directive
type file_inclusion_directive =
    [ `static_content of string (*Relative file name*)* bool (*[true] if a [string] is expected, [false] if a [-> string] is expected*)
    | `static_resource of string (*Relative file name*)
    | `static_content_directory of string (*Relative file name*)* bool (*[true] if a [string] is expected, [false] if a [-> string] is expected*)
    | `static_resource_directory of string (*Relative file name*)
    ]
type access_directive =
    [ `private_ (* visible only in the current module *)
    | `public (* visible to everyone *)
    | `package (* visible only in the current package *)
    ]
type hack_directive =
    [ `unsafe_cast
    | `fail
    | `tracker of PassTracker.t
    | `expand of Big_int.big_int option
    | `compiletime of string (* see pass_CompileTimeDirective *)
    | `opacapi (* see Opacapi, and checkopacapi *)
    ]
type type_directive =
    [ `coerce
    | `unsafe_cast
    | `nonexpansive
    | `opensums
    | `openrecord
    | `module_
    | `module_field_lifting
    | `warncoerce
    ]
type other_directive =
    [ `fun_action
    | `js_ident
    | `sliced_expr (** the expressions is a two elements containing first the client expression and then the server expression *)
    | `llarray
        (** cf doc in QmlAst *)
    | `recval (** see QmlAst *)
    ]
type alpha_renaming_directive =
    [ `open_ (** not used anymore *)
    | `toplevel_open
    | `module_
    | `toplevel
    ]

(**
path * access
*)
type documentation_directive =
    [ `doctype of string list * QmlAst.doctype_access_directive ]

type opavalue_directive = [
| `stringifier
| `comparator
| `serializer
| `xmlizer
]

type closure_instrumentation_directive = QmlAst.closure_instrumentation_directive

type basic_directive =
    [ magic_directive
    | string_directive
    | internationalization_directive
    | coding_directive
    | error_directive
    | concurrency_directive
    | file_inclusion_directive
    | hack_directive
    | type_directive
    | other_directive
    | documentation_directive
    | insert_server_directive
    | opavalue_directive
    | `create_lazy_record
    | distribution_directive
    | closure_instrumentation_directive
    ]
(** these directives are the ones that are not taken care of in the surfaceAst
they go straight to qml (or fail at the conversion when not implemented)
If you are adding a directive that needs to go though opa to be taken care of
in qml, it must end up in this type
*)



type dependency_directive =
    [ basic_directive
    | access_directive
    | `local of uids ]

type renaming_directive =
    [ access_directive
    | basic_directive
    | alpha_renaming_directive ]
type parsing_directive =
    [ `xml_parser of (string, parsing_directive) expr xml_parser
    | `parser_ of (string, parsing_directive) expr Trx_ast.expr
    | renaming_directive ]

type all_directives =
    [ parsing_directive
    | dependency_directive
    | renaming_directive ]
Something went wrong with that request. Please try again.