pax_global_header00006660000000000000000000000064144217506710014521gustar00rootroot0000000000000052 comment=e70df92bf649771b7197a6efb1a9d1ee8f498c13 ppx_optcomp-0.16.0/000077500000000000000000000000001442175067100141555ustar00rootroot00000000000000ppx_optcomp-0.16.0/.gitignore000066400000000000000000000000411442175067100161400ustar00rootroot00000000000000_build *.install *.merlin _opam ppx_optcomp-0.16.0/CHANGES.md000066400000000000000000000017361442175067100155560ustar00rootroot00000000000000## v0.11 - Completly changed the syntax to make this a proper ppx (and not a -pp as it previously was). The old syntax is now available in `ppx_optcomp_old`. - Depend on ppxlib instead of (now deprecated) ppx\_core and ppx\_driver. ## 113.43.00 - Make it easier to share a .h and .mlh Ppx_optcomp was modified to accept `defined(X)` only if `X` has been seen, either in a `#define` or `#undef`. This allow to share config.h files between C and OCaml and still be protected against typos in .ml files. ## 113.33.00 - Install standalone ppx-optcomp program that can be run through `-pp` ## 113.24.00 - Change the way optcomp resolve filenames in #import directives Do the same as cpp, i.e. for relative filenames, consider they are relative to the directory of the file being parsed. This doesn't matter internally as build commands are always executed from the current directory, but it matters for the public release as everything is executed from the root. ppx_optcomp-0.16.0/CONTRIBUTING.md000066400000000000000000000044101442175067100164050ustar00rootroot00000000000000This repository contains open source software that is developed and maintained by [Jane Street][js]. Contributions to this project are welcome and should be submitted via GitHub pull requests. Signing contributions --------------------- We require that you sign your contributions. Your signature certifies that you wrote the patch or otherwise have the right to pass it on as an open-source patch. The rules are pretty simple: if you can certify the below (from [developercertificate.org][dco]): ``` Developer Certificate of Origin Version 1.1 Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 1 Letterman Drive Suite D4700 San Francisco, CA, 94129 Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Developer's Certificate of Origin 1.1 By making a contribution to this project, I certify that: (a) The contribution was created in whole or in part by me and I have the right to submit it under the open source license indicated in the file; or (b) The contribution is based upon previous work that, to the best of my knowledge, is covered under an appropriate open source license and I have the right under that license to submit that work with modifications, whether created in whole or in part by me, under the same open source license (unless I am permitted to submit under a different license), as indicated in the file; or (c) The contribution was provided directly to me by some other person who certified (a), (b) or (c) and I have not modified it. (d) I understand and agree that this project and the contribution are public and that a record of the contribution (including all personal information I submit with it, including my sign-off) is maintained indefinitely and may be redistributed consistent with this project or the open source license(s) involved. ``` Then you just add a line to every git commit message: ``` Signed-off-by: Joe Smith ``` Use your real name (sorry, no pseudonyms or anonymous contributions.) If you set your `user.name` and `user.email` git configs, you can sign your commit automatically with git commit -s. [dco]: http://developercertificate.org/ [js]: https://opensource.janestreet.com/ ppx_optcomp-0.16.0/LICENSE.md000066400000000000000000000021461442175067100155640ustar00rootroot00000000000000The MIT License Copyright (c) 2015--2023 Jane Street Group, LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ppx_optcomp-0.16.0/Makefile000066400000000000000000000004031442175067100156120ustar00rootroot00000000000000INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) default: dune build install: dune install $(INSTALL_ARGS) uninstall: dune uninstall $(INSTALL_ARGS) reinstall: uninstall install clean: dune clean .PHONY: default install uninstall reinstall clean ppx_optcomp-0.16.0/README.md000066400000000000000000000111011442175067100154260ustar00rootroot00000000000000ppx_optcomp - Optional compilation for OCaml ============================================ ppx\_optcomp stands for Optional Compilation. It is a tool used to handle optional compilations of pieces of code depending of the word size, the version of the compiler, ... The syntax is based on OCaml item extension nodes, with keywords similar to cpp. ```ocaml [%%if ocaml_version < (4, 02, 0)] let x = 1 [%%else] let y = 2 [%%endif] ``` Syntax ------ ppx\_optcomp is implemented using ppx_driver and operates on ocaml AST. This means that whole file needs to be grammatically correct ocaml. The general syntax is: ``` [%%keyword expression] ``` Most of the statements are only supported on the toplevel. See [grammar description](http://caml.inria.fr/pub/docs/manual-ocaml/extn.html#sec248) for detailed information where ```[%% ]``` directives may be placed. Note in particular that the item extensions cannot be placed inside an expression, and this would result in syntax error. ```ocaml (* SYNTAX ERROR: let x = [%%if defined(abc) ] 1 [%%else] 2 [%%endif] *) ``` Additional syntax is provided for optional type variant declaration, as in ```ocaml type t = | FOO | BAR [@if ocaml_version < (4, 02, 0)] ``` Directives ---------- ### Defining variables - `[%%define` _identifier_ _expression_`]` - `[%%undef` _identifier_`]` We also allow: `[%%define` _identifier_`]`. This will define _identifier_ to `()`. The undefined identifiers are not valid in subsequent expressions, but for expression `defined(`_identifier_`)`, which evaluates to false. The scope of identifiers follows the same scoping rules as OCaml variables. For instance: ```ocaml (* [x] is undefined *) [%%define x 0] (* [x] is bound to [0] *) module A = struct (* [x] is bound to [0] *) [%%define x 42] (* [x] is bound to [42] *) end (* [x] is bound to [0] *) ``` ### Conditionals The following directives are available for conditional compilations: - `[%%if` _expression_`]` - `[%%elif` _expression_`]` - `[%%else]` - `[%%endif]` - `[@if` _expression_`]` In all cases _expression_ must be an expression that evaluates to a boolean value. Ppx\_optcomp will fail if it is not the case. Pseudo-function `defined(`_identifier_`)` may be then used in expressions to check whether a given identifier has been defined. Note that identifiers that were not defined or undefined beforehand are assumed to be a typo, and therefore are rejected, with a notable exception of ``` [%%ifndef FOO] [%%define FOO] ``` which is allowed even if `FOO` was not seen before. The last form may be used only in type-variant definitions and pattern matching, following constructors which are to be optional. If you need a few constructors under the same condition, you need to copy the directive multiple times, sorry. ``` type t = | A of int | B of int * int [@if ocaml >= 4.04] ... match (v: t) with | A x -> something x | B (y,z) [@if ocaml >= 4.04] -> something' y z ``` ### Warnings and errors `[%%warning _string_]` will cause the pre-processor to print a message on stderr. `[%%error _string_]` will cause the pre-processor to fail with the following error message. Note that in both cases _expression_ can be an arbitrary expression. ### Imports Ppx\_optcomp allows one to import another file using: `[%%import` _filename_`]` where _filename_ is a string constant. Filenames to import are resolved as follow: - if _filename_ is relative, i.e. doesn't start with `/`, it is considered as relative to the directory of the file being parsed - if _filename_ is absolute, i.e. starts with `/`, it is used as is Only optcomp directives are allowed in the imported files. The intended use is including some configuration variables at the beginning of a file: ```ocaml [%%import "config.mlh"] ``` If imported file's extension is `.h`, an alternate C-like syntax is expected in the file. This is to allow importing both from C and OCaml single configuration file like: ``` #ifndef CONFIG_H #define CONFIG_H #define FOO #undef BAR #define BAZ 3*3 + 3 #endif ``` Expressions and patterns ------------------------ ppx\_optcomp supports a subset of OCaml expressions and patterns: - literals: integers, characters and strings - tuples - `true` and `false` - let-bindings - pattern matching And it provides the following functions: - comparison operators: `=`, `<`, ... - boolean operators: `||`, `&&`, `not`, ... - arithmetic operators: `+`, `-`, `*`, `/` - `min` and `max` - `fst` and `snd` - conversion functions: `to_int`, `to_string`, `to_char`, `to_bool` - `defined`, `not_defined`: check whether a variable is defined - `show`: act as identity, but pretty-print a value to stderr ppx_optcomp-0.16.0/dune000066400000000000000000000000001442175067100150210ustar00rootroot00000000000000ppx_optcomp-0.16.0/dune-project000066400000000000000000000000201442175067100164670ustar00rootroot00000000000000(lang dune 1.10)ppx_optcomp-0.16.0/ppx_optcomp.opam000066400000000000000000000013631442175067100174060ustar00rootroot00000000000000opam-version: "2.0" version: "v0.16.0" maintainer: "Jane Street developers" authors: ["Jane Street Group, LLC"] homepage: "https://github.com/janestreet/ppx_optcomp" bug-reports: "https://github.com/janestreet/ppx_optcomp/issues" dev-repo: "git+https://github.com/janestreet/ppx_optcomp.git" doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/ppx_optcomp/index.html" license: "MIT" build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ "ocaml" {>= "4.14.0"} "base" {>= "v0.16" & < "v0.17"} "stdio" {>= "v0.16" & < "v0.17"} "dune" {>= "2.0.0"} "ppxlib" {>= "0.28.0"} ] available: arch != "arm32" & arch != "x86_32" synopsis: "Optional compilation for OCaml" description: " Part of the Jane Street's PPX rewriters collection. " ppx_optcomp-0.16.0/src/000077500000000000000000000000001442175067100147445ustar00rootroot00000000000000ppx_optcomp-0.16.0/src/cparser.ml000066400000000000000000000074121442175067100167410ustar00rootroot00000000000000(* Parser for directives in C-like syntax, rewriting them into extensions, like ones we would get from parsing OCaml file. *) module Unshadow = struct module Parser = Parser end open Ppxlib open Unshadow module Parsing = Stdlib.Parsing type lexer = Lexing.lexbuf -> Parser.token (* +---------------------------------------------------------------+ | Parsing of directives | +---------------------------------------------------------------+ *) let located x lexbuf = { Location. txt = x ; loc = Location.of_lexbuf lexbuf } ;; let parse parsing_fun lexer lexbuf = try parsing_fun lexer lexbuf with Parsing.Parse_error | Syntaxerr.Escape_error -> let loc = Location.of_lexbuf lexbuf in raise (Syntaxerr.Error(Syntaxerr.Other loc)) ;; let fetch_directive_argument (lexer : lexer) lexbuf = let rec loop acc (brackets : Parser.token list) = match lexer lexbuf, brackets with | EOF, _ | EOL, [] -> located Parser.EOF lexbuf :: acc | (EOL | COMMENT _), _ -> loop acc brackets | token, _ -> let acc = located token lexbuf :: acc in match token, brackets with | BEGIN , _ -> loop acc (END :: brackets) | DO , _ -> loop acc (DONE :: brackets) | LPAREN , _ -> loop acc (RPAREN :: brackets) | LBRACE , _ -> loop acc (RBRACE :: brackets) | LBRACELESS , _ -> loop acc (GREATERRBRACE :: brackets) | LBRACKETLESS , _ -> loop acc (GREATERRBRACKET :: brackets) | LBRACKETBAR , _ -> loop acc (BARRBRACKET :: brackets) | (LBRACKET | LBRACKETGREATER | LBRACKETPERCENT | LBRACKETPERCENTPERCENT | LBRACKETAT | LBRACKETATAT | LBRACKETATATAT), _ -> loop acc (RBRACKET :: brackets) | _, closing :: brackets when token = closing -> loop acc brackets | _ -> loop acc brackets in let start_pos = Lexing.lexeme_end_p lexbuf in match loop [] [] |> List.rev with | [] -> None | tokens -> let tokens = ref tokens in let fake_lexer (lexbuf : Lexing.lexbuf) : Parser.token = match !tokens with | [] -> EOF | token :: rest -> tokens := rest; lexbuf.lex_start_p <- token.loc.loc_start; lexbuf.lex_curr_p <- token.loc.loc_end; token.txt in let fake_lexbuf = Lexing.from_function (fun _ _ -> assert false) in fake_lexbuf.lex_curr_p <- start_pos; match Parse.Of_ocaml.copy_structure (parse Parser.implementation fake_lexer fake_lexbuf) with | [] -> None | [st] -> assert_no_attributes_in#structure_item st; Some st | _ :: st :: _ -> Location.raise_errorf ~loc:st.pstr_loc "optcomp: too many structure items" ;; let parse_directive (lexer : lexer) lexbuf : ('a Token.t) = let token = located (lexer lexbuf) lexbuf in let arg = fetch_directive_argument lexer lexbuf in let loc = { token.loc with loc_end = Lexing.lexeme_end_p lexbuf } in let payload = match arg with | Some st_item -> PStr [st_item] | None -> PStr [] in match token.txt with | IF -> Token.make_directive "if" loc payload | ELSE -> Token.make_directive "else" loc payload | LIDENT s -> Token.make_directive s loc payload | _ -> Location.raise_errorf ~loc "optcomp: unknown token" let parse_loop lexbuf = let is_beginning_of_line lexbuf = let pos = Lexing.lexeme_start_p lexbuf in pos.pos_cnum = pos.pos_bol in let rec parse_loop_aux acc = match Lexer.token_with_comments lexbuf with | HASH when is_beginning_of_line lexbuf -> let acc = parse_directive Lexer.token_with_comments lexbuf :: acc in parse_loop_aux acc | EOF -> acc | _ -> parse_loop_aux acc in List.rev (parse_loop_aux []) ppx_optcomp-0.16.0/src/dune000066400000000000000000000002341442175067100156210ustar00rootroot00000000000000(library (name ppx_optcomp) (public_name ppx_optcomp) (libraries compiler-libs.common base ppxlib stdio) (kind ppx_deriver) (preprocess no_preprocessing))ppx_optcomp-0.16.0/src/interpreter.ml000066400000000000000000000362211442175067100176450ustar00rootroot00000000000000open Base open Ppxlib open Ast_builder.Default module Filename = Stdlib.Filename module Parsing = Stdlib.Parsing module Type = struct type t = | Var of string | Bool | Int | Char | String | Tuple of t list let rec to_string = function | Var v -> "'" ^ v | Bool -> "bool" | Int -> "int" | Char -> "char" | String -> "string" | Tuple l -> "(" ^ String.concat ~sep:" * " (List.map l ~f:to_string) ^ ")" end module Value = struct type t = | Bool of bool | Int of int | Char of char | String of string | Tuple of t list let ocaml_version = Stdlib.Scanf.sscanf Stdlib.Sys.ocaml_version "%d.%d.%d" (fun major minor patchlevel -> Tuple [Int major; Int minor; Int patchlevel]) ;; let os_type = String Stdlib.Sys.os_type ;; let config_bool name = Bool (Ocaml_common.Config.config_var name |> Option.map ~f:Bool.of_string |> Option.value ~default:false) ;; let flambda_backend = config_bool "flambda_backend";; let flambda2 = config_bool "flambda2";; let host_is_i386 = Bool (Ocaml_common.Config.config_var "architecture" |> Option.map ~f:(fun arch -> String.equal arch "i386") |> Option.value ~default:false) let rec to_expression loc t = match t with | Bool x -> ebool ~loc x | Int x -> eint ~loc x | Char x -> echar ~loc x | String x -> estring ~loc x | Tuple [] -> eunit ~loc | Tuple [x] -> to_expression loc x | Tuple l -> pexp_tuple ~loc (List.map l ~f:(to_expression loc)) ;; let rec to_pattern loc t = match t with | Bool x -> pbool ~loc x | Int x -> pint ~loc x | Char x -> pchar ~loc x | String x -> pstring ~loc x | Tuple [] -> punit ~loc | Tuple [x] -> to_pattern loc x | Tuple l -> ppat_tuple ~loc (List.map l ~f:(to_pattern loc)) ;; let to_string_pretty v = let e = to_expression Location.none v in Pprintast.string_of_expression e let to_string v = let buf = Buffer.create 128 in let rec aux = function | Bool b -> Buffer.add_string buf (Bool.to_string b) | Int n -> Buffer.add_string buf (Int.to_string n) | Char ch -> Buffer.add_char buf ch | String s -> Buffer.add_string buf s; | Tuple [] -> Buffer.add_string buf "()" | Tuple (x :: l) -> Buffer.add_char buf '('; aux x; List.iter l ~f:(fun x -> Buffer.add_string buf ", "; aux x); Buffer.add_char buf ')' in aux v; Buffer.contents buf ;; let rec type_ : t -> Type.t = function | Bool _ -> Bool | Int _ -> Int | Char _ -> Char | String _ -> String | Tuple l -> Tuple (List.map l ~f:type_) ;; end module Env : sig type t val init : t val empty : t val add : t -> var:string Location.loc -> value:Value.t -> t val undefine : t -> string Location.loc -> t val of_list : (string Location.loc * Value.t) list -> t val eval : t -> string Location.loc -> Value.t val is_defined : ?permissive:bool -> t -> string Location.loc -> bool val seen : t -> string Location.loc -> bool val to_expression : t -> expression end = struct type var_state = | Defined of Value.t | Undefined type entry = { loc : Location.t (** Location at which it was defined/undefined *) ; state : var_state } type t = entry Map.M(String).t let empty = Map.empty (module String) let to_expression t = pexp_apply ~loc:Location.none (evar ~loc:Location.none "env") (List.map (Map.to_alist t) ~f:(fun (var, { loc; state }) -> (Labelled var, match state with | Defined v -> pexp_construct ~loc { txt = Lident "Defined"; loc } (Some (Value.to_expression loc v)) | Undefined -> pexp_construct ~loc { txt = Lident "Undefined"; loc } None))) let seen t (var : _ Loc.t) = Map.mem t var.txt let add t ~(var:_ Loc.t) ~value = Map.set t ~key:var.txt ~data:{ loc = var.loc; state = Defined value } ;; let undefine t (var : _ Loc.t) = Map.set t ~key:var.txt ~data:{ loc = var.loc; state = Undefined } ;; let of_list l = List.fold_left l ~init:empty ~f:(fun acc (var, value) -> add acc ~var ~value) ;; let init = of_list [ { loc = Location.none ; txt = "ocaml_version" }, Value.ocaml_version ; { loc = Location.none ; txt = "os_type" }, Value.os_type ; { loc = Location.none ; txt = "flambda_backend" }, Value.flambda_backend ; { loc = Location.none ; txt = "flambda2" }, Value.flambda2 ; { loc = Location.none ; txt = "host_is_i386" }, Value.host_is_i386 ] let short_loc_string (loc : Location.t) = Printf.sprintf "%s:%d" loc.loc_start.pos_fname loc.loc_start.pos_lnum ;; let eval (t : t) (var:string Loc.t) = match Map.find t var.txt with | Some { state = Defined v; loc = _ } -> v | Some { state = Undefined; loc } -> Location.raise_errorf ~loc:var.loc "optcomp: %s is undefined (undefined at %s)" var.txt (short_loc_string loc) | None -> Location.raise_errorf ~loc:var.loc "optcomp: unbound value %s" var.txt ;; let is_defined ?(permissive=false) (t : t) (var:string Loc.t) = match Map.find t var.txt with | Some { state = Defined _; _ } -> true | Some { state = Undefined; _ } -> false | None -> if permissive then false else Location.raise_errorf ~loc:var.loc "optcomp: doesn't know about %s.\n\ You need to either define it or undefine it with #undef.\n\ Optcomp doesn't accept variables it doesn't know about to avoid typos." var.txt ;; end (* +-----------------------------------------------------------------+ | Expression evaluation | +-----------------------------------------------------------------+ *) let invalid_type loc expected real = Location.raise_errorf ~loc "optcomp: this expression has type %s but is used with type %s" (Type.to_string real) (Type.to_string expected) ;; let var_of_lid (id : _ Located.t) = match Longident.flatten_exn id.txt with | l -> { id with txt = String.concat ~sep:"." l } | exception _ -> Location.raise_errorf ~loc:id.loc "optcomp: invalid variable name" ;; let cannot_convert loc dst x = Location.raise_errorf ~loc "cannot convert %s to %s" (Value.to_string_pretty x) dst ;; let convert_from_string loc dst f x = try f x with _ -> Location.raise_errorf ~loc "optcomp: cannot convert %S to %s" x dst ;; exception Pattern_match_failure of pattern * Value.t let lid_of_expr e = match e.pexp_desc with | Pexp_ident id | Pexp_construct (id, None) -> id | _ -> Location.raise_errorf ~loc:e.pexp_loc "optcomp: identifier expected" ;; let var_of_expr e = var_of_lid (lid_of_expr e) let not_supported e = Location.raise_errorf ~loc:e.pexp_loc "optcomp: expression not supported" ;; let parse_int loc x = match Int.of_string x with | v -> v | exception _ -> Location.raise_errorf ~loc "optcomp: invalid integer" ;; let rec eval env e : Value.t = let loc = e.pexp_loc in match e.pexp_desc with | Pexp_constant (Pconst_integer (x, None)) -> Int (parse_int loc x) | Pexp_constant (Pconst_char x ) -> Char x | Pexp_constant (Pconst_string (x, _, _)) -> String x | Pexp_construct ({ txt = Lident "true" ; _ }, None) -> Bool true | Pexp_construct ({ txt = Lident "false"; _ }, None) -> Bool false | Pexp_construct ({ txt = Lident "()" ; _ }, None) -> Tuple [] | Pexp_tuple l -> Tuple (List.map l ~f:(eval env)) | Pexp_ident id | Pexp_construct (id, None) -> Env.eval env (var_of_lid id) | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident s; _ }; _ }, args) -> begin let args = List.map args ~f:(fun (l, x) -> match l with Nolabel -> x | _ -> not_supported e) in match s, args with | "=" , [x; y] -> eval_cmp env Poly.( = ) x y | "<" , [x; y] -> eval_cmp env Poly.( < ) x y | ">" , [x; y] -> eval_cmp env Poly.( > ) x y | "<=" , [x; y] -> eval_cmp env Poly.( <= ) x y | ">=" , [x; y] -> eval_cmp env Poly.( >= ) x y | "<>" , [x; y] -> eval_cmp env Poly.( <> ) x y | "min", [x; y] -> eval_poly2 env Poly.min x y | "max", [x; y] -> eval_poly2 env Poly.max x y | "+" , [x; y] -> eval_int2 env ( + ) x y | "-" , [x; y] -> eval_int2 env ( - ) x y | "*" , [x; y] -> eval_int2 env ( * ) x y | "/" , [x; y] -> eval_int2 env ( / ) x y | "mod", [x; y] -> eval_int2 env Stdlib.( mod ) x y | "not", [x] -> Bool (not (eval_bool env x)) | "||" , [x; y] -> eval_bool2 env ( || ) x y | "&&" , [x; y] -> eval_bool2 env ( && ) x y | "^" , [x; y] -> eval_string2 env ( ^ ) x y | "fst", [x] -> fst (eval_pair env x) | "snd", [x] -> snd (eval_pair env x) | "to_string", [x] -> String (Value.to_string (eval env x)) | "to_int", [x] -> Int (match eval env x with | String x -> convert_from_string loc "int" Int.of_string x | Int x -> x | Char x -> Char.to_int x | Bool _ | Tuple _ as x -> cannot_convert loc "int" x) | "to_bool", [x] -> Bool (match eval env x with | String x -> convert_from_string loc "bool" Bool.of_string x | Bool x -> x | Int _ | Char _ | Tuple _ as x -> cannot_convert loc "bool" x) | "to_char", [x] -> Char (match eval env x with | String x -> convert_from_string loc "char" (fun s -> assert (String.length s = 1); s.[0]) x | Char x -> x | Int x -> begin match Char.of_int x with | Some x -> x | None -> Location.raise_errorf ~loc "optcomp: cannot convert %d to char" x end | Bool _ | Tuple _ as x -> cannot_convert loc "char" x) | "show", [x] -> let v = eval env x in let ppf = Stdlib.Format.err_formatter in let pprinted = Value.to_string_pretty v in Stdlib.Format.fprintf ppf "%a:@.SHOW %s@." Location.print loc pprinted; v | "defined", [x] -> Bool (Env.is_defined env (var_of_expr x)) | "not_defined", [x] -> Bool (not (Env.is_defined env (var_of_expr x))) | "not_defined_permissive", [x] -> Bool (not ( Env.is_defined ~permissive:true env (var_of_expr x))) | _ -> not_supported e end (* Let-binding *) | Pexp_let (Nonrecursive, vbs, e) -> let env = List.fold_left vbs ~init:env ~f:(fun new_env vb -> let v = eval env vb.pvb_expr in do_bind new_env vb.pvb_pat v) in eval env e (* Pattern matching *) | Pexp_match (e, cases) -> let v = eval env e in let rec loop = function | [] -> Location.raise_errorf ~loc "optcomp: cannot match %s against any of the cases" (Value.to_string v) | case :: rest -> match bind env case.pc_lhs v with | exception Pattern_match_failure _ -> loop rest | env -> let guard_ok = match case.pc_guard with | None -> true | Some e -> eval_bool env e in if guard_ok then eval env case.pc_rhs else loop rest in loop cases | _ -> not_supported e and bind env patt value = let loc = patt.ppat_loc in match patt.ppat_desc, value with | Ppat_any, _ -> env | Ppat_constant (Pconst_integer (x, None)), Int y when parse_int loc x = y -> env | Ppat_constant (Pconst_char x ), Char y when Char.equal x y -> env | Ppat_constant (Pconst_string (x, _, _)), String y when String.equal x y -> env | Ppat_construct ({ txt = Lident "true" ; _ }, None), Bool true -> env | Ppat_construct ({ txt = Lident "false"; _ }, None), Bool false -> env | Ppat_construct ({ txt = Lident "()" ; _ }, None), Tuple [] -> env | Ppat_var var, _ -> Env.add env ~var ~value | Ppat_construct (id, None), _ -> Env.add env ~var:(var_of_lid id) ~value | Ppat_alias (patt, var), _ -> Env.add (bind env patt value) ~var ~value | Ppat_tuple x, Tuple y when List.length x = List.length y -> Stdlib.ListLabels.fold_left2 x y ~init:env ~f:bind | _ -> raise (Pattern_match_failure (patt, value)) and do_bind env patt value = try bind env patt value with Pattern_match_failure (pat, v) -> Location.raise_errorf ~loc:pat.ppat_loc "Cannot match %s with this pattern" (Value.to_string_pretty v) and eval_same env ex ey = let vx = eval env ex and vy = eval env ey in let tx = Value.type_ vx and ty = Value.type_ vy in if Poly.equal tx ty then (vx, vy) else invalid_type ey.pexp_loc tx ty and eval_int env e = match eval env e with | Int x -> x | v -> invalid_type e.pexp_loc Int (Value.type_ v) and eval_bool env e = match eval env e with | Bool x -> x | v -> invalid_type e.pexp_loc Bool (Value.type_ v) and eval_string env e = match eval env e with | String x -> x | v -> invalid_type e.pexp_loc String (Value.type_ v) and eval_pair env e = match eval env e with | Tuple [x; y] -> (x, y) | v -> invalid_type e.pexp_loc (Tuple [Var "a"; Var "b"]) (Value.type_ v) and eval_int2 env f a b = let a = eval_int env a in let b = eval_int env b in Int (f a b) and eval_bool2 env f a b = let a = eval_bool env a in let b = eval_bool env b in Bool (f a b) and eval_string2 env f a b = let a = eval_string env a in let b = eval_string env b in String (f a b) and eval_cmp env f a b = let a, b = eval_same env a b in Bool (f a b) and eval_poly2 env f a b = let a, b = eval_same env a b in f a b (* +-----------------------------------------------------------------+ | Environment serialization | +-----------------------------------------------------------------+ *) module EnvIO = struct let to_expression = Env.to_expression let of_expression expr = Ast_pattern.parse Ast_pattern.(pexp_apply (pexp_ident (lident (string "env"))) __) expr.pexp_loc expr (fun args -> List.fold args ~init:Env.empty ~f:(fun env arg -> match arg with | Labelled var, { pexp_desc = Pexp_construct ({txt=Lident "Defined"; _}, Some e) ; pexp_loc = loc ; _ } -> Env.add env ~var:{ txt = var; loc } ~value:(eval Env.empty e) | Labelled var, { pexp_desc = Pexp_construct ({txt=Lident "Undefined"; _}, None) ; pexp_loc = loc ; _ } -> Env.undefine env { txt = var; loc } | _, e -> Location.raise_errorf ~loc:e.pexp_loc "ppx_optcomp: invalid cookie")) end ppx_optcomp-0.16.0/src/ppx_optcomp.ml000066400000000000000000000403441442175067100176530ustar00rootroot00000000000000open Base open Stdio open Ppxlib open Ast_builder.Default module Filename = Stdlib.Filename module Env = Interpreter.Env module Value = Interpreter.Value module Of_item = struct (* boilerplate code to pull extensions out of different ast nodes *) open Token let directive_or_block_of_ext ~item ({ txt = ext_name; loc }, payload) attrs = match Directive.of_string_opt ext_name with | None -> (* not one of our extensions *) Block [item] | Some dir -> assert_no_attributes attrs; Directive (dir, loc, payload) let structure item = match item.pstr_desc with | Pstr_extension (ext, attrs) -> directive_or_block_of_ext ~item ext attrs | _ -> Block [item] let signature item = match item.psig_desc with | Psig_extension (ext, attrs) -> directive_or_block_of_ext ~item ext attrs | _ -> Block [item] let class_structure item = match item.pcf_desc with | Pcf_extension ext -> directive_or_block_of_ext ~item ext [] | _ -> Block [item] let class_signature item = match item.pctf_desc with | Pctf_extension ext -> directive_or_block_of_ext ~item ext [] | _ -> Block [item] end module Ast_utils = struct let get_expr ~loc payload = match payload with | PStr [{ pstr_desc = Pstr_eval (e, attrs); _ }] -> assert_no_attributes attrs; e | _ -> Location.raise_errorf ~loc "optcomp: invalid directive syntax, expected single expression." let assert_no_arguments ~loc payload = match payload with | PStr [] -> () | _ -> Location.raise_errorf ~loc "optcomp: invalid directive syntax, expected no arguments." let make_apply_fun ~loc name expr = let iname = { txt = Lident name; loc } in eapply ~loc (pexp_ident ~loc iname) [expr] let get_ident ~loc payload = let e = get_expr ~loc payload in Interpreter.lid_of_expr e let get_var ~loc payload = let e = get_expr ~loc payload in Interpreter.var_of_expr e let get_var_expr ~loc payload = let apply_e = get_expr ~loc payload in match apply_e.pexp_desc with | Pexp_apply (var_e, [Nolabel, val_e]) -> Interpreter.var_of_expr var_e, Some val_e | Pexp_construct (var_li, Some val_e) -> Interpreter.var_of_lid var_li, Some val_e | Pexp_apply (var_e, []) -> Interpreter.var_of_expr var_e, None | Pexp_construct (var_li, None) -> Interpreter.var_of_lid var_li, None | _ -> Location.raise_errorf ~loc "optcomp: invalid directive syntax, expected var and expr" let get_string ~loc payload = let e = get_expr ~loc payload in match e with | { pexp_desc = Pexp_constant (Pconst_string (x, _, _)); _ } -> x | _ -> Location.raise_errorf ~loc "optcomp: invalid directive syntax, expected string" end module Token_stream : sig type 'a t = 'a Token.t list val of_items : 'a list -> of_item:('a -> 'a Token.t) -> 'a t end = struct type 'a t = 'a Token.t list type ftype = Ocaml | C let resolve_import ~loc ~filename : string * ftype = let ext = Filename.extension (Filename.basename filename) in let ftype = match ext with | ".ml" | ".mlh" -> Ocaml | ".h" -> C | _ -> Location.raise_errorf ~loc "optcomp: unknown file extension: %s\n\ Must be one of: .ml, .mlh or .h." ext in let fbase = Filename.dirname loc.loc_start.pos_fname in let fpath = if Filename.is_relative filename then Filename.concat fbase filename else filename in (fpath, ftype) let import_open ~loc payload = let filename = Ast_utils.get_string ~loc payload in let fpath, ftype = resolve_import ~loc ~filename in let in_ch = try In_channel.create fpath with exn -> let msg = match exn with | Sys_error msg -> msg | _ -> Exn.to_string exn in Location.raise_errorf ~loc "optcomp: cannot open imported file: %s: %s" fpath msg in (* disable old optcomp on imported files, or it consumes all variables :( *) Lexer.set_preprocessor (fun () -> ()) (fun x -> x); let lexbuf = Lexing.from_channel in_ch in lexbuf.lex_curr_p <- { pos_fname = fpath; pos_lnum = 1; pos_bol = 0; pos_cnum = 0 }; in_ch, lexbuf, ftype let unroll (stack : 'a Token.t list) : ('a Token.t * 'a Token.t list) = let bs, _, rest_rev = List.fold stack ~init:([], false, []) ~f:(fun (bs, found, rest) x -> match x, found with | Block b, false -> b @ bs, false, rest | _ -> bs, true, x :: rest ) in Block bs, List.rev rest_rev let rec of_items : 'a. 'a list -> of_item:('a -> 'a Token.t) -> 'a t = fun items ~of_item -> let of_items_st x = of_items ~of_item:Of_item.structure x in let tokens_rev = List.fold items ~init:[] ~f:(fun acc item -> match of_item item with | Directive (dir, loc, payload) as token -> let last_block, rest = unroll acc in begin match dir with | Import -> let in_ch, lexbuf, ftype = import_open ~loc payload in let new_tokens = match ftype with | C -> Cparser.parse_loop lexbuf | Ocaml -> let st_items = Parse.implementation lexbuf in Token.just_directives_exn ~loc (of_items_st st_items) in In_channel.close in_ch; List.rev new_tokens @ (last_block :: rest) | _ -> token :: last_block :: rest end | _ -> begin match acc with | Block items :: acc -> Block (items @ [item]) :: acc | _ -> Block [item] :: acc end ) in List.rev tokens_rev end module Meta_ast : sig type 'a t val of_tokens : 'a Token.t list -> 'a t val eval : drop_item:('a -> unit) -> eval_item:(Env.t -> 'a -> 'a) -> env:Env.t -> 'a t -> Env.t * 'a list val attr_mapper : to_loc:('a -> location) -> to_attrs:('a -> attributes) -> replace_attrs:('a -> attributes -> 'a) -> env:Env.t -> 'a -> 'a option end = struct open Ast_utils type 'a t = | Leaf of 'a list | If of expression * 'a t * 'a t | Block of 'a t list | Define of string Location.loc * expression option | Undefine of string Location.loc | Import of string Location.loc | Error of string Location.loc | Warning of string Location.loc type 'a partial_if = | EmptyIf of ('a t -> 'a t -> 'a t) (* [If] waiting for both blocks *) | PartialIf of ('a t -> 'a t) (* [If] waiting for else block *) type 'a temp_ast = | Full of 'a t | Partial of 'a partial_if loc let deprecated_ifs ~loc = Location.raise_errorf ~loc "optcomp: elif(n)def is deprecated, use elif defined()." let unroll_exn ~loc (acc:'a temp_ast list) : ('a t * 'a partial_if * 'a temp_ast list) = (* split by first EmptyIf/PartialIf *) let pre, if_fun, post = List.fold acc ~init:([], None, []) ~f:( fun (pre, found, post) x -> match found with | Some _ -> pre, found, x::post | None -> match x with | Partial { txt = f; _} -> pre, Some f, post | Full ast -> ast::pre, None, post ) in match if_fun with | None -> Location.raise_errorf ~loc "optcomp: else/endif/elif outside of if" | Some f -> Block pre, f, List.rev post let make_if ~loc cond = let if_fun ast1 ast2 = If (cond, ast1, ast2) in Partial { txt = (EmptyIf if_fun); loc } let of_tokens (tokens: 'a Token.t list) : ('a t) = let pre_parsed = List.fold tokens ~init:([] : 'a temp_ast list) ~f:(fun acc token -> match token with | Token.Block [] -> acc | Token.Block b -> Full (Leaf b) :: acc | Token.Directive (dir, loc, payload) -> match dir with | If -> make_if ~loc (get_expr ~loc payload) :: acc | Endif -> assert_no_arguments ~loc payload; let (last_block, if_fun, tail) = unroll_exn ~loc acc in begin match if_fun with | PartialIf f -> Full (f last_block) :: tail | EmptyIf f -> Full (f last_block (Block [])) :: tail end | Elif -> let cond = get_expr ~loc payload in let (last_block, if_fun, tail) = unroll_exn ~loc acc in begin match if_fun with | EmptyIf f -> let new_if_fun ast1 ast2 = f last_block (If (cond, ast1, ast2)) in Partial { txt = (EmptyIf new_if_fun); loc } :: tail | PartialIf _ -> Location.raise_errorf ~loc "optcomp: elif after else clause." end | Else -> assert_no_arguments ~loc payload; let (last_block, if_fun, tail) = unroll_exn ~loc acc in begin match if_fun with | EmptyIf f -> Partial { txt = PartialIf (f last_block); loc } :: tail | PartialIf _ -> Location.raise_errorf ~loc "optcomp: second else clause." end | Define -> let ident, expr = get_var_expr ~loc payload in Full (Define (ident, expr)) :: acc | Undef -> Full (Undefine (get_var ~loc payload)) :: acc | Error -> Full (Error { txt = (get_string ~loc payload); loc }) :: acc | Warning -> Full (Warning { txt = (get_string ~loc payload); loc }) :: acc | Import -> Full (Import { txt = (get_string ~loc payload); loc }) :: acc | Ifdef -> let ident = pexp_ident ~loc (get_ident ~loc payload) in let expr = make_apply_fun ~loc "defined" ident in make_if ~loc expr :: acc | Ifndef -> let ident = pexp_ident ~loc (get_ident ~loc payload) in let expr = make_apply_fun ~loc "not_defined" ident in make_if ~loc expr :: acc | Elifdef -> deprecated_ifs ~loc | Elifndef -> deprecated_ifs ~loc ) in let extract_full = function | Full x -> x | Partial { loc; _ } -> Location.raise_errorf ~loc "optcomp: unterminated if" in Block (List.rev_map pre_parsed ~f:extract_full) let eval ~drop_item ~eval_item ~env ast = let rec drop ast = match ast with | Leaf l -> List.iter l ~f:drop_item | Block (ast::asts) -> drop ast; drop (Block asts) | If (cond, ast1, ast2) -> begin Attribute.explicitly_drop#expression cond; drop ast1; drop ast2 end | _ -> () in let rec aux_eval ~env (ast : 'a t) : (Env.t * 'a list list) = match ast with | Leaf l -> let l' = List.map l ~f:(eval_item env) in env, [l'] | Block (ast::asts) -> let (new_env, res) = aux_eval ~env ast in let (newer_env, ress) = aux_eval ~env:new_env (Block asts) in newer_env, res @ ress | Block [] -> env, [] | Define (ident, Some expr) -> Env.add env ~var:ident ~value:(Interpreter.eval env expr), [] | Define (ident, None) -> Env.add env ~var:ident ~value:(Value.Tuple []), [] | Undefine ident -> Env.undefine env ident, [] | Import { loc; _ } -> Location.raise_errorf ~loc "optcomp: import not supported in this context." | If (cond, ast1, ast2) -> let cond = (* Explicitely allow the following pattern: {[ [%%ifndef FOO] [%%define FOO] ]} *) match cond.pexp_desc, ast1 with | Pexp_apply ( { pexp_desc = Pexp_ident { txt = Lident "not_defined"; _ }; _ }, [Nolabel, ({ pexp_desc = Pexp_ident { txt = Lident i1; loc }; _ } as expr)] ), Block (Define ({ txt = i2; _}, None) :: _) when String.(=) i1 i2 -> make_apply_fun ~loc "not_defined_permissive" expr | _ -> cond in begin match (Interpreter.eval env cond) with | Bool b -> drop (if b then ast2 else ast1); aux_eval ~env (if b then ast1 else ast2) | v -> Location.raise_errorf ~loc:cond.pexp_loc "optcomp: if condition evaluated to non-bool: %s" (Value.to_string v) end | Error { loc; txt } -> Location.raise_errorf ~loc "%s" txt | Warning { txt; loc } -> let ppf = Stdlib.Format.err_formatter in Stdlib.Format.fprintf ppf "%a:@.Warning %s@." Location.print loc txt; env, [] in let new_env, res = aux_eval ~env ast in (new_env, List.join res) let attr_mapper ~to_loc ~to_attrs ~replace_attrs ~env item = let loc = to_loc item in let is_our_attribute { attr_name = { txt; _}; _ } = Token.Directive.matches txt ~expected:"if" in let our_as, other_as = List.partition_tf (to_attrs item) ~f:is_our_attribute in match our_as with | [] -> Some item | [{ attr_name = { loc; _}; attr_payload = payload; attr_loc = _; } as our_a] -> Attribute.mark_as_handled_manually our_a; begin match Interpreter.eval env (get_expr ~loc payload) with | Bool b -> if b then Some (replace_attrs item other_as) else None | v -> Location.raise_errorf ~loc "optcomp: if condition evaulated to non-bool: %s" (Value.to_string v) end | _ -> Location.raise_errorf ~loc "optcomp: multiple [@if] attributes are not allowed" end let rewrite ~drop_item ~eval_item ~of_item ~env (x : 'a list) : Env.t * 'a list = let tokens : ('a Token.t list) = Token_stream.of_items x ~of_item in let ast = Meta_ast.of_tokens tokens in Meta_ast.eval ~drop_item ~eval_item ~env ast ;; let map = object(self) inherit [Env.t] Ast_traverse.map_with_context as super method structure_gen env x = rewrite x ~env ~drop_item:Attribute.explicitly_drop#structure_item ~eval_item:self#structure_item ~of_item:Of_item.structure method signature_gen env x = rewrite x ~env ~drop_item:Attribute.explicitly_drop#signature_item ~eval_item:self#signature_item ~of_item:Of_item.signature method! structure env x = snd (self#structure_gen env x) method! signature env x = snd (self#signature_gen env x) method! class_structure env x = let _, rewritten = rewrite x.pcstr_fields ~env ~drop_item:Attribute.explicitly_drop#class_field ~eval_item:self#class_field ~of_item:Of_item.class_structure in { x with pcstr_fields = rewritten } method! class_signature env x = let _, rewritten = rewrite x.pcsig_fields ~env ~drop_item:Attribute.explicitly_drop#class_type_field ~eval_item:self#class_type_field ~of_item:Of_item.class_signature in { x with pcsig_fields = rewritten } method! type_kind env x = let x = match x with | Ptype_variant cs -> let f = Meta_ast.attr_mapper ~env ~to_loc:(fun c -> c.pcd_loc) ~to_attrs:(fun c -> c.pcd_attributes) ~replace_attrs:(fun c attrs -> {c with pcd_attributes = attrs}) in let filtered_cs = List.filter_map cs ~f in Ptype_variant filtered_cs | _ -> x in super#type_kind env x method! expression_desc env x = let f = Meta_ast.attr_mapper ~env ~to_loc:(fun c -> c.pc_lhs.ppat_loc) ~to_attrs:(fun c -> c.pc_lhs.ppat_attributes) ~replace_attrs:(fun ({ pc_lhs; _} as c) attrs -> {c with pc_lhs = { pc_lhs with ppat_attributes = attrs}} ) in let x = match x with | Pexp_function cs -> Pexp_function (List.filter_map cs ~f) | Pexp_match (e, cs) -> Pexp_match (super#expression env e, List.filter_map cs ~f) | Pexp_try (e, cs) -> Pexp_try (super#expression env e, List.filter_map cs ~f) | _ -> x in super#expression_desc env x end ;; (* Preserve the enrivonment between invocation using cookies *) let state = ref Env.init let () = Driver.Cookies.add_simple_handler "ppx_optcomp.env" Ast_pattern.__ ~f:(function | None -> state := Env.init | Some x -> state := Interpreter.EnvIO.of_expression x); Driver.Cookies.add_post_handler (fun cookies -> Driver.Cookies.set cookies "ppx_optcomp.env" (Interpreter.EnvIO.to_expression !state)) ;; let preprocess ~f x = let new_env, x = f !state x in state := new_env; x ;; let () = Driver.register_transformation "optcomp" ~preprocess_impl:(preprocess ~f:map#structure_gen) ~preprocess_intf:(preprocess ~f:map#signature_gen) ;; ppx_optcomp-0.16.0/src/token.ml000066400000000000000000000034631442175067100164240ustar00rootroot00000000000000open Base open Ppxlib module Directive = struct type t = If | Else | Elif | Endif | Ifdef | Ifndef | Define | Undef | Error | Warning | Import | (* deprecated, but provide useful warnings *) Elifdef | Elifndef let matches ~expected matched = String.(=) expected matched || String.(=) ("optcomp." ^ expected) matched (* not using [matches] here because I'm pretty sure the pattern matching compiler will make this faster than string equality. *) let of_string_opt s = match s with | "optcomp.if" | "if" -> Some If | "optcomp.else" | "else" -> Some Else | "optcomp.elif" | "elif" -> Some Elif | "optcomp.endif" | "endif" -> Some Endif | "optcomp.ifdef" | "ifdef" -> Some Ifdef | "optcomp.ifndef" | "ifndef" -> Some Ifndef | "optcomp.define" | "define" -> Some Define | "optcomp.undef" | "undef" -> Some Undef | "optcomp.error" -> Some Error | "optcomp.warning" | "warning" -> Some Warning | "optcomp.import" | "import" -> Some Import | "optcomp.elifdef" | "elifdef" -> Some Elifdef | "optcomp.elifndef" | "elifndef" -> Some Elifndef | _ -> None end type 'a t = | Block of 'a list (** blocks with no optcomp extensions in it *) | Directive of Directive.t * location * payload let make_directive name loc payload = match Directive.of_string_opt name with | Some dir -> Directive (dir, loc, payload) | None -> Location.raise_errorf ~loc "optcomp: unknown directive" let just_directives_exn ~loc ls = List.filter_map ls ~f:(fun token -> match token with | Directive _ as dir -> Some dir | Block [] -> None | Block _ -> Location.raise_errorf ~loc "optcomp: only optcomp directives allowed in this context" ) ppx_optcomp-0.16.0/test/000077500000000000000000000000001442175067100151345ustar00rootroot00000000000000ppx_optcomp-0.16.0/test/dune000066400000000000000000000001211442175067100160040ustar00rootroot00000000000000(library (name ppx_optcomp_test) (preprocess (pps ppx_optcomp ppx_inline_test)))ppx_optcomp-0.16.0/test/errors.mlt000066400000000000000000000014431442175067100171700ustar00rootroot00000000000000module Test_double_else = struct [%% if true ] let x = 1 [%% else ] let x = 2 [%% else ] let x = 3 [%% endif] end [%%expect{| Line _, characters _-_: Error: optcomp: second else clause. |}] module Test_else_elif = struct [%% if true ] let x = 1 [%% else ] let x = 2 [%% elif false ] let x = 3 [%% endif] end [%%expect{| Line _, characters _-_: Error: optcomp: elif after else clause. |}] module Test_unterminated_if = struct [%% if true ] let x = a end [%%expect{| Line _, characters _-_: Error: optcomp: unterminated if |}] module Test_import_nonexistent = struct [%% import "non_existent_file.h"] end [%%expect{| Line _, characters _-_: Error: optcomp: cannot open imported file: ./non_existent_file.h: ./non_existent_file.h: No such file or directory |}] ppx_optcomp-0.16.0/test/examples.mlt000066400000000000000000000140411442175067100174700ustar00rootroot00000000000000module Test_simple_if = struct open Core [%% if true ] let x = "OK" [%% else ] let x = "BAD" [%% endif] let () = printf "%s" x end [%%expect{| OK |}] module Test_comments = struct open Core [%% if (* comment *) true ] let x = "OK" [%% else ] let x = "BAD" (* comment *) [%% endif] let () = printf "%s" x end [%%expect{| OK |}] module Test_nested_if = struct open Core [%% define ABC true ] [%% define xyz false ] [%% if ABC ] let x = "OK1" [%% else ] [%% if xyz ] let x = "BAD1" [%% endif] let x = "BAD2" [%% endif] let y = "OK2" let () = printf "%s %s" x y end [%%expect{| OK1 OK2 |}] module Test_defined = struct open Core [%% define FOO ] [%% undef BAR ] [%% if (defined FOO) ] let x = "OK1" [%% else ] let x = "BAD1" [%% endif ] [%% if (defined BAR) ] let y = "BAD2" [%% else ] let y = "OK2" [%% endif ] let () = printf "%s %s" x y end [%%expect{| OK1 OK2 |}] module Test_error_simple = struct [%% warning "Ooops."] [%% error "Big ooooooops."] end [%%expect{| Line _, characters _-_: Error: Big ooooooops. File "examples.mlt", line 74, characters 6-13:: Warning Ooops. |}] module Test_optional_variant = struct open Core [%%define FOO] [%%undef BAR] [%%define BAZ 3] type t = | OK_1 | OK_2 [@if defined FOO] | OK_3 [@if not (defined BAR)] | BAD_4 [@if BAZ < 0] | OK_5 let _ : t*t*t*t = OK_1, OK_2, OK_3, OK_5 let _ : t = BAD_4 end [%%expect{| Line _, characters _-_: Error: This variant expression is expected to have type t There is no constructor BAD_4 within type t |}] module Test_import_order = struct [%% define A true] [%% define B A] [%% import "test_imported/order/cd.ml"] [%% define E D] end [%%expect{||}] module Test_nested_error = struct [%% import "test_imported/error/a.ml" ] end [%%expect{| Line _, characters _-_: Error: nested error |}] module Test_import_config = struct open Core [%% import "test_imported/config.h"] [%% import "test_imported/config.h"] (* try importing twice *) [%% if (defined FOO) ] let x = "OK" [%% else] let x = "BAD" [%% endif] let () = printf "%s" x end [%%expect{| OK |}] module Test_order = struct open Core let () = printf "%s" "a" let () = printf "%s" "b" [%% if true ] let () = printf "%s" "c" let () = printf "%s" "d" [%% define ABC] let () = printf "%s" "e" let () = printf "%s" "f" [%% endif ] [%% if false ] [%% else ] let () = printf "%s" "g" let () = printf "%s" "h" [%% define ABC] let () = printf "%s" "i" let () = printf "%s" "j" [%% endif ] [%% if false ] [%% elif true ] let () = printf "%s" "k" let () = printf "%s" "l" [%% define ABC] let () = printf "%s" "m" let () = printf "%s" "n" [%% endif ] let () = printf "%s" "o" let () = printf "%s" "p" [%% define ABC] let () = printf "%s" "q" let () = printf "%s" "r" end [%%expect{| abcdefghijklmnopqr |}] module Test_show = struct open Core [%% if (show (3+3*3)) > 0] let () = printf "%s" "OK"; [%% endif ] [%% define x "OK"] module A = struct [%% define y (show x)] end [%% define x "BAD"] end [%%expect{| File "examples.mlt", line 183, characters 9-23:: SHOW 12 File "examples.mlt", line 189, characters 17-25:: SHOW "OK" OK |}] module Test_optional_match = struct open Core [%%define FOO] [%%undef BAR] type t = | OK1 of string | OK2 of string * int [@if defined FOO] | BAD of int [@if defined BAR] let () = match ((OK2 ("OK", 2)): t) with | OK1 s -> printf "%s" s | OK2 (y,z) [@if defined FOO] -> printf "%s %i\n" y z | BAD _ [@if defined BAR] -> printf "This will cause error if not dropped %s" undefined_ident let f = function | OK1 _ -> "OK" | OK2 _ -> "OK" | BAD _ [@if defined BAR] -> "BAD" let () = printf "%s" (f (OK1 "abc")) end [%%expect{| OK 2 OK |}] [%%define FOO] module Test_signature : sig [%% if defined FOO] type t [%%else] type s [%%endif] type u end = struct [%% if defined FOO] type t [%%else] type s [%%endif] type u end [%%expect{||}] module Test_drop_attr = struct [%%if false] external abc : unit -> int = "abc" [@@noalloc] [%%endif] type s end [%%expect{||}] module Test_qualified_name = struct [%% optcomp.define FOO 3 ] type t = A | B [@optcomp.if FOO = 3] end [%%expect{||}] module Test_optcomp_first = struct type t = A | B [@if false] [@@deriving sexp] end [%%expect{||}] module Test_ifndef_quirk = struct [%%ifndef FOO_NOT_USED_BEFORE] [%%define FOO_NOT_USED_BEFORE] [%%endif] end [%%expect{||}] module Test_scoping = struct open Core [%%define x "OK"] module B = struct module A = struct [%%define x "BAD1"] [%%ifdef x] let () = printf "%s" "OK2" [%%endif] end [%%define y (show x)] end [%%define x "BAD2"] end [%%expect{| File "examples.mlt", line 287, characters 16-24:: SHOW "OK" OK2 |}] module Test_scoping2 = struct [%%define x ""] module A = struct [%%define x "A"] [%%define y (show ("in A", x))] end module B = struct [%%define y (show ("in B", x))] end [%%define y (show ("at toplevel", x))] end [%%expect{| File "examples.mlt", line 304, characters 16-34:: SHOW ("in A", "A") File "examples.mlt", line 308, characters 16-34:: SHOW ("in B", "") File "examples.mlt", line 311, characters 14-39:: SHOW ("at toplevel", "") |}] module Test_scoping3 = struct module A = struct [%%define x "A"] [%%define y (show ("in A", x))] end let () = () [%%define x "top"] let () = () [%%define y (show ("between", x))] let () = () module B = struct [%%define y (show ("in B", x))] end end [%%expect{| File "examples.mlt", line 328, characters 16-34:: SHOW ("in A", "A") File "examples.mlt", line 337, characters 14-35:: SHOW ("between", "top") File "examples.mlt", line 342, characters 16-34:: SHOW ("in B", "top") |}] (* Test env is preserved in toplevel *) [%%define x "test_toplevel"] [%%define y x] [%%define y (show y)] [%%expect{| File "examples.mlt", line 359, characters 12-20:: SHOW "test_toplevel" |}] ppx_optcomp-0.16.0/test/test_imported/000077500000000000000000000000001442175067100200165ustar00rootroot00000000000000ppx_optcomp-0.16.0/test/test_imported/config.h000066400000000000000000000000671442175067100214370ustar00rootroot00000000000000#ifndef CONFIG_H #define CONFIG_H #define FOO #endif ppx_optcomp-0.16.0/test/test_imported/error/000077500000000000000000000000001442175067100211475ustar00rootroot00000000000000ppx_optcomp-0.16.0/test/test_imported/error/a.ml000066400000000000000000000000241442175067100217150ustar00rootroot00000000000000[%% import "b.ml" ] ppx_optcomp-0.16.0/test/test_imported/error/b.ml000066400000000000000000000000241442175067100217160ustar00rootroot00000000000000[%% import "c.ml" ] ppx_optcomp-0.16.0/test/test_imported/error/c.ml000066400000000000000000000000431442175067100217200ustar00rootroot00000000000000[%% optcomp.error "nested error" ] ppx_optcomp-0.16.0/test/test_imported/order/000077500000000000000000000000001442175067100211315ustar00rootroot00000000000000ppx_optcomp-0.16.0/test/test_imported/order/c.ml000066400000000000000000000000171442175067100217030ustar00rootroot00000000000000[%%define C B] ppx_optcomp-0.16.0/test/test_imported/order/cd.ml000066400000000000000000000000441442175067100220470ustar00rootroot00000000000000[%%import "c.ml"] [%%import "d.ml"] ppx_optcomp-0.16.0/test/test_imported/order/d.ml000066400000000000000000000000171442175067100217040ustar00rootroot00000000000000[%%define D C]