├── dune ├── exemples ├── test.ml ├── .ocamlformat ├── small_template.eml ├── dune ├── exemple.ml └── templates │ ├── exemple_copy.eml.tex │ ├── exemple.eml │ ├── subfolder │ └── exemple2.eml.tex │ └── .merlin ├── .ocamlformat ├── src ├── ppx_eml.mli ├── common │ ├── error.mli │ ├── mocaml │ │ ├── transform.mli │ │ ├── dune │ │ ├── printer.mli │ │ ├── primitive.mli │ │ ├── primitive.ml │ │ ├── transform.ml │ │ ├── mocaml.ml │ │ ├── builder.mli │ │ ├── ast.ml │ │ ├── builder.ml │ │ ├── printer.ml │ │ └── mocaml.mli │ ├── parser_aux.ml │ ├── result.ml │ ├── error.ml │ ├── ustring.mli │ ├── dune │ ├── lexer.mli │ ├── file_handling.mli │ ├── template_builder.mli │ ├── compile.mli │ ├── template_builder.ml │ ├── ustring.ml │ ├── template.mli │ ├── file_handling.ml │ ├── template.ml │ ├── lexer.ml │ └── compile.ml ├── dune ├── eml_compiler.ml └── ppx_eml.ml ├── .gitignore ├── tests ├── cram │ ├── ppx_error.t │ │ ├── dune-project │ │ ├── dune │ │ ├── run.t │ │ └── foo.ml │ └── dune ├── dune └── test.ml ├── runtime ├── dune └── EML_runtime.ml ├── CHANGES.md ├── dune-project ├── embedded_ocaml_templates.opam ├── LICENSE.md └── README.md /dune: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /exemples/test.ml: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /exemples/.ocamlformat: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=ocamlformat -------------------------------------------------------------------------------- /exemples/small_template.eml: -------------------------------------------------------------------------------- 1 | <%(d%)- 23 %> -------------------------------------------------------------------------------- /src/ppx_eml.mli: -------------------------------------------------------------------------------- 1 | (* empty on purpose *) 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | **/_build 2 | **/.merlin 3 | .vscode -------------------------------------------------------------------------------- /src/common/error.mli: -------------------------------------------------------------------------------- 1 | val fail : ('a, unit, string, 'b) format4 -> 'a 2 | -------------------------------------------------------------------------------- /src/common/mocaml/transform.mli: -------------------------------------------------------------------------------- 1 | val force_mutual_recursion : Ast.struct_ -> Ast.struct_ 2 | -------------------------------------------------------------------------------- /tests/cram/ppx_error.t/dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.6) 2 | (name test_embedded_ocaml_templates) 3 | -------------------------------------------------------------------------------- /src/common/parser_aux.ml: -------------------------------------------------------------------------------- 1 | type output_option = {slurp: bool; escape: bool; format: string option} 2 | -------------------------------------------------------------------------------- /runtime/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name EML_runtime) 3 | (public_name embedded_ocaml_templates.EML_runtime)) 4 | -------------------------------------------------------------------------------- /src/common/mocaml/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mocaml) 3 | (package embedded_ocaml_templates) 4 | (libraries pprint compiler-libs.common)) 5 | -------------------------------------------------------------------------------- /src/common/result.ml: -------------------------------------------------------------------------------- 1 | include Stdlib.Result 2 | 3 | module O = struct 4 | let ( let* ) t f = bind t f 5 | 6 | let ( let+ ) t f = map f t 7 | end 8 | -------------------------------------------------------------------------------- /src/common/error.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | let fail message = eprintf "%s\n" message ; flush stderr ; exit 1 4 | 5 | let fail format = ksprintf fail format 6 | -------------------------------------------------------------------------------- /src/common/ustring.mli: -------------------------------------------------------------------------------- 1 | type t = Uchar.t array 2 | 3 | val of_string : string -> t 4 | 5 | val print : t -> unit 6 | 7 | val to_string : t -> string 8 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | 0.8 2 | ----- 3 | 4 | Bugfixes 5 | - Locations of errors in the ppx are now reported correctly. 6 | 7 | 8 | 0.7 9 | ----- 10 | 11 | Initial logged release. -------------------------------------------------------------------------------- /tests/cram/ppx_error.t/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name foo) 3 | (libraries embedded_ocaml_templates.EML_runtime) 4 | (preprocess 5 | (pps embedded_ocaml_templates.ppx_eml))) 6 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test) 3 | (inline_tests) 4 | (libraries embedded_ocaml_templates.EML_runtime) 5 | (preprocess 6 | (pps ppx_inline_test embedded_ocaml_templates.ppx_eml))) 7 | -------------------------------------------------------------------------------- /src/common/mocaml/printer.mli: -------------------------------------------------------------------------------- 1 | val expr_to_string : Ast.expr -> string 2 | 3 | val program_to_string : Ast.struct_item list -> string 4 | 5 | val print_program : out_channel -> Ast.struct_item list -> unit 6 | -------------------------------------------------------------------------------- /tests/cram/dune: -------------------------------------------------------------------------------- 1 | (env 2 | (eml_compiler 3 | (binaries 4 | (../odoc_print/odoc_print.exe as eml_compiler)))) 5 | 6 | (cram 7 | (deps %{bin:eml_compiler}) 8 | (enabled_if (>= %{ocaml_version} 4.11.0))) 9 | -------------------------------------------------------------------------------- /tests/cram/ppx_error.t/run.t: -------------------------------------------------------------------------------- 1 | $ dune build ./foo.exe 2 | File "foo.ml", line 11, characters 6-21: 3 | Error: This expression has type string but an expression was expected of type 4 | int 5 | [1] 6 | -------------------------------------------------------------------------------- /tests/cram/ppx_error.t/foo.ml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | let simple_format (i) = [%eml "aaaaa 7 | bbbbbb 8 | <%d= 9 | 10 | 11 | string_of_int i 12 | 13 | 14 | %>cccc 15 | ddddd"] -------------------------------------------------------------------------------- /src/common/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name common) 3 | (package embedded_ocaml_templates) 4 | (libraries sedlex uutf ppxlib containers pprint mocaml) 5 | (inline_tests) 6 | (preprocess 7 | (pps sedlex.ppx ppx_inline_test)) 8 | (flags :standard -w +39)) 9 | -------------------------------------------------------------------------------- /exemples/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name exemple) 3 | (preprocess 4 | (pps embedded_ocaml_templates.ppx_eml))) 5 | 6 | (rule 7 | (alias test) 8 | (target templates.ml) 9 | (deps 10 | (source_tree templates)) 11 | (action 12 | (run eml_compiler -continuation templates))) 13 | -------------------------------------------------------------------------------- /src/common/mocaml/primitive.mli: -------------------------------------------------------------------------------- 1 | type t = 2 | | Textual of {code: string; startpos: Lexing.position; endpos: Lexing.position} 3 | | Parsed of Parsetree.expression 4 | 5 | val build : string -> Lexing.position -> Lexing.position -> t 6 | 7 | val with_dummy_pos : string -> t 8 | 9 | val is_empty : t -> bool 10 | -------------------------------------------------------------------------------- /src/common/lexer.mli: -------------------------------------------------------------------------------- 1 | type error = [`Unmatched_tag of Lexing.position] 2 | 3 | type 'a or_error = ('a, error) result 4 | 5 | val elt' : Sedlexing.lexbuf -> Template.elt' or_error option 6 | (** None means `EOF` was reached *) 7 | 8 | val template : Sedlexing.lexbuf -> Template.t or_error 9 | 10 | val pp_error : Format.formatter -> error -> unit 11 | -------------------------------------------------------------------------------- /src/common/file_handling.mli: -------------------------------------------------------------------------------- 1 | type file = File of string | Directory of (string * file array) 2 | 3 | val sort_by_int : 'a array -> to_int:('a -> 'b) -> unit 4 | 5 | val print_file : file -> unit 6 | 7 | val path_readdir : string -> string array 8 | 9 | val read_file_or_directory : 10 | ?filter:(string -> bool) -> ?sorted:bool -> string -> file 11 | -------------------------------------------------------------------------------- /src/common/template_builder.mli: -------------------------------------------------------------------------------- 1 | type error_or_template = Template.t Lexer.or_error 2 | 3 | val of_lexing_buffer : Sedlexing.lexbuf -> error_or_template 4 | 5 | val of_ustring : ?startpos:Lexing.position -> Uchar.t array -> error_or_template 6 | 7 | val of_string : ?startpos:Lexing.position -> string -> error_or_template 8 | 9 | val of_filename : string -> error_or_template 10 | -------------------------------------------------------------------------------- /src/common/compile.mli: -------------------------------------------------------------------------------- 1 | val compile_to_string : Template.t -> string 2 | (** [compile_to_string template] compile a single template and outputs a string 3 | containing the compiled OCaml code for [template] *) 4 | 5 | val compile_folder : ?continuation_mode:bool -> string -> unit 6 | (** [compile_folder ~continuation_mode:cm filename] compiles a whole folder of 7 | templates and write to the corresponding OCaml file. 2*) 8 | -------------------------------------------------------------------------------- /src/common/mocaml/primitive.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Textual of {code: string; startpos: Lexing.position; endpos: Lexing.position} 3 | | Parsed of Parsetree.expression 4 | 5 | let build code startpos endpos = Textual {code; startpos; endpos} 6 | 7 | let with_dummy_pos code = 8 | Textual {code; startpos= Lexing.dummy_pos; endpos= Lexing.dummy_pos} 9 | 10 | let is_empty = function Textual {code= ""; _} -> true | _ -> false 11 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name eml_compiler) 3 | (public_name eml_compiler) 4 | (libraries common sedlex uutf ppxlib containers) 5 | (modules eml_compiler) 6 | (flags :standard -w +39)) 7 | 8 | (library 9 | (name ppx_eml) 10 | (public_name embedded_ocaml_templates.ppx_eml) 11 | (wrapped false) 12 | (kind ppx_rewriter) 13 | (libraries common sedlex uutf ppxlib containers) 14 | (modules ppx_eml) 15 | (flags :standard -w +39)) 16 | -------------------------------------------------------------------------------- /src/common/mocaml/transform.ml: -------------------------------------------------------------------------------- 1 | open Ast 2 | 3 | let force_mutual_recursion struct_ = 4 | let aux (functions, others) = function 5 | | SIDef (pattern, expr) -> 6 | ((pattern, expr) :: functions, others) 7 | | SIRecDefs functions' -> 8 | (functions' @ functions, others) 9 | | other -> 10 | (functions, other :: others) 11 | in 12 | let functions, others = List.fold_left aux ([], []) struct_ in 13 | others @ [SIRecDefs functions] 14 | -------------------------------------------------------------------------------- /src/common/mocaml/mocaml.ml: -------------------------------------------------------------------------------- 1 | module Builder = Builder 2 | module Printer = Printer 3 | module Transform = Transform 4 | module Primitive = Primitive 5 | 6 | type type_ = Ast.type_ 7 | 8 | type expr = Ast.expr 9 | 10 | type pattern = Ast.pattern 11 | 12 | type struct_ = Ast.struct_ 13 | 14 | type struct_item = Ast.struct_item 15 | 16 | type module_ = Ast.module_ 17 | 18 | type mixed = Ast.mixed 19 | 20 | type branch = Ast.branch 21 | 22 | type primitive = Ast.primitive 23 | -------------------------------------------------------------------------------- /src/common/template_builder.ml: -------------------------------------------------------------------------------- 1 | type error_or_template = Template.t Lexer.or_error 2 | 3 | let of_lexing_buffer lexbuf = Lexer.template lexbuf 4 | 5 | let of_ustring ?(startpos = Lexing.dummy_pos) ustring = 6 | Lexer.template 7 | (let buffer = Sedlexing.from_uchar_array ustring in 8 | Sedlexing.set_position buffer startpos ; 9 | buffer ) 10 | 11 | let of_string ?(startpos = Lexing.dummy_pos) string = 12 | of_ustring ~startpos (Ustring.of_string string) 13 | 14 | let of_filename filename = 15 | let gen = 16 | Gen.of_array (Ustring.of_string @@ CCIO.with_in filename CCIO.read_all) 17 | in 18 | let buffer = Sedlexing.from_gen gen in 19 | Sedlexing.set_filename buffer filename ; 20 | Lexer.template buffer 21 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.6) 2 | 3 | (name embedded_ocaml_templates) 4 | 5 | (using menhir 2.1) 6 | 7 | (generate_opam_files true) 8 | 9 | (maintainers "Emile Trotignon ") 10 | 11 | (authors "Emile Trotignon ") 12 | 13 | (source 14 | (github EmileTrotignon/embedded_ocaml_templates)) 15 | 16 | (package 17 | (name embedded_ocaml_templates) 18 | (license MIT) 19 | (synopsis 20 | "EML is a simple templating language that lets you generate text with plain OCaml") 21 | (description 22 | "EML is a simple templating language that lets you generate text with plain OCaml") 23 | (depends 24 | (ocaml 25 | (>= 4.08.0)) 26 | (sedlex 27 | (>= 2.0)) 28 | uutf 29 | pprint 30 | (ppxlib 31 | (>= 0.18.0)) 32 | containers 33 | ppx_inline_test)) 34 | -------------------------------------------------------------------------------- /runtime/EML_runtime.ml: -------------------------------------------------------------------------------- 1 | (** [EML_runtime] provides runtime utilities for the code generated by the EML 2 | compiler. *) 3 | 4 | (** [escape s] is the HTML-escaped version of the string [s]. 5 | Characters '&', '<', '>', '"' and ''' are replaced by their HTMl encoding. *) 6 | let escape s = 7 | let buffer = Buffer.create (String.length s) in 8 | String.iter 9 | (function 10 | | '&' -> 11 | Buffer.add_string buffer "&" 12 | | '<' -> 13 | Buffer.add_string buffer "<" 14 | | '>' -> 15 | Buffer.add_string buffer ">" 16 | | '"' -> 17 | Buffer.add_string buffer """ 18 | | '\'' -> 19 | Buffer.add_string buffer "'" 20 | | c -> 21 | Buffer.add_char buffer c ) 22 | s ; 23 | Buffer.contents buffer 24 | -------------------------------------------------------------------------------- /src/common/ustring.ml: -------------------------------------------------------------------------------- 1 | open Containers 2 | 3 | type t = Uchar.t array 4 | 5 | let to_buffer ustring = 6 | let buffer = Buffer.create (Array.length ustring) in 7 | Array.iter (Uutf.Buffer.add_utf_8 buffer) ustring ; 8 | buffer 9 | 10 | let print ustring = print_string (Buffer.contents (to_buffer ustring)) 11 | 12 | let of_string string = 13 | let src = `String string in 14 | let decoder = Uutf.decoder src in 15 | let buffer = CCVector.create () in 16 | let rec aux () = 17 | match Uutf.decode decoder with 18 | | `Await -> 19 | assert false 20 | | `Uchar u -> 21 | CCVector.push buffer u ; aux () 22 | | `End -> 23 | () 24 | | `Malformed string -> 25 | Printf.ksprintf failwith "Malformed input : %s" string 26 | in 27 | aux () ; CCVector.to_array buffer 28 | 29 | let to_string ustring = Buffer.contents (to_buffer ustring) 30 | -------------------------------------------------------------------------------- /exemples/exemple.ml: -------------------------------------------------------------------------------- 1 | (* <%# firstname lastname email birthdate phonenumber formations experiences %>*) 2 | (* (date_start, date_end, diploma, school) *) 3 | (* (date, title, company, location, description) *) 4 | let _john = "John" 5 | (* 6 | let john2 = [%eml {|<%-john%> 7 | <_%i-23%>|}] *) 8 | 9 | let () = 10 | (* Templates.exemple john2 "Smith" "john.smith@johnsmith.com" "01/01/1970" 11 | "1234567890" 12 | [ ("1994", "1995", "Master of Science", "University MacCollege") 13 | ; ("1990", "1994", "Bachelor of Science", "University MacCollege") ] 14 | print_string ; 15 | print_newline () ; *) 16 | Templates.Subfolder.exemple2 "John" "Smith" "john.smith@johnsmith.com" 17 | "01/01/1970" "1234567890" 18 | [ ("1994", "1995", "Master of Science", "University MacCollege") 19 | ; ("1990", "1994", "Bachelor of Science", "University MacCollege") ] 20 | [] print_string 21 | -------------------------------------------------------------------------------- /src/common/template.mli: -------------------------------------------------------------------------------- 1 | module Prim = Mocaml.Primitive 2 | 3 | type elt = 4 | | Text of string 5 | | Code of Prim.t 6 | | Output of {code: Prim.t; escape: bool; format: string option} 7 | 8 | type t = Prim.t option * elt list 9 | 10 | type tag_options = {slurp_before: bool; slurp_after: bool} 11 | 12 | type tag = 13 | | Code of Prim.t 14 | | Output of {code: Prim.t; escape: bool; format: string option} 15 | 16 | type elt' = Text of string | Whitespace of string | Tag of tag_options * tag 17 | 18 | type t' = Prim.t option * elt' list 19 | 20 | val elt_of_tag : tag -> elt 21 | 22 | val t_of_t' : 'a * elt' list -> 'a * elt list 23 | 24 | val text : string -> elt 25 | 26 | val text' : string -> elt' 27 | 28 | val code : Prim.t -> elt 29 | 30 | val code' : Prim.t -> tag 31 | 32 | val tag : bool -> tag -> bool -> elt' 33 | 34 | val output : ?escape:bool -> ?format:string -> Prim.t -> elt 35 | 36 | val output' : ?escape:bool -> ?format:string -> Prim.t -> tag 37 | -------------------------------------------------------------------------------- /exemples/templates/exemple_copy.eml.tex: -------------------------------------------------------------------------------- 1 | <%# firstname lastname email birthdate phonenumber formations %> 2 | \documentclass[10pt, a4paper, roman, french]{moderncv} 3 | \moderncvstyle{classic} 4 | \moderncvcolor{purple} 5 | \usepackage[utf8]{inputenc} 6 | \usepackage[light]{CormorantGaramond} 7 | \usepackage[T1]{fontenc} 8 | \usepackage[scale=0.75,a4paper]{geometry} 9 | \usepackage{babel} 10 | \usepackage{geometry} 11 | \geometry{hmargin=2.5cm,vmargin=1.5cm} 12 | 13 | %---------------------------------------------------------------------------------- 14 | % informations personnelles 15 | %---------------------------------------------------------------------------------- 16 | \firstname{ <%-firstname%> } 17 | \familyname{ <%-lastname%> } 18 | \mobile{<%- phonenumber%>} 19 | \extrainfo{Né le <%-birthdate%> } 20 | \email{ <%-email%> } 21 | \begin{document} 22 | \makecvtitle 23 | \section{Formation} 24 | <% List.iteri (fun i (date_start, date_end, diploma, school) ->%> 25 | \cventry{ <%i- i %> <%-date_start%> -- <%-date_end%>}{<%-diploma%>}{<%-school%>}{}{}{} 26 | <%) formations ;%> 27 | \end{document} -------------------------------------------------------------------------------- /src/eml_compiler.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | let continuation_mode = ref false 4 | 5 | let filename = ref None 6 | 7 | let args = 8 | Arg.align 9 | [ ("-continuation", Arg.Set continuation_mode, " Enable continuation mode") 10 | ; ( "-build-info" 11 | , Arg.Unit (fun () -> print_endline "RWO" ; exit 0) 12 | , " Print info about this build and exit" ) 13 | ; ( "-version" 14 | , Arg.Unit (fun () -> print_endline "0.2" ; exit 0) 15 | , " Print the version of this build and exit" ) ] 16 | 17 | let usage = 18 | {|Generate an OCaml source file from a template 19 | 20 | eml_compiler FILENAME 21 | 22 | More detailed information 23 | 24 | === flags === 25 | |} 26 | 27 | let () = 28 | Arg.parse args (fun s -> filename := Some s) usage ; 29 | let filename = 30 | match !filename with 31 | | Some s -> 32 | s 33 | | None -> 34 | prerr_endline "Missing required argument FILENAME" ; 35 | prerr_endline "For usage, run eml_compiler -help" ; 36 | exit 1 37 | in 38 | let continuation_mode = !continuation_mode in 39 | Compile.compile_folder ~continuation_mode filename 40 | -------------------------------------------------------------------------------- /embedded_ocaml_templates.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: 4 | "EML is a simple templating language that lets you generate text with plain OCaml" 5 | description: 6 | "EML is a simple templating language that lets you generate text with plain OCaml" 7 | maintainer: ["Emile Trotignon "] 8 | authors: ["Emile Trotignon "] 9 | license: "MIT" 10 | homepage: "https://github.com/EmileTrotignon/embedded_ocaml_templates" 11 | bug-reports: 12 | "https://github.com/EmileTrotignon/embedded_ocaml_templates/issues" 13 | depends: [ 14 | "dune" {>= "3.6"} 15 | "ocaml" {>= "4.08.0"} 16 | "sedlex" {>= "2.0"} 17 | "uutf" 18 | "pprint" 19 | "ppxlib" {>= "0.18.0"} 20 | "containers" 21 | "ppx_inline_test" 22 | "odoc" {with-doc} 23 | ] 24 | build: [ 25 | ["dune" "subst"] {dev} 26 | [ 27 | "dune" 28 | "build" 29 | "-p" 30 | name 31 | "-j" 32 | jobs 33 | "@install" 34 | "@runtest" {with-test} 35 | "@doc" {with-doc} 36 | ] 37 | ] 38 | dev-repo: 39 | "git+https://github.com/EmileTrotignon/embedded_ocaml_templates.git" 40 | -------------------------------------------------------------------------------- /exemples/templates/exemple.eml: -------------------------------------------------------------------------------- 1 | <%# firstname lastname email birthdate phonenumber formations %> 2 | \documentclass[10pt, a4paper, roman, french]{moderncv} 3 | \moderncvstyle{classic} 4 | \moderncvcolor{purple} 5 | \usepackage[utf8]{inputenc} 6 | \usepackage[light]{CormorantGaramond} 7 | \usepackage[T1]{fontenc} 8 | \usepackage[scale=0.75,a4paper]{geometry} 9 | \usepackage{babel} 10 | \usepackage{geometry} 11 | \geometry{hmargin=2.5cm,vmargin=1.5cm} 12 | 13 | %---------------------------------------------------------------------------------- 14 | % informations personnelles 15 | %---------------------------------------------------------------------------------- 16 | \firstname{ <%-firstname%> } 17 | \familyname{ <%-lastname%> } 18 | \mobile{<%- phonenumber%>} 19 | \extrainfo{Né le <%-birthdate%> } 20 | \email{ <%-email%> } 21 | \begin{document} 22 | \makecvtitle 23 | \section{Formation} 24 | <% List.iter (fun (date_start, date_end, diploma, school) ->%> 25 | \cventry{ <%-date_start%> -- <%-date_end%>}{<%-diploma%>}{<%-school%>}{}{}{} 26 | <%) formations ;%> 27 | \end{document} -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | ===================== 3 | 4 | Copyright © `2020` `Émile Trotignon` 5 | 6 | Permission is hereby granted, free of charge, to any person 7 | obtaining a copy of this software and associated documentation 8 | files (the “Software”), to deal in the Software without 9 | restriction, including without limitation the rights to use, 10 | copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the 12 | Software is furnished to do so, subject to the following 13 | conditions: 14 | 15 | The above copyright notice and this permission notice shall be 16 | included in all copies or substantial portions of the Software. 17 | 18 | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, 19 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 20 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 21 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 22 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 23 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 24 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 25 | OTHER DEALINGS IN THE SOFTWARE. 26 | -------------------------------------------------------------------------------- /src/ppx_eml.ml: -------------------------------------------------------------------------------- 1 | module Parser_ = Parser 2 | open Ppxlib 3 | 4 | (* Not present before 4.11 *) 5 | let set_position lexbuf position = 6 | Lexing.( 7 | lexbuf.lex_curr_p <- {position with pos_fname= lexbuf.lex_curr_p.pos_fname} ; 8 | lexbuf.lex_abs_pos <- position.pos_cnum ) 9 | 10 | let name = "eml" 11 | 12 | let expand ~loc:_ ~path:_ (s : string) loc _delim = 13 | let startpos = loc.loc_start in 14 | (* let startpos = {loc.loc_start with pos_lnum= loc.loc_start.pos_lnum - 1} in *) 15 | match Common.Template_builder.of_string ~startpos s with 16 | | Error e -> 17 | Common.Lexer.pp_error Format.err_formatter e ; 18 | exit 1 19 | | Ok template -> 20 | let code = Common.Compile.compile_to_string template in 21 | (* print_endline code ; *) 22 | let buffer = Lexing.from_string code in 23 | set_position buffer loc.loc_start ; 24 | Parser_.parse_expression Lexer.token buffer 25 | |> Selected_ast.Of_ocaml.copy_expression 26 | 27 | let ext = 28 | Extension.declare name Extension.Context.expression 29 | Ast_pattern.(single_expr_payload (pexp_constant (pconst_string __ __ __))) 30 | expand 31 | 32 | let () = Ppxlib.Driver.register_transformation name ~extensions:[ext] 33 | -------------------------------------------------------------------------------- /exemples/templates/subfolder/exemple2.eml.tex: -------------------------------------------------------------------------------- 1 | <%# firstname lastname email birthdate phonenumber formations experiences %> 2 | \documentclass[10pt, a4paper, roman, french]{moderncv} 3 | \moderncvstyle{classic} 4 | \moderncvcolor{purple} 5 | \usepackage[utf8]{inputenc} 6 | \usepackage[light]{CormorantGaramond} 7 | \usepackage[T1]{fontenc} 8 | \usepackage[scale=0.75,a4paper]{geometry} 9 | \usepackage{babel} 10 | \usepackage{geometry} 11 | \geometry{hmargin=2.5cm,vmargin=1.5cm} 12 | 13 | %---------------------------------------------------------------------------------- 14 | % informations personnelles 15 | %---------------------------------------------------------------------------------- 16 | \firstname{ <%-firstname%> } 17 | \familyname{ <%-lastname%> } 18 | \mobile{<%- phonenumber%>} 19 | \extrainfo{Né le <%-birthdate%> } 20 | \email{ <%-email%> } 21 | \begin{document} 22 | \makecvtitle 23 | \section{Formation} 24 | <% List.iter (fun (date_start, date_end, diploma, school) ->%> 25 | \cventry{ <%-date_start%> -- <%-date_end%>}{<%-diploma%>}{<%-school%>}{}{}{} 26 | <%) formations ;%> 27 | \section{Expérience} 28 | <% List.iter (fun (date, title, company, location, description) ->%> 29 | \cventry{ <%-date%> }{ <%-title%> }{ <%-company%> }{ <%-location%> }{}{ <%-description%> } 30 | <%) experiences ;%> 31 | \end{document} -------------------------------------------------------------------------------- /src/common/file_handling.ml: -------------------------------------------------------------------------------- 1 | type file = File of string | Directory of (string * file array) 2 | 3 | let sort_by_int array ~to_int = 4 | ArrayLabels.sort array ~cmp:(fun a b -> compare (to_int a) (to_int b)) 5 | 6 | let rec print_file file = 7 | match file with 8 | | File f -> 9 | Printf.printf "File %s\n" f 10 | | Directory (s, fa) -> 11 | Printf.printf "File %s (\n" s ; 12 | ArrayLabels.iter fa ~f:print_file ; 13 | print_endline ")" 14 | 15 | let path_readdir dirname = 16 | ArrayLabels.map ~f:(Filename.concat dirname) (Sys.readdir dirname) 17 | 18 | let rec read_file_or_directory ?(filter = fun _ -> true) ?(sorted = false) 19 | filename = 20 | if not (Sys.file_exists filename) then 21 | Error.fail "file or directory `%s` does not exist" filename ; 22 | let directories_first_sort files = 23 | sort_by_int files ~to_int:(fun f -> 24 | match f with Directory _ -> 0 | File _ -> 1 ) 25 | in 26 | match Sys.is_directory filename with 27 | | true -> 28 | Directory 29 | ( filename 30 | , let files = 31 | ArrayLabels.map 32 | ~f:(fun file -> 33 | match file with 34 | | File name -> 35 | File name 36 | | Directory (name, files) -> 37 | Directory (name, files) ) 38 | (CCArrayLabels.filter 39 | ~f:(fun file -> 40 | match file with File s -> filter s | Directory _ -> true ) 41 | (ArrayLabels.map 42 | ~f:(read_file_or_directory ~filter ~sorted) 43 | (ArrayLabels.map ~f:(Filename.concat filename) 44 | (Sys.readdir filename) ) ) ) 45 | in 46 | if sorted then directories_first_sort files ; 47 | files ) 48 | | false -> ( 49 | match Sys.file_exists filename with 50 | | true -> 51 | File filename 52 | | false -> 53 | Printf.eprintf "Unknown file %s\n" filename ; 54 | exit 1 ) 55 | -------------------------------------------------------------------------------- /tests/test.ml: -------------------------------------------------------------------------------- 1 | (* -------------------------------------------------------------------------- *) 2 | (* -------------------------------------------------------------------------- *) 3 | (* -------------------------------------------------------------------------- *) 4 | 5 | let simple s = [%eml {|prefix<%= s %>suffix|}] 6 | 7 | let simple_no_escape s = [%eml {|prefix<%- s %>suffix|}] 8 | 9 | let slurp_left s = [%eml {|prefix <_%= s %>suffix|}] 10 | 11 | let slurp_right s = [%eml {|prefix<%= s %_> suffix|}] 12 | 13 | let slurp_left_no_escape s = [%eml {|prefix <_%- s %>suffix|}] 14 | 15 | let slurp_right_no_escape s = [%eml {|prefix<%- s %_> suffix|}] 16 | 17 | let for_loop s n = 18 | [%eml {|prefix<%for _=1 to n do (%>ipre<%= s %>isuf<% ) done ; %>suffix|}] 19 | 20 | let for_loop_slurp s n = 21 | [%eml 22 | (*--------------------------*) 23 | {|prefix 24 | <_%for _=1 to n do %_> 25 | ipre <_%= s %_> isuf 26 | <_% done ; %_> 27 | suffix|}] 28 | 29 | let simple_format i = [%eml {|<%d=i%>|}] 30 | 31 | let simple_format_no_escape i = [%eml {|<%d-i%>|}] 32 | 33 | let complex_format i = [%eml {|<%[d%]= i %>|}] 34 | 35 | let complex_format_no_escape i = [%eml {|<%[d%]- i %>|}] 36 | 37 | let s' printer a = Printf.sprintf "%a" printer a 38 | 39 | let%test "simple" = simple "coucou" = "prefixcoucousuffix" 40 | 41 | let%test "simple escape" = 42 | simple {|&<>"'|} = "prefix&<>"'suffix" 43 | 44 | let%test "simple_no_escape" = 45 | simple_no_escape "coucou" = "prefixcoucousuffix" 46 | && simple_no_escape {|&<>"'|} = {|prefix&<>"'suffix|} 47 | 48 | let%test "slurp" = 49 | slurp_left "coucou" = "prefixcoucousuffix" 50 | && slurp_right "coucou" = "prefixcoucousuffix" 51 | 52 | let%test "slurp escape" = 53 | slurp_left "coucou" = "prefixcoucousuffix" 54 | && slurp_right "coucou" = "prefixcoucousuffix" 55 | 56 | let%test "slurp_no_escape" = 57 | slurp_left_no_escape "coucou" = "prefixcoucousuffix" 58 | && slurp_right_no_escape "coucou" = "prefixcoucousuffix" 59 | && slurp_left_no_escape {|&<>"'|} = {|prefix&<>"'suffix|} 60 | && slurp_right_no_escape {|&<>"'|} = {|prefix&<>"'suffix|} 61 | 62 | let%test "for_loop" = 63 | for_loop " foo " 3 = {|prefixipre foo isufipre foo isufipre foo isufsuffix|} 64 | && for_loop " foo " 2 = {|prefixipre foo isufipre foo isufsuffix|} 65 | 66 | let%test "for_loop" = 67 | for_loop_slurp " foo " 3 68 | = {|prefixipre foo isufipre foo isufipre foo isufsuffix|} 69 | && for_loop_slurp " foo " 2 = {|prefixipre foo isufipre foo isufsuffix|} 70 | 71 | let%test "simple_format" = 72 | simple_format 1 = "1" 73 | && simple_format 12353 = "12353" 74 | && simple_format 92853 = "92853" 75 | && complex_format_no_escape 1 = "1" 76 | && simple_format 12353 = "12353" 77 | && simple_format 92853 = "92853" 78 | -------------------------------------------------------------------------------- /src/common/mocaml/builder.mli: -------------------------------------------------------------------------------- 1 | open Ast 2 | 3 | val ( ^-> ) : 'a -> 'b -> 'a * 'b 4 | 5 | val ( ^^-> ) : 'a -> 'b -> 'a * 'b 6 | 7 | val ( ^= ) : 'a -> 'b -> 'a * 'b 8 | 9 | module T : sig 10 | val name : string -> type_ 11 | 12 | val primitive : primitive -> type_ 13 | 14 | val apply : type_ list -> string -> type_ 15 | 16 | val module_field : string list -> type_ 17 | 18 | val arrow : type_ list -> type_ -> type_ 19 | 20 | val ( ^-> ) : type_ -> type_ -> type_ 21 | 22 | val int : type_ 23 | 24 | val bool : type_ 25 | 26 | val string : type_ 27 | 28 | val char : type_ 29 | 30 | val unit : type_ 31 | 32 | val int64 : type_ 33 | 34 | val nativeint : type_ 35 | 36 | val float : type_ 37 | end 38 | 39 | module E : sig 40 | val if_ : expr -> expr -> expr -> expr 41 | 42 | val let_ : (pattern * expr) list -> expr -> expr 43 | 44 | val leti : (pattern * expr) list * expr -> expr 45 | 46 | val apply : expr -> ?named_args:(string * expr) list -> expr list -> expr 47 | 48 | val cons : ?payload:expr list -> string -> expr 49 | 50 | val var : string -> expr 51 | 52 | val tuple : expr list -> expr 53 | 54 | val lit_list : expr list -> expr 55 | 56 | val lit_string : string -> expr 57 | 58 | val lit_int : int -> expr 59 | 60 | val fun_ : pattern list * expr -> expr 61 | 62 | val prim : primitive -> expr 63 | 64 | val ref : expr -> expr 65 | 66 | val deref : expr -> expr 67 | 68 | val assign_to_ref : expr -> expr -> expr 69 | 70 | val sequence : expr list -> expr -> expr 71 | 72 | val open_module : string -> expr -> expr 73 | 74 | val module_field : string list -> expr 75 | 76 | val mixed_seq : mixed list -> expr -> expr 77 | 78 | val match_ : expr -> branch list -> expr 79 | 80 | val unit : expr 81 | 82 | val annot : expr -> type_ -> expr 83 | 84 | val ( ^: ) : expr -> type_ -> expr 85 | 86 | val li_cons : expr -> expr -> expr 87 | 88 | val empty_list : expr 89 | 90 | val empty_string : expr 91 | 92 | val function_ : branch list -> expr 93 | end 94 | 95 | module P : sig 96 | val wildcard : pattern 97 | 98 | val char : char -> pattern 99 | 100 | val string : string -> pattern 101 | 102 | val int : int -> pattern 103 | 104 | val tuple : pattern list -> pattern 105 | 106 | val var : string -> pattern 107 | 108 | val prim : primitive -> pattern 109 | 110 | val cons : ?payload:pattern list -> string -> pattern 111 | 112 | val unit : pattern 113 | end 114 | 115 | module Mixed : sig 116 | val unit : expr -> mixed 117 | 118 | val prim : primitive -> mixed 119 | end 120 | 121 | module SI : sig 122 | val def : pattern * expr -> struct_item 123 | 124 | val module_ : string * module_ -> struct_item 125 | end 126 | 127 | module M : sig 128 | val struct_ : struct_ -> module_ 129 | 130 | val alias : string -> module_ 131 | 132 | val field : string list -> module_ 133 | end 134 | 135 | module Prim : sig 136 | val textual : string -> Lexing.position -> Lexing.position -> primitive 137 | 138 | val parsed : Parsetree.expression -> primitive 139 | end 140 | -------------------------------------------------------------------------------- /src/common/template.ml: -------------------------------------------------------------------------------- 1 | module Prim = Mocaml.Primitive 2 | 3 | type elt = 4 | | Text of string 5 | | Code of Prim.t 6 | | Output of {code: Prim.t; escape: bool; format: string option} 7 | 8 | type t = Prim.t option * elt list 9 | 10 | type tag_options = {slurp_before: bool; slurp_after: bool} 11 | 12 | type tag = 13 | | Code of Prim.t 14 | | Output of {code: Prim.t; escape: bool; format: string option} 15 | 16 | type elt' = Text of string | Whitespace of string | Tag of tag_options * tag 17 | 18 | type t' = Prim.t option * elt' list 19 | 20 | let elt_of_tag (tag : tag) : elt = 21 | match tag with 22 | | Code s -> 23 | Code s 24 | | Output {code; escape; format} -> 25 | Output {code; escape; format} 26 | 27 | let t_of_t' (args, elts) = 28 | ( args 29 | , let remove_whitespaces elts = 30 | let rec aux elts slurp_next (acc : elt' list) = 31 | match (elts, acc) with 32 | | [], _ -> 33 | acc 34 | | (Text _ as x) :: xs, _ -> 35 | aux xs false (x :: acc) 36 | | (Whitespace _ as x) :: xs, _ -> 37 | aux xs false (if slurp_next then acc else x :: acc) 38 | | ( (Tag ({slurp_before= true; slurp_after}, _) as x) :: xs 39 | , Whitespace _ :: acc_s ) -> 40 | aux xs slurp_after (x :: acc_s) 41 | | (Tag ({slurp_before= _; slurp_after}, _) as x) :: xs, _ -> 42 | aux xs slurp_after (x :: acc) 43 | in 44 | List.rev (aux elts false []) 45 | in 46 | let elts' = remove_whitespaces elts in 47 | List.map 48 | (function 49 | | Tag (_, tag) -> 50 | elt_of_tag tag 51 | | Text s -> 52 | Text s 53 | | Whitespace s -> 54 | Text s ) 55 | elts' ) 56 | 57 | let text s : elt = Text s 58 | 59 | let text' s : elt' = Text s 60 | 61 | let code s : elt = Code s 62 | 63 | let code' s : tag = Code s 64 | 65 | let output ?(escape = true) ?format code : elt = 66 | let code = Prim.with_dummy_pos code in 67 | Output {code; escape; format} 68 | 69 | let output' ?(escape = true) ?format code : tag = 70 | let code = Prim.with_dummy_pos code in 71 | Output {code; escape; format} 72 | 73 | let tag slurp_before tag slurp_after = Tag ({slurp_before; slurp_after}, tag) 74 | 75 | let%test "no slurp" = 76 | let ast' = 77 | ( "" 78 | , [ Text "atom 1\n" 79 | ; tag false (output' {|"string 1\n"|}) false 80 | ; Whitespace " \n" 81 | ; Text "atom 2\n" 82 | ; tag false (output' ~format:"d" {|35|}) false ] ) 83 | in 84 | let ast = 85 | ( "" 86 | , [ text "atom 1\n" 87 | ; output {|"string 1\n"|} 88 | ; text " \n" 89 | ; text "atom 2\n" 90 | ; output ~format:"d" {|35|} ] ) 91 | in 92 | let ast'' = t_of_t' ast' in 93 | ast'' = ast 94 | 95 | let%test "slurp" = 96 | let ast' = 97 | ( "" 98 | , [ text' "atom1" 99 | ; tag false (output' {|"string 1\n"|}) true 100 | ; Whitespace " \n" 101 | ; Text "atom2" 102 | ; tag false (output' ~format:"d" {|35|}) false ] ) 103 | in 104 | let ast = 105 | ( "" 106 | , ( [ Text "atom1" 107 | ; output {|"string 1\n"|} 108 | ; Text "atom2" 109 | ; output ~format:"d" {|35|} ] 110 | : elt list ) ) 111 | in 112 | let ast'' = t_of_t' ast' in 113 | ast'' = ast 114 | 115 | let output ?(escape = true) ?format code : elt = Output {code; escape; format} 116 | 117 | let output' ?(escape = true) ?format code : tag = Output {code; escape; format} 118 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Embedded Ocaml Templates 2 | 3 | EML is a simple templating language that lets you generate text with plain OCaml. 4 | It is analogous to the way you would write PHP pages, but the langage being 5 | Ocaml instead. 6 | 7 | The syntax is as follow : 8 | 9 | First of all, you can declare the template's arguments at the top of the 10 | template : 11 | 12 | ```eml 13 | <%# arg1 (arg2:type) (arg3_1, arg3_2) %> 14 | ``` 15 | 16 | This is optionnal, but this is the way to get ocaml values from the outside. You 17 | could also link a library that exposes the values. 18 | 19 | Then you can use two tags : 20 | 21 | ```eml 22 | <% ocaml code here %> 23 | ``` 24 | 25 | This tag expect any ocaml code. If what you put in here is an expression of type 26 | unit, you should include the ";" yourself. You are able to open parenthesis and 27 | close them in a subsequent tag. 28 | 29 | ```eml 30 | <%= ocaml expression here %> 31 | ``` 32 | 33 | This tag expect an expression of type string and is going to be replaced by the 34 | value of the expression, with HTML escaping. 35 | If this tag is inside a loop or an if statement, or any control structure, it's 36 | going to behave the way you would expect it to : 37 | outputting its content every time the branch is executed, with the right context. 38 | 39 | This tag has a variant : 40 | 41 | ```eml 42 | <%i= ocaml expression here %> 43 | ``` 44 | 45 | Here you can use any "simple" printf format specifier, where simple is defined 46 | by the following regex : 47 | 48 | ```regex 49 | 'd' | 'i' | 'u' | 'n' | 'l' | 'N' | 'L' | 'x' | 'o' | 'X' | 's' | 'c' 50 | | 'S' | 'C' | 'f' | 'e' | 'E' | 'g' | 'G' | 'h' | 'H' | 'b' | 'B' 51 | | ('l' | 'n' | 'L'), ('d' | 'i' | 'u' | 'x' | 'X' | 'o') 52 | | 't' 53 | ``` 54 | 55 | You can notice that `<%s- x %>` is equivalent to `<%- x %>` 56 | 57 | You can use more complicated printf format specifiers with format flags, width 58 | and precision using the following syntax : 59 | 60 | ```eml 61 | <%[i%]= ocaml expression here %> 62 | ``` 63 | 64 | Every time `=` is used to mark an outputting tag, it can be replaced by `-` to 65 | disable HTML escaping. 66 | 67 | A slurp marker is also provided : 68 | `<_%` slurps whitespaces before it, and `%_>` after. It can be combined with 69 | output tags this way : `<_%=`. 70 | 71 | Identifiers prefixed with `__eml_` are reserved. This includes string delimiters 72 | `{__eml_|` and `|__eml_}`. Using them will not necessarily raise an error, but 73 | there is no guarantee if you do. 74 | 75 | Because OCaml does not have an eval function, the templates have to be compiled. 76 | What is provided by this package is an executable that will compile either a 77 | single .eml file into an OCaml module containing a function that render the 78 | template, or take a whole directory containing a function for each .eml file and 79 | a submodule for each subdirectory (recursively). 80 | 81 | Here is an exemple of a dune rule: 82 | 83 | ```dune 84 | (rule 85 | (target templates.ml) 86 | (deps (source_tree templates)) 87 | (action (run eml_compiler templates))) 88 | ``` 89 | 90 | There is also a ppx rewriter provided : 91 | 92 | ```ocaml 93 | let name = "John" 94 | let john = [%eml "<%-name%>"] 95 | ``` 96 | 97 | You can use the argument tag this way : 98 | 99 | ```ocaml 100 | let user = [%eml "<%# name age %>name:<%-name%>, age:<%i- age%>"] 101 | ``` 102 | 103 | But in my opinion it is more elegant to write : 104 | 105 | ```ocaml 106 | let user name age = [%eml "name:<%-name%>, age:<%i- age%>"] 107 | ``` 108 | 109 | There is also this nice new syntax that available from OCaml 4.11 onward : 110 | 111 | ```ocaml 112 | let user name age = {%eml|name:<%-name%>, age:<%i- age%>|} 113 | ``` 114 | 115 | -------------------------------------------------------------------------------- /src/common/mocaml/ast.ml: -------------------------------------------------------------------------------- 1 | type primitive = Primitive.t 2 | 3 | (** represent patterns *) 4 | type pattern = 5 | | PWildcard (** [PWildcard] is the pattern [_]. *) 6 | | PChar of char (** [PChar 'c'] is the pattern ['c']. *) 7 | | PString of string (** [PString "s"] is the pattern ["s"]. *) 8 | | PInt of int (** [PInt i] is the pattern [i]. *) 9 | | PTuple of pattern list 10 | (** [PTuple [p1; p2; ... ; pn]] is the pattern 11 | [(p1, p2, ... , pn)]. *) 12 | | PVar of string 13 | (** [PVar "ident"] is the pattern binding a single variable named [ident]. *) 14 | | PCons of string * pattern list 15 | (** [PCons ("Cons", [a1; a2; ...; an])] is the pattern 16 | [Cons(a1, a2, ... , an)]. *) 17 | | PPrimitive of primitive (** [PPrimitive prim] is the pattern [prim]. *) 18 | 19 | type type_ = 20 | | TName of string (** [TName "ident"] is the type of name [ident]. *) 21 | | TPrimitive of primitive (** [TPrimitive prim] is the type [prim]. *) 22 | | TApply of type_ list * string 23 | (** [TApply ([a1; a2; ... ; an], "name")] is the type 24 | [(a1, a2, ... , an) name]. *) 25 | | TModuleField of string list 26 | (** [TModuleField (["Module1"; "Module2"; ... ; "Modulen"; "ident"])] is 27 | the type [Module1.Module2...Modulen.ident]. *) 28 | | TArrow of type_ list * type_ 29 | (** [TArrow ([t1; t2; ... ; tn], t)] is the type 30 | [t1 -> t2 -> ... -> tn -> t]. *) 31 | 32 | type expr = 33 | | EIf of expr * expr * expr 34 | (** [EIf (cond, e1, e2)] is the expression [if cond then e1 else e2]. *) 35 | | ELet of (pattern * expr) list * expr 36 | (** [ELet ([(p1, e1); ... ; (pn, en)], e)] is the expression 37 | [let p1 = e1 in ... let pn = en in e]. *) 38 | | EApply of expr * (string * expr) list * expr list 39 | (** [EApply (func, [("lab1", el1); ...; ("labn", eln)], [e1; ... ; en]))] 40 | is the expression [func ~lab1:el1 ... ~labn:eln e1 ... en]. *) 41 | | ECons of string * expr list 42 | (** [ECons ("Cons", [e1; e2; ...; en])] is the expression 43 | [Cons (e1, e2, ... , en)]. *) 44 | | EVar of string (** [EVar "ident"] is the expression [ident]. *) 45 | | ETuple of expr list 46 | (** [ETuple [e1; e2; ... ; en]] is the expression [(e1, e2, ... , en)]. *) 47 | | ELitList of expr list 48 | (** [ELitList [e1; e2; ... ; en]] is the expression [[e1; e2; ... ; en]]. *) 49 | | ELitInt of int (** [ELitInt i] is the expression [i]. *) 50 | | ELitString of string 51 | (** [ELitString "some text"] is the expression ["some text"]. *) 52 | | EFun of pattern list * expr 53 | (** [EFun([p1; ...; pn], body)] is the expression [fun p1 ... pn -> body]. *) 54 | | EPrimitive of primitive (** [EPrim prim] is the expression [prim]. *) 55 | | ESequence of expr list * expr 56 | (** [ESequence ([e1; e2; ... ; en], e)] is the expression 57 | [e1; e2; ... ; en ; e]. *) 58 | | EOpenModule of string * expr 59 | (** [EOpenModule ("Module", e)] is the expression [Module.(e)] *) 60 | | EModuleField of string list 61 | (** [EModuleField (["Module1"; ... ; "Modulen" ; "ident"])] is the 62 | expression [Module1...Modulen.ident] *) 63 | | EMixedSequence of mixed list * expr 64 | (** [EMixedSequence ([m1; m2; ... ; mn], e)] is the expression 65 | [m1 m2 ... mn e]. This is not function application, but textual 66 | concatenation. *) 67 | | EMatch of expr * branch list 68 | (** [EMatch(e, [b1; b2; ... ; bn])] is the expression 69 | [match e with b1 | b2 | ... | bn] *) 70 | | EUnit (** [EUnit] is the expression [()] *) 71 | | EAnnotated of expr * type_ 72 | (** [EAnnotated (e, t)] is the expression [(e : t)] *) 73 | 74 | and branch = pattern * expr 75 | 76 | and mixed = MiUnit of expr | MiPrimitive of primitive 77 | 78 | type struct_item = 79 | | SIDef of pattern * expr 80 | | SIModule of string * module_ 81 | | SIRecDefs of (pattern * expr) list 82 | 83 | and struct_ = struct_item list 84 | 85 | and module_ = MStruct of struct_ | MAlias of string | MField of string list 86 | -------------------------------------------------------------------------------- /exemples/templates/.merlin: -------------------------------------------------------------------------------- 1 | EXCLUDE_QUERY_DIR 2 | B /home/emile/.opam/4.07.0/lib/base 3 | B /home/emile/.opam/4.07.0/lib/base/caml 4 | B /home/emile/.opam/4.07.0/lib/base/md5 5 | B /home/emile/.opam/4.07.0/lib/base/shadow_stdlib 6 | B /home/emile/.opam/4.07.0/lib/base_bigstring 7 | B /home/emile/.opam/4.07.0/lib/base_quickcheck 8 | B /home/emile/.opam/4.07.0/lib/bin_prot 9 | B /home/emile/.opam/4.07.0/lib/bin_prot/shape 10 | B /home/emile/.opam/4.07.0/lib/core 11 | B /home/emile/.opam/4.07.0/lib/core_kernel 12 | B /home/emile/.opam/4.07.0/lib/core_kernel/base_for_tests 13 | B /home/emile/.opam/4.07.0/lib/fieldslib 14 | B /home/emile/.opam/4.07.0/lib/jane-street-headers 15 | B /home/emile/.opam/4.07.0/lib/ocaml 16 | B /home/emile/.opam/4.07.0/lib/ocaml/threads 17 | B /home/emile/.opam/4.07.0/lib/parsexp 18 | B /home/emile/.opam/4.07.0/lib/ppx_assert/runtime-lib 19 | B /home/emile/.opam/4.07.0/lib/ppx_bench/runtime-lib 20 | B /home/emile/.opam/4.07.0/lib/ppx_compare/runtime-lib 21 | B /home/emile/.opam/4.07.0/lib/ppx_enumerate/runtime-lib 22 | B /home/emile/.opam/4.07.0/lib/ppx_expect/collector 23 | B /home/emile/.opam/4.07.0/lib/ppx_expect/common 24 | B /home/emile/.opam/4.07.0/lib/ppx_expect/config 25 | B /home/emile/.opam/4.07.0/lib/ppx_hash/runtime-lib 26 | B /home/emile/.opam/4.07.0/lib/ppx_inline_test/config 27 | B /home/emile/.opam/4.07.0/lib/ppx_inline_test/runtime-lib 28 | B /home/emile/.opam/4.07.0/lib/ppx_module_timer/runtime 29 | B /home/emile/.opam/4.07.0/lib/ppx_sexp_conv/runtime-lib 30 | B /home/emile/.opam/4.07.0/lib/sexplib 31 | B /home/emile/.opam/4.07.0/lib/sexplib/unix 32 | B /home/emile/.opam/4.07.0/lib/sexplib0 33 | B /home/emile/.opam/4.07.0/lib/spawn 34 | B /home/emile/.opam/4.07.0/lib/splittable_random 35 | B /home/emile/.opam/4.07.0/lib/stdio 36 | B /home/emile/.opam/4.07.0/lib/time_now 37 | B /home/emile/.opam/4.07.0/lib/typerep 38 | B /home/emile/.opam/4.07.0/lib/variantslib 39 | B ../_build/default/templates/.templates.objs/byte 40 | S /home/emile/.opam/4.07.0/lib/base 41 | S /home/emile/.opam/4.07.0/lib/base/caml 42 | S /home/emile/.opam/4.07.0/lib/base/md5 43 | S /home/emile/.opam/4.07.0/lib/base/shadow_stdlib 44 | S /home/emile/.opam/4.07.0/lib/base_bigstring 45 | S /home/emile/.opam/4.07.0/lib/base_quickcheck 46 | S /home/emile/.opam/4.07.0/lib/bin_prot 47 | S /home/emile/.opam/4.07.0/lib/bin_prot/shape 48 | S /home/emile/.opam/4.07.0/lib/core 49 | S /home/emile/.opam/4.07.0/lib/core_kernel 50 | S /home/emile/.opam/4.07.0/lib/core_kernel/base_for_tests 51 | S /home/emile/.opam/4.07.0/lib/fieldslib 52 | S /home/emile/.opam/4.07.0/lib/jane-street-headers 53 | S /home/emile/.opam/4.07.0/lib/ocaml 54 | S /home/emile/.opam/4.07.0/lib/ocaml/threads 55 | S /home/emile/.opam/4.07.0/lib/parsexp 56 | S /home/emile/.opam/4.07.0/lib/ppx_assert/runtime-lib 57 | S /home/emile/.opam/4.07.0/lib/ppx_bench/runtime-lib 58 | S /home/emile/.opam/4.07.0/lib/ppx_compare/runtime-lib 59 | S /home/emile/.opam/4.07.0/lib/ppx_enumerate/runtime-lib 60 | S /home/emile/.opam/4.07.0/lib/ppx_expect/collector 61 | S /home/emile/.opam/4.07.0/lib/ppx_expect/common 62 | S /home/emile/.opam/4.07.0/lib/ppx_expect/config 63 | S /home/emile/.opam/4.07.0/lib/ppx_hash/runtime-lib 64 | S /home/emile/.opam/4.07.0/lib/ppx_inline_test/config 65 | S /home/emile/.opam/4.07.0/lib/ppx_inline_test/runtime-lib 66 | S /home/emile/.opam/4.07.0/lib/ppx_module_timer/runtime 67 | S /home/emile/.opam/4.07.0/lib/ppx_sexp_conv/runtime-lib 68 | S /home/emile/.opam/4.07.0/lib/sexplib 69 | S /home/emile/.opam/4.07.0/lib/sexplib/unix 70 | S /home/emile/.opam/4.07.0/lib/sexplib0 71 | S /home/emile/.opam/4.07.0/lib/spawn 72 | S /home/emile/.opam/4.07.0/lib/splittable_random 73 | S /home/emile/.opam/4.07.0/lib/stdio 74 | S /home/emile/.opam/4.07.0/lib/time_now 75 | S /home/emile/.opam/4.07.0/lib/typerep 76 | S /home/emile/.opam/4.07.0/lib/variantslib 77 | S . 78 | FLG -ppx '/home/emile/ocaml_projects/embedded_ocaml_templates/_build/default/.ppx/57ef275c515ec1fe105f6ff0979f5a61/ppx.exe --as-ppx --cookie '\''library-name="templates"'\''' 79 | FLG -open Templates -w @1..3@5..28@30..39@43@46..47@49..57@61..62-40 -strict-sequence -strict-formats -short-paths -keep-locs -w +39 80 | -------------------------------------------------------------------------------- /src/common/mocaml/builder.ml: -------------------------------------------------------------------------------- 1 | open Ast 2 | open Primitive 3 | 4 | (* -------------------------------------------------------------------------- *) 5 | (* Infix sugar *) 6 | 7 | let ( ^-> ) a b = (a, b) 8 | 9 | let ( ^^-> ) a b = (a, b) 10 | 11 | let ( ^= ) a b = (a, b) 12 | 13 | (* -------------------------------------------------------------------------- *) 14 | (* Type builder *) 15 | 16 | module T = struct 17 | let name s = TName s 18 | 19 | let primitive p = TPrimitive p 20 | 21 | let apply li n = TApply (li, n) 22 | 23 | let module_field f = TModuleField f 24 | 25 | let arrow li final = TArrow (li, final) 26 | 27 | let ( ^-> ) t1 t2 = arrow [t1] t2 28 | 29 | let int = name "int" 30 | 31 | let bool = name "bool" 32 | 33 | let string = name "string" 34 | 35 | let char = name "char" 36 | 37 | let unit = name "unit" 38 | 39 | let int64 = name "int64" 40 | 41 | let nativeint = name "nativeint" 42 | 43 | let float = name "float" 44 | end 45 | (* -------------------------------------------------------------------------- *) 46 | (* Expression builders *) 47 | 48 | module E = struct 49 | let if_ cond e1 e2 = EIf (cond, e1, e2) 50 | 51 | let let_ li e = ELet (li, e) 52 | 53 | let leti (li, e) = let_ li e 54 | 55 | let apply f ?(named_args = []) args = EApply (f, named_args, args) 56 | 57 | let cons ?(payload = []) cons = ECons (cons, payload) 58 | 59 | let var name = EVar name 60 | 61 | let tuple li = ETuple li 62 | 63 | let lit_list li = ELitList li 64 | 65 | let lit_string li = ELitString li 66 | 67 | let lit_int i = ELitInt i 68 | 69 | let fun_ (args, body) = if args = [] then body else EFun (args, body) 70 | 71 | let prim p = EPrimitive p 72 | 73 | let ref e = apply (var "ref") [e] 74 | 75 | let deref e = apply (var "!") [e] 76 | 77 | let assign_to_ref r v = apply (var "( := )") [r; v] 78 | 79 | let sequence li e = if li = [] then e else ESequence (li, e) 80 | 81 | let open_module m e = EOpenModule (m, e) 82 | 83 | let module_field path = EModuleField path 84 | 85 | let mixed_seq li e = EMixedSequence (li, e) 86 | 87 | let match_ e li = EMatch (e, li) 88 | 89 | let unit = EUnit 90 | 91 | let annot e t = EAnnotated (e, t) 92 | 93 | let ( ^: ) a b = EAnnotated (a, b) 94 | 95 | let li_cons e1 e2 = cons "(::)" ~payload:[e1; e2] 96 | 97 | let empty_list = lit_list [] 98 | 99 | let empty_string = lit_string "" 100 | 101 | let function_ branches = 102 | fun_ 103 | @@ [PVar "__mocaml_improbable_v"] 104 | ^^-> match_ (var "__mocaml_improbable_v") branches 105 | end 106 | (* -------------------------------------------------------------------------- *) 107 | (* Pattern builders *) 108 | 109 | module P = struct 110 | let wildcard = PWildcard 111 | 112 | let char c = PChar c 113 | 114 | let string s = PString s 115 | 116 | let int i = PInt i 117 | 118 | let tuple li = PTuple li 119 | 120 | let var s = PVar s 121 | 122 | let prim p = PPrimitive p 123 | 124 | let cons ?(payload = []) s = PCons (s, payload) 125 | 126 | let unit = cons "()" 127 | end 128 | (* -------------------------------------------------------------------------- *) 129 | (* mixed builders *) 130 | 131 | module Mixed = struct 132 | let unit e = MiUnit e 133 | 134 | let prim s = MiPrimitive s 135 | end 136 | 137 | (* -------------------------------------------------------------------------- *) 138 | (* struct item builders *) 139 | 140 | module SI = struct 141 | let def (pattern, expr) = SIDef (pattern, expr) 142 | 143 | let module_ (name, module_) = SIModule (name, module_) 144 | end 145 | (* -------------------------------------------------------------------------- *) 146 | (* modules builders *) 147 | 148 | module M = struct 149 | let struct_ s = MStruct s 150 | 151 | let alias n = MAlias n 152 | 153 | let field li = MField li 154 | end 155 | 156 | (* -------------------------------------------------------------------------- *) 157 | (* primitives *) 158 | 159 | module Prim = struct 160 | let textual code startpos endpos = Textual {code; startpos; endpos} 161 | 162 | let parsed expr = Parsed expr 163 | end 164 | -------------------------------------------------------------------------------- /src/common/mocaml/printer.ml: -------------------------------------------------------------------------------- 1 | open Ast 2 | open PPrint 3 | 4 | let ( @> ) f g x = f (g x) 5 | 6 | let ( ^-^ ) a b = a ^^ space ^^ b 7 | 8 | let ( ^/^ ) a b = a ^^ hardline ^^ b 9 | 10 | let ( ^|^ ) a b = a ^^ break 1 ^^ b 11 | 12 | let nest = nest 2 13 | 14 | let nest_break i doc = nest (break i ^^ doc) 15 | 16 | let nl = hardline 17 | 18 | let rarrow = string "->" 19 | 20 | let equal = string "=" 21 | 22 | let pipe = string "|" 23 | 24 | let comma_list printer = separate_map (break 0 ^^ comma ^^ space) printer 25 | 26 | let dot_list printer = separate_map dot printer 27 | 28 | let semicolon_list printer = separate_map (break 0 ^^ semi ^^ space) printer 29 | 30 | let space_list printer = separate_map (break 1) printer 31 | 32 | let nl_list printer = separate_map hardline printer 33 | 34 | let pipe_list printer = separate_map (break 1 ^^ pipe ^^ space) printer 35 | 36 | let rarrow_list printer = separate_map (space ^^ rarrow ^^ break 1) printer 37 | 38 | let parens doc = lparen ^-^ doc ^-^ rparen 39 | 40 | (* let ifdoc b doc = if b then doc else empty *) 41 | let comment doc = !^"(*" ^^ doc ^^ !^"*)" 42 | 43 | let position p = 44 | Lexing.( 45 | break 0 46 | ^^ comment 47 | (OCaml.record "position" 48 | [ ("pos_fname", OCaml.string p.pos_fname) 49 | ; ("pos_lnum", OCaml.int p.pos_lnum) 50 | ; ("pos_bol", OCaml.int p.pos_bol) 51 | ; ("pos_cnum", OCaml.int p.pos_cnum) ] ) 52 | ^^ !^"\n" ^^ sharp ^-^ OCaml.int p.pos_lnum ^-^ OCaml.string p.pos_fname 53 | ^^ !^"\n" ) 54 | 55 | let primitive = function 56 | | Primitive.(Textual {code; startpos; endpos= _}) -> 57 | let cnum = startpos.pos_cnum - startpos.pos_bol in 58 | position startpos ^^ repeat cnum space ^^ !^code ^^ nl 59 | | Parsed expr -> 60 | Pprintast.expression Format.str_formatter expr ; 61 | let str = Format.flush_str_formatter () in 62 | arbitrary_string str 63 | 64 | let rec pattern p = 65 | group 66 | ( match p with 67 | | PWildcard -> 68 | underscore 69 | | PTuple li -> 70 | parens (semicolon_list pattern li) 71 | | PVar name -> 72 | !^name 73 | | PPrimitive prim -> 74 | primitive prim 75 | | PChar c -> 76 | OCaml.char c 77 | | PString s -> 78 | OCaml.string s 79 | | PInt i -> 80 | OCaml.int i 81 | | PCons (name, payload) -> 82 | if payload = [] then !^name 83 | else !^name ^-^ parens (comma_list pattern payload) ) 84 | 85 | and def (p, e) = 86 | group 87 | ( group (!^"let" ^-^ pattern p ^-^ equal) 88 | ^^ nest_break 1 (expr e) 89 | ^|^ string "in" ) 90 | 91 | and mixed = function 92 | | MiUnit e -> 93 | expr e ^-^ semi 94 | | MiPrimitive p -> 95 | primitive p 96 | 97 | and type_ t = 98 | group 99 | ( match t with 100 | | TName name -> 101 | !^name 102 | | TModuleField li -> 103 | dot_list string li 104 | | TPrimitive p -> 105 | primitive p 106 | | TApply (li, name) -> 107 | parens (comma_list type_ li) ^-^ !^name 108 | | TArrow (li, final) -> 109 | rarrow_list type_ li ^-^ rarrow ^|^ type_ final ) 110 | 111 | and named_arg (name, arg) = parens @@ !^"~" ^^ !^name ^^ colon ^^ expr arg 112 | 113 | and expr e = 114 | group 115 | ( match e with 116 | | EUnit -> 117 | !^"()" 118 | | EIf (cond, e1, e2) -> 119 | group 120 | @@ group (!^"if" ^|^ expr cond ^|^ !^"then") 121 | ^|^ expr e1 122 | ^|^ group (!^"else" ^|^ expr e2) 123 | | ELet (defs, e) -> 124 | group (space_list def defs) ^-^ expr e 125 | | EApply (f, named_args, args) -> 126 | parens (expr f) 127 | ^-^ space_list named_arg named_args 128 | ^-^ space_list (parens @> expr) args 129 | | ECons (cons, args) -> 130 | if args = [] then !^cons else !^cons ^-^ parens (comma_list expr args) 131 | | ETuple exprs -> 132 | parens (comma_list expr exprs) 133 | | ELitList exprs -> 134 | brackets (semicolon_list expr exprs) 135 | | ELitInt i -> 136 | PPrint.OCaml.int i 137 | | EVar name -> 138 | !^name 139 | | EFun (args, body) -> 140 | group (!^"fun" ^-^ space_list pattern args ^-^ rarrow) 141 | ^^ nest_break 1 (expr body) 142 | | ESequence (li, e) -> 143 | semicolon_list expr li ^|^ semi ^-^ expr e 144 | | EPrimitive prim -> 145 | primitive prim 146 | | EOpenModule (m, e) -> 147 | string m ^^ dot ^^ lparen ^^ nest_break 0 (expr e) ^|^ rparen 148 | | EModuleField path -> 149 | dot_list string path 150 | | EMixedSequence (li, e) -> 151 | space_list mixed li ^|^ expr e 152 | | ELitString s -> 153 | OCaml.string s 154 | | EMatch (e, branches) -> 155 | group (!^"match" ^^ nest_break 1 (expr e) ^|^ !^"with") 156 | ^|^ pipe_list branch branches 157 | | EAnnotated (e, t) -> 158 | parens (expr e ^-^ colon ^-^ type_ t) ) 159 | 160 | and branch (p, e) = group (pattern p ^-^ rarrow ^^ nest_break 1 (expr e)) 161 | 162 | and mutual_def (p, e) = nl ^^ !^"and" ^-^ pattern p ^-^ equal ^|^ expr e 163 | 164 | and struct_item = function 165 | | SIDef (p, e) -> 166 | !^"let" ^^ nest_break 1 (pattern p) ^|^ equal ^^ nest_break 1 (expr e) 167 | | SIModule (name, m) -> 168 | !^"module" ^-^ !^name ^-^ equal ^^ nest_break 1 (module_ m) 169 | | SIRecDefs defs -> ( 170 | match defs with 171 | | (p, e) :: defs -> 172 | group 173 | (!^{|let[@warning "-39"] rec|} ^^ nest_break 1 (pattern p) ^|^ equal) 174 | ^^ nest_break 1 (expr e) 175 | ^|^ concat_map mutual_def defs 176 | | [] -> 177 | assert false ) 178 | 179 | and module_ = function 180 | | MStruct s -> 181 | struct_ s 182 | | MAlias a -> 183 | !^a 184 | | MField li -> 185 | dot_list string li 186 | 187 | and struct_ s = !^"struct" ^/^ nl_list struct_item s ^/^ !^"end" 188 | 189 | and program s = nl_list struct_item s 190 | 191 | let to_channel f channel args = 192 | let doc = f args in 193 | ToChannel.pretty 0.8 120 channel doc 194 | 195 | let to_string f arg = 196 | let doc = f arg in 197 | let buffer = Buffer.create 10 in 198 | ToBuffer.pretty 0.8 120 buffer doc ; 199 | Buffer.contents buffer 200 | 201 | let expr_to_string = to_string expr 202 | 203 | let program_to_string = to_string program 204 | 205 | let print_program = to_channel program 206 | -------------------------------------------------------------------------------- /src/common/lexer.ml: -------------------------------------------------------------------------------- 1 | open Result.O 2 | open Template 3 | 4 | type error = [`Unmatched_tag of Lexing.position] 5 | 6 | type 'a or_error = ('a, error) result 7 | 8 | let digit = [%sedlex.regexp? '0' .. '9'] 9 | 10 | let output_marker = [%sedlex.regexp? '-' | '='] 11 | 12 | let format_flag = [%sedlex.regexp? '#' | '0' | '-' | '+'] 13 | 14 | let format_width = [%sedlex.regexp? Plus digit] 15 | 16 | let format_precision = [%sedlex.regexp? '.', Plus digit] 17 | 18 | let escape marker = marker = '=' 19 | 20 | let simple_format = 21 | [%sedlex.regexp? 22 | ( 'd' 23 | | 'i' 24 | | 'u' 25 | | 'n' 26 | | 'l' 27 | | 'N' 28 | | 'L' 29 | | 'x' 30 | | 'o' 31 | | 'X' 32 | | 's' 33 | | 'c' 34 | | 'S' 35 | | 'C' 36 | | 'f' 37 | | 'e' 38 | | 'E' 39 | | 'g' 40 | | 'G' 41 | | 'h' 42 | | 'H' 43 | | 'b' 44 | | 'B' 45 | | ('l' | 'n' | 'L'), ('d' | 'i' | 'u' | 'x' | 'X' | 'o') 46 | | 't' )] 47 | 48 | let format = 49 | [%sedlex.regexp? 50 | Opt format_flag, Opt format_width, Opt format_precision, simple_format] 51 | 52 | let tag_left_par = 53 | [%sedlex.regexp? '<', Opt '_', '%', (Opt simple_format, Opt output_marker)] 54 | 55 | let tag_right_par_slurp = [%sedlex.regexp? '%', '_', '>'] 56 | 57 | let tag_right_par_no_slurp = [%sedlex.regexp? '%', '>'] 58 | 59 | let tag_right_par = [%sedlex.regexp? '%', Opt '_', '>'] 60 | 61 | let tagpar = [%sedlex.regexp? tag_left_par | tag_right_par] 62 | 63 | let text buffer first = 64 | let text = CCVector.of_array first in 65 | let rec aux () = 66 | match%sedlex buffer with 67 | | tagpar | white_space -> 68 | Sedlexing.rollback buffer 69 | | eof -> 70 | () 71 | | any -> 72 | CCVector.append_array text (Sedlexing.lexeme buffer) ; 73 | aux () 74 | | _ -> 75 | assert false 76 | in 77 | aux () ; 78 | let text = text |> CCVector.to_array |> Ustring.to_string in 79 | Template.Text text 80 | 81 | let code buffer : _ or_error = 82 | let startpos = fst @@ Sedlexing.lexing_positions buffer in 83 | let text = CCVector.create () in 84 | let rec aux depth = 85 | let endpos = snd @@ Sedlexing.lexing_positions buffer in 86 | match%sedlex buffer with 87 | | tag_left_par -> 88 | CCVector.append_array text (Sedlexing.lexeme buffer) ; 89 | aux (depth + 1) 90 | | tag_right_par_slurp -> 91 | let depth = depth - 1 in 92 | if depth = 0 then Ok (true, endpos) 93 | else ( 94 | CCVector.append_array text (Sedlexing.lexeme buffer) ; 95 | aux depth ) 96 | | tag_right_par_no_slurp -> 97 | let depth = depth - 1 in 98 | if depth = 0 then Ok (false, endpos) 99 | else ( 100 | CCVector.append_array text (Sedlexing.lexeme buffer) ; 101 | aux depth ) 102 | | white_space -> 103 | CCVector.append_array text (Sedlexing.lexeme buffer) ; 104 | aux depth 105 | | eof -> 106 | Error (`Unmatched_tag startpos) 107 | | any -> 108 | CCVector.append_array text (Sedlexing.lexeme buffer) ; 109 | aux depth 110 | | _ -> 111 | assert false 112 | in 113 | let+ slurp, endpos = aux 1 in 114 | let text = text |> CCVector.to_array |> Ustring.to_string in 115 | let prim = Mocaml.Primitive.build text startpos endpos in 116 | (slurp, prim) 117 | 118 | let get_whitespaces buffer first = 119 | let text = CCVector.of_array first in 120 | let rec aux () = 121 | match%sedlex buffer with 122 | | eof -> 123 | () 124 | | white_space -> 125 | CCVector.append_array text (Sedlexing.lexeme buffer) ; 126 | aux () 127 | | _ -> 128 | Sedlexing.rollback buffer 129 | in 130 | aux () ; CCVector.to_array text 131 | 132 | let slurp buffer = 133 | match%sedlex buffer with "_" -> true | "" -> false | _ -> assert false 134 | 135 | (** [Ok (Some t)] means there was a tag, [Error e] means an error, and [Ok None] 136 | means no error, but no tag either. *) 137 | let tag buffer = 138 | let slurp_before = slurp buffer in 139 | match%sedlex buffer with 140 | | "%", simple_format, output_marker -> 141 | let matched = Ustring.to_string (Sedlexing.lexeme buffer) in 142 | let n = String.length matched in 143 | let format = Some (String.sub matched 1 (n - 2)) in 144 | let output_marker = matched.[n - 1] in 145 | let escape = output_marker = '=' in 146 | let+ slurp_after, code = code buffer in 147 | Some (Tag ({slurp_after; slurp_before}, Output {code; escape; format})) 148 | | "%" -> 149 | let+ slurp_after, code = code buffer in 150 | Some (Tag ({slurp_after; slurp_before}, Code code)) 151 | | "%", output_marker -> 152 | let matched = Ustring.to_string (Sedlexing.lexeme buffer) in 153 | let output_marker = matched.[1] in 154 | let escape = output_marker = '=' in 155 | let+ slurp_after, code = code buffer in 156 | Some 157 | (Tag ({slurp_after; slurp_before}, Output {code; escape; format= None})) 158 | | "%[", format, "%]", output_marker -> 159 | let matched = Ustring.to_string (Sedlexing.lexeme buffer) in 160 | let n = String.length matched in 161 | let format = Some (String.sub matched 2 (String.length matched - 5)) in 162 | let output_marker = matched.[n - 1] in 163 | let escape = escape output_marker in 164 | let+ slurp_after, code = code buffer in 165 | Some (Tag ({slurp_after; slurp_before}, Output {code; escape; format})) 166 | | _ -> 167 | Ok None 168 | 169 | let elt' buffer = 170 | match%sedlex buffer with 171 | | "<" -> 172 | Some 173 | (let+ tag = tag buffer in 174 | match tag with Some tag -> tag | None -> Text "<" ) 175 | | eof -> 176 | None 177 | | white_space -> 178 | Some 179 | (Ok 180 | (Whitespace 181 | (Ustring.to_string 182 | (get_whitespaces buffer (Sedlexing.lexeme buffer)) ) ) ) 183 | | any -> 184 | Some (Ok (text buffer (Sedlexing.lexeme buffer))) 185 | | _ -> 186 | assert false 187 | 188 | let rec elt'_list acc buffer : _ or_error = 189 | match elt' buffer with 190 | | None -> 191 | Ok (List.rev acc) 192 | | Some (Ok elt') -> 193 | elt'_list (elt' :: acc) buffer 194 | | Some (Error e) -> 195 | Error e 196 | 197 | let elt'_list = elt'_list [] 198 | 199 | let params buffer = 200 | match%sedlex buffer with 201 | | "<%#" -> 202 | let+ _, code = code buffer in 203 | Some code 204 | | _ -> 205 | Ok None 206 | 207 | let template' buffer = 208 | let* params = params buffer in 209 | let+ elt's = elt'_list buffer in 210 | (params, elt's) 211 | 212 | let template buffer = 213 | let+ template' = template' buffer in 214 | t_of_t' template' 215 | 216 | let pp_pos fmt pos = 217 | Ppxlib.( 218 | Format.fprintf fmt "at line %d:%d in file %s" pos.pos_lnum 219 | (pos.pos_cnum - pos.pos_bol) 220 | pos.pos_fname ) 221 | 222 | let pp_error fmt (`Unmatched_tag loc) = 223 | let message = "Unmatched tag" in 224 | Format.fprintf fmt "%s at %a\n%!" message pp_pos loc 225 | -------------------------------------------------------------------------------- /src/common/mocaml/mocaml.mli: -------------------------------------------------------------------------------- 1 | (** Mocaml provides a way to construct Ocaml ASTs with regular AST mixed 2 | with textual fragments that may not be syntactically correct on their own. 3 | Every Ocaml construct is not provided : they are added on a per-need basis. 4 | *) 5 | 6 | (** The representation of a type. *) 7 | type type_ 8 | 9 | (** The representation of an expression. *) 10 | type expr 11 | 12 | (** The representation of a pattern. *) 13 | type pattern 14 | 15 | (** The representation of a structure item. *) 16 | type struct_item 17 | 18 | (** The representation of a structure. *) 19 | type struct_ = struct_item list 20 | 21 | (** The representation of a module. *) 22 | type module_ 23 | 24 | (** Either textual code, or AST representation. *) 25 | type mixed 26 | 27 | (** The representation of a match branch. *) 28 | type branch 29 | 30 | type primitive = Primitive.t 31 | 32 | (* -------------------------------------------------------------------------- *) 33 | 34 | module Builder : sig 35 | val ( ^-> ) : pattern -> expr -> branch 36 | (** [p ^-> e] is the branch [p -> e]. *) 37 | 38 | val ( ^^-> ) : pattern list -> expr -> pattern list * expr 39 | 40 | val ( ^= ) : 'a -> 'b -> 'a * 'b 41 | 42 | (** This module provides values to build types. *) 43 | module T : sig 44 | val name : string -> type_ 45 | (** [T.name "ident"] is the type of name [ident]. *) 46 | 47 | val primitive : primitive -> type_ 48 | (** [T.primitive prim] is the type [prim]. *) 49 | 50 | val apply : type_ list -> string -> type_ 51 | (** [T.apply ([a1; a2; ... ; an], "name")] is the type 52 | [(a1, a2, ... , an) name]. *) 53 | 54 | val module_field : string list -> type_ 55 | (** [T.module_field (["Module1"; "Module2"; ... ; "Modulen"; "ident"])] is 56 | the type [Module1.Module2...Modulen.ident]. *) 57 | 58 | val arrow : type_ list -> type_ -> type_ 59 | (** [T.arrow ([t1; t2; ... ; tn], t)] is the type 60 | [t1 -> t2 -> ... -> tn -> t]. *) 61 | 62 | val ( ^-> ) : type_ -> type_ -> type_ 63 | (** [t1 ^-> t2] is the type [t1 -> t2]. *) 64 | 65 | val int : type_ 66 | (** [T.int] is the type [int]. *) 67 | 68 | val bool : type_ 69 | (** [T.bool] is the type [bool]. *) 70 | 71 | val string : type_ 72 | (** [T.string] is the type [string]. *) 73 | 74 | val char : type_ 75 | (** [T.char] is the type [char]. *) 76 | 77 | val unit : type_ 78 | (** [T.unit] is the type [unit]. *) 79 | 80 | val int64 : type_ 81 | (** [T.int64] is the type [int64]. *) 82 | 83 | val nativeint : type_ 84 | (** [T.nativeint] is the type [nativeint]. *) 85 | 86 | val float : type_ 87 | (** [T.float] is the type [float]. *) 88 | end 89 | 90 | (** This module provides values to build expressions *) 91 | module E : sig 92 | val if_ : expr -> expr -> expr -> expr 93 | (** [E.if_ cond e1 e2] is the expression [if cond then e1 else e2]. *) 94 | 95 | val let_ : (pattern * expr) list -> expr -> expr 96 | (** [E.let [(p1 ^= e1); ... ; (pn ^= en)] e] is the expression 97 | [let p1 = e1 in ... let pn = en in e]. *) 98 | 99 | val apply : expr -> ?named_args:(string * expr) list -> expr list -> expr 100 | (** [E.apply func ~named_args:[("lab1", el1); ...; ("labn", eln)] [e1; ... ; en]] 101 | is the expression [func ~lab1:el1 ... ~labn:eln e1 ... en]. *) 102 | 103 | val cons : ?payload:expr list -> string -> expr 104 | (** [E.cons ~payload:[e1; e2; ...; en] "Cons"] is the expression 105 | [Cons (e1, e2, ... , en)]. *) 106 | 107 | val var : string -> expr 108 | (** [E.var "ident"] is the expression [ident]. *) 109 | 110 | val tuple : expr list -> expr 111 | (** [E.tuple [e1; e2; ... ; en]] is the expression [(e1, e2, ... , en)]. *) 112 | 113 | val lit_list : expr list -> expr 114 | (** [E.lit_list [e1; e2; ... ; en]] is the expression [[e1; e2; ... ; en]]. *) 115 | 116 | val lit_string : string -> expr 117 | (** [E.lit_string "some text"] is the expression ["some text"]. *) 118 | 119 | val lit_int : int -> expr 120 | (** [E.lit_int i] is the expression [i]. *) 121 | 122 | val fun_ : pattern list * expr -> expr 123 | (** [E.fun_ [p1; ...; pn] ^^-> body] is the expression 124 | [fun p1 ... pn -> body]. *) 125 | 126 | val prim : primitive -> expr 127 | (** [E.prim prim] is the expression [prim]. *) 128 | 129 | val ref : expr -> expr 130 | (** [E.ref e] is the expression [ref e]. *) 131 | 132 | val deref : expr -> expr 133 | (** [E.deref e] is the expression [!e]. *) 134 | 135 | val assign_to_ref : expr -> expr -> expr 136 | (** [E.assign_to_ref r v] is the expression [r := v]. *) 137 | 138 | val sequence : expr list -> expr -> expr 139 | (** [E.sequence [e1; e2; ... ; en] e] is the expression 140 | [e1; e2; ... ; en ; e]. *) 141 | 142 | val open_module : string -> expr -> expr 143 | (** [E.open_module "Module" e] is the expression [Module.( e )]. *) 144 | 145 | val module_field : string list -> expr 146 | (** [E.module_field (["Module1"; ... ; "Modulen" ; "ident"])] is the 147 | expression [Module1...Modulen.ident]. *) 148 | 149 | val mixed_seq : mixed list -> expr -> expr 150 | (** [E.mixed_seq ([m1; m2; ... ; mn], e)] is the expression 151 | [m1 m2 ... mn e]. This is not function application, but textual 152 | concatenation. *) 153 | 154 | val match_ : expr -> branch list -> expr 155 | (** [E.match e [b1; b2; ... ; bn]] is the expression 156 | [match e with b1 | b2 | ... | bn]. *) 157 | 158 | val unit : expr 159 | (** [E.unit] is the expression [()]. *) 160 | 161 | val annot : expr -> type_ -> expr 162 | (** [E.annot e t] is the expression [(e : t)]. Same as [( ^: )]. *) 163 | 164 | val ( ^: ) : expr -> type_ -> expr 165 | (** [e ^: t] is the expression [(e : t)]. Same as [annot]. *) 166 | 167 | val li_cons : expr -> expr -> expr 168 | (** [E.li_cons x xs] is the expression [x :: xs]. *) 169 | 170 | val empty_list : expr 171 | (** [E.empty_list] is the expression [[]]. *) 172 | 173 | val empty_string : expr 174 | (** [E.empty_string] is the expression [""]. *) 175 | 176 | val function_ : branch list -> expr 177 | (** [E.function_ [b1; b2; ... ; bn]] is the expression 178 | [function b1 | b2 | ... | bn]. *) 179 | end 180 | 181 | (** This module provides values to build patterns *) 182 | module P : sig 183 | val wildcard : pattern 184 | (** [P.wildcard] is the pattern [_]. *) 185 | 186 | val char : char -> pattern 187 | (** [P.char 'c'] is the pattern ['c']. *) 188 | 189 | val string : string -> pattern 190 | (** [P.string "s"] is the pattern ["s"]. *) 191 | 192 | val int : int -> pattern 193 | (** [PInt i] is the pattern [i]. *) 194 | 195 | val tuple : pattern list -> pattern 196 | (** [P.tuple [p1; p2; ... ; pn]] is the pattern 197 | [(p1, p2, ... , pn)]. *) 198 | 199 | val var : string -> pattern 200 | (** [P.var "ident"] is the pattern binding a single variable named [ident]. *) 201 | 202 | val prim : primitive -> pattern 203 | 204 | val cons : ?payload:pattern list -> string -> pattern 205 | (** [P.cons ("Cons", [a1; a2; ...; an])] is the pattern 206 | [Cons(a1, a2, ... , an)]. *) 207 | 208 | val unit : pattern 209 | (** [P.unit] is the pattern [()]. *) 210 | end 211 | 212 | module Mixed : sig 213 | val unit : expr -> mixed 214 | (** A complete expression, of type unit. *) 215 | 216 | val prim : primitive -> mixed 217 | (** A textual OCaml node. May be incomplete. *) 218 | end 219 | 220 | (** This module provides values to build structure items. *) 221 | module SI : sig 222 | val def : pattern * expr -> struct_item 223 | (** [SI.def (p ^= e)] is the structure item [let p = e]. *) 224 | 225 | val module_ : string * module_ -> struct_item 226 | (** [ SI.module ("MyModule" ^= m)] is the structure item 227 | [module MyMOdule p = m]. *) 228 | end 229 | 230 | (** This module provides values to build (the representation of) modules *) 231 | module M : sig 232 | val struct_ : struct_ -> module_ 233 | (** A struct. *) 234 | 235 | val alias : string -> module_ 236 | (** An alias for another module. *) 237 | 238 | val field : string list -> module_ 239 | (** A module that is a sub-module of another one. *) 240 | end 241 | 242 | (** This modules provides values to insert user code in our programs. *) 243 | module Prim : sig 244 | val textual : string -> Lexing.position -> Lexing.position -> primitive 245 | (** A textual representation of the code. *) 246 | 247 | val parsed : Parsetree.expression -> primitive 248 | (** A parsed AST *) 249 | end 250 | end 251 | 252 | (* -------------------------------------------------------------------------- *) 253 | 254 | module Printer : sig 255 | val expr_to_string : expr -> string 256 | 257 | val program_to_string : struct_item list -> string 258 | 259 | val print_program : out_channel -> struct_item list -> unit 260 | end 261 | 262 | (* -------------------------------------------------------------------------- *) 263 | 264 | module Transform : sig 265 | val force_mutual_recursion : struct_ -> struct_ 266 | (** [force_mutual_recursion struct_] is [struct_] with every value being 267 | mutually recursive with every other value. *) 268 | end 269 | 270 | module Primitive : module type of Primitive 271 | -------------------------------------------------------------------------------- /src/common/compile.ml: -------------------------------------------------------------------------------- 1 | open Template 2 | open File_handling 3 | open Mocaml.Builder 4 | module Prim = Mocaml.Primitive 5 | 6 | let prefix s = "__eml_" ^ s 7 | 8 | let e_escape = E.module_field ["EML_runtime"; "escape"] 9 | 10 | let n_buffer = prefix "buffer" 11 | 12 | let n_continuation = prefix "continuation" 13 | 14 | let e_app_continuation e = E.(apply (var n_continuation) [e]) 15 | 16 | let stdlib_module_field fi = E.module_field ("Stdlib" :: fi) 17 | 18 | (** Takes an expression representing an integer [n] and allocate a buffer of size [n] *) 19 | let e_buffer_create e = E.apply (stdlib_module_field ["Buffer"; "create"]) [e] 20 | 21 | (** add_string b s appends the string s at the end of buffer b. *) 22 | let e_buffer_add_string buf s = 23 | E.apply (stdlib_module_field ["Buffer"; "add_string"]) [buf; s] 24 | 25 | let e_buffer_contents buf = 26 | E.apply (stdlib_module_field ["Buffer"; "contents"]) [buf] 27 | 28 | let e_app_escape e = E.apply e_escape [e] 29 | 30 | (* d, i: convert an integer argument to signed decimal. 31 | u, n, l, L, or N: convert an integer argument to unsigned decimal. Warning: n, l, L, and N are used for scanf, and should not be used for printf. 32 | x: convert an integer argument to unsigned hexadecimal, using lowercase letters. 33 | X: convert an integer argument to unsigned hexadecimal, using uppercase letters. 34 | o: convert an integer argument to unsigned octal. 35 | d, i: convert an integer argument to signed decimal. 36 | u, n, l, L, or N: convert an integer argument to unsigned decimal. Warning: n, l, L, and N are used for scanf, and should not be used for printf. 37 | x: convert an integer argument to unsigned hexadecimal, using lowercase letters. 38 | X: convert an integer argument to unsigned hexadecimal, using uppercase letters. 39 | 40 | o: convert an integer argument to unsigned octal. 41 | s: insert a string argument. 42 | S: convert a string argument to OCaml syntax (double quotes, escapes). 43 | c: insert a character argument. 44 | C: convert a character argument to OCaml syntax (single quotes, escapes). 45 | f: convert a floating-point argument to decimal notation, in the style dddd.ddd. 46 | F: convert a floating-point argument to OCaml syntax (dddd. or dddd.ddd or d.ddd e+-dd). 47 | e or E: convert a floating-point argument to decimal notation, in the style d.ddd e+-dd (mantissa and exponent). 48 | g or G: convert a floating-point argument to decimal notation, in style f or e, E (whichever is more compact). Moreover, any trailing zeros are removed from the fractional part of the result and the decimal-point character is removed if there is no fractional part remaining. 49 | h or H: convert a floating-point argument to hexadecimal notation, in the style 0xh.hhhh e+-dd (hexadecimal mantissa, exponent in decimal and denotes a power of 2). 50 | B: convert a boolean argument to the string true or false 51 | b: convert a boolean argument (deprecated; do not use in new programs). 52 | ld, li, lu, lx, lX, lo: convert an int32 argument to the format specified by the second letter (decimal, hexadecimal, etc). 53 | nd, ni, nu, nx, nX, no: convert a nativeint argument to the format specified by the second letter. 54 | Ld, Li, Lu, Lx, LX, Lo: convert an int64 argument to the format specified by the second letter. 55 | a: user-defined printer. Take two arguments and apply the first one to outchan (the current output channel) and to the second argument. The first argument must therefore have type out_channel -> 'b -> unit and the second 'b. The output produced by the function is inserted in the output of fprintf at the current point. 56 | t: same as %a, but take only one argument (with type out_channel -> unit) and apply it to outchan. 57 | { fmt %}: convert a format string argument to its type digest. The argument must have the same type as the internal format string fmt. 58 | ( fmt %): format string substitution. Take a format string argument and substitute it to the internal format string fmt to print following arguments. The argument must have the same type as the internal format string fmt. 59 | !: take no argument and flush the output. 60 | %: take no argument and output one % character. 61 | @: take no argument and output one @ character. 62 | ,: take no argument and output nothing: a no-op delimiter for conversion specifications 63 | *) 64 | 65 | let type_of_format = 66 | T.( 67 | function 68 | | "d" | "i" | "u" | "n" | "L" | "N" | "x" | "X" | "o" -> 69 | Some int 70 | | "s" | "S" -> 71 | Some string 72 | | "c" | "C" -> 73 | Some char 74 | | "f" | "F" | "e" | "E" | "g" | "G" | "h" | "H" -> 75 | Some float 76 | | "B" | "b" -> 77 | Some bool 78 | | "nd" | "ni" | "nu" | "nx" | "nX" | "no" -> 79 | Some nativeint 80 | | "Ld" | "Li" | "Lu" | "Lx" | "LX" | "Lo" -> 81 | Some int64 82 | | "t" -> 83 | Some (unit ^-> string) 84 | | _ -> 85 | None ) 86 | 87 | (* for reference *) 88 | let _escape s = 89 | let buffer = Buffer.create (String.length s) in 90 | String.iter 91 | (function 92 | | '&' -> 93 | Buffer.add_string buffer "&" 94 | | '<' -> 95 | Buffer.add_string buffer "<" 96 | | '>' -> 97 | Buffer.add_string buffer ">" 98 | | '"' -> 99 | Buffer.add_string buffer """ 100 | | '\'' -> 101 | Buffer.add_string buffer "'" 102 | | c -> 103 | Buffer.add_char buffer c ) 104 | s ; 105 | Buffer.contents buffer 106 | 107 | let esprintf format args = 108 | E.apply (stdlib_module_field ["Printf"; "sprintf"]) (format :: args) 109 | 110 | let compile_to_expr ((args, elements) : Template.t) : Mocaml.expr = 111 | let header e = 112 | let defs = [(P.var n_buffer, e_buffer_create (E.lit_int 16))] in 113 | match args with 114 | | Some args -> 115 | E.fun_ ([P.prim args] ^^-> E.let_ defs e) 116 | | None -> 117 | E.let_ defs e 118 | in 119 | let footer = e_buffer_contents (E.var n_buffer) in 120 | let ele_to_expr : elt -> Mocaml.mixed = function 121 | | Text s -> 122 | Mixed.unit E.(e_buffer_add_string (var n_buffer) (lit_string s)) 123 | | Code s -> 124 | Mixed.prim s 125 | | Output {format; code; escape} -> 126 | let eescape = if escape then e_app_escape else Fun.id in 127 | let format = Option.value ~default:"s" format in 128 | let type_ = type_of_format format in 129 | let format = "%" ^ format in 130 | Mixed.unit 131 | E.( 132 | match type_ with 133 | | None -> 134 | e_buffer_add_string (var n_buffer) 135 | (eescape @@ esprintf (lit_string format) [prim code]) 136 | | Some type_ -> 137 | e_buffer_add_string (var n_buffer) 138 | (eescape @@ esprintf (lit_string format) [prim code ^: type_]) ) 139 | in 140 | let body = E.(mixed_seq (List.map ele_to_expr elements) footer) in 141 | header body 142 | 143 | let compile_to_string template = 144 | Mocaml.Printer.expr_to_string (compile_to_expr template) 145 | 146 | let compile_to_expr_continuation ((args, elements) : Template.t) : Mocaml.expr = 147 | let args = match args with Some args -> P.[prim args] | None -> [] in 148 | let header e = E.fun_ @@ P.(args @ [var n_continuation]) ^^-> e in 149 | let ele_to_expr : elt -> Mocaml.mixed = function 150 | | Text s -> 151 | Mixed.unit E.(e_app_continuation (lit_string s)) 152 | | Code s -> 153 | Mixed.prim s 154 | | Output {format; code; escape} -> 155 | let eescape = if escape then e_app_escape else Fun.id in 156 | let format = Option.value ~default:"s" format in 157 | let type_ = type_of_format format in 158 | let format = "%" ^ format in 159 | Mixed.unit 160 | E.( 161 | match type_ with 162 | | None -> 163 | e_app_continuation @@ eescape 164 | @@ esprintf (lit_string format) [prim code] 165 | | Some type_ -> 166 | e_app_continuation @@ eescape 167 | @@ esprintf (lit_string format) [prim code ^: type_] ) 168 | in 169 | header @@ E.(mixed_seq (List.map ele_to_expr elements) unit) 170 | 171 | let compile ?(continuation_mode = false) name t = 172 | let compile = 173 | if continuation_mode then compile_to_expr_continuation else compile_to_expr 174 | in 175 | (P.var name, compile t) 176 | 177 | let is_eml_file filename = 178 | let extensions = filename |> String.split_on_char '.' |> List.rev in 179 | match extensions with 180 | | [] -> 181 | false 182 | | "eml" :: _ -> 183 | true 184 | | _ :: "eml" :: _ -> 185 | true 186 | | _ -> 187 | false 188 | 189 | let eml_basename filename = 190 | filename |> String.split_on_char '.' |> List.rev 191 | |> (function 192 | | [] -> 193 | assert false 194 | | "eml" :: li -> 195 | li 196 | | _ :: "eml" :: li -> 197 | li 198 | | _ -> 199 | assert false ) 200 | |> List.rev |> String.concat "." 201 | 202 | let compile_folder ?(continuation_mode = false) folder_name = 203 | let directory = 204 | read_file_or_directory ~filter:is_eml_file ~sorted:true folder_name 205 | in 206 | let rec aux current_file = 207 | match current_file with 208 | | File filename -> ( 209 | let name = eml_basename filename in 210 | let function_name = Filename.basename name in 211 | match Template_builder.of_filename filename with 212 | | Ok template -> 213 | let pat, expr = compile ~continuation_mode function_name template in 214 | Some (SI.def (pat ^= expr)) 215 | | Error e -> 216 | Lexer.pp_error Format.err_formatter e ; 217 | exit 1 ) 218 | | Directory (name, files) -> ( 219 | let module_name = String.capitalize_ascii (Filename.basename name) in 220 | files |> Array.to_list |> List.filter_map aux 221 | |> function 222 | | [] -> 223 | None 224 | | _ :: _ as struct_items -> 225 | let struct_items = 226 | Mocaml.Transform.force_mutual_recursion struct_items 227 | in 228 | Some (SI.module_ @@ module_name ^= M.struct_ struct_items) ) 229 | in 230 | match directory with 231 | | File _ -> 232 | if is_eml_file folder_name then 233 | let name = eml_basename folder_name ^ ".ml" in 234 | match Template_builder.of_filename folder_name with 235 | | Ok template -> 236 | let pattern, value = compile ~continuation_mode "render" template in 237 | let defs = [SI.def (pattern ^= value)] in 238 | CCIO.with_out name (fun chan -> 239 | Mocaml.Printer.print_program chan defs ) 240 | | Error e -> 241 | Lexer.pp_error Format.err_formatter e 242 | else assert false 243 | | Directory (name, files) -> 244 | if files = [||] then 245 | Error.fail "Error : directory `%s` does not contain eml files" name ; 246 | let program = files |> Array.to_list |> List.filter_map aux in 247 | CCIO.with_out (folder_name ^ ".ml") (fun chan -> 248 | Mocaml.Printer.print_program chan program ) 249 | --------------------------------------------------------------------------------