├── .gitignore ├── CHANGES.md ├── CONTRIBUTING.md ├── LICENSE.md ├── Makefile ├── README.org ├── bin ├── dune ├── main.ml └── main.mli ├── cinaps.opam ├── dune-project ├── src ├── cinaps.ml ├── dune ├── non_staged_error.ml ├── non_staged_error.mli ├── parse.ml ├── parse.mli ├── runtime │ ├── cinaps_runtime.ml │ ├── cinaps_runtime.mli │ └── dune ├── syntax.ml └── syntax.mli └── test ├── dune ├── empty-cinaps └── dune └── test_staged.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | *.merlin 4 | _opam 5 | 6 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## Unreleased 2 | 3 | - Correctly generate empty cinaps files (#6) 4 | 5 | ## v0.15.1 6 | 7 | ### Changed 8 | 9 | - The styler is now unconditionally applied; it used to be applied only to 10 | files with extension ".ml" or ".mli" (#5) 11 | 12 | ## v0.15.0 13 | 14 | ### Fixed 15 | 16 | - Make cinaps compatible with ocaml 4.04 (#4, @NathanReb) 17 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | This repository contains open source software that is developed and 2 | maintained by [Jane Street][js]. 3 | 4 | Contributions to this project are welcome and should be submitted via 5 | GitHub pull requests. 6 | 7 | Signing contributions 8 | --------------------- 9 | 10 | We require that you sign your contributions. Your signature certifies 11 | that you wrote the patch or otherwise have the right to pass it on as 12 | an open-source patch. The rules are pretty simple: if you can certify 13 | the below (from [developercertificate.org][dco]): 14 | 15 | ``` 16 | Developer Certificate of Origin 17 | Version 1.1 18 | 19 | Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 20 | 1 Letterman Drive 21 | Suite D4700 22 | San Francisco, CA, 94129 23 | 24 | Everyone is permitted to copy and distribute verbatim copies of this 25 | license document, but changing it is not allowed. 26 | 27 | 28 | Developer's Certificate of Origin 1.1 29 | 30 | By making a contribution to this project, I certify that: 31 | 32 | (a) The contribution was created in whole or in part by me and I 33 | have the right to submit it under the open source license 34 | indicated in the file; or 35 | 36 | (b) The contribution is based upon previous work that, to the best 37 | of my knowledge, is covered under an appropriate open source 38 | license and I have the right under that license to submit that 39 | work with modifications, whether created in whole or in part 40 | by me, under the same open source license (unless I am 41 | permitted to submit under a different license), as indicated 42 | in the file; or 43 | 44 | (c) The contribution was provided directly to me by some other 45 | person who certified (a), (b) or (c) and I have not modified 46 | it. 47 | 48 | (d) I understand and agree that this project and the contribution 49 | are public and that a record of the contribution (including all 50 | personal information I submit with it, including my sign-off) is 51 | maintained indefinitely and may be redistributed consistent with 52 | this project or the open source license(s) involved. 53 | ``` 54 | 55 | Then you just add a line to every git commit message: 56 | 57 | ``` 58 | Signed-off-by: Joe Smith 59 | ``` 60 | 61 | Use your real name (sorry, no pseudonyms or anonymous contributions.) 62 | 63 | If you set your `user.name` and `user.email` git configs, you can sign 64 | your commit automatically with git commit -s. 65 | 66 | [dco]: http://developercertificate.org/ 67 | [js]: https://opensource.janestreet.com/ 68 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2017--2020 Jane Street Group, LLC 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) 2 | 3 | default: 4 | dune build 5 | 6 | install: 7 | dune install $(INSTALL_ARGS) 8 | 9 | uninstall: 10 | dune uninstall $(INSTALL_ARGS) 11 | 12 | reinstall: uninstall install 13 | 14 | clean: 15 | dune clean 16 | 17 | .PHONY: default install uninstall reinstall clean 18 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | * CINAPS - Cinaps Is Not A Preprocessing System 2 | 3 | Cinaps is a trivial Metaprogramming tool for OCaml using the OCaml 4 | toplevel. 5 | 6 | It is intended for two purposes: 7 | - when you want to include a bit of generated code in a file, but 8 | writing a proper generator/ppx rewriter is not worth it 9 | - when you have many repeated blocks of similar code in your program, 10 | to help writing and maintaining them 11 | 12 | It is not intended as a general preprocessor, and in particular cannot 13 | only be used to generate static code that is independent of the 14 | system. 15 | 16 | ** How does it work? 17 | 18 | Cinaps is a purely textual tool. It recognizes special syntax of the 19 | form =(*$ *)= in the input. == is evaluated 20 | and whatever it prints on the standard output is compared against what 21 | follows in the file until the next =($ ... *)= form, in the same way 22 | that expectation tests works. 23 | 24 | A form ending with =$*)= stops the matching and switch back to plain 25 | text mode. In particular the empty form =(*$*)= can be used to mark 26 | the end of a generated block. 27 | 28 | If the actual output doesn't match the expected one, cinaps creates a 29 | =.corrected= file containing the actual output, diff the original file 30 | against the actual output and exits with an error code. Other it 31 | simply exits with error code 0. 32 | 33 | For instance: 34 | 35 | #+begin_src sh 36 | $ cat file.ml 37 | let x = 1 38 | (*$ print_newline (); 39 | List.iter (fun s -> Printf.printf "let ( %s ) = Pervasives.( %s )\n" s s) 40 | ["+"; "-"; "*"; "/"] *) 41 | (*$*) 42 | let y = 2 43 | 44 | $ cinaps file.ml 45 | ---file.ml 46 | +++file.ml.corrected 47 | File "file.ml", line 5, characters 0-1: 48 | let x = 1 49 | (*$ print_newline (); 50 | List.iter (fun s -> Printf.printf "let ( %s ) = Pervasives.( %s )\n" s s) 51 | ["+"; "-"; "*"; "/"] *) 52 | +|let ( + ) = Pervasives.( + ) 53 | +|let ( - ) = Pervasives.( - ) 54 | +|let ( * ) = Pervasives.( * ) 55 | +|let ( / ) = Pervasives.( / ) 56 | (*$*) 57 | let y = 2 58 | 59 | $ echo $? 60 | 1 61 | $ cp file.ml.corrected file.ml 62 | $ cinaps file.ml 63 | $ echo $? 64 | 0 65 | #+end_src 66 | 67 | You can also pass =-i= to override the file in place in case of 68 | mismatch. For instance you can have a =cinaps= target in your build 69 | system to refresh the files in your project. 70 | 71 | ** Capturing text from the input 72 | 73 | In any form =(*$ ... *)= form, the variable =_last_text_block= 74 | contains the contents of the text between the previous =(*$ ... *)= 75 | form or beginning of file and the current form. 76 | 77 | For instance you can use it to write a block of code and copy it to a 78 | second block of code that is similar except for some simple 79 | substitution: 80 | 81 | #+begin_src ocaml 82 | (*$*) 83 | let rec power_int32 n p = 84 | if Int32.equal p 0 then 85 | Int32.one 86 | else 87 | Int32.mul n (power n (Int32.pred p)) 88 | 89 | (*$ print_string (Str.global_replace (Str.regexp "32") "64" _last_text_block) *) 90 | let rec power_int64 n p = 91 | if Int64.equal p 0 then 92 | Int64.one 93 | else 94 | Int64.mul n (power n (Int64.pred p)) 95 | 96 | (*$*) 97 | #+end_src 98 | 99 | Now, whenever you modify =power_int32=, you can just run cinaps to update 100 | the =power_int64= version. 101 | 102 | ** Sharing values across multiple files 103 | 104 | The toplevel directive ~#use~ works in CINAPS, and can be used to read in values 105 | from other files. For example, 106 | 107 | 1. In ~import.cinaps~, 108 | 109 | #+BEGIN_SRC ocaml 110 | (* -*- mode: tuareg -*- *) 111 | include StdLabels 112 | include Printf 113 | 114 | let all_fields = [ "name", "string"; "age", "int" ] 115 | #+END_SRC 116 | 117 | 2. In ~foo.ml~, 118 | 119 | #+BEGIN_SRC ocaml 120 | (*$ #use "import.cinaps";; 121 | List.iter all_fields ~f:(fun (name, type_) -> 122 | printf "\n\ 123 | external get_%s : unit -> %s = \"get_%s\"" name type_ name) *) 124 | external get_name : unit -> string = "get_name" 125 | external get_age : unit -> int = "get_age"(*$*) 126 | #+END_SRC 127 | 128 | 3. In ~stubs.h~, 129 | 130 | #+BEGIN_SRC C 131 | /*$ #use "import.cinaps";; 132 | List.iter all_fields ~f:(fun (name, _) -> 133 | printf "\n\ 134 | extern value get_%s(void);" name) */ 135 | extern value get_name(void); 136 | extern value get_age(void);/*$*/ 137 | #+END_SRC 138 | 139 | Etc. 140 | 141 | Note that the ~#use~ directive will read in OCaml from files of any extension. 142 | ~*.cinaps~ is a safe choice in the presence of jenga and dune, which by default 143 | try to use all ~*.ml~ files in the directory for the executables or library. 144 | 145 | ** Automatic reformatting of CINAPS output 146 | 147 | In files managed by automatic formatting tools such as ocp-indent or 148 | ocamlformat, the code need not come out of CINAPs already formatted correctly. 149 | 150 | ~cinaps.exe -styler FOO~ uses ~FOO~ to reformat its output, before diffing 151 | against the source file. 152 | -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (executables (names main) (public_names cinaps) (libraries cinaps) 2 | (preprocess no_preprocessing)) -------------------------------------------------------------------------------- /bin/main.ml: -------------------------------------------------------------------------------- 1 | let () = Cinaps.main () 2 | -------------------------------------------------------------------------------- /bin/main.mli: -------------------------------------------------------------------------------- 1 | (* empty *) 2 | -------------------------------------------------------------------------------- /cinaps.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "opensource@janestreet.com" 3 | authors: ["Jane Street Group, LLC "] 4 | homepage: "https://github.com/ocaml-ppx/cinaps" 5 | bug-reports: "https://github.com/ocaml-ppx/cinaps/issues" 6 | dev-repo: "git+https://github.com/ocaml-ppx/cinaps.git" 7 | license: "MIT" 8 | build: [ 9 | ["dune" "build" "-p" name "-j" jobs] 10 | ] 11 | depends: [ 12 | "ocaml" {>= "4.10"} 13 | "dune" {>= "2.0.0"} 14 | "re" {>= "1.8.0"} 15 | "ppx_jane" {with-test} 16 | "base-unix" 17 | ] 18 | synopsis: "Trivial metaprogramming tool" 19 | description: " 20 | Cinaps is a trivial Metaprogramming tool using the OCaml toplevel. It 21 | is based on the same idea as expectation tests. The user write some 22 | OCaml code inside special comments and cinaps make sure that what 23 | follows is what is printed by the OCaml code. 24 | " 25 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.10) 2 | 3 | (name cinaps) 4 | -------------------------------------------------------------------------------- /src/cinaps.ml: -------------------------------------------------------------------------------- 1 | open StdLabels 2 | 3 | let quote_string s = 4 | let is_substring s ~sub = 5 | let re = Re.(compile (seq [ rep any; str sub ])) in 6 | Re.execp re s 7 | in 8 | let rec find_tag n = 9 | let rec make_tag = function 10 | | 0 -> "" 11 | | n -> 12 | Printf.sprintf "%c%s" (Char.chr (Char.code 'a' + (n mod 26))) (make_tag (n / 26)) 13 | in 14 | let tag = make_tag n in 15 | if is_substring s ~sub:("|" ^ tag ^ "}") then find_tag (n + 1) else tag 16 | in 17 | let tag = find_tag 0 in 18 | Printf.sprintf "{%s|%s|%s}" tag s tag 19 | ;; 20 | 21 | type syntax = 22 | | Auto 23 | | This of Syntax.t 24 | 25 | let syntax_of_string = function 26 | | "auto" -> Auto 27 | | "c" -> This Syntax.c 28 | | "ocaml" -> This Syntax.ocaml 29 | | "sexp" -> This Syntax.sexp 30 | | s -> Printf.ksprintf invalid_arg "syntax_of_string (%S)" s 31 | ;; 32 | 33 | let syntax_of_filename fn = 34 | let unknown () = 35 | let pos = { Lexing.pos_fname = fn; pos_lnum = 1; pos_cnum = 0; pos_bol = 0 } in 36 | Parse.raisef 37 | ~pos 38 | "Don't know what syntax to use for this file, pass an explicit [-syntax] option" 39 | in 40 | match String.rindex fn '.' with 41 | | exception _ -> unknown () 42 | | i -> 43 | (match String.sub fn ~pos:(i + 1) ~len:(String.length fn - i - 1) with 44 | | "ml" | "mli" | "mll" | "mly" | "mld" -> Syntax.ocaml 45 | | "c" | "h" | "cpp" | "c++" | "cxx" -> Syntax.c 46 | | "sexp" -> Syntax.sexp 47 | | _ -> 48 | (match Filename.basename fn with 49 | | "jbuild" -> Syntax.sexp 50 | | _ -> unknown ())) 51 | ;; 52 | 53 | let process_file ~f ~syntax ~file_name ~file_contents ~copy_input = 54 | let lexbuf = Lexing.from_string file_contents in 55 | lexbuf.lex_curr_p <- { pos_fname = file_name; pos_cnum = 0; pos_lnum = 1; pos_bol = 0 }; 56 | Parse.run ~f ~syntax ~file_name ~file_contents ~copy_input 57 | ;; 58 | 59 | let main () = 60 | let syntax = ref Auto in 61 | let staged_output = ref None in 62 | let init_staged fn = 63 | let oc = open_out fn in 64 | staged_output := Some oc; 65 | Printf.fprintf oc "let () = Cinaps_runtime.init ();;\n" 66 | in 67 | let args = 68 | Arg.align 69 | ([ ( "-syntax" 70 | , Arg.Symbol ([ "auto"; "c"; "ocaml" ], fun s -> syntax := syntax_of_string s) 71 | , " Syntax to use (default: auto)" ) 72 | ; ( "-staged" 73 | , String init_staged 74 | , "FILE Staged mode: write a .ml file that must be built and executed" ) 75 | ] 76 | @ Cinaps_runtime.args) 77 | in 78 | let usage = Printf.sprintf "%s " Sys.executable_name in 79 | let process_file fn = 80 | let syntax = 81 | match !syntax with 82 | | Auto -> syntax_of_filename fn 83 | | This s -> s 84 | in 85 | let file_contents = Cinaps_runtime.read_file fn in 86 | match !staged_output with 87 | | None -> 88 | let pos = { Lexing.pos_fname = fn; pos_lnum = 1; pos_cnum = 0; pos_bol = 0 } in 89 | Parse.raisef ~pos "%s" Non_staged_error.error_message 90 | | Some oc -> 91 | let append_code_block 92 | ~last_text_block:(pos, len) 93 | ~(code_start : Lexing.position) 94 | ~code 95 | = 96 | Printf.fprintf 97 | oc 98 | "let _last_text_block = Cinaps_runtime.input_sub %d %d;;\n# %d %S\n%*s%s\n;;\n" 99 | pos 100 | len 101 | code_start.pos_lnum 102 | code_start.pos_fname 103 | (code_start.pos_cnum - code_start.pos_bol) 104 | "" 105 | code 106 | in 107 | let copy_input pos len = 108 | Printf.fprintf oc "let () = Cinaps_runtime.copy_input %d %d;;\n" pos len 109 | in 110 | Printf.fprintf 111 | oc 112 | "let () = Cinaps_runtime.process_file\n\ 113 | \ ~file_name:%S\n\ 114 | \ ~file_contents:%s\n\ 115 | \ (fun () -> let module _ = struct\n" 116 | fn 117 | (quote_string file_contents); 118 | process_file ~f:append_code_block ~syntax ~file_contents ~file_name:fn ~copy_input; 119 | Printf.fprintf oc "end in ());;\n" 120 | in 121 | try 122 | Arg.parse args process_file usage; 123 | (match !staged_output with 124 | | None -> () 125 | | Some oc -> 126 | Printf.fprintf oc "Cinaps_runtime.exit ();;\n"; 127 | close_out oc); 128 | Cinaps_runtime.exit () 129 | with 130 | | Parse.Error { pos; msg } -> 131 | Printf.eprintf 132 | "File %S, line %d, character %d:\nError: %s\n" 133 | pos.pos_fname 134 | pos.pos_lnum 135 | (pos.pos_cnum - pos.pos_bol) 136 | msg; 137 | exit 1 138 | ;; 139 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library (name cinaps) (libraries unix re cinaps.runtime) 2 | (preprocess no_preprocessing)) -------------------------------------------------------------------------------- /src/non_staged_error.ml: -------------------------------------------------------------------------------- 1 | let error_message = 2 | "the direct mode of cinaps is no longer supported. Please use the \"cinaps\" stanza in \ 3 | your dune file instead." 4 | ;; 5 | -------------------------------------------------------------------------------- /src/non_staged_error.mli: -------------------------------------------------------------------------------- 1 | (** Error message printed when not passing [-staged] *) 2 | val error_message : string 3 | -------------------------------------------------------------------------------- /src/parse.ml: -------------------------------------------------------------------------------- 1 | open StdLabels 2 | open Syntax 3 | 4 | exception 5 | Error of 6 | { pos : Lexing.position 7 | ; msg : string 8 | } 9 | 10 | let raisef ~pos fmt = Printf.ksprintf (fun msg -> raise (Error { pos; msg })) fmt 11 | 12 | let rec advance_bol s (bol : Lexing.position) ~start ~stop = 13 | if start >= stop 14 | then bol 15 | else ( 16 | match s.[start] with 17 | | '\n' -> 18 | advance_bol 19 | s 20 | { bol with pos_lnum = bol.pos_lnum + 1; pos_bol = start + 1 } 21 | ~start:(start + 1) 22 | ~stop 23 | | _ -> advance_bol s bol ~start:(start + 1) ~stop) 24 | ;; 25 | 26 | let rec loop ~copy_input ~syntax ~f ~file_contents ~keep ~text_start ~bol ~pos = 27 | match Re.exec_opt syntax.comment_start_dollar file_contents ~pos with 28 | | None -> if keep then copy_input text_start (String.length file_contents - text_start) 29 | | Some groups -> 30 | let start = Re.Group.start groups 0 in 31 | let stop = Re.Group.stop groups 0 in 32 | (match Re.exec_opt syntax.comment_end_anchored file_contents ~pos:stop with 33 | | Some groups -> 34 | let stop = Re.Group.stop groups 0 in 35 | let start = if keep then text_start else start in 36 | copy_input start (stop - start); 37 | let bol = advance_bol file_contents bol ~start:pos ~stop in 38 | loop 39 | ~copy_input 40 | ~syntax 41 | ~f 42 | ~file_contents 43 | ~keep:true 44 | ~pos:stop 45 | ~bol 46 | ~text_start:stop 47 | | None -> 48 | let bol = advance_bol file_contents bol ~start:pos ~stop in 49 | let last_text_block = text_start, start - text_start in 50 | let start = if keep then text_start else start in 51 | let code_start = { bol with Lexing.pos_cnum = stop } in 52 | let code_stop, keep_next, pos = 53 | code ~copy_input ~syntax ~file_contents ~depth:0 ~pos:stop ~code_start 54 | in 55 | let code = 56 | let code_start = code_start.pos_cnum in 57 | String.sub file_contents ~pos:code_start ~len:(code_stop - code_start) 58 | in 59 | copy_input start (pos - start); 60 | f ~last_text_block ~code_start ~code; 61 | let bol = advance_bol file_contents bol ~start:stop ~stop:pos in 62 | loop 63 | ~copy_input 64 | ~syntax 65 | ~f 66 | ~file_contents 67 | ~keep:keep_next 68 | ~text_start:pos 69 | ~bol 70 | ~pos) 71 | 72 | and code ~copy_input ~syntax ~file_contents ~depth ~pos ~code_start = 73 | match 74 | Re.exec_opt 75 | syntax.comment_end_or_dollar_comment_end_or_comment_start_if_rec_comment 76 | file_contents 77 | ~pos 78 | with 79 | | None -> raisef ~pos:code_start "End of file reached before end of code block" 80 | | Some groups -> 81 | let start = Re.Group.start groups 0 in 82 | let stop = Re.Group.stop groups 0 in 83 | if Re.Group.test groups 3 84 | then 85 | (* Group 3 matched --> this is comment_start *) 86 | code ~copy_input ~syntax ~file_contents ~code_start ~depth:(depth + 1) ~pos:stop 87 | else if Re.Group.test groups 2 88 | then 89 | if (* Group 2 matched --> this is dollar_comment_end *) 90 | depth = 0 91 | then start, true, stop 92 | else 93 | code ~copy_input ~syntax ~file_contents ~depth:(depth - 1) ~pos:stop ~code_start 94 | else ( 95 | assert (Re.Group.test groups 1); 96 | (* Group 1 matched --> this is comment_end *) 97 | if depth = 0 98 | then start, false, stop 99 | else 100 | code ~copy_input ~syntax ~file_contents ~depth:(depth - 1) ~pos:stop ~code_start) 101 | ;; 102 | 103 | let run ~syntax ~f ~file_name ~file_contents ~copy_input = 104 | loop 105 | ~copy_input 106 | ~syntax 107 | ~f 108 | ~file_contents 109 | ~keep:true 110 | ~text_start:0 111 | ~bol:{ pos_fname = file_name; pos_lnum = 1; pos_bol = 0; pos_cnum = 0 } 112 | ~pos:0 113 | ;; 114 | -------------------------------------------------------------------------------- /src/parse.mli: -------------------------------------------------------------------------------- 1 | val run 2 | : syntax:Syntax.t 3 | -> f:(last_text_block:int * int -> code_start:Lexing.position -> code:string -> unit) 4 | -> file_name:string 5 | -> file_contents:string 6 | -> copy_input:(int -> int -> unit) 7 | -> unit 8 | 9 | exception 10 | Error of 11 | { pos : Lexing.position 12 | ; msg : string 13 | } 14 | 15 | val raisef : pos:Lexing.position -> ('a, unit, string, _) format4 -> 'a 16 | -------------------------------------------------------------------------------- /src/runtime/cinaps_runtime.ml: -------------------------------------------------------------------------------- 1 | let split_string_on_char ~sep s = String.split_on_char sep s 2 | 3 | open StdLabels 4 | 5 | let in_place = ref false 6 | let styler = ref None 7 | let diff_command = ref None 8 | let use_color = ref false 9 | 10 | let args = 11 | let open Arg in 12 | [ "-i", Set in_place, 13 | " Update the file in-place" 14 | ;"-diff-cmd", String (fun s -> diff_command := Some s), 15 | " Diff command when using code expectations" 16 | ; "-no-color", Clear use_color, 17 | " Don't use colors when printing errors" 18 | ; "-styler", String (fun s -> styler := Some s), 19 | " Code styler" 20 | ] 21 | 22 | let init () = 23 | let usage = 24 | Printf.sprintf "%s " Sys.executable_name 25 | in 26 | let anon fn = 27 | raise (Arg.Bad (Printf.sprintf "Don't know what to do with %S." fn)) 28 | in 29 | Arg.parse (Arg.align args) anon usage 30 | 31 | module Print_diff = struct 32 | let patdiff_cmd () = 33 | let args = 34 | List.concat [ 35 | ["-keep-whitespace"]; 36 | ["-location-style omake"]; 37 | (if !use_color then ["-unrefined"] else ["-ascii"]); 38 | ] 39 | in 40 | String.concat ~sep:" " ("patdiff" :: args) 41 | 42 | let print ~file1 ~file2 = 43 | let exec cmd = 44 | let cmd = 45 | Printf.sprintf "%s %s %s 1>&2" cmd (Filename.quote file1) (Filename.quote file2) 46 | in 47 | match Sys.command cmd with 48 | | 0 -> true 49 | | 1 -> false 50 | | n -> Printf.eprintf "%S exited with code %d\n" cmd n; exit 2 51 | in 52 | match !diff_command with 53 | | Some s -> ignore (exec s : bool) 54 | | None -> 55 | if exec (patdiff_cmd ()) then ( 56 | Printf.eprintf "File \"%s\", line 1, characters 0-0:\n%!" file1; 57 | ignore (exec "diff -u" : bool); 58 | ) 59 | end 60 | 61 | let failure = ref false 62 | 63 | let current_file_contents = ref "" 64 | 65 | let copy_input pos len = output_substring stdout !current_file_contents pos len 66 | 67 | let input_sub pos len = String.sub !current_file_contents ~pos ~len 68 | 69 | let protect ~finally ~f = 70 | match f () with 71 | | x -> finally (); x 72 | | exception e -> finally (); raise e 73 | 74 | let read_file fn = 75 | let ic = open_in_bin fn in 76 | let len = in_channel_length ic in 77 | let s = really_input_string ic len in 78 | close_in ic; 79 | s 80 | 81 | let write_file fn s = 82 | let oc = open_out_bin fn in 83 | output_string oc s; 84 | close_out oc 85 | 86 | let process_file ~file_name ~file_contents f = 87 | let tmp_fn, oc = Filename.open_temp_file "cinaps" (Filename.extension file_name) in 88 | let expected = 89 | protect ~finally:(fun () -> Sys.remove tmp_fn) ~f:(fun () -> 90 | let stdout_copy = Unix.dup Unix.stdout in 91 | Unix.dup2 (Unix.descr_of_out_channel oc) Unix.stdout; 92 | close_out oc; 93 | current_file_contents := file_contents; 94 | f (); 95 | flush stdout; 96 | Unix.close Unix.stdout; 97 | Unix.dup2 stdout_copy Unix.stdout; 98 | Unix.close stdout_copy; 99 | match !styler with 100 | | Some cmd -> begin 101 | let cmd = 102 | String.concat ~sep:"" 103 | (match split_string_on_char cmd ~sep:'%' with 104 | | [] -> assert false 105 | | x :: l -> 106 | x :: List.map l ~f:(fun s -> 107 | let len = String.length s in 108 | if len > 0 && s.[0] = 'i' then 109 | (Filename.quote file_name) ^ String.sub s ~pos:1 ~len:(len - 1) 110 | else 111 | "%" ^ s)) 112 | in 113 | let cmd = Printf.sprintf "%s %s" cmd (Filename.quote tmp_fn) in 114 | let ic = Unix.open_process_in cmd in 115 | let s = 116 | let file_len = String.length file_contents in 117 | let buf = Buffer.create file_len in 118 | try 119 | Buffer.add_channel buf ic file_len; 120 | while true do Buffer.add_channel buf ic 65536 done; 121 | assert false 122 | with End_of_file -> 123 | Buffer.contents buf 124 | in 125 | match Unix.close_process_in ic with 126 | | WEXITED 0 -> s 127 | | WEXITED n -> 128 | Printf.eprintf "command exited with code %d: %s\n" n cmd; 129 | exit 1 130 | | WSIGNALED n -> 131 | Printf.eprintf "command got signal %d: %s\n" n cmd; 132 | exit 1 133 | | WSTOPPED _ -> assert false 134 | end 135 | | _ -> read_file tmp_fn) 136 | in 137 | let corrected_fn = file_name ^ ".cinaps-corrected" in 138 | if file_contents = expected then begin 139 | if Sys.file_exists corrected_fn then Sys.remove corrected_fn 140 | end else if !in_place then 141 | write_file file_name expected 142 | else begin 143 | write_file corrected_fn expected; 144 | match !diff_command with 145 | | Some "-" -> 146 | (* keep the corrected file but do not output the diff *) 147 | () 148 | | _ -> 149 | failure := true; 150 | Print_diff.print 151 | ~file1:file_name 152 | ~file2:corrected_fn 153 | end 154 | 155 | let exit () = 156 | exit (if !failure then 1 else 0) 157 | -------------------------------------------------------------------------------- /src/runtime/cinaps_runtime.mli: -------------------------------------------------------------------------------- 1 | 2 | val args : (string * Arg.spec * string) list 3 | 4 | (* For statged mode only *) 5 | val init : unit -> unit 6 | 7 | val exit : unit -> _ 8 | 9 | val process_file 10 | : file_name:string 11 | -> file_contents:string 12 | -> (unit -> unit) 13 | -> unit 14 | 15 | val copy_input : int -> int -> unit 16 | val input_sub : int -> int -> string 17 | 18 | val read_file : string -> string 19 | -------------------------------------------------------------------------------- /src/runtime/dune: -------------------------------------------------------------------------------- 1 | (library (name cinaps_runtime) (public_name cinaps.runtime) (libraries unix) 2 | (preprocess no_preprocessing)) -------------------------------------------------------------------------------- /src/syntax.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | { comment_start_dollar : Re.re 3 | ; comment_end_or_dollar_comment_end_or_comment_start_if_rec_comment : Re.re 4 | ; comment_end_anchored : Re.re 5 | } 6 | 7 | let make ~comment_start ~comment_end ~is_ocaml = 8 | { comment_start_dollar = Re.compile (Re.seq [ comment_start; Re.char '$' ]) 9 | ; comment_end_or_dollar_comment_end_or_comment_start_if_rec_comment = 10 | Re.compile 11 | (Re.alt 12 | (Re.group comment_end 13 | :: Re.group (Re.seq [ Re.char '$'; comment_end ]) 14 | :: (if is_ocaml then [ Re.group comment_start ] else []))) 15 | ; comment_end_anchored = Re.compile (Re.seq [ Re.start; comment_end ]) 16 | } 17 | ;; 18 | 19 | let ocaml = make ~comment_start:(Re.str "(*") ~comment_end:(Re.str "*)") ~is_ocaml:true 20 | let c = make ~comment_start:(Re.str "/*") ~comment_end:(Re.str "*/") ~is_ocaml:false 21 | let sexp = make ~comment_start:(Re.str "#|") ~comment_end:(Re.str "|#") ~is_ocaml:false 22 | -------------------------------------------------------------------------------- /src/syntax.mli: -------------------------------------------------------------------------------- 1 | type t = 2 | { comment_start_dollar : Re.re 3 | ; comment_end_or_dollar_comment_end_or_comment_start_if_rec_comment : Re.re 4 | ; comment_end_anchored : Re.re 5 | } 6 | 7 | val ocaml : t 8 | val c : t 9 | val sexp : t 10 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (rule (deps test_staged.ml) (targets test_staged_gen.ml) 2 | (action (bash "%{bin:cinaps} -staged test_staged_gen.ml test_staged.ml"))) 3 | 4 | (executables (names test_staged_gen) (modules test_staged_gen) 5 | (libraries cinaps.runtime)) 6 | 7 | (alias (name runtest) (deps test_staged_gen.exe) 8 | (action (bash ./test_staged_gen.exe))) 9 | -------------------------------------------------------------------------------- /test/empty-cinaps/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets test_empty.ml) 3 | (action (bash "%{bin:cinaps} -staged test_empty.ml"))) 4 | 5 | (test 6 | (libraries cinaps.runtime) 7 | (name test_empty)) 8 | -------------------------------------------------------------------------------- /test/test_staged.ml: -------------------------------------------------------------------------------- 1 | (*$ open StdLabels 2 | open Printf 3 | let () = printf "\ntoto\n" *) 4 | toto 5 | (*$*) 6 | 7 | (*$ printf "\n";; 8 | List.iter ["unit"; "string"] ~f:(fun s -> 9 | printf "let foo_%s = foo_%s\n" s s) 10 | *) 11 | let foo_unit = foo_unit 12 | let foo_string = foo_string 13 | (*$*) 14 | 15 | 16 | (*$ let blah () = printf "42" 17 | let foo () = printf "1" 18 | let bar () = printf "2" $*) 19 | 20 | 21 | let f = function 22 | | (*$blah()*)42(*$*) -> "blah" 23 | | (*$foo() *)1(*$*) -> "foo" 24 | | (*$bar() *)2(*$*) -> "bar" 25 | --------------------------------------------------------------------------------