├── doc ├── dune └── index.mld ├── test ├── cmdliner │ ├── .ocamlformat-ignore │ ├── README.md │ ├── dune │ ├── test_ppx_deriving_cmdliner.ml │ └── LICENSE.txt ├── test_enum.mli ├── dune ├── test_group_cmd.mli ├── test_enum.ml ├── test_subliner.ml ├── test_term_info.ml ├── test_term_as_term.ml ├── test_group_cmd.ml ├── utils.ml ├── test_term.mli ├── test_term_conv.ml ├── test_attr.ml └── test_term.ml ├── .ocamlformat ├── src ├── dune ├── error.ml ├── deriver_enum.ml ├── utils.ml ├── deriver.ml ├── enum.ml ├── attribute_parser.mli ├── rewriter.ml ├── group_cmds.ml ├── attribute_parser.ml └── term.ml ├── .gitignore ├── example ├── greet_subliner_term.ml ├── greet.ml ├── foobar.ml ├── greet_subliner.ml ├── dune └── greet_cmdliner.ml ├── .github └── workflows │ ├── odoc.yml │ └── build.yml ├── dune-project ├── LICENSE ├── ppx_subliner.opam └── README.md /doc/dune: -------------------------------------------------------------------------------- 1 | (documentation 2 | (package ppx_subliner)) 3 | -------------------------------------------------------------------------------- /test/cmdliner/.ocamlformat-ignore: -------------------------------------------------------------------------------- 1 | test_ppx_deriving_cmdliner.ml -------------------------------------------------------------------------------- /test/test_enum.mli: -------------------------------------------------------------------------------- 1 | type t = Enum_1 | Enum_2 [@names [ "overide-name"; "o" ]] 2 | [@@deriving subliner_enum] 3 | 4 | val test_set : unit Alcotest.test_case list 5 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_subliner) 3 | (preprocess 4 | (pps ppx_subliner ppx_deriving_cmdliner ppxlib.metaquot)) 5 | (libraries ppx_subliner alcotest ppxlib)) 6 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | break-fun-decl=fit-or-vertical 2 | break-fun-sig=fit-or-vertical 3 | break-infix=fit-or-vertical 4 | break-infix-before-func 5 | if-then-else=fit-or-vertical 6 | 7 | -------------------------------------------------------------------------------- /test/cmdliner/README.md: -------------------------------------------------------------------------------- 1 | The tests in this dir are copied from [ppx_deriving_cmdliner](https://github.com/hammerlab/ppx_deriving_cmdliner) and are modified to use `ppx_subliner` and `ppx_show`. -------------------------------------------------------------------------------- /test/cmdliner/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_ppx_deriving_cmdliner) 3 | (libraries alcotest result ppx_show.runtime) 4 | (flags :standard -w -27-39) 5 | (preprocess 6 | (pps ppx_show ppx_subliner))) 7 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name ppx_subliner) 3 | (kind ppx_rewriter) 4 | (preprocess 5 | (pps ppxlib.metaquot ppx_make)) 6 | (libraries ppxlib) 7 | (ppx_runtime_libraries cmdliner) 8 | (instrumentation 9 | (backend bisect_ppx))) 10 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # ocamlbuild working directory 2 | _build/ 3 | _coverage/ 4 | 5 | # Merlin configuring file for Vim and Emacs 6 | .merlin 7 | *.coverage 8 | 9 | # Dune generated files 10 | *.install 11 | 12 | # Local OPAM switch 13 | _opam/ 14 | 15 | # Vim buffer 16 | *.sw[pqr] 17 | -------------------------------------------------------------------------------- /example/greet_subliner_term.ml: -------------------------------------------------------------------------------- 1 | type params = { night : bool; name : string [@pos 0] } [@@deriving cmdliner] 2 | 3 | let greet { night; name } = Greet.english ~night name 4 | 5 | [%%subliner.term 6 | eval.params <- greet] 7 | [@@name "greet"] [@@version "3.14"] 8 | (** Greet in English *) 9 | -------------------------------------------------------------------------------- /example/greet.ml: -------------------------------------------------------------------------------- 1 | let english ~night name = 2 | if night then 3 | Printf.printf "\nGood night, %s\n" name 4 | else 5 | Printf.printf "\nGood morning, %s\n" name 6 | 7 | let chinese ~night name = 8 | if night then 9 | Printf.printf "\n晚上好, %s\n" name 10 | else 11 | Printf.printf "\n早上好, %s\n" name 12 | 13 | let programmer () = Printf.printf "\nHello world!\n" 14 | -------------------------------------------------------------------------------- /.github/workflows/odoc.yml: -------------------------------------------------------------------------------- 1 | name: Deploy odoc 2 | 3 | on: 4 | push: 5 | branches: [main] 6 | 7 | jobs: 8 | deploy-doc: 9 | runs-on: ubuntu-latest 10 | steps: 11 | - name: Checkout code 12 | uses: actions/checkout@v3 13 | 14 | - name: Use OCaml 4.14.x 15 | uses: ocaml/setup-ocaml@v2 16 | with: 17 | ocaml-compiler: 4.14.x 18 | dune-cache: true 19 | 20 | - name: Deploy odoc to GitHub Pages 21 | uses: ocaml/setup-ocaml/deploy-doc@v2 22 | -------------------------------------------------------------------------------- /test/test_group_cmd.mli: -------------------------------------------------------------------------------- 1 | type t = { t : string } [@@deriving subliner] 2 | 3 | module M : sig 4 | type m = { m : int } [@@deriving subliner] 5 | end 6 | 7 | type cmdliner = { cmdliner : string [@pos 0] } [@@deriving cmdliner] 8 | 9 | type simple = 10 | | Simple_t of t 11 | | Simple_m of M.m 12 | | Simple_name_attr of t [@name "override-name"] 13 | | Simple_no_arg 14 | | Simple_inline of { i : int } 15 | | Simple_cmdliner of cmdliner 16 | | Simple_multi of t * M.m * cmdliner 17 | [@@deriving subliner] 18 | 19 | val test_set : unit Alcotest.test_case list 20 | -------------------------------------------------------------------------------- /example/foobar.ml: -------------------------------------------------------------------------------- 1 | type foo = { my_arg : string } [@@deriving subliner] 2 | 3 | type params = Foo of foo | Bar | Foobar of { my_arg : string } 4 | [@@deriving subliner] 5 | 6 | let handle = function 7 | | Foo { my_arg } -> print_endline ("Foo " ^ my_arg) 8 | | Bar -> print_endline "Bar" 9 | | Foobar { my_arg } -> print_endline ("Foobar" ^ my_arg) 10 | 11 | (* {eval function}.{type name} <- {function expression> *) 12 | [%%subliner.cmds 13 | eval.params <- handle] 14 | [@@name "foobar"] 15 | [@@version "3.14"] 16 | [@@default Cmdliner.Term.(ret (const (`Error (false, "foobar2000"))))] 17 | (** Some docs *) 18 | -------------------------------------------------------------------------------- /example/greet_subliner.ml: -------------------------------------------------------------------------------- 1 | type subparams = { night : bool; name : string [@pos 0] [@docv "NAME"] } 2 | [@@deriving subliner] 3 | 4 | type params = 5 | | English of subparams (** Greet in English *) 6 | | Chinese of subparams (** Greet in Chinese *) 7 | | Programmer (** Hello world! *) 8 | [@@deriving subliner] 9 | 10 | let greet = function 11 | | English { night; name } -> Greet.english ~night name 12 | | Chinese { night; name } -> Greet.chinese ~night name 13 | | Programmer -> Greet.programmer () 14 | 15 | [%%subliner.cmds 16 | eval.params <- greet] 17 | [@@name "greet"] [@@version "3.14"] 18 | (** Greet in different languages! *) 19 | -------------------------------------------------------------------------------- /test/test_enum.ml: -------------------------------------------------------------------------------- 1 | type t = Enum_1 | Enum_2 [@names [ "override-name"; "o" ]] 2 | [@@deriving subliner_enum] 3 | 4 | let cmdliner_term () = 5 | let open Cmdliner in 6 | Arg.required 7 | @@ Arg.pos 0 (Arg.some @@ cmdliner_conv ()) None (Cmdliner.Arg.info []) 8 | 9 | let test = Test_term.test_ok "simple" cmdliner_term 10 | let test_error = Test_term.test_error "simple" cmdliner_term 11 | 12 | let test_set = 13 | [ 14 | test "simple" Enum_1 [| "cmd"; "enum-1" |]; 15 | test "names_1" Enum_2 [| "cmd"; "override-name" |]; 16 | test "names_2" Enum_2 [| "cmd"; "o" |]; 17 | test_error "invalid" `Parse [| "cmd"; "enum-2" |]; 18 | ] 19 | -------------------------------------------------------------------------------- /src/error.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | let f = Location.raise_errorf 4 | 5 | let unsupported_type ~loc type_ { txt = name; loc = _ } = 6 | f ~loc "%s %s cannot be derived" type_ name 7 | 8 | let field_type ~loc = f ~loc "unsupported field type" 9 | let attribute_name ~loc = f ~loc "unexpected attribute name: %s" 10 | let attribute_payload ~loc = f ~loc "payload of `%s` must be an expression" 11 | let attribute_flag ~loc = f ~loc "flag cannot have any payload" 12 | let attr_list_type ~loc = f ~loc "`%s` must be used with list type" 13 | let enum_payload ~loc = f ~loc "enum variant cannot have any payload" 14 | 15 | let unexpected ~loc = 16 | f ~loc "congratulation for triggering this `impossible` error" 17 | -------------------------------------------------------------------------------- /example/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name greet) 3 | (modules greet)) 4 | 5 | (executable 6 | (name foobar) 7 | (modules foobar) 8 | (preprocess 9 | (pps ppx_deriving_cmdliner ppx_subliner))) 10 | 11 | (executable 12 | (name greet_cmdliner) 13 | (modules greet_cmdliner) 14 | (preprocess 15 | (pps ppx_deriving_cmdliner)) 16 | (libraries cmdliner greet)) 17 | 18 | (executable 19 | (name greet_subliner) 20 | (modules greet_subliner) 21 | (preprocess 22 | (pps ppx_deriving_cmdliner ppx_subliner)) 23 | (libraries greet)) 24 | 25 | (executable 26 | (name greet_subliner_term) 27 | (modules greet_subliner_term) 28 | (preprocess 29 | (pps ppx_deriving_cmdliner ppx_subliner)) 30 | (libraries greet)) 31 | -------------------------------------------------------------------------------- /test/test_subliner.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Alcotest.run "ppx_subliner" 3 | [ 4 | ("attr", Test_attr.Common.test_set); 5 | ("attr.term", Test_attr.Term.test_set); 6 | ("attr.string_conv", Test_attr.String_conv.test_set); 7 | ("attr.cmd_info", Test_attr.Cmd_info.test_set); 8 | ("attr.single", Test_attr.Single.test_set); 9 | ("term.conv", Test_term_conv.test_set); 10 | ("term.info", Test_term_info.test_set); 11 | ("term.as-term", Test_term_as_term.test_set); 12 | ("term.named", Test_term.Named.test_set); 13 | ("term.postional", Test_term.Positional.test_set); 14 | ("term", Test_term.test_set); 15 | ("group-cmd", Test_group_cmd.test_set); 16 | ("enum", Test_enum.test_set); 17 | ] 18 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | (name ppx_subliner) 3 | (version "0.2.1") 4 | 5 | (generate_opam_files true) 6 | 7 | (source (github bn-d/ppx_subliner)) 8 | (license MIT) 9 | (authors "Boning ") 10 | (maintainers "Boning ") 11 | (documentation "https://boni.ng/ppx_subliner/ppx_subliner/index.html") 12 | 13 | (package 14 | (name ppx_subliner) 15 | (synopsis "[@@deriving subliner] and [%%subliner] for Cmdliner") 16 | (description "[@@deriving] plugin to generate Cmdliner terms and sub-command \ 17 | groups and ppx rewriter to generate Cmdliner evaluations.") 18 | (depends 19 | (ppxlib (>= 0.10.0)) 20 | (cmdliner (>= 1.1.0)) 21 | (ppx_make (>= 0.3.0)) 22 | (alcotest :with-test) 23 | (ppx_deriving_cmdliner :with-test) 24 | (ppx_show :with-test) 25 | (bisect_ppx :with-test))) 26 | -------------------------------------------------------------------------------- /test/test_term_info.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | open Ppx_subliner.Term.Info 3 | module Ap = Ppx_subliner.Attribute_parser.Term 4 | 5 | let loc = Location.none 6 | 7 | let test_gen = 8 | Utils.test_equal Ppxlib.Pprintast.expression 9 | (expr_of_attrs ~loc [%expr [ "NAME" ]]) 10 | 11 | let test_set = 12 | let u = (loc, [%str ()]) in 13 | [ 14 | test_gen "empty" [%expr Cmdliner.Arg.info [ "NAME" ]] Ap.empty; 15 | test_gen "all" 16 | (let env_expr = 17 | [%expr Cmdliner.Cmd.Env.info ~deprecated:() ~docs:() ~doc:() ()] 18 | in 19 | [%expr 20 | Cmdliner.Arg.info ~deprecated:() ~absent:() ~docs:() ~docv:() 21 | ~doc:(Stdlib.String.trim ()) ~env:[%e env_expr] [ "NAME" ]]) 22 | (Ap.make_t ~deprecated:u ~absent:u ~docs:u ~docv:u ~doc:u ~env:u 23 | ~env_deprecated:u ~env_docs:u ~env_doc:u ()); 24 | ] 25 | -------------------------------------------------------------------------------- /example/greet_cmdliner.ml: -------------------------------------------------------------------------------- 1 | open Cmdliner 2 | 3 | type params = { night : bool; name : string [@pos 0] } [@@deriving cmdliner] 4 | 5 | let english = 6 | let doc = "Greet in English" in 7 | let info = Cmd.info ~doc "english" in 8 | let f { night; name } = Greet.english ~night name in 9 | Cmd.v info Term.(const f $ params_cmdliner_term ()) 10 | 11 | let chinese = 12 | let doc = "Greet in Chinese" in 13 | let info = Cmd.info ~doc "chinese" in 14 | let f { night; name } = Greet.chinese ~night name in 15 | Cmd.v info Term.(const f $ params_cmdliner_term ()) 16 | 17 | let programmer = 18 | let doc = "Hello world!" in 19 | let info = Cmd.info ~doc "programmer" in 20 | let f () = Greet.programmer () in 21 | Cmd.v info Term.(const f $ const ()) 22 | 23 | let cmd = 24 | let doc = "Greet in different languages!" in 25 | let info = Cmd.info ~doc "greet" in 26 | let default = Term.(ret (const (`Help (`Auto, None)))) in 27 | Cmd.group ~default info [ english; chinese; programmer ] 28 | 29 | let () = exit (Cmd.eval cmd) 30 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 Boning 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 | -------------------------------------------------------------------------------- /ppx_subliner.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.2.1" 4 | synopsis: "[@@deriving subliner] and [%%subliner] for Cmdliner" 5 | description: 6 | "[@@deriving] plugin to generate Cmdliner terms and sub-command groups and ppx rewriter to generate Cmdliner evaluations." 7 | maintainer: ["Boning "] 8 | authors: ["Boning "] 9 | license: "MIT" 10 | homepage: "https://github.com/bn-d/ppx_subliner" 11 | doc: "https://boni.ng/ppx_subliner/ppx_subliner/index.html" 12 | bug-reports: "https://github.com/bn-d/ppx_subliner/issues" 13 | depends: [ 14 | "dune" {>= "2.7"} 15 | "ppxlib" {>= "0.10.0"} 16 | "cmdliner" {>= "1.1.0"} 17 | "ppx_make" {>= "0.3.0"} 18 | "alcotest" {with-test} 19 | "ppx_deriving_cmdliner" {with-test} 20 | "ppx_show" {with-test} 21 | "bisect_ppx" {with-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: "git+https://github.com/bn-d/ppx_subliner.git" 39 | -------------------------------------------------------------------------------- /src/deriver_enum.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | (* generate structure for type declaration *) 4 | let structure_of_type_decl ~loc:_ (_ : rec_flag) (td : type_declaration) : 5 | structure = 6 | let name = td.ptype_name and loc = td.ptype_loc in 7 | let () = Utils.check_params_empty name td.ptype_params in 8 | match td with 9 | | { ptype_kind = Ptype_variant cds; _ } -> 10 | (* type t = C of T | ... *) 11 | Enum.structure_of_const_decls ~loc name cds 12 | | _ -> Error.unsupported_type ~loc "type declaration" name 13 | 14 | (* generate signature for type declaration *) 15 | let signature_of_type_decl ~loc:_ (_ : rec_flag) (td : type_declaration) : 16 | signature = 17 | let name = td.ptype_name and loc = td.ptype_loc in 18 | let () = Utils.check_params_empty name td.ptype_params in 19 | match td with 20 | | { ptype_kind = Ptype_variant _; _ } -> 21 | (* type t = C of T | ... *) 22 | Enum.signature_of_const_decls ~loc name 23 | | _ -> Error.unsupported_type ~loc "type declaration" name 24 | 25 | let str_type_decl = Utils.make_type_decl_generator structure_of_type_decl 26 | let sig_type_decl = Utils.make_type_decl_generator signature_of_type_decl 27 | let deriver = Deriving.add "subliner_enum" ~str_type_decl ~sig_type_decl 28 | -------------------------------------------------------------------------------- /src/utils.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | (* compatibility *) 4 | let string_starts_with ~prefix s = 5 | let open String in 6 | let len_s = length s and len_pre = length prefix in 7 | let rec aux i = 8 | if i = len_pre then 9 | true 10 | else if unsafe_get s i <> unsafe_get prefix i then 11 | false 12 | else 13 | aux (i + 1) 14 | in 15 | len_s >= len_pre && aux 0 16 | 17 | (* Misc. Utils *) 18 | 19 | let gen_name_str suffix = function 20 | | "t" -> suffix 21 | | s -> Printf.sprintf "%s_%s" s suffix 22 | 23 | let check_params_empty { txt; loc } params = 24 | if List.length params == 0 then 25 | () 26 | else 27 | Location.raise_errorf ~loc "type %s cannot have params" txt 28 | 29 | let make_type_decl_generator f = 30 | Deriving.Generator.V2.make_noarg (fun ~ctxt (rec_flag, tds) -> 31 | let loc = Expansion_context.Deriver.derived_item_loc ctxt in 32 | tds |> List.map (f ~loc rec_flag) |> List.concat) 33 | 34 | let longident_loc_of_name { txt; loc } = { txt = Lident txt; loc } 35 | 36 | let map_lid_name f { txt; loc } = 37 | let impl = function 38 | | Lident str -> Lident (f str) 39 | | Ldot (t, str) -> Ldot (t, f str) 40 | | _ -> Location.raise_errorf ~loc "Lapply of Longident is not supported" 41 | in 42 | { txt = impl txt; loc } 43 | 44 | let esome ~loc e = [%expr Some [%e e]] 45 | let elist ~loc e = [%expr [ [%e e] ]] 46 | -------------------------------------------------------------------------------- /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: CI Workflow 2 | 3 | on: 4 | push: 5 | branches: [main] 6 | pull_request: 7 | branches: [main] 8 | workflow_dispatch: 9 | 10 | jobs: 11 | build: 12 | strategy: 13 | fail-fast: false 14 | matrix: 15 | os: 16 | - ubuntu-latest 17 | ocaml-compiler: 18 | - 4.08.x 19 | - 4.14.1 20 | 21 | runs-on: ${{ matrix.os }} 22 | 23 | steps: 24 | - name: Checkout code 25 | uses: actions/checkout@v3 26 | 27 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 28 | uses: ocaml/setup-ocaml@v2 29 | with: 30 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 31 | 32 | - name: Install dependencies 33 | run: opam install . --deps-only --with-test 34 | 35 | - name: Build 36 | run: opam exec -- dune build --verbose 37 | 38 | - name: Test 39 | run: opam exec -- dune runtest --verbose 40 | 41 | - name: Coverage 42 | if: ${{ matrix.ocaml-compiler == '4.14.1' }} 43 | env: 44 | COVERALLS_REPO_TOKEN: ${{ secrets.COVERALLS_REPO_TOKEN }} 45 | PULL_REQUEST_NUMBER: ${{ github.event.number }} 46 | run: | 47 | opam exec -- dune runtest --instrument-with bisect_ppx --force 48 | opam exec -- bisect-ppx-report summary 49 | opam exec -- bisect-ppx-report send-to Coveralls 50 | -------------------------------------------------------------------------------- /src/deriver.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | (* generate structure for type declaration *) 4 | let structure_of_type_decl ~loc:_ (_ : rec_flag) (td : type_declaration) : 5 | structure = 6 | let name = td.ptype_name and loc = td.ptype_loc in 7 | let () = Utils.check_params_empty name td.ptype_params in 8 | match td with 9 | | { ptype_kind = Ptype_variant cds; _ } -> 10 | (* type t = C of T | ... *) 11 | Group_cmds.structure_of_const_decls ~loc name cds 12 | | { ptype_kind = Ptype_record lds; _ } -> 13 | (* type t = {l: T; ...} *) 14 | Term.structure_of_label_decls ~loc name lds 15 | | _ -> Error.unsupported_type ~loc "type declaration" name 16 | 17 | (* generate signature for type declaration *) 18 | let signature_of_type_decl ~loc:_ (_ : rec_flag) (td : type_declaration) : 19 | signature = 20 | let name = td.ptype_name and loc = td.ptype_loc in 21 | let () = Utils.check_params_empty name td.ptype_params in 22 | match td with 23 | | { ptype_kind = Ptype_variant _; _ } -> 24 | (* type t = C of T | ... *) 25 | Group_cmds.signature_of_const_decls ~loc name 26 | | { ptype_kind = Ptype_record _; _ } -> 27 | (* type t = {l: T; ...} *) 28 | Term.signature_of_label_decls ~loc name 29 | | _ -> Error.unsupported_type ~loc "type declaration" name 30 | 31 | let str_type_decl = Utils.make_type_decl_generator structure_of_type_decl 32 | let sig_type_decl = Utils.make_type_decl_generator signature_of_type_decl 33 | let deriver = Deriving.add "subliner" ~str_type_decl ~sig_type_decl 34 | -------------------------------------------------------------------------------- /test/test_term_as_term.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | open Ppx_subliner.Term.As_term 3 | module Ap = Ppx_subliner.Attribute_parser.Term 4 | 5 | let loc = Location.none 6 | let test = Utils.test_equal Utils.pp (of_attrs ~loc) 7 | let test_raises = Utils.test_raises (of_attrs ~loc) 8 | 9 | let test_set = 10 | let unit_expr = [%expr ()] in 11 | let s = (loc, [%str]) and u = (loc, [%str [%e unit_expr]]) in 12 | [ 13 | test "empty" (`value None) Ap.empty; 14 | test "default" (`value (Some unit_expr)) (Ap.make_t ~default:u ()); 15 | test_raises "default.invalid" 16 | ~exn:"payload of `default` must be an expression" 17 | (Ap.make_t ~default:s ()); 18 | test "non_empty" `non_empty (Ap.make_t ~non_empty:s ()); 19 | test_raises "non_empty.invalid" ~exn:"flag cannot have any payload" 20 | (Ap.make_t ~non_empty:u ()); 21 | test "last" (`last (None, None)) (Ap.make_t ~last:s ()); 22 | test "last.default" 23 | (`last (None, Some unit_expr)) 24 | (Ap.make_t ~last:s ~default:u ()); 25 | test "last.sep" 26 | (`last (Some unit_expr, None)) 27 | (Ap.make_t ~last:s ~last_sep:u ()); 28 | test_raises "last.invalid" ~exn:"flag cannot have any payload" 29 | (Ap.make_t ~last:u ()); 30 | test_raises "non_empty_last_conflict" 31 | ~exn:"`non_empty` and `last` cannot be used at the same time" 32 | (Ap.make_t ~non_empty:s ~last:s ()); 33 | test_raises "non_empty_default_conflict" 34 | ~exn:"`non_empty` and `default` cannot be used at the same time" 35 | (Ap.make_t ~non_empty:s ~default:u ()); 36 | ] 37 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # [@@deriving subliner] and [%%subliner] 2 | [![OCaml][ocaml-badge]](#) 3 | [![CI][ci-badge]](https://github.com/bn-d/ppx_subliner/actions/workflows/build.yml) 4 | [![GitHub release status][release-badge]](https://github.com/bn-d/ppx_subliner/releases) 5 | [![Coverage Status][coveralls-badge]](https://coveralls.io/github/bn-d/ppx_subliner?branch=main) 6 | 7 | [ocaml-badge]: https://img.shields.io/badge/-OCaml-EC6813?logo=ocaml&labelColor=white 8 | [ci-badge]: https://github.com/bn-d/ppx_subliner/actions/workflows/build.yml/badge.svg?branch=master 9 | [release-badge]: https://img.shields.io/github/v/release/bn-d/ppx_subliner 10 | [coveralls-badge]: https://coveralls.io/repos/github/bn-d/ppx_subliner/badge.svg?branch=main 11 | 12 | `[@@deriving]` plugin to generate [Cmdliner](cmdliner) sub-command groups, and ppx rewriter to generate [Cmdliner](cmdliner) evaluations. 13 | 14 | ## Installation 15 | 16 | `ppx_subliner` can be installed via [OCaml Package Manager](https://opam.ocaml.org/packages/ppx_subliner/). 17 | 18 | ```console 19 | $ opam install ppx_subliner 20 | ``` 21 | 22 | ## Usage 23 | Please see the [documentation](https://boni.ng/ppx_subliner/ppx_subliner/index.html). 24 | 25 | [cmdliner]: https://github.com/dbuenzli/cmdliner 26 | 27 | ## Example 28 | 29 | ```ocaml 30 | type foo = { my_arg : string } [@@deriving subliner] 31 | 32 | type params = Foo of foo | Bar | Foobar of { my_arg : string } 33 | [@@deriving subliner] 34 | 35 | let handle = function 36 | | Foo { my_arg } -> print_endline ("Foo " ^ my_arg) 37 | | Bar -> print_endline "Bar" 38 | | Foobar { my_arg } -> print_endline ("Foobar" ^ my_arg) 39 | 40 | [%%subliner.cmds 41 | eval.params <- handle] 42 | (** Some docs *) 43 | ``` 44 | -------------------------------------------------------------------------------- /test/test_group_cmd.ml: -------------------------------------------------------------------------------- 1 | type t = { t : string } [@@deriving subliner] 2 | 3 | module M = struct 4 | type m = { m : int } [@@deriving subliner] 5 | end 6 | 7 | type cmdliner = { cmdliner : string [@pos 0] } [@@deriving cmdliner] 8 | 9 | type simple = 10 | | Simple_t of t (** special naming rule for type t *) 11 | | Simple_m of M.m 12 | | Simple_name_attr of t [@name "override-name"] 13 | | Simple_no_arg 14 | | Simple_inline of { i : int } 15 | | Simple_cmdliner of cmdliner (** ppx_deriving_cmdliner compatibility *) 16 | | Simple_multi of t * M.m * cmdliner 17 | [@@deriving subliner] 18 | 19 | let test = 20 | let cmd = 21 | let info = Cmdliner.Cmd.info "cmd" in 22 | Cmdliner.Cmd.group info (simple_cmdliner_group_cmds Fun.id) 23 | in 24 | Utils.test_cmd_ok "simple" cmd 25 | 26 | let test_set = 27 | [ 28 | test "simple_t" 29 | (Simple_t { t = "test-str-t" }) 30 | [| "cmd"; "simple-t"; "-t"; "test-str-t" |]; 31 | test "simple_m" (Simple_m { m = 42 }) [| "cmd"; "simple-m"; "-m"; "42" |]; 32 | test "simple_name_attr" 33 | (Simple_name_attr { t = "test-str" }) 34 | [| "cmd"; "override-name"; "-t"; "test-str" |]; 35 | test "simple_no_arg" Simple_no_arg [| "cmd"; "simple-no-arg" |]; 36 | test "simple_inline" 37 | (Simple_inline { i = 42 }) 38 | [| "cmd"; "simple-inline"; "-i"; "42" |]; 39 | test "simple_cmdliner" 40 | (Simple_cmdliner { cmdliner = "test-str-cmdliner" }) 41 | [| "cmd"; "simple-cmdliner"; "test-str-cmdliner" |]; 42 | test "simple_multi" 43 | (Simple_multi 44 | ({ t = "test-str-t" }, { m = 42 }, { cmdliner = "test-str-cmdliner" })) 45 | [| 46 | "cmd"; 47 | "simple-multi"; 48 | "-t"; 49 | "test-str-t"; 50 | "-m"; 51 | "42"; 52 | "test-str-cmdliner"; 53 | |]; 54 | ] 55 | -------------------------------------------------------------------------------- /test/utils.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | let diff_msg = "actual is different from expected" 4 | let pp _ _ = () 5 | 6 | let eval_error_to_string : Cmdliner.Cmd.eval_error -> string = function 7 | | `Parse -> "A parse error occurred" 8 | | `Term -> "A term evaluation error occurred" 9 | | `Exn -> "An uncaught exception occurred" 10 | 11 | let eval_error = 12 | Alcotest.of_pp (fun fmt e -> 13 | Format.pp_print_string fmt @@ eval_error_to_string e) 14 | 15 | let eval pp = 16 | Alcotest.of_pp (fun fmt o -> 17 | match o with 18 | | Ok (`Ok t) -> Format.fprintf fmt "`ok(%a)" pp t 19 | | Ok `Version -> Format.pp_print_string fmt "`version" 20 | | Ok `Help -> Format.pp_print_string fmt "`help" 21 | | Error e -> Format.fprintf fmt "`error(%s)" @@ eval_error_to_string e) 22 | 23 | let testf f name check input = 24 | let test () = 25 | let res = check @@ f input in 26 | if res then () else Alcotest.fail "check failed" 27 | in 28 | 29 | Alcotest.test_case name `Quick test 30 | 31 | let test_equal pp f name expected input = 32 | let t = Alcotest.of_pp pp in 33 | let test () = 34 | let actual = f input in 35 | Alcotest.(check t) diff_msg expected actual 36 | in 37 | Alcotest.test_case name `Quick test 38 | 39 | let test_raises f name ~exn input = 40 | let test () = 41 | try 42 | let () = f input |> ignore in 43 | Alcotest.fail "test expected to fail with exception" 44 | with Location.Error error -> 45 | let actual = Location.Error.message error in 46 | Alcotest.(check string) name exn actual 47 | in 48 | Alcotest.test_case name `Quick test 49 | 50 | let test_cmd prefix cmd name expected argv = 51 | let f () = 52 | Cmdliner.Cmd.eval_value ~argv cmd 53 | |> Alcotest.check (eval pp) diff_msg expected 54 | in 55 | Alcotest.test_case (prefix ^ "." ^ name) `Quick f 56 | 57 | let test_cmd_ok prefix cmd name expected argv = 58 | test_cmd prefix cmd name (Ok (`Ok expected)) argv 59 | 60 | let test_cmd_error prefix cmd name expected argv = 61 | test_cmd prefix cmd name (Error expected) argv 62 | -------------------------------------------------------------------------------- /src/enum.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | let suffix = "cmdliner_conv" 4 | let gen_name_str = Utils.gen_name_str suffix 5 | let gen_name { txt = name; loc } = { txt = gen_name_str name; loc } 6 | 7 | let expression_of_const_decl (cd : constructor_declaration) : expression = 8 | let loc = cd.pcd_loc in 9 | let () = 10 | match cd.pcd_args with Pcstr_tuple [] -> () | _ -> Error.enum_payload ~loc 11 | in 12 | let enum_expr = 13 | Ast_helper.Exp.construct ~loc (Utils.longident_loc_of_name cd.pcd_name) None 14 | and names = Attribute_parser.Enum.parse cd.pcd_attributes in 15 | match names with 16 | | None -> 17 | let name_expr = 18 | let name = 19 | cd.pcd_name.txt 20 | |> String.lowercase_ascii 21 | |> String.map (function '_' -> '-' | c -> c) 22 | in 23 | Ast_builder.Default.estring ~loc name 24 | in 25 | [%expr [ ([%e name_expr], [%e enum_expr]) ]] 26 | | Some (loc, structure) -> 27 | let expr = Attribute_parser.to_expr "names" (loc, structure) in 28 | [%expr List.map (fun name -> (name, [%e enum_expr])) [%e expr]] 29 | 30 | let core_type_of_type_name ~loc name = 31 | let ct = 32 | let lid = Utils.longident_loc_of_name name in 33 | Ast_helper.Typ.constr ~loc lid [] 34 | in 35 | [%type: unit -> [%t ct] Cmdliner.Arg.conv] 36 | 37 | let structure_of_const_decls ~loc name (cds : constructor_declaration list) = 38 | let stri = 39 | let pat = Ast_helper.Pat.var ~loc @@ gen_name name 40 | and ct = core_type_of_type_name ~loc name 41 | and expr = 42 | let enum_exprs = List.map expression_of_const_decl cds in 43 | Ast_builder.Default.elist ~loc enum_exprs 44 | in 45 | [%stri 46 | let ([%p pat] : [%t ct]) = 47 | fun () -> 48 | let enums = List.concat [%e expr] in 49 | Cmdliner.Arg.enum enums] 50 | in 51 | [ stri ] 52 | 53 | let signature_of_const_decls ~loc name = 54 | let sigi = 55 | let fun_name = gen_name name and ct = core_type_of_type_name ~loc name in 56 | Ast_helper.Val.mk ~loc fun_name ct |> Ast_helper.Sig.value ~loc 57 | in 58 | [ sigi ] 59 | -------------------------------------------------------------------------------- /test/test_term.mli: -------------------------------------------------------------------------------- 1 | val test_ok : 2 | string -> 3 | (unit -> 'a Cmdliner.Term.t) -> 4 | string -> 5 | 'a -> 6 | string array -> 7 | unit Alcotest.test_case 8 | 9 | val test_error : 10 | string -> 11 | (unit -> 'a Cmdliner.Term.t) -> 12 | string -> 13 | Cmdliner.Cmd.eval_error -> 14 | string array -> 15 | unit Alcotest.test_case 16 | 17 | module Named : sig 18 | type simple = { 19 | flag : bool; 20 | default : int; [@default 42] 21 | bool_default : bool; [@default true] 22 | option : float array option; 23 | required : int32; 24 | non_empty : int64 list; [@non_empty] 25 | last : char; [@last] 26 | last_default : nativeint; [@last] [@default Nativeint.of_int 42] 27 | } 28 | [@@deriving subliner] 29 | 30 | type opt_all = { 31 | required : bool list; [@opt_all] 32 | default : int list; [@opt_all] [@default [ 1; 2 ]] 33 | non_empty : int list; [@opt_all] [@non_empty] 34 | last : int; [@opt_all] [@last] 35 | last_default : int; [@opt_all] [@last] [@default 4] 36 | } 37 | [@@deriving subliner] 38 | 39 | val test_set : unit Alcotest.test_case list 40 | end 41 | 42 | module Positional : sig 43 | type simple = { 44 | pos : char; [@pos 0] 45 | last : string; [@pos 1] [@last] 46 | non_empty : int list; [@pos 2] [@non_empty] 47 | default : int; [@pos 3] [@default 42] 48 | option : float option; [@pos 4] 49 | last_default : bool; [@pos 5] [@last] [@default true] 50 | } 51 | [@@deriving subliner] 52 | 53 | type left = { last : int [@pos_left 2] [@last] } [@@deriving subliner] 54 | 55 | type right = { non_empty : int list [@pos_right 0] [@non_empty] } 56 | [@@deriving subliner] 57 | 58 | type all = { nested : int list list [@pos_all] } [@@deriving subliner] 59 | type rev = { rev : int list [@pos 0] [@rev] } [@@deriving subliner] 60 | 61 | val test_set : unit Alcotest.test_case list 62 | end 63 | 64 | type names = { names : int [@names [ "new_name"; "n" ]] } [@@deriving subliner] 65 | 66 | type sep = { 67 | sep : (int list[@sep '@']); 68 | list : (int list[@sep '@']); 69 | array : (int array[@sep '@']); 70 | tuple : (int * int[@sep '@']); 71 | nested : (((int * int * int)[@sep '#']) list[@sep ';']); 72 | last_sep : int; [@last] [@last.sep '@'] 73 | } 74 | [@@deriving subliner] 75 | 76 | type term = { term : names [@term names_cmdliner_term ()] } 77 | [@@deriving subliner] 78 | 79 | type conv = { conv : (int list[@conv custom_conv]) } [@@deriving subliner] 80 | 81 | val test_set : unit Alcotest.test_case list 82 | -------------------------------------------------------------------------------- /src/attribute_parser.mli: -------------------------------------------------------------------------------- 1 | val to_bool : (Ppxlib.location * Ppxlib.structure) option -> bool 2 | val to_expr : string -> Ppxlib.location * Ppxlib.structure -> Ppxlib.expression 3 | 4 | val to_expr_opt : 5 | string -> 6 | (Ppxlib.location * Ppxlib.structure) option -> 7 | Ppxlib.expression option 8 | 9 | val to_trimmed_string_expr_opt : 10 | string -> 11 | (Ppxlib.location * Ppxlib.structure) option -> 12 | Ppxlib.expression option 13 | 14 | module Term : sig 15 | type 'a t = { 16 | (* term *) 17 | term : 'a option; 18 | (* info *) 19 | deprecated : 'a option; 20 | absent : 'a option; 21 | docs : 'a option; 22 | docv : 'a option; 23 | doc : 'a option; 24 | env : 'a option; 25 | env_deprecated : 'a option; 26 | env_docs : 'a option; 27 | env_doc : 'a option; 28 | (* named *) 29 | names : 'a option; 30 | opt_all : 'a option; 31 | (* positional *) 32 | pos : 'a option; 33 | pos_all : 'a option; 34 | pos_left : 'a option; 35 | pos_right : 'a option; 36 | rev : 'a option; 37 | (* as term *) 38 | non_empty : 'a option; 39 | last : 'a option; 40 | last_sep : 'a option; 41 | (* type *) 42 | default : 'a option; 43 | } 44 | [@@deriving make] 45 | 46 | val empty : 'a t 47 | val map : ('a -> 'b) -> 'a t -> 'b t 48 | 49 | val parse : Ppxlib.attributes -> (Ppxlib.location * Ppxlib.structure) t 50 | (** parse attribute list to a static type *) 51 | end 52 | 53 | module Conv : sig 54 | val parse : Ppxlib.attributes -> (Ppxlib.location * Ppxlib.structure) option 55 | (** parse attribute list to a static type *) 56 | end 57 | 58 | module String_conv : sig 59 | type 'a t = { file : 'a option; dir : 'a option; non_dir_file : 'a option } 60 | [@@deriving make] 61 | 62 | val empty : 'a t 63 | val map : ('a -> 'b) -> 'a t -> 'b t 64 | 65 | val parse : Ppxlib.attributes -> (Ppxlib.location * Ppxlib.structure) t 66 | (** parse attribute list to a static type *) 67 | end 68 | 69 | module Sep_conv : sig 70 | val parse : Ppxlib.attributes -> (Ppxlib.location * Ppxlib.structure) option 71 | (** parse attribute list to a static type *) 72 | end 73 | 74 | module Cmd_info : sig 75 | type 'a t = { 76 | deprecated : 'a option; 77 | man_xrefs : 'a option; 78 | man : 'a option; 79 | envs : 'a option; 80 | exits : 'a option; 81 | sdocs : 'a option; 82 | docs : 'a option; 83 | doc : 'a option; 84 | version : 'a option; 85 | name : 'a option; 86 | } 87 | [@@deriving make] 88 | 89 | val empty : 'a t 90 | val map : ('a -> 'b) -> 'a t -> 'b t 91 | 92 | val parse : Ppxlib.attributes -> (Ppxlib.location * Ppxlib.structure) t 93 | (** parse attribute list to a static type *) 94 | end 95 | 96 | module Enum : sig 97 | val parse : Ppxlib.attributes -> (Ppxlib.location * Ppxlib.structure) option 98 | (** parse attribute list to a static type *) 99 | end 100 | 101 | module Default_term : sig 102 | val parse : Ppxlib.attributes -> (Ppxlib.location * Ppxlib.structure) option 103 | (** parse attribute list to a static type *) 104 | end 105 | -------------------------------------------------------------------------------- /src/rewriter.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | module Ap = Attribute_parser 3 | 4 | type eval_type = Cmds | Term 5 | 6 | let eval_type_of_name = function 7 | | "subliner.cmds" -> Some Cmds 8 | | "subliner.term" -> Some Term 9 | | _ -> None 10 | 11 | let unsupported_error ~loc = 12 | Location.raise_errorf ~loc 13 | "extension payload is not supported. please ensure it is in the format of \ 14 | [%%subliner.[cmds|term] . <- ]" 15 | 16 | let cmd_expr_of_func_expr ~loc ~attrs t lid func_expr : expression = 17 | match t with 18 | | Cmds -> 19 | (* Cmd.info *) 20 | let cmd_info_expr = 21 | (* exe name will be the default cmd name *) 22 | let default_name_expr = [%expr Filename.basename Sys.argv.(0)] in 23 | Group_cmds.Info.expr_of_attrs ~loc default_name_expr attrs 24 | and default_term_expr = 25 | Ap.Default_term.parse attrs 26 | |> Ap.to_expr_opt "default" 27 | |> Option.value 28 | ~default:[%expr Cmdliner.Term.(ret (const (`Help (`Auto, None))))] 29 | and group_cmd_fun_expr = 30 | lid 31 | |> Utils.map_lid_name Group_cmds.gen_name_str 32 | |> Ast_helper.Exp.ident ~loc 33 | in 34 | [%expr 35 | let info : Cmdliner.Cmd.info = [%e cmd_info_expr] 36 | and default = [%e default_term_expr] 37 | and group_cmd = [%e group_cmd_fun_expr] [%e func_expr] in 38 | Cmdliner.Cmd.group ~default info group_cmd] 39 | | Term -> 40 | (* Cmd.info *) 41 | let cmd_info_expr = 42 | (* exe name will be the default cmd name *) 43 | let default_name_expr = [%expr Filename.basename Sys.argv.(0)] in 44 | Group_cmds.Info.expr_of_attrs ~loc default_name_expr attrs 45 | and params_term_expr = 46 | lid |> Utils.map_lid_name Term.gen_name_str |> Ast_helper.Exp.ident 47 | in 48 | [%expr 49 | let info : Cmdliner.Cmd.info = [%e cmd_info_expr] in 50 | Cmdliner.( 51 | Cmd.v info Term.(const [%e func_expr] $ [%e params_term_expr] ()))] 52 | 53 | let eval_fun_of_expr ~loc ~attrs t (expr : expression) : structure_item = 54 | match expr.pexp_desc with 55 | | Pexp_setfield (eval_expr, type_lid, func_expr) -> 56 | let loc = expr.pexp_loc in 57 | let cmd_expr = cmd_expr_of_func_expr ~loc ~attrs t type_lid func_expr in 58 | [%stri 59 | let () = 60 | let cmd = [%e cmd_expr] in 61 | exit (Cmdliner.Cmd.([%e eval_expr]) cmd)] 62 | | _ -> unsupported_error ~loc 63 | 64 | let eval_fun_of_payload ~loc ~attrs t : payload -> structure_item = function 65 | | PStr [ { pstr_desc = Pstr_eval (expr, _attrs); _ } ] -> 66 | eval_fun_of_expr ~loc ~attrs t expr 67 | | _ -> unsupported_error ~loc 68 | 69 | let impl (strs : structure_item list) : structure_item list = 70 | List.filter_map 71 | (fun str -> 72 | let loc = str.pstr_loc in 73 | match str.pstr_desc with 74 | | Pstr_extension (({ txt; loc = _ }, payload), attrs) 75 | when Utils.string_starts_with ~prefix:"subliner" txt -> ( 76 | match eval_type_of_name txt with 77 | | Some t -> Some (eval_fun_of_payload ~loc ~attrs t payload) 78 | | None -> Location.raise_errorf "unknown subliner rewriter name") 79 | | _ -> Some str) 80 | strs 81 | 82 | let () = Driver.register_transformation ~impl "subliner" 83 | -------------------------------------------------------------------------------- /test/test_term_conv.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | open Ppx_subliner.Term.Conv 3 | 4 | let loc = Location.none 5 | let test = Utils.test_equal Utils.pp of_core_type 6 | let test_raises = Utils.test_raises of_core_type 7 | let test_gen name = Utils.test_equal Utils.pp (to_expr ~loc) ("gen." ^ name) 8 | 9 | let test_set = 10 | let u = [%expr ()] and some = [%expr Some ()] in 11 | [ 12 | test "bool" Bool [%type: bool]; 13 | test "Bool.t" Bool [%type: Bool.t]; 14 | test "char" Char [%type: char]; 15 | test "Char.t`" Char [%type: Char.t]; 16 | test "int" Int [%type: int]; 17 | test "Int.t" Int [%type: Int.t]; 18 | test "nativeint" Nativeint [%type: nativeint]; 19 | test "Nativeint.t" Nativeint [%type: Nativeint.t]; 20 | test "int32" Int32 [%type: int32]; 21 | test "Int32.t" Int32 [%type: Int32.t]; 22 | test "int64" Int64 [%type: int64]; 23 | test "Int64.t" Int64 [%type: Int64.t]; 24 | test "float" Float [%type: float]; 25 | test "Float.t" Float [%type: Float.t]; 26 | test "string" String [%type: string]; 27 | test "String.t" String [%type: String.t]; 28 | test "file" File [%type: (string[@file])]; 29 | test "dir" Dir [%type: (string[@dir])]; 30 | test "non_dir_file" Non_dir_file [%type: (string[@non_dir_file])]; 31 | test "option" (Option Int) [%type: int option]; 32 | test "Option.t" (Option Int) [%type: int Option.t]; 33 | test "list" (List (None, Int)) [%type: int list]; 34 | test "List.t" (List (None, Int)) [%type: int List.t]; 35 | test "list.sep" (List (Some u, Int)) [%type: (int list[@sep [%e u]])]; 36 | test "array" (Array (None, Int)) [%type: int array]; 37 | test "Array.t" (Array (None, Int)) [%type: int Array.t]; 38 | test "array.sep" (Array (Some u, Int)) [%type: (int array[@sep [%e u]])]; 39 | test "pair" (Pair (None, (Int, Float))) [%type: int * float]; 40 | test "pair.sep" 41 | (Pair (Some u, (Int, Float))) 42 | [%type: (int * float[@sep [%e u]])]; 43 | test "t3" (T3 (None, (Int, Float, Char))) [%type: int * float * char]; 44 | test "t3.sep" 45 | (T3 (Some u, (Int, Float, Char))) 46 | [%type: (int * float * char[@sep [%e u]])]; 47 | test "t4" 48 | (T4 (None, (Int, Float, Char, Bool))) 49 | [%type: int * float * char * bool]; 50 | test "t4.sep" 51 | (T4 (Some u, (Int, Float, Char, Bool))) 52 | [%type: (int * float * char * bool[@sep [%e u]])]; 53 | test "nested" (List (None, List (None, Int))) [%type: int list list]; 54 | test "inside_attr" (List (None, File)) [%type: (string[@file]) list]; 55 | test "custom" (Custom [%expr ()]) [%type: (my_type[@conv ()])]; 56 | test_raises "invalid_1" ~exn:"unsupported field type" [%type: int seq]; 57 | test_raises "invalid_2" ~exn:"unsupported field type" [%type: unit]; 58 | test_gen "basic" [%expr Cmdliner.Arg.(bool)] Bool; 59 | test_gen "option" [%expr Cmdliner.Arg.(some char)] (Option Char); 60 | test_gen "list" [%expr Cmdliner.Arg.(list ?sep:None int)] (List (None, Int)); 61 | test_gen "list.sep" 62 | [%expr Cmdliner.Arg.(list ?sep:[%e some] int)] 63 | (List (Some u, Int)); 64 | test_gen "array" 65 | [%expr Cmdliner.Arg.(array ?sep:None int)] 66 | (Array (None, Int)); 67 | test_gen "array.sep" 68 | [%expr Cmdliner.Arg.(array ?sep:[%e some] int)] 69 | (Array (Some u, Int)); 70 | test_gen "pair" 71 | [%expr Cmdliner.Arg.(pair ?sep:None int float)] 72 | (Pair (None, (Int, Float))); 73 | test_gen "pair.sep" 74 | [%expr Cmdliner.Arg.(pair ?sep:[%e some] int float)] 75 | (Pair (Some u, (Int, Float))); 76 | test_gen "t3" 77 | [%expr Cmdliner.Arg.(t3 ?sep:None int float char)] 78 | (T3 (None, (Int, Float, Char))); 79 | test_gen "t3.sep" 80 | [%expr Cmdliner.Arg.(t3 ?sep:[%e some] int float char)] 81 | (T3 (Some u, (Int, Float, Char))); 82 | test_gen "t4" 83 | [%expr Cmdliner.Arg.(t4 ?sep:None int float char bool)] 84 | (T4 (None, (Int, Float, Char, Bool))); 85 | test_gen "t4.sep" 86 | [%expr Cmdliner.Arg.(t4 ?sep:[%e some] int float char bool)] 87 | (T4 (Some u, (Int, Float, Char, Bool))); 88 | test_gen "custom" [%expr Cmdliner.Arg.(())] (Custom [%expr ()]); 89 | ] 90 | -------------------------------------------------------------------------------- /test/test_attr.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | module Ap = Ppx_subliner.Attribute_parser 3 | 4 | let loc = Location.none 5 | 6 | module Term = struct 7 | module M = Ap.Term 8 | 9 | let test = 10 | Utils.test_equal Utils.pp (fun e -> 11 | e.pexp_attributes |> M.parse |> M.map (fun _ -> ())) 12 | 13 | let test_raises = Utils.test_raises (fun e -> M.parse e.pexp_attributes) 14 | 15 | let test_set = 16 | [ 17 | test "empty" (M.make_t ()) [%expr t [@irrelevant]]; 18 | test "term" (M.make_t ~term:() ()) [%expr t [@term]]; 19 | test "deprecated" (M.make_t ~deprecated:() ()) [%expr t [@deprecated]]; 20 | test "deprecated_" (M.make_t ~deprecated:() ()) [%expr t [@deprecated_]]; 21 | test "absent" (M.make_t ~absent:() ()) [%expr t [@absent]]; 22 | test "docs" (M.make_t ~docs:() ()) [%expr t [@docs]]; 23 | test "docv" (M.make_t ~docv:() ()) [%expr t [@docv]]; 24 | test "doc" (M.make_t ~doc:() ()) [%expr t [@doc]]; 25 | test "env" (M.make_t ~env:() ()) [%expr t [@env]]; 26 | test "env.deprecated" 27 | (M.make_t ~env_deprecated:() ()) 28 | [%expr t [@env.deprecated]]; 29 | test "env.docs" (M.make_t ~env_docs:() ()) [%expr t [@env.docs]]; 30 | test "env.doc" (M.make_t ~env_doc:() ()) [%expr t [@env.doc]]; 31 | test "names" (M.make_t ~names:() ()) [%expr t [@names]]; 32 | test "opt_all" (M.make_t ~opt_all:() ()) [%expr t [@opt_all]]; 33 | test "pos" (M.make_t ~pos:() ()) [%expr t [@pos]]; 34 | test "pos_all" (M.make_t ~pos_all:() ()) [%expr t [@pos_all]]; 35 | test "pos_left" (M.make_t ~pos_left:() ()) [%expr t [@pos_left]]; 36 | test "pos_right" (M.make_t ~pos_right:() ()) [%expr t [@pos_right]]; 37 | test "rev" (M.make_t ~rev:() ()) [%expr t [@rev]]; 38 | test "non_empty" (M.make_t ~non_empty:() ()) [%expr t [@non_empty]]; 39 | test "last" (M.make_t ~last:() ()) [%expr t [@last]]; 40 | test "last.sep" (M.make_t ~last_sep:() ()) [%expr t [@last.sep]]; 41 | test "default" (M.make_t ~default:() ()) [%expr t [@default]]; 42 | ] 43 | end 44 | 45 | module Common = struct 46 | module M = Term.M 47 | 48 | let test = Term.test 49 | let test_raises = Term.test_raises 50 | let testf = Utils.testf (fun e -> e.pexp_attributes |> M.parse |> M.map snd) 51 | 52 | let test_set = 53 | [ 54 | test "derived" (M.make_t ~doc:() ()) [%expr t [@ocaml.doc]]; 55 | test "prefixed" (M.make_t ~doc:() ()) [%expr t [@subliner.doc]]; 56 | (* level priority *) 57 | testf "priority_0" 58 | (fun { doc; _ } -> doc |> Option.get |> List.length |> ( = ) 1) 59 | [%expr t [@ocaml.doc] [@doc ""]]; 60 | testf "priority_1" 61 | (fun { doc; _ } -> doc |> Option.get |> List.length |> ( = ) 1) 62 | [%expr t [@doc] [@subliner.doc ""]]; 63 | testf "priority_2" 64 | (fun { doc; _ } -> doc |> Option.get |> List.length |> ( = ) 1) 65 | [%expr t [@ocaml.doc] [@subliner.doc ""]]; 66 | testf "priority_3" 67 | (fun { doc; _ } -> doc |> Option.get |> List.length |> ( = ) 1) 68 | [%expr t [@doc] [@doc ""]]; 69 | testf "priority_4" 70 | (fun { doc; _ } -> doc |> Option.get |> List.length |> ( = ) 1) 71 | [%expr t [@subliner.doc ""] [@doc]]; 72 | (* expected failure *) 73 | test_raises "invalid_payload" 74 | ~exn:"payload of `attribute` must be an expression" 75 | [%expr t [@doc: int]]; 76 | test_raises "invalid_attr" ~exn:"unexpected attribute name: irrelevant" 77 | [%expr t [@subliner.irrelevant]]; 78 | ] 79 | end 80 | 81 | module String_conv = struct 82 | module M = Ap.String_conv 83 | 84 | let test = 85 | Utils.test_equal Utils.pp (fun e -> 86 | e.pexp_attributes |> M.parse |> M.map (fun _ -> ())) 87 | 88 | let test_set = 89 | [ 90 | test "empty" (M.make_t ()) [%expr t [@irrelevant] [@ocaml.doc]]; 91 | test "file" (M.make_t ~file:() ()) [%expr t [@file]]; 92 | test "dir" (M.make_t ~dir:() ()) [%expr t [@dir]]; 93 | test "non_dir_file" 94 | (M.make_t ~non_dir_file:() ()) 95 | [%expr t [@non_dir_file]]; 96 | ] 97 | end 98 | 99 | module Cmd_info = struct 100 | module M = Ap.Cmd_info 101 | 102 | let test = 103 | Utils.test_equal Utils.pp (fun e -> 104 | e.pexp_attributes |> M.parse |> M.map (fun _ -> ())) 105 | 106 | let test_set = 107 | [ 108 | test "empty" (M.make_t ()) [%expr t [@irrelevant]]; 109 | test "deprecated" (M.make_t ~deprecated:() ()) [%expr t [@deprecated]]; 110 | test "deprecated_" (M.make_t ~deprecated:() ()) [%expr t [@deprecated_]]; 111 | test "man_xrefs" (M.make_t ~man_xrefs:() ()) [%expr t [@man_xrefs]]; 112 | test "man" (M.make_t ~man:() ()) [%expr t [@man]]; 113 | test "envs" (M.make_t ~envs:() ()) [%expr t [@envs]]; 114 | test "exits" (M.make_t ~exits:() ()) [%expr t [@exits]]; 115 | test "sdocs" (M.make_t ~sdocs:() ()) [%expr t [@sdocs]]; 116 | test "docs" (M.make_t ~docs:() ()) [%expr t [@docs]]; 117 | test "doc" (M.make_t ~doc:() ()) [%expr t [@doc]]; 118 | test "version" (M.make_t ~version:() ()) [%expr t [@version]]; 119 | test "name" (M.make_t ~name:() ()) [%expr t [@name]]; 120 | ] 121 | end 122 | 123 | module Single = struct 124 | let test f name = 125 | Utils.test_equal Utils.pp 126 | (fun e -> e.pexp_attributes |> f |> Option.map (fun _ -> ())) 127 | name 128 | 129 | let test_set = 130 | [ 131 | test Ap.Conv.parse "conv.empty" None [%expr t [@ocaml.doc]]; 132 | test Ap.Conv.parse "conv" (Some ()) [%expr t [@conv]]; 133 | test Ap.Sep_conv.parse "sep.empty" None [%expr t [@ocaml.doc]]; 134 | test Ap.Sep_conv.parse "sep" (Some ()) [%expr t [@sep]]; 135 | test Ap.Enum.parse "enum.empty" None [%expr t [@ocaml.doc]]; 136 | test Ap.Enum.parse "enum" (Some ()) [%expr t [@names]]; 137 | test Ap.Default_term.parse "default.empty" None [%expr t [@ocaml.doc]]; 138 | test Ap.Default_term.parse "default" (Some ()) [%expr t [@default]]; 139 | ] 140 | end 141 | -------------------------------------------------------------------------------- /src/group_cmds.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | module Ap = Attribute_parser 3 | 4 | let suffix = "cmdliner_group_cmds" 5 | let gen_name_str = Utils.gen_name_str suffix 6 | let gen_name { txt = name; loc } = { txt = gen_name_str name; loc } 7 | 8 | type info_attrs = expression Ap.Cmd_info.t 9 | 10 | module Info = struct 11 | let expr_of_attrs ~loc (default_name_expr : expression) (attrs : attributes) : 12 | expression = 13 | (* get cmd info args from attributes *) 14 | let info_attrs = 15 | Ap.Cmd_info.parse attrs 16 | |> Ap.Cmd_info.map (Ap.to_expr "Cmdliner.Cmd.info attributes") 17 | in 18 | let name_expr = 19 | Option.fold ~none:default_name_expr ~some:Fun.id info_attrs.name 20 | in 21 | let args = 22 | let labelled = 23 | [ 24 | ("deprecated", info_attrs.deprecated); 25 | ("man_xrefs", info_attrs.man_xrefs); 26 | ("man", info_attrs.man); 27 | ("envs", info_attrs.envs); 28 | ("exits", info_attrs.exits); 29 | ("sdocs", info_attrs.sdocs); 30 | ("docs", info_attrs.docs); 31 | ("doc", info_attrs.doc); 32 | ("version", info_attrs.version); 33 | ] 34 | |> List.filter_map (fun (name, expr_opt) -> 35 | Option.map (fun expr -> (Labelled name, expr)) expr_opt) 36 | and no_label = [ (Nolabel, name_expr) ] in 37 | labelled @ no_label 38 | in 39 | Ast_helper.Exp.apply ~loc [%expr Cmdliner.Cmd.info] args 40 | end 41 | 42 | (* only for types that has been derived *) 43 | let param_term_expr_of_core_type ct = 44 | let loc = ct.ptyp_loc in 45 | let param_term_fun_expr = 46 | match ct.ptyp_desc with 47 | | Ptyp_constr (lid, []) -> 48 | lid |> Utils.map_lid_name Term.gen_name_str |> Ast_helper.Exp.ident ~loc 49 | | _ -> Location.raise_errorf ~loc "constructor argument is not supported" 50 | in 51 | [%expr [%e param_term_fun_expr] ()] 52 | 53 | let handle_tuple_expr_of_core_type 54 | ~loc 55 | name 56 | (func_expr : expression) 57 | (cts : core_type list) = 58 | let names = 59 | List.mapi 60 | (fun i ct -> { txt = "v_" ^ string_of_int i; loc = ct.ptyp_loc }) 61 | cts 62 | in 63 | let pat = 64 | let pats = List.map (Ast_helper.Pat.var ~loc) names in 65 | Ast_helper.Pat.tuple ~loc pats 66 | and choice_expr = 67 | let tuple_expr = 68 | names 69 | |> List.map Utils.longident_loc_of_name 70 | |> List.map (Ast_helper.Exp.ident ~loc) 71 | |> Ast_helper.Exp.tuple ~loc 72 | in 73 | Ast_helper.Exp.construct ~loc 74 | (Utils.longident_loc_of_name name) 75 | (Some tuple_expr) 76 | in 77 | [%expr fun [%p pat] -> [%e func_expr] [%e choice_expr]] 78 | 79 | let make_tuple_expr_of_core_types ~loc (cts : core_type list) = 80 | cts 81 | |> List.mapi (fun i ct -> 82 | let loc = ct.ptyp_loc and name_str = "v_" ^ string_of_int i in 83 | let pat = Ast_helper.Pat.var ~loc { txt = name_str; loc } 84 | and ident_expr = 85 | Ast_helper.Exp.ident ~loc { txt = Lident name_str; loc } 86 | in 87 | (pat, ident_expr)) 88 | |> List.split 89 | |> fun (pats, exprs) -> 90 | let pats = List.rev pats and tuple_expr = Ast_helper.Exp.tuple ~loc exprs in 91 | List.fold_left 92 | (fun acc pat -> Ast_helper.Exp.fun_ ~loc Nolabel None pat acc) 93 | tuple_expr pats 94 | 95 | let handle_params_term_expr_of_const_decl 96 | (func_expr : expression) 97 | (cd : constructor_declaration) : expression * expression = 98 | let loc = cd.pcd_loc in 99 | match cd.pcd_args with 100 | | Pcstr_tuple [] -> 101 | let handle_expr = 102 | let choice_expr = 103 | Ast_helper.Exp.construct ~loc 104 | (Utils.longident_loc_of_name cd.pcd_name) 105 | None 106 | in 107 | [%expr fun () -> [%e func_expr] [%e choice_expr]] 108 | in 109 | (handle_expr, [%expr Cmdliner.Term.const ()]) 110 | | Pcstr_tuple [ ct ] -> 111 | let handle_expr = 112 | let choice_expr = 113 | Ast_helper.Exp.construct ~loc 114 | (Utils.longident_loc_of_name cd.pcd_name) 115 | (Some [%expr params]) 116 | in 117 | [%expr fun params -> [%e func_expr] [%e choice_expr]] 118 | and param_term_expr = param_term_expr_of_core_type ct in 119 | (handle_expr, param_term_expr) 120 | | Pcstr_tuple cts -> 121 | let handle_expr = 122 | handle_tuple_expr_of_core_type ~loc cd.pcd_name func_expr cts 123 | and param_term_expr = 124 | let make_tuple_expr = make_tuple_expr_of_core_types ~loc cts in 125 | cts 126 | |> List.map param_term_expr_of_core_type 127 | |> List.fold_left 128 | (fun acc param_term_expr -> 129 | Ast_helper.Exp.apply ~loc [%expr ( $ )] 130 | [ (Nolabel, acc); (Nolabel, param_term_expr) ]) 131 | [%expr const [%e make_tuple_expr]] 132 | |> fun e -> [%expr Cmdliner.Term.([%e e])] 133 | in 134 | (handle_expr, param_term_expr) 135 | | Pcstr_record lds -> 136 | let handle_expr = [%expr fun params -> [%e func_expr] params] 137 | and param_term_expr = 138 | Term.expression_of_label_decls ~loc ~const:(Some cd.pcd_name) lds 139 | in 140 | (handle_expr, param_term_expr) 141 | 142 | let cmd_vb_expr_of_const_decl 143 | (func_expr : expression) 144 | (cd : constructor_declaration) = 145 | let loc = cd.pcd_loc in 146 | let name_str = cd.pcd_name.txt |> String.lowercase_ascii in 147 | let var_name = { txt = Printf.sprintf "subcmd_%s" name_str; loc } in 148 | 149 | let vb = 150 | let pat = Ast_helper.Pat.var ~loc var_name 151 | and expr = 152 | (* Cmd.info *) 153 | let cmd_info_expr = 154 | (* lower case constructor name will be the default cmd name *) 155 | let default_name_expr = 156 | name_str 157 | |> String.map (function '_' -> '-' | c -> c) 158 | |> Ast_builder.Default.estring ~loc:cd.pcd_name.loc 159 | in 160 | Info.expr_of_attrs ~loc default_name_expr cd.pcd_attributes 161 | (* ('params -> 'result) * 'params Term.t *) 162 | and handle_expr, params_term_expr = 163 | handle_params_term_expr_of_const_decl func_expr cd 164 | in 165 | [%expr 166 | let info : Cmdliner.Cmd.info = [%e cmd_info_expr] 167 | and handle = [%e handle_expr] 168 | and params_term = [%e params_term_expr] in 169 | Cmdliner.(Cmd.v info Term.(const handle $ params_term))] 170 | in 171 | Ast_helper.Vb.mk ~loc pat expr 172 | and var_expr = 173 | var_name |> Utils.longident_loc_of_name |> Ast_helper.Exp.ident ~loc 174 | in 175 | (vb, var_expr) 176 | 177 | let core_type_of_type_name ~loc name = 178 | let ct = 179 | let lid = Utils.longident_loc_of_name name in 180 | Ast_helper.Typ.constr ~loc lid [] 181 | in 182 | [%type: ([%t ct] -> 'a) -> 'a Cmdliner.Cmd.t list] 183 | 184 | let structure_of_const_decls ~loc name (cds : constructor_declaration list) = 185 | let stri = 186 | let pat = Ast_helper.Pat.var ~loc @@ gen_name name 187 | and ct = core_type_of_type_name ~loc name 188 | and expr = 189 | let cmd_vbs, cmd_exprs = 190 | cds |> List.map (cmd_vb_expr_of_const_decl [%expr func]) |> List.split 191 | in 192 | let cmd_list_expr = Ast_builder.Default.elist ~loc cmd_exprs in 193 | Ast_helper.Exp.let_ ~loc Nonrecursive cmd_vbs cmd_list_expr 194 | in 195 | [%stri let ([%p pat] : [%t ct]) = fun func -> [%e expr]] 196 | in 197 | [ stri ] 198 | 199 | let signature_of_const_decls ~loc name = 200 | let sigi = 201 | let fun_name = gen_name name and ct = core_type_of_type_name ~loc name in 202 | Ast_helper.Val.mk ~loc fun_name ct |> Ast_helper.Sig.value ~loc 203 | in 204 | [ sigi ] 205 | -------------------------------------------------------------------------------- /test/cmdliner/test_ppx_deriving_cmdliner.ml: -------------------------------------------------------------------------------- 1 | let cmd_test_case ~term ~argv ~expected ~pprinter what = 2 | let info = Cmdliner.Cmd.info "cmd" in 3 | Alcotest.(check (of_pp pprinter)) 4 | what expected ( 5 | let cmd = Cmdliner.Cmd.v info term in 6 | match Cmdliner.Cmd.eval_value ~argv cmd with 7 | | Ok passing -> ( 8 | match passing with 9 | | `Ok actual -> 10 | actual 11 | | `Version -> 12 | assert false 13 | | `Help -> 14 | assert false 15 | ) 16 | | Error _ -> 17 | assert false 18 | ) 19 | 20 | let pp_array pp_item fmt items = Ppx_show_runtime.pp_list pp_item fmt (Array.to_list items) 21 | 22 | type common_types = 23 | { a1: string 24 | ; b1: int 25 | ; c1: float 26 | ; d1: string option 27 | ; e1: string list 28 | ; f1: int array 29 | ; g1: int list 30 | ; h1: bool 31 | ; i1: string 32 | ; j1: string list option 33 | ; k1: int list option } 34 | [@@deriving subliner, show] 35 | 36 | let simple () = 37 | let argv = 38 | [| "cmd" 39 | ; "--a1" 40 | ; "apple" 41 | ; "--b1" 42 | ; "123" 43 | ; "--c1" 44 | ; "1.20" 45 | ; "--d1" 46 | ; "yes" 47 | ; "--e1" 48 | ; "apple,banana,pear" 49 | ; "--f1" 50 | ; "1,2,3,4,5" 51 | ; "--g1" 52 | ; "100,200,300" 53 | ; "--h1" 54 | ; "--i1" 55 | ; "testing" 56 | ; "--k1" 57 | ; "1,2,3,4,5" |] 58 | in 59 | let expected = 60 | { a1= "apple" 61 | ; b1= 123 62 | ; c1= 1.20 63 | ; d1= Some "yes" 64 | ; e1= ["apple"; "banana"; "pear"] 65 | ; f1= [|1; 2; 3; 4; 5|] 66 | ; g1= [100; 200; 300] 67 | ; h1= true 68 | ; i1= "testing" 69 | ; j1= None 70 | ; k1= Some [1; 2; 3; 4; 5] } 71 | in 72 | cmd_test_case "expected simple types to match" 73 | ~term:(common_types_cmdliner_term ()) 74 | ~argv ~expected ~pprinter:pp_common_types 75 | 76 | type default_types = 77 | { a1: string [@default "apple"] 78 | ; b1: int [@default 10] 79 | ; c1: float [@default 1.20] 80 | ; e1: string list [@default []] 81 | ; f1: int array [@default [|1; 2; 3|]] 82 | ; g1: int list [@default [1; 2; 3]] 83 | ; h1: bool [@default true] } 84 | [@@deriving subliner, show] 85 | 86 | let defaults () = 87 | let argv = [|"cmd"|] in 88 | let expected = 89 | { a1= "apple" 90 | ; b1= 10 91 | ; c1= 1.20 92 | ; e1= [] 93 | ; f1= [|1; 2; 3|] 94 | ; g1= [1; 2; 3] 95 | ; h1= true } 96 | in 97 | cmd_test_case "expected defaults to work" 98 | ~term:(default_types_cmdliner_term ()) 99 | ~argv ~expected ~pprinter:pp_default_types 100 | 101 | type env_types = {a1: string [@env "A_ONE_ENV"]} [@@deriving subliner, show] 102 | 103 | let env () = 104 | let argv = [|"cmd"|] in 105 | let expected = {a1= "foobar"} in 106 | Unix.putenv "A_ONE_ENV" "foobar" ; 107 | cmd_test_case "expected env variables to work" 108 | ~term:(env_types_cmdliner_term ()) 109 | ~argv ~expected ~pprinter:pp_env_types 110 | 111 | type list_sep_types = {a1: (int list [@sep '@']); b1: (string array [@sep '*'])} 112 | [@@deriving subliner, show] 113 | 114 | let list_sep () = 115 | let argv = [|"cmd"; "--a1"; "1@9@3@5"; "--b1"; "foo*bar*baz"|] in 116 | let expected = {a1= [1; 9; 3; 5]; b1= [|"foo"; "bar"; "baz"|]} in 117 | cmd_test_case "expected custom list sep to work" 118 | ~term:(list_sep_types_cmdliner_term ()) 119 | ~argv ~expected ~pprinter:pp_list_sep_types 120 | 121 | type pos_types = {a1: string [@pos 1]; b1: int [@pos 0]} 122 | [@@deriving subliner, show] 123 | 124 | let positional () = 125 | let argv = [|"cmd"; "1"; "second-pos"|] in 126 | let expected = {a1= "second-pos"; b1= 1} in 127 | cmd_test_case "expected positional args to work" 128 | ~term:(pos_types_cmdliner_term ()) 129 | ~argv ~expected ~pprinter:pp_pos_types 130 | (** 131 | type enum_types = 132 | { a1: int list [@enum [("one", 1); ("two", 2); ("three", 3); ("four", 4)]] 133 | ; b1: [`A | `B | `C] [@enum [("a", `A); ("b", `B); ("c", `C)]] } 134 | [@@deriving subliner, show] 135 | 136 | let enums () = 137 | let argv = [|"cmd"; "--a1"; "one,two"; "--b1"; "b"|] in 138 | let expected = {a1= [1; 2]; b1= `B} in 139 | cmd_test_case "expected enum args to work" 140 | ~term:(enum_types_cmdliner_term ()) 141 | ~argv ~expected ~pprinter:pp_enum_types 142 | *) 143 | module M = struct 144 | type t = int * int [@@deriving show] 145 | 146 | let fst (f, _) = f 147 | 148 | let snd (_, s) = s 149 | 150 | let of_string s = 151 | try 152 | let sepi = String.index s '|' in 153 | let fst = String.sub s 0 sepi in 154 | let snd = String.sub s (sepi + 1) (String.length s - sepi - 1) in 155 | Result.Ok (int_of_string fst, int_of_string snd) 156 | with _ -> Result.Error (`Msg (Printf.sprintf "Couldn't parse `%s`" s)) 157 | 158 | let to_string t = Printf.sprintf "%d|%d" (fst t) (snd t) 159 | 160 | let cmdliner_converter = 161 | let parse = of_string in 162 | let print fmt t = Format.fprintf fmt "%s" (to_string t) in 163 | Cmdliner.Arg.conv ~docv:"M" (parse, print) 164 | end 165 | 166 | type custom_types = {foo: (M.t [@conv M.cmdliner_converter]); bar: (M.t [@conv M.cmdliner_converter])} 167 | [@@deriving subliner, show] 168 | 169 | let customs () = 170 | let argv = [|"cmd"; "--foo"; "11|200"; "--bar"; "0|13"|] in 171 | let expected = {foo= (11, 200); bar= (0, 13)} in 172 | cmd_test_case "expected custom type converter to work" 173 | ~term:(custom_types_cmdliner_term ()) 174 | ~argv ~expected ~pprinter:pp_custom_types 175 | 176 | type opt_all_types = {foo: string list [@opt_all]} [@@deriving subliner, show] 177 | 178 | let opt_all () = 179 | let argv = [|"cmd"; "--foo"; "test"; "--foo"; "foo"|] in 180 | let expected = {foo= ["test"; "foo"]} in 181 | cmd_test_case "expected opt_all list to work" 182 | ~term:(opt_all_types_cmdliner_term ()) 183 | ~argv ~expected ~pprinter:pp_opt_all_types 184 | 185 | type foo = {a1: string; b1: string} [@@deriving subliner, show] 186 | 187 | type terms_types = {foo: foo [@term foo_cmdliner_term ()]} 188 | [@@deriving subliner, show] 189 | 190 | let terms () = 191 | let argv = [|"cmd"; "--a1"; "apple"; "--b1"; "pie"|] in 192 | let expected = {foo= {a1= "apple"; b1= "pie"}} in 193 | cmd_test_case "expected custom @term to work" 194 | ~term:(terms_types_cmdliner_term ()) 195 | ~argv ~expected ~pprinter:pp_terms_types 196 | (* 197 | type misc_types = 198 | { a1: string [@name "renamed"] 199 | ; b1: bool [@enum [("true", true); ("false", false)]] 200 | ; c1: bool [@enum [("true", true); ("false", false)]] [@default true] 201 | ; d1: bool [@enum [("true", true); ("false", false)]] [@default true] 202 | ; e1: string * string 203 | ; f1: string * string * int 204 | ; g1: float * string * int * char } 205 | [@@deriving subliner, show] 206 | 207 | let miscs () = 208 | let argv = 209 | [| "cmd" 210 | ; "--renamed" 211 | ; "test" 212 | ; "--b1" 213 | ; "true" 214 | ; "--d1" 215 | ; "false" 216 | ; "--e1" 217 | ; "a,b" 218 | ; "--f1" 219 | ; "a,b,1" 220 | ; "--g1" 221 | ; "1.1,bar,100,c" |] 222 | in 223 | let expected = 224 | { a1= "test" 225 | ; b1= true 226 | ; c1= true 227 | ; d1= false 228 | ; e1= ("a", "b") 229 | ; f1= ("a", "b", 1) 230 | ; g1= (1.1, "bar", 100, 'c') } 231 | in 232 | cmd_test_case "expected `@name` & enum bools to work" 233 | ~term:(misc_types_cmdliner_term ()) 234 | ~argv ~expected ~pprinter:pp_misc_types 235 | *) 236 | let test_set = 237 | [ ("simple types", `Quick, simple) 238 | ; ("default types", `Quick, defaults) 239 | ; ("ENV types", `Quick, env) 240 | ; ("list sep types", `Quick, list_sep) 241 | ; ("positional types", `Quick, positional) 242 | (* ; ("enum types", `Quick, enums)*) 243 | ; ("custom types", `Quick, customs) 244 | ; ("opt_all type", `Quick, opt_all) 245 | ; ("term type", `Quick, terms) 246 | (* ; ("misc types", `Quick, miscs)*) ] 247 | 248 | let () = Alcotest.run "Ppx_deriving_cmdliner" [("test", test_set)] -------------------------------------------------------------------------------- /test/test_term.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | module Ap = Ppx_subliner.Attribute_parser.Term 3 | 4 | let loc = Location.none 5 | 6 | let cmd term = 7 | let info = Cmdliner.Cmd.info "cmd" in 8 | Cmdliner.Cmd.v info Cmdliner.Term.(const Fun.id $ term ()) 9 | 10 | let test_ok prefix term = Utils.test_cmd_ok prefix (cmd term) 11 | let test_error prefix term = Utils.test_cmd_error prefix (cmd term) 12 | 13 | let test_raise = 14 | Utils.test_raises (fun (ct, attrs) -> 15 | let name = { txt = "field"; loc } in 16 | Ppx_subliner.Term.T.expr_of_attrs ~loc name ct attrs) 17 | 18 | module Named = struct 19 | type simple = { 20 | flag : bool; 21 | default : int; [@default 42] 22 | bool_default : bool; [@default true] 23 | option : float array option; 24 | required : int32; 25 | non_empty : int64 list; [@non_empty] 26 | last : char; [@last] 27 | last_default : nativeint; [@last] [@default Nativeint.of_int 42] 28 | } 29 | [@@deriving subliner] 30 | 31 | type opt_all = { 32 | required : bool list; [@opt_all] 33 | default : int list; [@opt_all] [@default [ 1; 2 ]] 34 | non_empty : int list; [@opt_all] [@non_empty] 35 | last : int; [@opt_all] [@last] 36 | last_default : int; [@opt_all] [@last] [@default 4] 37 | } 38 | [@@deriving subliner] 39 | 40 | let test_set = 41 | let test_simple = test_ok "simple" simple_cmdliner_term 42 | and test_simple_error = test_error "simple" simple_cmdliner_term 43 | and test_opt_all = test_ok "opt_all" opt_all_cmdliner_term 44 | and test_opt_all_error = test_error "opt_all" opt_all_cmdliner_term in 45 | [ 46 | test_simple "simple" 47 | { 48 | flag = true; 49 | default = 1; 50 | bool_default = false; 51 | option = Some [| 3.14; 3.15 |]; 52 | required = Int32.of_int 21; 53 | non_empty = [ Int64.of_int 22; Int64.of_int 23 ]; 54 | last = 'c'; 55 | last_default = Nativeint.of_int 3; 56 | } 57 | [| 58 | "cmd"; 59 | "--flag"; 60 | "--default=1"; 61 | "--bool-default=false"; 62 | "--option=3.14,3.15"; 63 | "--required=21"; 64 | "--non-empty=22,23"; 65 | "--last=a,b,c"; 66 | "--last-default=1,2,3"; 67 | |]; 68 | test_simple "default" 69 | { 70 | flag = false; 71 | default = 42; 72 | bool_default = true; 73 | option = None; 74 | required = Int32.of_int 21; 75 | non_empty = [ Int64.of_int 22 ]; 76 | last = 'a'; 77 | last_default = Nativeint.of_int 42; 78 | } 79 | [| "cmd"; "--required=21"; "--non-empty=22"; "--last=a" |]; 80 | test_simple_error "required" `Parse 81 | [| "cmd"; "--non-empty=22"; "--last=a,b,c" |]; 82 | test_simple_error "non-empty" `Parse 83 | [| "cmd"; "--required=21"; "--last=a,b,c" |]; 84 | test_simple_error "last" `Parse 85 | [| "cmd"; "--required=21"; "--non-empty=22" |]; 86 | test_opt_all "simple" 87 | { 88 | required = [ true; false ]; 89 | default = [ 1; 2 ]; 90 | non_empty = [ 3; 4 ]; 91 | last = 6; 92 | last_default = 8; 93 | } 94 | [| 95 | "cmd"; 96 | "--required=true"; 97 | "--required=false"; 98 | "--default=1"; 99 | "--default=2"; 100 | "--non-empty=3"; 101 | "--non-empty=4"; 102 | "--last=5"; 103 | "--last=6"; 104 | "--last-default=7"; 105 | "--last-default=8"; 106 | |]; 107 | test_opt_all "default" 108 | { 109 | required = []; 110 | default = [ 1; 2 ]; 111 | non_empty = [ 1 ]; 112 | last = 1; 113 | last_default = 4; 114 | } 115 | [| "cmd"; "--non-empty=1"; "--last=1" |]; 116 | test_opt_all_error "non-empty" `Parse [| "cmd"; "--last=1" |]; 117 | test_opt_all_error "last" `Parse [| "cmd"; "--non-empty=1" |]; 118 | ] 119 | end 120 | 121 | module Positional = struct 122 | type simple = { 123 | pos : char; [@pos 0] 124 | last : string; [@pos 1] [@last] 125 | non_empty : int list; [@pos 2] [@non_empty] 126 | default : int; [@pos 3] [@default 42] 127 | option : float option; [@pos 4] 128 | last_default : bool; [@pos 5] [@last] [@default true] 129 | } 130 | [@@deriving subliner] 131 | 132 | type left = { last : int [@pos_left 2] [@last] } [@@deriving subliner] 133 | 134 | type right = { non_empty : int list [@pos_right 0] [@non_empty] } 135 | [@@deriving subliner] 136 | 137 | type all = { nested : int list list [@pos_all] } [@@deriving subliner] 138 | type rev = { rev : int list [@pos 0] [@rev] } [@@deriving subliner] 139 | 140 | let test_set = 141 | let test_simple = test_ok "simple" simple_cmdliner_term 142 | and test_simple_error = test_error "simple" simple_cmdliner_term 143 | and test_left = test_ok "list_pos" left_cmdliner_term 144 | and test_right = test_ok "list_pos" right_cmdliner_term 145 | and test_right_error = test_error "list_pos" right_cmdliner_term 146 | and test_all = test_ok "list_pos" all_cmdliner_term in 147 | [ 148 | test_simple "simple" 149 | { 150 | pos = 'a'; 151 | last = "c"; 152 | non_empty = [ 1; 2; 3 ]; 153 | default = 1; 154 | option = Some 1.2; 155 | last_default = false; 156 | } 157 | [| "cmd"; "a"; "a,b,c"; "1,2,3"; "1"; "1.2"; "true,false" |]; 158 | test_simple "default" 159 | { 160 | pos = 'b'; 161 | last = "dd"; 162 | non_empty = [ 4 ]; 163 | default = 42; 164 | option = None; 165 | last_default = true; 166 | } 167 | [| "cmd"; "b"; "dd"; "4" |]; 168 | test_simple_error "required" `Term [| "cmd" |]; 169 | test_simple_error "non_empty" `Parse [| "cmd"; "a"; "a"; "" |]; 170 | test_simple_error "too_many" `Parse 171 | [| "cmd"; "a"; "a"; "1"; "1.2"; "true,false"; "too_many" |]; 172 | test_left "left_1" { last = 2 } [| "cmd"; "1"; "2" |]; 173 | test_left "left_2" { last = 1 } [| "cmd"; "1" |]; 174 | test_right "right" 175 | { non_empty = [ 2; 3; 4 ] } 176 | [| "cmd"; "1"; "2"; "3"; "4" |]; 177 | test_right_error "non_empty" `Term [| "cmd" |]; 178 | test_all "nested" 179 | { nested = [ [ 1 ]; [ 2 ]; [ 3 ] ] } 180 | [| "cmd"; "1"; "2"; "3" |]; 181 | test_all "empty" { nested = [] } [| "cmd" |]; 182 | test_ok "pos_list" rev_cmdliner_term "rev" { rev = [ 3 ] } 183 | [| "cmd"; "1"; "2"; "3" |]; 184 | ] 185 | end 186 | 187 | type names = { names : int [@names [ "new_name"; "n" ]] } [@@deriving subliner] 188 | 189 | type sep = { 190 | sep : (int list[@sep '@']); 191 | list : (int list[@sep '@']); 192 | array : (int array[@sep '@']); 193 | tuple : (int * int[@sep '@']); 194 | nested : (((int * int * int)[@sep '#']) list[@sep ';']); 195 | last_sep : int; [@last] [@last.sep '@'] 196 | } 197 | [@@deriving subliner] 198 | 199 | type term = { term : names [@term names_cmdliner_term ()] } 200 | [@@deriving subliner] 201 | 202 | let custom_conv = Cmdliner.Arg.(list ~sep:'@' int) 203 | 204 | type conv = { conv : (int list[@conv custom_conv]) } [@@deriving subliner] 205 | 206 | let test_set = 207 | let f = (loc, [%str]) and e = (loc, [%str expr]) in 208 | let test_names = test_ok "names" names_cmdliner_term in 209 | [ 210 | test_names "long" { names = 1 } [| "cmd"; "--new_name"; "1" |]; 211 | test_names "short" { names = 1 } [| "cmd"; "-n"; "1" |]; 212 | test_ok "sep" sep_cmdliner_term "simple" 213 | { 214 | sep = [ 1; 2 ]; 215 | list = [ 3; 4 ]; 216 | array = [| 5; 6 |]; 217 | tuple = (7, 8); 218 | nested = [ (0, 0, 0); (255, 255, 255) ]; 219 | last_sep = 10; 220 | } 221 | [| 222 | "cmd"; 223 | "--sep=1@2"; 224 | "--list=3@4"; 225 | "--array=5@6"; 226 | "--tuple=7@8"; 227 | "--nested=0#0#0;255#255#255"; 228 | "--last-sep=9@10"; 229 | |]; 230 | test_ok "term" term_cmdliner_term "simple" 231 | { term = { names = 1 } } 232 | [| "cmd"; "--new_name"; "1" |]; 233 | test_ok "conv" conv_cmdliner_term "simple" 234 | { conv = [ 1; 2; 3 ] } 235 | [| "cmd"; "--conv"; "1@2@3" |]; 236 | test_raise "multi_pos" 237 | ~exn: 238 | "only one of `pos`, `pos_all`, `pos_left` and `pos_right` can be \ 239 | specified at the same time" 240 | ([%type: int], Ap.make_t ~pos:e ~pos_all:f ()); 241 | test_raise "pos_names_conflict" 242 | ~exn:"`names` cannot be used with positional argument" 243 | ([%type: int], Ap.make_t ~pos:f ~names:e ()); 244 | test_raise "pos_opt_all_conflict" 245 | ~exn:"`opt_all` cannot be used with positional argument" 246 | ([%type: int], Ap.make_t ~pos:e ~opt_all:f ()); 247 | test_raise "pos_all_rev_conflict" ~exn:"`rev` cannot be used with `pos_all`" 248 | ([%type: int], Ap.make_t ~pos_all:f ~rev:f ()); 249 | test_raise "pos_sep_conflict" 250 | ~exn:"`sep` cannot be used with `pos_left`, `pos_right` and `pos_all`" 251 | ([%type: (int list[@sep ','])], Ap.make_t ~pos_all:f ()); 252 | test_raise "pos.invalid" 253 | ~exn:"`pos_left`, `pos_right` and `pos_all` must be used with list type" 254 | ([%type: int], Ap.make_t ~pos_all:f ()); 255 | test_raise "opt_all_sep_conflict" 256 | ~exn:"`opt_all` and `sep` cannot be used on the same list" 257 | ([%type: (int list[@sep ','])], Ap.make_t ~opt_all:f ()); 258 | test_raise "opt_all.invalid" ~exn:"`opt_all` must be used with list type" 259 | ([%type: int], Ap.make_t ~opt_all:f ()); 260 | test_raise "non_empty.invalid" 261 | ~exn:"`non_empty` must be used with list type" 262 | ([%type: int], Ap.make_t ~non_empty:f ()); 263 | ] 264 | -------------------------------------------------------------------------------- /src/attribute_parser.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | let prefix = "subliner." 4 | let prefix_len = String.length prefix 5 | 6 | type 'a level = Derived of 'a | General of 'a | Prefixed of 'a 7 | 8 | module Level = struct 9 | let join level_opt level = 10 | match (level_opt, level) with 11 | | None, _ 12 | | Some (Derived _), _ 13 | | Some (General _), General _ 14 | | _, Prefixed _ -> 15 | Some level 16 | | _ -> level_opt 17 | 18 | let get = function Derived a | General a | Prefixed a -> a 19 | 20 | let map f = function 21 | | Derived a -> Derived (f a) 22 | | General a -> General (f a) 23 | | Prefixed a -> Prefixed (f a) 24 | 25 | let general opt = Option.map (fun v -> General v) opt 26 | let prefixed opt = Option.map (fun v -> Prefixed v) opt 27 | end 28 | 29 | let parse_impl 30 | ~empty 31 | ~map 32 | ~tag_of_string 33 | ~update_field_of_tag 34 | (attrs : attributes) = 35 | let tag_level_of_attr_name { txt = name; loc } = 36 | let tag = tag_of_string name in 37 | match name with 38 | | _ when Option.is_some tag -> Level.general tag 39 | | "ocaml.doc" -> Some (Derived `doc) 40 | | _ when Utils.string_starts_with ~prefix name -> ( 41 | let name = 42 | let len = String.length name in 43 | String.sub name prefix_len (len - prefix_len) 44 | in 45 | let tag = tag_of_string name in 46 | match tag with 47 | | Some _ -> Level.prefixed tag 48 | | None -> Error.attribute_name ~loc name) 49 | | _ -> None 50 | in 51 | attrs 52 | |> List.fold_left 53 | (fun acc attr -> 54 | tag_level_of_attr_name attr.attr_name 55 | |> function 56 | | None -> acc 57 | | Some field -> 58 | update_field_of_tag (Level.get field) 59 | (Level.map 60 | (fun _ -> 61 | let loc = attr.attr_loc in 62 | match attr.attr_payload with 63 | | PStr structure -> (loc, structure) 64 | | _ -> Error.attribute_payload ~loc "attribute") 65 | field) 66 | acc) 67 | empty 68 | |> map Level.get 69 | 70 | let parse_single name attrs = 71 | let tag_of_string s = if s = name then Some `current else None 72 | and update_field_of_tag tag v t = 73 | match tag with `current -> Level.join t v | `doc -> t 74 | in 75 | parse_impl ~empty:None ~map:Option.map ~tag_of_string ~update_field_of_tag 76 | attrs 77 | 78 | let to_bool = 79 | Option.fold ~none:false ~some:(function 80 | | _, [] -> true 81 | | loc, _ -> Error.attribute_flag ~loc) 82 | 83 | let to_expr name = function 84 | | _, [ { pstr_desc = Pstr_eval (expr, _); _ } ] -> expr 85 | | loc, _ -> Error.attribute_payload ~loc name 86 | 87 | let to_expr_opt name = Option.map (to_expr name) 88 | 89 | let to_trimmed_string_expr name expr = 90 | match expr with 91 | | loc, [ { pstr_desc = Pstr_eval (expr, _); _ } ] -> 92 | [%expr Stdlib.String.trim [%e expr]] 93 | | loc, _ -> Error.attribute_payload ~loc name 94 | 95 | let to_trimmed_string_expr_opt name = Option.map (to_trimmed_string_expr name) 96 | 97 | module Term = struct 98 | type 'a t = { 99 | (* term *) 100 | term : 'a option; 101 | (* info *) 102 | deprecated : 'a option; 103 | absent : 'a option; 104 | docs : 'a option; 105 | docv : 'a option; 106 | doc : 'a option; 107 | env : 'a option; 108 | env_deprecated : 'a option; 109 | env_docs : 'a option; 110 | env_doc : 'a option; 111 | (* named *) 112 | names : 'a option; 113 | opt_all : 'a option; 114 | (* positional *) 115 | pos : 'a option; 116 | pos_all : 'a option; 117 | pos_left : 'a option; 118 | pos_right : 'a option; 119 | rev : 'a option; 120 | (* as term *) 121 | non_empty : 'a option; 122 | last : 'a option; 123 | last_sep : 'a option; 124 | (* type *) 125 | default : 'a option; 126 | } 127 | [@@deriving make] 128 | 129 | let empty = make_t () 130 | 131 | let map 132 | f 133 | { 134 | term; 135 | deprecated; 136 | absent; 137 | docs; 138 | docv; 139 | doc; 140 | env; 141 | env_deprecated; 142 | env_docs; 143 | env_doc; 144 | names; 145 | opt_all; 146 | pos; 147 | pos_all; 148 | pos_left; 149 | pos_right; 150 | rev; 151 | non_empty; 152 | last; 153 | last_sep; 154 | default; 155 | } = 156 | let f = Option.map f in 157 | { 158 | (* term *) 159 | term = f term; 160 | (* info *) 161 | deprecated = f deprecated; 162 | absent = f absent; 163 | docs = f docs; 164 | docv = f docv; 165 | doc = f doc; 166 | (* Cmd.Env.info *) 167 | env = f env; 168 | env_deprecated = f env_deprecated; 169 | env_docs = f env_docs; 170 | env_doc = f env_doc; 171 | (* named *) 172 | names = f names; 173 | opt_all = f opt_all; 174 | (* positional *) 175 | pos = f pos; 176 | pos_all = f pos_all; 177 | pos_left = f pos_left; 178 | pos_right = f pos_right; 179 | rev = f rev; 180 | (* as term *) 181 | non_empty = f non_empty; 182 | last = f last; 183 | last_sep = f last_sep; 184 | (* type *) 185 | default = f default; 186 | } 187 | 188 | let tag_of_string = function 189 | | "term" -> Some `term 190 | | "deprecated" | "deprecated_" -> Some `deprecated 191 | | "absent" -> Some `absent 192 | | "docs" -> Some `docs 193 | | "docv" -> Some `docv 194 | | "doc" -> Some `doc 195 | | "env" -> Some `env 196 | | "env.deprecated" -> Some `env_deprecated 197 | | "env.docs" -> Some `env_docs 198 | | "env.doc" -> Some `env_doc 199 | | "names" -> Some `names 200 | | "opt_all" -> Some `opt_all 201 | | "pos" -> Some `pos 202 | | "pos_all" -> Some `pos_all 203 | | "pos_left" -> Some `pos_left 204 | | "pos_right" -> Some `pos_right 205 | | "rev" -> Some `rev 206 | | "non_empty" -> Some `non_empty 207 | | "last" -> Some `last 208 | | "last.sep" -> Some `last_sep 209 | | "default" -> Some `default 210 | | _ -> None 211 | 212 | let update_field_of_tag tag v t = 213 | match tag with 214 | | `term -> { t with term = Level.join t.term v } 215 | | `deprecated -> { t with deprecated = Level.join t.deprecated v } 216 | | `absent -> { t with absent = Level.join t.absent v } 217 | | `docs -> { t with docs = Level.join t.docs v } 218 | | `docv -> { t with docv = Level.join t.docv v } 219 | | `doc -> { t with doc = Level.join t.doc v } 220 | | `env -> { t with env = Level.join t.env v } 221 | | `env_deprecated -> 222 | { t with env_deprecated = Level.join t.env_deprecated v } 223 | | `env_docs -> { t with env_docs = Level.join t.env_docs v } 224 | | `env_doc -> { t with env_doc = Level.join t.env_doc v } 225 | | `names -> { t with names = Level.join t.names v } 226 | | `opt_all -> { t with opt_all = Level.join t.opt_all v } 227 | | `pos -> { t with pos = Level.join t.pos v } 228 | | `pos_all -> { t with pos_all = Level.join t.pos_all v } 229 | | `pos_left -> { t with pos_left = Level.join t.pos_left v } 230 | | `pos_right -> { t with pos_right = Level.join t.pos_right v } 231 | | `rev -> { t with rev = Level.join t.rev v } 232 | | `non_empty -> { t with non_empty = Level.join t.non_empty v } 233 | | `last -> { t with last = Level.join t.last v } 234 | | `last_sep -> { t with last_sep = Level.join t.last_sep v } 235 | | `default -> { t with default = Level.join t.default v } 236 | 237 | let parse attrs = 238 | parse_impl ~empty ~map ~tag_of_string ~update_field_of_tag attrs 239 | end 240 | 241 | module Conv = struct 242 | let parse = parse_single "conv" 243 | end 244 | 245 | module String_conv = struct 246 | type 'a t = { file : 'a option; dir : 'a option; non_dir_file : 'a option } 247 | [@@deriving make] 248 | 249 | let empty = make_t () 250 | 251 | let map f { file; dir; non_dir_file } = 252 | let f = Option.map f in 253 | { file = f file; dir = f dir; non_dir_file = f non_dir_file } 254 | 255 | let tag_of_string = function 256 | | "file" -> Some `file 257 | | "dir" -> Some `dir 258 | | "non_dir_file" -> Some `non_dir_file 259 | | _ -> None 260 | 261 | let update_field_of_tag tag v t = 262 | match tag with 263 | | `file -> { t with file = Level.join t.file v } 264 | | `dir -> { t with dir = Level.join t.dir v } 265 | | `non_dir_file -> { t with non_dir_file = Level.join t.non_dir_file v } 266 | | `doc -> t 267 | 268 | let parse attrs = 269 | parse_impl ~empty ~map ~tag_of_string ~update_field_of_tag attrs 270 | end 271 | 272 | module Sep_conv = struct 273 | let parse = parse_single "sep" 274 | end 275 | 276 | module Cmd_info = struct 277 | type 'a t = { 278 | deprecated : 'a option; 279 | man_xrefs : 'a option; 280 | man : 'a option; 281 | envs : 'a option; 282 | exits : 'a option; 283 | sdocs : 'a option; 284 | docs : 'a option; 285 | doc : 'a option; 286 | version : 'a option; 287 | name : 'a option; 288 | } 289 | [@@deriving make] 290 | 291 | let empty = make_t () 292 | 293 | let map 294 | f 295 | { 296 | deprecated; 297 | man_xrefs; 298 | man; 299 | envs; 300 | exits; 301 | sdocs; 302 | docs; 303 | doc; 304 | version; 305 | name; 306 | } = 307 | let f = Option.map f in 308 | { 309 | deprecated = f deprecated; 310 | man_xrefs = f man_xrefs; 311 | man = f man; 312 | envs = f envs; 313 | exits = f exits; 314 | sdocs = f sdocs; 315 | docs = f docs; 316 | doc = f doc; 317 | version = f version; 318 | name = f name; 319 | } 320 | 321 | let tag_of_string = function 322 | | "deprecated" | "deprecated_" -> Some `deprecated 323 | | "man_xrefs" -> Some `man_xrefs 324 | | "man" -> Some `man 325 | | "envs" -> Some `envs 326 | | "exits" -> Some `exits 327 | | "sdocs" -> Some `sdocs 328 | | "docs" -> Some `docs 329 | | "doc" -> Some `doc 330 | | "version" -> Some `version 331 | | "name" -> Some `name 332 | | _ -> None 333 | 334 | let update_field_of_tag tag v t = 335 | match tag with 336 | | `deprecated -> { t with deprecated = Level.join t.deprecated v } 337 | | `man_xrefs -> { t with man_xrefs = Level.join t.man_xrefs v } 338 | | `man -> { t with man = Level.join t.man v } 339 | | `envs -> { t with envs = Level.join t.envs v } 340 | | `exits -> { t with exits = Level.join t.exits v } 341 | | `sdocs -> { t with sdocs = Level.join t.sdocs v } 342 | | `docs -> { t with docs = Level.join t.docs v } 343 | | `doc -> { t with doc = Level.join t.doc v } 344 | | `version -> { t with version = Level.join t.version v } 345 | | `name -> { t with name = Level.join t.name v } 346 | 347 | let parse attrs = 348 | parse_impl ~empty ~map ~tag_of_string ~update_field_of_tag attrs 349 | end 350 | 351 | module Enum = struct 352 | let parse = parse_single "names" 353 | end 354 | 355 | module Default_term = struct 356 | let parse = parse_single "default" 357 | end 358 | -------------------------------------------------------------------------------- /doc/index.mld: -------------------------------------------------------------------------------- 1 | {0 [[@@deriving subliner]] and [[%%subliner]]} 2 | 3 | [[@@deriving]] plugin to generate 4 | {{:https://opam.ocaml.org/packages/cmdliner/}Cmdliner} sub-commands groups, and 5 | rewriter to generate {{:https://opam.ocaml.org/packages/cmdliner/}Cmdliner} 6 | evaluations. 7 | 8 | 9 | {1 Usage} 10 | 11 | To use [[@@deriving subliner]] or [[%%subliner]], add 12 | [(preprocess (pps ppx_subliner))] to the library or executable configuration in 13 | dune file. 14 | 15 | 16 | {1 Syntax} 17 | 18 | 19 | {2 Term} 20 | 21 | 22 | A {{:https://opam.ocaml.org/packages/cmdliner/}Cmdliner} term can be generated 23 | by tagging [[@@deriving subliner]] to a record type. 24 | 25 | For record type [params], function [params_cmdliner_term] with type 26 | [unit -> params Cmdliner.Term.t] will be generated. A command line argument will 27 | be generated for each field in the record. {!term_attr} and {!type_attr} can be 28 | attached to fields or types to modify the behavior of the corresponding arguments. 29 | 30 | {[ 31 | type params = { my_arg : string } [@@deriving_inline subliner] 32 | include 33 | sig 34 | [@@@ocaml.warning "-32"] 35 | val params_cmdliner_term : unit -> params Cmdliner.Term.t 36 | end[@@ocaml.doc "@inline"] 37 | [@@@end] 38 | ]} 39 | 40 | The derived function can be used with [[%subliner.term]] extension and a 41 | handling function to generate 42 | {{:https://opam.ocaml.org/packages/cmdliner/}Cmdliner} evaluation. 43 | {!cmd_info_attr} and {!default_term_attr} can be attached to the extension to 44 | modify the behavior of the command line tools. 45 | 46 | {[ 47 | let handle { my_arg } = print_endline my_arg 48 | 49 | [%%subliner.term eval.params <- handle] 50 | ]} 51 | 52 | Different {{:https://erratique.ch/software/cmdliner/doc/Cmdliner/Cmd/index.html#eval}evaluation functions} 53 | can be used and optional parameters can be applied. 54 | 55 | {[ 56 | [%%subliner.term (eval_result ~catch:false).params <- handle_result] 57 | ]} 58 | 59 | 60 | {2 Sub-commands} 61 | 62 | 63 | A group of {{:https://opam.ocaml.org/packages/cmdliner/}Cmdliner} sub-commands 64 | can be generated by tagging [[@@deriving subliner]] to a variant type and 65 | providing a handling function for that variant. 66 | 67 | For variant type [params], function [params_cmdliner_group_cmds] with type 68 | [(params -> 'a) -> 'a Cmdliner.Cmd.t list] will be generated. The input function 69 | takes a handling function to process parsed input. A sub-command will be 70 | generated for each constructor in the variant. {!cmd_info_attr} can be attached 71 | to constructors to modify the behavior of the corresponding sub-commands. 72 | 73 | Each constructor of the variant can have no parameters, one parameter, or a 74 | tuple of multiple parameters, or be an inline record. 75 | 76 | If a constructor has a parameter with type [p], function 77 | [p_cmdliner_term] with type [unit -> p Cmdliner.Term.t] is required. 78 | The function can be either obtained by tagging a supported record with 79 | [[@@deriving subliner]], 80 | {{:https://github.com/hammerlab/ppx_deriving_cmdliner}[[@@deriving cmdliner]]} 81 | or constructed manually. If a constructor has multiple parameters, all parameter 82 | types must have the corresponding functions. 83 | 84 | {[ 85 | type foo = { my_arg : string } 86 | val foo_cmdliner_term : unit -> foo Cmdliner.Term,t 87 | 88 | type params = 89 | | Foo of foo 90 | | Bar 91 | | Foobar of { my_arg : string } 92 | [@@deriving_inline subliner] 93 | include 94 | sig 95 | [@@@ocaml.warning "-32"] 96 | val params_cmdliner_group_cmds : (params -> 'a) -> 'a Cmdliner.Cmd.t list 97 | end[@@ocaml.doc "@inline"] 98 | [@@@end] 99 | ]} 100 | 101 | The derived function can be used with [[%%subliner.cmds]] extension to generate 102 | {{:https://opam.ocaml.org/packages/cmdliner/}Cmdliner} evaluation. 103 | {!cmd_info_attr} and {!default_term_attr} can be attached to the extension to 104 | modify the behavior of the command line tools. 105 | 106 | {[ 107 | let handle = function 108 | | Foo { my_arg } -> print_endline ("Foo " ^ my_arg) 109 | | Bar -> print_endline "Bar" 110 | 111 | [%%subliner.cmds eval.params <- handle] 112 | ]} 113 | 114 | Different {{:https://erratique.ch/software/cmdliner/doc/Cmdliner/Cmd/index.html#eval}evaluation functions} 115 | can be used and optional parameters can be applied. 116 | 117 | {[ 118 | [%%subliner.cmds (eval_result ~catch:false).params <- handle_result] 119 | ]} 120 | 121 | 122 | {2 Enumeration} 123 | 124 | 125 | A {{:https://opam.ocaml.org/packages/cmdliner/}Cmdliner} argument converter of 126 | enumeration can be generated by tagging [[@@deriving subliner_enum]] to a 127 | variant type without any payload. 128 | 129 | For variant type [enum], function [enum_cmdliner_conv] with type 130 | [unit -> enum Cmdliner.Arg.conv] will be generated. {!enum_attr} can be attached 131 | to constructors to modify the behavior of the corresponding enumeration. 132 | 133 | {[ 134 | type enum = Foo | Bar 135 | [@@deriving_inline subliner_enum] 136 | include 137 | sig 138 | [@@@ocaml.warning "-32"] 139 | val enum_cmdliner_conv : unit -> enum Cmdliner.Arg.conv 140 | end[@@ocaml.doc "@inline"] 141 | [@@@end] 142 | ]} 143 | 144 | The derived function can be used inside [[@@deriving subliner]]. 145 | 146 | {[ 147 | type params = { enum : enum [@conv enum_cmdliner_conv ()] } 148 | ]} 149 | 150 | 151 | {1 Supported Attributes} 152 | All attributes may be prefixed with [subliner.] to avoid conflicts with other 153 | extensions. 154 | 155 | 156 | {2:term_attr [Term.t] Attributes} 157 | 158 | 159 | {3 [[@term t Term.t]]} 160 | 161 | Use the user provided [Term.t] for this field as it is. All other attributes 162 | will be ignored. 163 | 164 | {[ 165 | type params = { foo : t [@term cmdliner_term ()] } 166 | ]} 167 | 168 | {3 [[@names string list]]} 169 | 170 | Set the names of the named argument. If not provided, kebab case of the field 171 | name will be used (i.e. filed [foo_bar] will have name ["foo-bar"] by default). 172 | 173 | {[ 174 | type params = { foo : string [@names [ "my-arg-name"; "n" ]] } 175 | ]} 176 | 177 | {3 [[@doc string]]} 178 | 179 | Set the man page description of the argument. If not provided, the doc string 180 | will be used. 181 | 182 | {[ 183 | type params = { foo : string [@doc "This is the documentation"] } 184 | ]} 185 | 186 | {3:attr_opt_all [[@opt_all]]} 187 | 188 | Allow the optional argument to appear more than once ( see {{:https://erratique.ch/software/cmdliner/doc/Cmdliner/Arg/index.html#val-opt_all}opt_all} 189 | for more details). This attribute must be used with a list, or used with 190 | {!attr_last} attribute at the same time. 191 | 192 | Conflict with {!attr_pos}. 193 | 194 | {[ 195 | type params = { foo : string list [@opt_all] } 196 | ]} 197 | 198 | {3:attr_pos [[@pos int]], [[@pos_all]], [[@pos_right int]], [[@pos_left int]]} 199 | 200 | Set the argument to be positional. [[@pos_all]], [[@pos_right int]] and 201 | [[@pos_left int]] must be used with a list type or used with {!attr_last} attribute 202 | at the same time. 203 | 204 | [[@rev]] can be used with [[@pos int]], [[@pos_right int]] and [[@pos_left int]] 205 | to compute the argument position in reverse order. 206 | 207 | Conflict with {!attr_opt_all}. 208 | 209 | {[ 210 | type params = { foo : string list [@pos_right 1] } 211 | ]} 212 | 213 | {3:attr_non_empty [[@non_empty]]} 214 | 215 | Enforce a list argument to be non-empty. 216 | 217 | Conflict with {!attr_term_default}, {!attr_last}. 218 | 219 | {[ 220 | type params = { foo : string list [@non_empty] } 221 | ]} 222 | 223 | {3:attr_last [[@last]]} 224 | 225 | Only evaluates the last element of the list. 226 | 227 | [[@last.sep char]] can be used with this attribute to set the separator of the list. 228 | 229 | Conflict with {!attr_non_empty}. 230 | 231 | {[ 232 | type params = { foo : string [@last] [@last.sep ';'] } 233 | ]} 234 | 235 | {3:attr_term_default [[@default t]]} 236 | 237 | Set the default value of the argument. 238 | 239 | Conflict with {!attr_non_empty}. 240 | 241 | {[ 242 | type params = { foo : string [@default "My default string"] } 243 | ]} 244 | 245 | {3 [[@env string]]} 246 | 247 | Set the the name of an environment variable which is looked up for defining the 248 | argument if it is absent. 249 | 250 | [[@env.deprecated string]], [[@env.docs string]] and [[@env.doc string]] can be 251 | used with this attribute. For their exact usages, please refer to the 252 | documentation of {{:https://erratique.ch/software/cmdliner/doc/Cmdliner/Cmd/Env/index.html#val-info}Cmdliner.Cmd.Env.info}. 253 | 254 | {[ 255 | type params = { foo : string [@env "MY_ENV_VAR"] } 256 | ]} 257 | 258 | {3 Other} 259 | 260 | [[@deprecated string]], [[@absent string]], [[@docs string]] and [[@docv string]] 261 | are also supported. For their exact usages, please refer to the documentation of 262 | {{:https://erratique.ch/software/cmdliner/doc/Cmdliner/Arg/index.html#val-info}Cmdliner.Arg.info}. 263 | 264 | 265 | {2:cmd_info_attr [Cmd.info] Attributes} 266 | 267 | 268 | {3 [[@name string]]} 269 | 270 | Set the name of the command. If not provided, the kebab case of the constructor 271 | name will be used (i.e. constructor [Foo_bar] will have name ["foo-bar"] by default) 272 | for sub-commands, and the executable name will be used for command line tools. 273 | 274 | {[ 275 | type params = Foo [@name "my-cmd-name"] 276 | ]} 277 | 278 | {3 [[@doc string]]} 279 | 280 | Set the one line description of the command. If not provided, the doc string 281 | will be used. 282 | 283 | {[ 284 | type params = Foo (** This is a short description of My_cmd. *) 285 | ]} 286 | 287 | {3 Other} 288 | 289 | [[@version string]], [[@deprecated string]], [[@docs string]], [[@sdocs string]], 290 | [[@exits Cmd.Exit.info list]], [[@envs Cmd.Env.info list]], 291 | [[@man Manpage.block list]] and [[@man_xrefs Manpage.xref list]] are also 292 | supported. For their exact usages, please refer to the documentation of 293 | {{:https://erratique.ch/software/cmdliner/doc/Cmdliner/Cmd/index.html#val-info}Cmdliner.Cmd.info}. 294 | 295 | 296 | {2:enum_attr Enumeration Attribute} 297 | 298 | 299 | {3 [[@name string]]} 300 | 301 | 302 | {3 [[@names string list]]} 303 | 304 | Set the names of the enumeration. If not provided, the kebab case of the 305 | constructor name will be used (i.e. constructor [Foo_bar] will have name 306 | ["foo-bar"] by default). 307 | 308 | {[ 309 | type enum = Foo_bar [@names [ "my-enum-name"; "e" ]] 310 | ]} 311 | 312 | 313 | {2:default_term_attr Default [Term.t] Attribute} 314 | 315 | 316 | For sub-command evaluation, [[@@default]] can be used to change the command line 317 | syntax to parse if no sub command is specified. By default, it will show the 318 | default help page. 319 | 320 | {[ 321 | let default = Cmdliner.Term.(ret (const (`Error (true, "Some error messages")))) 322 | 323 | [%%subliner.cmds eval.params <- handle] 324 | [@@default default] 325 | ]} 326 | 327 | 328 | {2:type_attr Attributes for Types} 329 | 330 | 331 | The following attributes must be attached to types directly. 332 | 333 | {[ 334 | (* correct *) 335 | type params = { foo : (string [@attr]) } 336 | 337 | (* wrong, the attribute is attached to the field instead of the type *) 338 | 339 | type params = { foo : string [@attr] } 340 | ]} 341 | 342 | {3 [[@conv t Arg.conv]]} 343 | 344 | Use the user provided [Arg.conv] for this type as it is. All other attributes 345 | will be ignored. 346 | 347 | {[ 348 | type params = { foo : (t [@conv cmdliner_conv]) list } 349 | ]} 350 | 351 | {3 [[@file]], [[@dir]], [[@non_dir_file]]} 352 | 353 | Check whether the provided name for file, dir or non-dir file exists. Only one 354 | of these attributes can be specified at the same time. 355 | 356 | {[ 357 | type params = { foo : (string [@non_dir_file]) } 358 | ]} 359 | 360 | {3 [[@sep char]]} 361 | 362 | Set the separate of lists, arrays or tuples. This attribute can be used on 363 | nested structures. 364 | 365 | {[ 366 | type params = { rgb : (((int * int * int)[@sep '#']) list[@sep ';']) } 367 | ]} -------------------------------------------------------------------------------- /test/cmdliner/LICENSE.txt: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "{}" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright {yyyy} {name of copyright owner} 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. -------------------------------------------------------------------------------- /src/term.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | module Ap = Attribute_parser 3 | 4 | let suffix = "cmdliner_term" 5 | let gen_name_str = Utils.gen_name_str suffix 6 | let gen_name { txt = name; loc } = { txt = gen_name_str name; loc } 7 | 8 | type attrs = (location * structure) Ap.Term.t 9 | 10 | module Conv = struct 11 | type t = 12 | | Bool 13 | | Char 14 | | Int 15 | | Nativeint 16 | | Int32 17 | | Int64 18 | | Float 19 | | String 20 | | File 21 | | Dir 22 | | Non_dir_file 23 | | Option of t 24 | | List of expression option * t 25 | | Array of expression option * t 26 | | Pair of expression option * (t * t) 27 | | T3 of expression option * (t * t * t) 28 | | T4 of expression option * (t * t * t * t) 29 | | Custom of expression 30 | 31 | let rec of_core_type ct = 32 | let conv = Ap.Conv.parse ct.ptyp_attributes |> Ap.to_expr_opt "conv" in 33 | 34 | match ct with 35 | | _ when Option.is_some conv -> Custom (Option.get conv) 36 | | [%type: bool] | [%type: Bool.t] -> Bool 37 | | [%type: char] | [%type: Char.t] -> Char 38 | | [%type: int] | [%type: Int.t] -> Int 39 | | [%type: nativeint] | [%type: Nativeint.t] -> Nativeint 40 | | [%type: int32] | [%type: Int32.t] -> Int32 41 | | [%type: int64] | [%type: Int64.t] -> Int64 42 | | [%type: float] | [%type: Float.t] -> Float 43 | | ([%type: string] | [%type: String.t]) as ct -> 44 | let attrs = Ap.String_conv.parse ct.ptyp_attributes in 45 | let file = Ap.to_bool attrs.file 46 | and dir = Ap.to_bool attrs.dir 47 | and non_dir_file = Ap.to_bool attrs.non_dir_file in 48 | if file && not (dir || non_dir_file) then 49 | File 50 | else if dir && not (file || non_dir_file) then 51 | Dir 52 | else if non_dir_file && not (file || dir) then 53 | Non_dir_file 54 | else if not (file || dir || non_dir_file) then 55 | String 56 | else 57 | Location.raise_errorf ~loc:ct.ptyp_loc 58 | "only one of `dir`, `file` and `non_dir_file` can be specified at \ 59 | the same time" 60 | | [%type: [%t? in_ct] option] | [%type: [%t? in_ct] Option.t] -> 61 | Option (of_core_type in_ct) 62 | | ([%type: [%t? in_ct] list] as ct) | ([%type: [%t? in_ct] List.t] as ct) -> 63 | let sep = 64 | Ap.Sep_conv.parse ct.ptyp_attributes |> Ap.to_expr_opt "sep" 65 | in 66 | List (sep, of_core_type in_ct) 67 | | ([%type: [%t? in_ct] array] | [%type: [%t? in_ct] Array.t]) as ct -> 68 | let sep = 69 | Ap.Sep_conv.parse ct.ptyp_attributes |> Ap.to_expr_opt "sep" 70 | in 71 | Array (sep, of_core_type in_ct) 72 | | [%type: [%t? t0] * [%t? t1]] as ct -> 73 | let sep = 74 | Ap.Sep_conv.parse ct.ptyp_attributes |> Ap.to_expr_opt "sep" 75 | in 76 | Pair (sep, (of_core_type t0, of_core_type t1)) 77 | | [%type: [%t? t0] * [%t? t1] * [%t? t2]] as ct -> 78 | let sep = 79 | Ap.Sep_conv.parse ct.ptyp_attributes |> Ap.to_expr_opt "sep" 80 | in 81 | T3 (sep, (of_core_type t0, of_core_type t1, of_core_type t2)) 82 | | [%type: [%t? t0] * [%t? t1] * [%t? t2] * [%t? t3]] as ct -> 83 | let sep = 84 | Ap.Sep_conv.parse ct.ptyp_attributes |> Ap.to_expr_opt "sep" 85 | in 86 | T4 87 | ( sep, 88 | (of_core_type t0, of_core_type t1, of_core_type t2, of_core_type t3) 89 | ) 90 | | { ptyp_loc = loc; _ } -> Error.field_type ~loc 91 | 92 | let to_expr ~loc t : expression = 93 | let rec impl ~loc = function 94 | | Bool -> [%expr bool] 95 | | Char -> [%expr char] 96 | | Int -> [%expr int] 97 | | Nativeint -> [%expr nativeint] 98 | | Int32 -> [%expr int32] 99 | | Int64 -> [%expr int64] 100 | | Float -> [%expr float] 101 | | String -> [%expr string] 102 | | File -> [%expr file] 103 | | Dir -> [%expr dir] 104 | | Non_dir_file -> [%expr non_dir_file] 105 | | Option t -> 106 | let expr = impl ~loc t in 107 | [%expr some [%e expr]] 108 | | List (sep, t) -> 109 | let sep_expr = 110 | Option.fold ~none:[%expr None] ~some:(Utils.esome ~loc) sep 111 | and expr = impl ~loc t in 112 | [%expr list ?sep:[%e sep_expr] [%e expr]] 113 | | Array (sep, t) -> 114 | let sep_expr = 115 | Option.fold ~none:[%expr None] ~some:(Utils.esome ~loc) sep 116 | and expr = impl ~loc t in 117 | [%expr array ?sep:[%e sep_expr] [%e expr]] 118 | | Pair (sep, (t0, t1)) -> 119 | let sep_expr = 120 | Option.fold ~none:[%expr None] ~some:(Utils.esome ~loc) sep 121 | and t0_expr = impl ~loc t0 122 | and t1_expr = impl ~loc t1 in 123 | [%expr pair ?sep:[%e sep_expr] [%e t0_expr] [%e t1_expr]] 124 | | T3 (sep, (t0, t1, t2)) -> 125 | let sep_expr = 126 | Option.fold ~none:[%expr None] ~some:(Utils.esome ~loc) sep 127 | and t0_expr = impl ~loc t0 128 | and t1_expr = impl ~loc t1 129 | and t2_expr = impl ~loc t2 in 130 | [%expr t3 ?sep:[%e sep_expr] [%e t0_expr] [%e t1_expr] [%e t2_expr]] 131 | | T4 (sep, (t0, t1, t2, t3)) -> 132 | let sep_expr = 133 | Option.fold ~none:[%expr None] ~some:(Utils.esome ~loc) sep 134 | and t0_expr = impl ~loc t0 135 | and t1_expr = impl ~loc t1 136 | and t2_expr = impl ~loc t2 137 | and t3_expr = impl ~loc t3 in 138 | [%expr 139 | t4 ?sep:[%e sep_expr] [%e t0_expr] [%e t1_expr] [%e t2_expr] 140 | [%e t3_expr]] 141 | | Custom expr -> expr 142 | in 143 | 144 | let expr = impl ~loc t in 145 | [%expr Cmdliner.Arg.([%e expr])] 146 | end 147 | 148 | type conv = Conv.t 149 | 150 | module Cmd_env_info = struct 151 | let expr_of_attrs ~loc (attrs : attrs) : expression option = 152 | Ap.to_expr_opt "env" attrs.env 153 | |> Option.map (fun env_epxr -> 154 | let args = 155 | let labelled = 156 | [ 157 | ( "deprecated", 158 | Ap.to_expr_opt "env.deprecated" attrs.env_deprecated ); 159 | ("docs", Ap.to_expr_opt "env.docs" attrs.env_docs); 160 | ("doc", Ap.to_expr_opt "env.doc" attrs.env_doc); 161 | ] 162 | |> List.filter_map (fun (name, expr_opt) -> 163 | Option.map (fun expr -> (Labelled name, expr)) expr_opt) 164 | and no_label = [ (Nolabel, env_epxr) ] in 165 | labelled @ no_label 166 | in 167 | 168 | Ast_helper.Exp.apply ~loc [%expr Cmdliner.Cmd.Env.info] args) 169 | end 170 | 171 | module Info = struct 172 | let expr_of_attrs ~loc (names_expr : expression) (attrs : attrs) : expression 173 | = 174 | let args = 175 | let labelled = 176 | [ 177 | ("deprecated", Ap.to_expr_opt "deprecated" attrs.deprecated); 178 | ("absent", Ap.to_expr_opt "absent" attrs.absent); 179 | ("docs", Ap.to_expr_opt "docs" attrs.docs); 180 | ("docv", Ap.to_expr_opt "docv" attrs.docv); 181 | ("doc", Ap.to_trimmed_string_expr_opt "doc" attrs.doc); 182 | ("env", Cmd_env_info.expr_of_attrs ~loc attrs); 183 | ] 184 | |> List.filter_map (fun (name, expr_opt) -> 185 | Option.map (fun expr -> (Labelled name, expr)) expr_opt) 186 | (* names_expr should always resolved by Named or Positional *) 187 | and no_label = [ (Nolabel, names_expr) ] in 188 | labelled @ no_label 189 | in 190 | Ast_helper.Exp.apply ~loc [%expr Cmdliner.Arg.info] args 191 | end 192 | 193 | module As_term = struct 194 | let of_attrs ~loc (attrs : attrs) : 195 | [ `value of expression option 196 | | `non_empty 197 | | `last of expression option * expression option ] = 198 | let non_empty = Ap.to_bool attrs.non_empty 199 | and last = Ap.to_bool attrs.last 200 | and default = Ap.to_expr_opt "default" attrs.default in 201 | match (non_empty, last, default) with 202 | | true, false, None -> `non_empty 203 | | true, true, _ -> 204 | Location.raise_errorf ~loc 205 | "`non_empty` and `last` cannot be used at the same time" 206 | | true, _, Some _ -> 207 | Location.raise_errorf ~loc 208 | "`non_empty` and `default` cannot be used at the same time" 209 | | false, true, _ -> 210 | let sep = Ap.to_expr_opt "sep" attrs.last_sep in 211 | `last (sep, default) 212 | | false, false, _ -> `value default 213 | 214 | let to_expr ~loc : 215 | [< `value of 'a | `required | `non_empty | `last of 'b ] -> expression = 216 | function 217 | | `value _ -> [%expr Cmdliner.Arg.value] 218 | | `required -> [%expr Cmdliner.Arg.required] 219 | | `non_empty -> [%expr Cmdliner.Arg.non_empty] 220 | | `last _ -> [%expr Cmdliner.Arg.last] 221 | end 222 | 223 | module Named = struct 224 | let to_named_fun_expr ~loc = function 225 | | `flag -> [%expr Cmdliner.Arg.flag] 226 | | `flag_all -> [%expr Cmdliner.Arg.flag_all] 227 | | `opt (conv, default_expr) -> 228 | let conv_expr = Conv.to_expr ~loc conv in 229 | [%expr Cmdliner.Arg.opt [%e conv_expr] [%e default_expr]] 230 | | `opt_all (conv, default_expr) -> 231 | let conv_expr = Conv.to_expr ~loc conv in 232 | [%expr Cmdliner.Arg.opt_all [%e conv_expr] [%e default_expr]] 233 | 234 | let expr_of_attrs ~loc name ct (attrs : attrs) : expression = 235 | let as_term, type_ = 236 | let as_term = As_term.of_attrs ~loc attrs 237 | and conv = Conv.of_core_type ct 238 | and opt_all = Ap.to_bool attrs.opt_all in 239 | if not opt_all then 240 | match (as_term, conv) with 241 | | `value None, Bool -> (`value (), `flag) 242 | | `value (Some default_expr), _ -> (`value (), `opt (conv, default_expr)) 243 | | `value None, Option _ -> (`value (), `opt (conv, [%expr None])) 244 | | `value None, _ -> (`required, `opt (Conv.Option conv, [%expr None])) 245 | | `non_empty, List _ -> (`non_empty, `opt (conv, [%expr []])) 246 | | `last (sep, default), _ -> 247 | let default_expr = 248 | Option.fold ~none:[%expr []] ~some:(Utils.elist ~loc) default 249 | in 250 | (`last (), `opt (Conv.List (sep, conv), default_expr)) 251 | | `non_empty, _ -> Error.attr_list_type ~loc "non_empty" 252 | else 253 | match (as_term, conv) with 254 | | `value default, List (None, in_conv) -> 255 | let default_expr = Option.value ~default:[%expr []] default in 256 | (`value (), `opt_all (in_conv, default_expr)) 257 | | `non_empty, List (None, in_conv) -> 258 | (`non_empty, `opt_all (in_conv, [%expr []])) 259 | | `last (_, default), _ -> 260 | let default_expr = 261 | Option.fold ~none:[%expr []] ~some:(Utils.elist ~loc) default 262 | in 263 | (`last (), `opt_all (conv, default_expr)) 264 | | _, List (Some _, _) -> 265 | Location.raise_errorf ~loc 266 | "`opt_all` and `sep` cannot be used on the same list" 267 | | _ -> Error.attr_list_type ~loc "opt_all" 268 | and names_expr = 269 | (* field name will be the default arg name *) 270 | let default_names_expr = 271 | name.txt 272 | |> String.map (function '_' -> '-' | c -> c) 273 | |> Ast_builder.Default.estring ~loc:name.loc 274 | |> Utils.elist ~loc 275 | in 276 | attrs.names 277 | |> Ap.to_expr_opt "names" 278 | |> Option.value ~default:default_names_expr 279 | in 280 | 281 | let as_term_expr = As_term.to_expr ~loc as_term 282 | and named_fun_expr = to_named_fun_expr ~loc type_ 283 | and info_expr = Info.expr_of_attrs ~loc names_expr attrs in 284 | 285 | [%expr [%e as_term_expr] ([%e named_fun_expr] [%e info_expr])] 286 | end 287 | 288 | module Positional = struct 289 | let pos_fun_expr_impl ~loc rev pos_expr fun_expr = 290 | let rev_expr = Ast_builder.Default.ebool ~loc rev in 291 | [%expr [%e fun_expr] ~rev:[%e rev_expr] [%e pos_expr]] 292 | 293 | let to_pos_fun_expr ~loc = function 294 | | `pos_all -> [%expr Cmdliner.Arg.pos_all] 295 | | `pos (r, p) -> pos_fun_expr_impl ~loc r p [%expr Cmdliner.Arg.pos] 296 | | `pos_left (r, p) -> 297 | pos_fun_expr_impl ~loc r p [%expr Cmdliner.Arg.pos_left] 298 | | `pos_right (r, p) -> 299 | pos_fun_expr_impl ~loc r p [%expr Cmdliner.Arg.pos_right] 300 | 301 | let expr_of_attrs ~loc ct (attrs : attrs) : expression = 302 | let () = 303 | attrs.names 304 | |> Ap.to_expr_opt "names" 305 | |> Option.fold ~none:() ~some:(fun _ -> 306 | Error.f ~loc "`names` cannot be used with positional argument") 307 | and () = 308 | if Ap.to_bool attrs.opt_all then 309 | Error.f ~loc "`opt_all` cannot be used with positional argument" 310 | else 311 | () 312 | in 313 | let type_ = 314 | let rev = Ap.to_bool attrs.rev in 315 | match attrs with 316 | | { pos = Some pos; _ } -> 317 | let pos_expr = Ap.to_expr "pos" pos in 318 | `pos (rev, pos_expr) 319 | | { pos_left = Some pos; _ } -> 320 | let pos_expr = Ap.to_expr "pos_left" pos in 321 | `pos_left (rev, pos_expr) 322 | | { pos_right = Some pos; _ } -> 323 | let pos_expr = Ap.to_expr "pos_right" pos in 324 | `pos_right (rev, pos_expr) 325 | | { pos_all = Some _; _ } when rev -> 326 | Location.raise_errorf ~loc "`rev` cannot be used with `pos_all`" 327 | | { pos_all = Some pos; _ } -> 328 | let _ = Ap.to_bool (Some pos) in 329 | `pos_all 330 | | _ -> Error.unexpected ~loc 331 | in 332 | 333 | let as_term, conv, default_expr = 334 | let as_term = As_term.of_attrs ~loc attrs 335 | and conv = Conv.of_core_type ct in 336 | match type_ with 337 | | `pos _ -> ( 338 | match (as_term, conv) with 339 | | `value (Some default_expr), _ -> (`value (), conv, default_expr) 340 | | `value None, Option _ -> (`value (), conv, [%expr None]) 341 | | `value None, _ -> (`required, Option conv, [%expr None]) 342 | | `non_empty, List _ -> (`non_empty, conv, [%expr []]) 343 | | `last (sep, default), _ -> 344 | let default_expr = 345 | Option.fold ~none:[%expr []] ~some:(Utils.elist ~loc) default 346 | in 347 | (`last (), List (sep, conv), default_expr) 348 | | `non_empty, _ -> Error.attr_list_type ~loc "non_empty") 349 | | `pos_left _ | `pos_right _ | `pos_all -> ( 350 | match (as_term, conv) with 351 | | `value default, List (None, in_conv) -> 352 | let default_expr = Option.value ~default:[%expr []] default in 353 | (`value (), in_conv, default_expr) 354 | | `non_empty, List (None, in_conv) -> (`non_empty, in_conv, [%expr []]) 355 | | `last (_, default), _ -> 356 | let default_expr = 357 | Option.fold ~none:[%expr []] ~some:(Utils.elist ~loc) default 358 | in 359 | (`last (), conv, default_expr) 360 | | _, List (Some _, _) -> 361 | Location.raise_errorf ~loc 362 | "`sep` cannot be used with `pos_left`, `pos_right` and \ 363 | `pos_all`" 364 | | _ -> 365 | Location.raise_errorf ~loc 366 | "`pos_left`, `pos_right` and `pos_all` must be used with list \ 367 | type") 368 | in 369 | 370 | let as_term_expr = As_term.to_expr ~loc as_term 371 | and info_expr = Info.expr_of_attrs ~loc [%expr []] attrs 372 | and conv_expr = Conv.to_expr ~loc conv 373 | and pos_fun_expr = to_pos_fun_expr ~loc type_ in 374 | 375 | [%expr 376 | [%e as_term_expr] 377 | ([%e pos_fun_expr] [%e conv_expr] [%e default_expr] [%e info_expr])] 378 | end 379 | 380 | module T = struct 381 | let expr_of_attrs ~loc name ct (attrs : attrs) = 382 | let term = Ap.to_expr_opt "term" attrs.term in 383 | match term with 384 | | Some term_expr -> term_expr 385 | | None -> ( 386 | let pos_count = 387 | let count opt = if Option.is_some opt then 1 else 0 in 388 | count attrs.pos 389 | + count attrs.pos_all 390 | + count attrs.pos_left 391 | + count attrs.pos_right 392 | in 393 | match pos_count with 394 | (* named *) 395 | | 0 -> Named.expr_of_attrs ~loc name ct attrs 396 | (* positional *) 397 | | 1 -> Positional.expr_of_attrs ~loc ct attrs 398 | (* multiple pos error *) 399 | | _ -> 400 | Location.raise_errorf ~loc 401 | "only one of `pos`, `pos_all`, `pos_left` and `pos_right` can be \ 402 | specified at the same time") 403 | end 404 | 405 | let make_fun_vb_expr_of_label_decls ~loc ~const (lds : label_declaration list) = 406 | let vb = 407 | let pat = Ast_helper.Pat.var ~loc { txt = "make"; loc } 408 | and expr = 409 | lds 410 | |> List.map (fun ld -> 411 | let li = Utils.longident_loc_of_name ld.pld_name in 412 | (li, Ast_helper.Exp.ident ~loc li)) 413 | |> fun fields -> 414 | Ast_helper.Exp.record ~loc fields None 415 | |> fun record_expr -> 416 | (match const with 417 | | None -> record_expr 418 | | Some const -> 419 | Ast_helper.Exp.construct ~loc 420 | (Utils.longident_loc_of_name const) 421 | (Some record_expr)) 422 | |> fun value_expr -> 423 | List.fold_left 424 | (fun acc ld -> 425 | let pat = Ast_helper.Pat.var ~loc ld.pld_name in 426 | Ast_helper.Exp.fun_ ~loc Nolabel None pat acc) 427 | value_expr (List.rev lds) 428 | in 429 | Ast_helper.Vb.mk ~loc pat expr 430 | and var_expr = [%expr make] in 431 | (vb, var_expr) 432 | 433 | let term_vb_expr_of_label_decl (ld : label_declaration) = 434 | let loc = ld.pld_loc in 435 | let name_str = ld.pld_name.txt in 436 | let var_name = { txt = Printf.sprintf "subterm_%s" name_str; loc } in 437 | 438 | let vb = 439 | let pat = Ast_helper.Pat.var ~loc var_name 440 | and expr = 441 | ld.pld_attributes 442 | |> Ap.Term.parse 443 | |> T.expr_of_attrs ~loc ld.pld_name ld.pld_type 444 | in 445 | Ast_helper.Vb.mk ~loc pat expr 446 | and var_expr = 447 | var_name |> Utils.longident_loc_of_name |> Ast_helper.Exp.ident ~loc 448 | in 449 | (vb, var_expr) 450 | 451 | let aggregation_expr_of_term_exprs 452 | ~loc 453 | (make_expr : expression) 454 | (term_exprs : expression list) = 455 | let expr = 456 | List.fold_left 457 | (fun acc term_expr -> [%expr [%e acc] $ [%e term_expr]]) 458 | [%expr const [%e make_expr]] 459 | term_exprs 460 | in 461 | [%expr Cmdliner.Term.([%e expr])] 462 | 463 | let core_type_of_type_name ~loc name = 464 | let ct = 465 | let lid = Utils.longident_loc_of_name name in 466 | Ast_helper.Typ.constr ~loc lid [] 467 | in 468 | [%type: unit -> [%t ct] Cmdliner.Term.t] 469 | 470 | let expression_of_label_decls ~loc ~const (lds : label_declaration list) = 471 | let make_vb, make_expr = make_fun_vb_expr_of_label_decls ~loc ~const lds 472 | and term_vbs, term_exprs = 473 | lds |> List.map term_vb_expr_of_label_decl |> List.split 474 | in 475 | let aggregation_expr = 476 | aggregation_expr_of_term_exprs ~loc make_expr term_exprs 477 | in 478 | Ast_helper.Exp.let_ ~loc Nonrecursive (make_vb :: term_vbs) aggregation_expr 479 | 480 | let structure_of_label_decls ~loc name (lds : label_declaration list) = 481 | let stri = 482 | let pat = Ast_helper.Pat.var ~loc @@ gen_name name 483 | and ct = core_type_of_type_name ~loc name 484 | and expr = expression_of_label_decls ~loc ~const:None lds in 485 | [%stri let ([%p pat] : [%t ct]) = fun () -> [%e expr]] 486 | in 487 | [ stri ] 488 | 489 | let signature_of_label_decls ~loc name = 490 | let sigi = 491 | let fun_name = gen_name name and ct = core_type_of_type_name ~loc name in 492 | Ast_helper.Val.mk ~loc fun_name ct |> Ast_helper.Sig.value ~loc 493 | in 494 | [ sigi ] 495 | --------------------------------------------------------------------------------