├── src ├── carcass_cli.mllib ├── carcass.mllib ├── carcass_etc.ml ├── carcass_cli.mli ├── carcass_cli.ml ├── carcass.mli └── carcass.ml ├── doc ├── api.odocl ├── dev.odocl └── style.css ├── etc ├── LICENSE.md ├── content ├── topkg │ ├── _doc.odocl │ ├── _merlin │ ├── _gitignore │ ├── _CHANGES.md │ ├── _tags │ ├── _pkg.ml │ ├── _src.mli │ ├── _README.md │ └── pkg.body ├── ocaml │ ├── ocp-indent │ ├── mod.body │ └── src ├── ocamlbuild │ ├── lib │ │ └── _lib.mllib │ ├── lib-top │ │ ├── _mod_top.mllib │ │ └── _mod_top.ml │ ├── hello │ │ ├── _merlin │ │ ├── _tags │ │ ├── _hello.ml │ │ └── _build │ ├── lib.body │ ├── hello.body │ └── lib-top.body ├── c │ ├── unit.body │ ├── hello.body │ ├── src │ ├── unit │ │ ├── _unit.c │ │ ├── _unit.h │ │ └── _unit-alt.c │ └── hello │ │ ├── _hello.c │ │ └── _Makefile ├── ocamlfind │ ├── pkg │ ├── lib │ └── lib-top ├── www │ ├── page.body │ ├── html │ ├── js │ ├── css │ ├── _page.html │ └── _page.js ├── opam │ └── topkg └── flesh.setup ├── .ocp-indent ├── .gitignore ├── CHANGES.md ├── .merlin ├── _tags ├── pkg ├── META └── pkg.ml ├── LICENSE.md ├── opam ├── src-bin ├── carcass_bin.mli ├── body.mli ├── bone.mli ├── flesh.mli ├── help.mli ├── info.mli ├── match.mli ├── setup.mli ├── carcass_bin.ml ├── bone.ml ├── body.ml ├── cli.mli ├── match.ml ├── cli.ml ├── flesh.ml ├── info.ml ├── setup.ml └── help.ml └── README.md /src/carcass_cli.mllib: -------------------------------------------------------------------------------- 1 | Carcass_cli -------------------------------------------------------------------------------- /doc/api.odocl: -------------------------------------------------------------------------------- 1 | Carcass 2 | Carcass_cli -------------------------------------------------------------------------------- /etc/LICENSE.md: -------------------------------------------------------------------------------- 1 | $(LICENSE_TERMS) 2 | -------------------------------------------------------------------------------- /etc/content: -------------------------------------------------------------------------------- 1 | $(CARCASS_MATCH_CONTENT) -------------------------------------------------------------------------------- /etc/topkg/_doc.odocl: -------------------------------------------------------------------------------- 1 | $(NAME,capitalize) -------------------------------------------------------------------------------- /src/carcass.mllib: -------------------------------------------------------------------------------- 1 | Carcass 2 | Carcass_etc -------------------------------------------------------------------------------- /etc/ocaml/ocp-indent: -------------------------------------------------------------------------------- 1 | $(OCP_INDENT_CONFIG) 2 | -------------------------------------------------------------------------------- /etc/ocamlbuild/lib/_lib.mllib: -------------------------------------------------------------------------------- 1 | $(NAME,capitalize) 2 | -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | strict_with=always,match_clause=4,strict_else=never -------------------------------------------------------------------------------- /etc/ocamlbuild/lib-top/_mod_top.mllib: -------------------------------------------------------------------------------- 1 | $(NAME,capitalize)_top 2 | -------------------------------------------------------------------------------- /etc/topkg/_merlin: -------------------------------------------------------------------------------- 1 | PKG bytes 2 | S src 3 | S test 4 | B _build/** 5 | -------------------------------------------------------------------------------- /etc/ocamlbuild/hello/_merlin: -------------------------------------------------------------------------------- 1 | PKG bytes result uchar 2 | S src 3 | B _build/** 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | tmp 3 | *~ 4 | \.\#* 5 | \#*# 6 | *.native 7 | *.byte 8 | *.install -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | vX.Y.Z YYYY-MM-DD Location 2 | -------------------------- 3 | 4 | First release. 5 | -------------------------------------------------------------------------------- /etc/topkg/_gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | tmp 3 | *~ 4 | \.\#* 5 | \#*# 6 | *.install 7 | *.native 8 | *.byte -------------------------------------------------------------------------------- /etc/ocamlbuild/hello/_tags: -------------------------------------------------------------------------------- 1 | true : bin_annot, safe_string, package(bytes result uchar) 2 | : include -------------------------------------------------------------------------------- /etc/topkg/_CHANGES.md: -------------------------------------------------------------------------------- 1 | vX.Y.Z YYYY-MM-DD Location 2 | -------------------------- 3 | 4 | First release. 5 | -------------------------------------------------------------------------------- /etc/topkg/_tags: -------------------------------------------------------------------------------- 1 | true : bin_annot, safe_string, package(bytes) 2 | 3 | : include 4 | : include -------------------------------------------------------------------------------- /doc/dev.odocl: -------------------------------------------------------------------------------- 1 | Carcass 2 | Carcass_cli 3 | Carcass_bin 4 | Body 5 | Bone 6 | Cli 7 | Flesh 8 | Help 9 | Info 10 | Match 11 | Setup 12 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PKG uchar result rresult 2 | PKG fmt fmt.tty fmt.cli 3 | PKG logs logs.fmt logs.cli 4 | PKG astring fpath bos cmdliner 5 | PKG uutf uucp 6 | 7 | S src 8 | S test 9 | B _build/** 10 | -------------------------------------------------------------------------------- /etc/c/unit.body: -------------------------------------------------------------------------------- 1 | doc "C compilation unit" 2 | "C compilation unit, a .h/.c file pair." 3 | 4 | var NAME "the compilation unit name" 5 | 6 | bind $(NAME).h c/unit/_unit.h 7 | bind $(NAME).c c/unit/_unit.c 8 | -------------------------------------------------------------------------------- /etc/ocaml/mod.body: -------------------------------------------------------------------------------- 1 | doc "OCaml module" 2 | "OCaml module, a .mli/.ml file pair." 3 | 4 | var NAME "the module name" 5 | 6 | bind $(NAME,uncapitalize).ml ocaml/src 7 | bind $(NAME,uncapitalize).mli ocaml/src 8 | -------------------------------------------------------------------------------- /etc/c/hello.body: -------------------------------------------------------------------------------- 1 | doc 2 | "C hello world program" 3 | "C hello world program compiled with make" 4 | 5 | var NAME "the name of the program" 6 | 7 | bind Makefile c/hello/_Makefile 8 | bind src/$(NAME,uncapitalize).c c/hello/_hello.c 9 | -------------------------------------------------------------------------------- /src/carcass_etc.ml: -------------------------------------------------------------------------------- 1 | 2 | (* This file is overwritten by the configuration process. During 3 | development it will work if you invoke the carcass binary 4 | from the root directory of the repository. *) 5 | 6 | let dir = Fpath.v "etc" 7 | -------------------------------------------------------------------------------- /etc/topkg/_pkg.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | #use "topfind" 3 | #require "topkg" 4 | open Topkg 5 | 6 | let () = 7 | Pkg.describe "$(NAME,uncapitalize)" @@ fun c -> 8 | Ok [ Pkg.mllib "src/$(NAME,uncapitalize).mllib"; 9 | Pkg.test "test/test"; ] 10 | -------------------------------------------------------------------------------- /etc/ocamlfind/pkg: -------------------------------------------------------------------------------- 1 | description = "$(PKG_SYNOPSIS)" 2 | version = "%%VERSION_NUM%%" 3 | requires = "" 4 | archive(byte) = "$(NAME,uncapitalize).cma" 5 | archive(native) = "$(NAME,uncapitalize).cmxa" 6 | plugin(byte) = "$(NAME,uncapitalize).cma" 7 | plugin(native) = "$(NAME,uncapitalize).cmxs" 8 | -------------------------------------------------------------------------------- /etc/ocamlbuild/lib.body: -------------------------------------------------------------------------------- 1 | doc 2 | "OCaml library" 3 | "OCaml library made of a single module. A .mli/.ml file pair and an 4 | ocamlbuild .mllib file to compile it." 5 | 6 | var NAME "the library and module name" 7 | 8 | bind . ocaml/mod.body 9 | bind $(NAME,uncapitalize).mllib ocamlbuild/lib/_lib.mllib 10 | -------------------------------------------------------------------------------- /etc/www/page.body: -------------------------------------------------------------------------------- 1 | doc 2 | "HTML page with JavaScript" 3 | "HTML page linked with an empty CSS and JavaScript file." 4 | 5 | var NAME "the base name for the HTML, CSS and JavaScript files" 6 | var TITLE "the HTML page title" 7 | 8 | bind $(NAME).html www/_page.html 9 | bind $(NAME).css www/css 10 | bind $(NAME).js www/_page.js -------------------------------------------------------------------------------- /etc/ocamlfind/lib: -------------------------------------------------------------------------------- 1 | package "$(NAME,uncapitalize)" ( 2 | description = "$(LIB_SYNOPSIS)" 3 | version = "%%VERSION%%" 4 | requires = "" 5 | archive(byte) = "$(NAME,uncapitalize).cma" 6 | archive(native) = "$(NAME,uncapitalize).cmxa" 7 | plugin(byte) = "$(NAME,uncapitalize).cma" 8 | plugin(native) = "$(NAME,uncapitalize).cmxs" 9 | ) 10 | -------------------------------------------------------------------------------- /etc/ocamlfind/lib-top: -------------------------------------------------------------------------------- 1 | package "top" ( 2 | description = "$(NAME) toplevel support" 3 | version = "%%VERSION%%" 4 | requires = "$(NAME,uncapitalize)" 5 | archive(byte) = "$(NAME,uncapitalize)_top.cma" 6 | archive(native) = "$(NAME,uncapitalize)_top.cmxa" 7 | plugin(byte) = "$(NAME,uncapitalize)_top.cma" 8 | plugin(native) = "$(NAME,uncapitalize)_top.cmxs" 9 | ) 10 | -------------------------------------------------------------------------------- /etc/www/html: -------------------------------------------------------------------------------- 1 | 2 | 5 | 6 | 7 | 8 | 9 | $(TITLE) 10 | 11 | 12 |

$(TITLE)

13 | $(CARCASS_MATCH_CONTENT) 14 | 15 | 16 | 19 | -------------------------------------------------------------------------------- /etc/ocamlbuild/hello.body: -------------------------------------------------------------------------------- 1 | doc 2 | "OCaml hello world program" 3 | "OCaml hello world program compiled with ocamlbuild." 4 | 5 | var NAME "the name of the program" 6 | 7 | bind .merlin ocamlbuild/hello/_merlin 8 | bind .ocp-indent ocaml/ocp-indent 9 | bind _tags ocamlbuild/hello/_tags 10 | bind build ocamlbuild/hello/_build 11 | bind src/$(NAME,uncapitalize).ml ocamlbuild/hello/_hello.ml 12 | -------------------------------------------------------------------------------- /etc/c/src: -------------------------------------------------------------------------------- 1 | /*--------------------------------------------------------------------------- 2 | $(SRC_HEADER,indent(" ")) 3 | ---------------------------------------------------------------------------*/ 4 | $(CARCASS_MATCH_CONTENT) 5 | /*--------------------------------------------------------------------------- 6 | $(SRC_FOOTER,indent(" ")) 7 | ---------------------------------------------------------------------------*/ 8 | -------------------------------------------------------------------------------- /etc/ocaml/src: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | $(SRC_HEADER,indent(" ")) 3 | ---------------------------------------------------------------------------*) 4 | $(CARCASS_MATCH_CONTENT) 5 | (*--------------------------------------------------------------------------- 6 | $(SRC_FOOTER,indent(" ")) 7 | ---------------------------------------------------------------------------*) 8 | -------------------------------------------------------------------------------- /etc/www/js: -------------------------------------------------------------------------------- 1 | /*--------------------------------------------------------------------------- 2 | $(SRC_HEADER,indent(" ")) 3 | ---------------------------------------------------------------------------*/ 4 | $(CARCASS_MATCH_CONTENT) 5 | /*--------------------------------------------------------------------------- 6 | $(SRC_FOOTER,indent(" ")) 7 | ---------------------------------------------------------------------------*/ 8 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true : bin_annot, safe_string 2 | true : package(unix), package(rresult), package(astring), package(uutf), \ 3 | package(fmt), package(fpath), package(logs), package(bos) 4 | 5 | : include 6 | : package(cmdliner) 7 | 8 | : include 9 | : package(cmdliner), package(fmt.tty), package(fmt.cli), \ 10 | package(logs.fmt), package(logs.cli) 11 | 12 | : include 13 | -------------------------------------------------------------------------------- /etc/www/css: -------------------------------------------------------------------------------- 1 | @charset "UTF-8"; 2 | /*--------------------------------------------------------------------------- 3 | $(SRC_HEADER,indent(" ")) 4 | ---------------------------------------------------------------------------*/ 5 | $(CARCASS_MATCH_CONTENT) 6 | /*--------------------------------------------------------------------------- 7 | $(SRC_FOOTER,indent(" ")) 8 | ---------------------------------------------------------------------------*/ 9 | -------------------------------------------------------------------------------- /etc/c/unit/_unit.c: -------------------------------------------------------------------------------- 1 | /*--------------------------------------------------------------------------- 2 | $(SRC_HEADER,indent(" ")) 3 | ---------------------------------------------------------------------------*/ 4 | 5 | #include <$(NAME).h> 6 | $(CARCASS_MATCH_CONTENT) 7 | /*--------------------------------------------------------------------------- 8 | $(SRC_FOOTER,indent(" ")) 9 | ---------------------------------------------------------------------------*/ 10 | -------------------------------------------------------------------------------- /etc/ocamlbuild/hello/_hello.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | $(SRC_HEADER,indent(" ")) 3 | ---------------------------------------------------------------------------*) 4 | 5 | let () = print_endline "Hello world!" 6 | 7 | (*--------------------------------------------------------------------------- 8 | $(SRC_FOOTER,indent(" ")) 9 | ---------------------------------------------------------------------------*) 10 | -------------------------------------------------------------------------------- /etc/c/unit/_unit.h: -------------------------------------------------------------------------------- 1 | /*--------------------------------------------------------------------------- 2 | $(SRC_HEADER,indent(" ")) 3 | ---------------------------------------------------------------------------*/ 4 | 5 | #ifndef $(NAME,uppercase)_H 6 | #define $(NAME,uppercase)_H 7 | $(CARCASS_MATCH_CONTENT) 8 | #endif 9 | 10 | /*--------------------------------------------------------------------------- 11 | $(SRC_FOOTER,indent(" ")) 12 | ---------------------------------------------------------------------------*/ 13 | -------------------------------------------------------------------------------- /etc/ocamlbuild/lib-top/_mod_top.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | $(SRC_HEADER,indent(" ")) 3 | ---------------------------------------------------------------------------*) 4 | 5 | let () = ignore (Toploop.use_file Format.err_formatter "$(NAME,uncapitalize)_top_init.ml") 6 | 7 | (*--------------------------------------------------------------------------- 8 | $(SRC_FOOTER,indent(" ")) 9 | ---------------------------------------------------------------------------*) 10 | -------------------------------------------------------------------------------- /etc/c/unit/_unit-alt.c: -------------------------------------------------------------------------------- 1 | 2 | NAME=NAME 3 | SRC_HEADER_INDENT = indent(SRC_HEADER," ") 4 | 5 | -------- 6 | /*--------------------------------------------------------------------------- 7 | SRC_HEADER 8 | ---------------------------------------------------------------------------*/ 9 | 10 | #include 11 | $(CARCASS_MATCH_CONTENT) 12 | /*--------------------------------------------------------------------------- 13 | $(SRC_FOOTER,indent(" ")) 14 | ---------------------------------------------------------------------------*/ 15 | -------------------------------------------------------------------------------- /etc/c/hello/_hello.c: -------------------------------------------------------------------------------- 1 | /*--------------------------------------------------------------------------- 2 | $(SRC_HEADER,indent(" ")) 3 | ---------------------------------------------------------------------------*/ 4 | 5 | #include 6 | 7 | int main (int argc, char *argv[]) 8 | { 9 | puts ("Hello, world!"); 10 | return 0; 11 | } 12 | 13 | /*--------------------------------------------------------------------------- 14 | $(SRC_FOOTER,indent(" ")) 15 | ---------------------------------------------------------------------------*/ 16 | -------------------------------------------------------------------------------- /etc/topkg/_src.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | $(SRC_HEADER,indent(" ")) 3 | ---------------------------------------------------------------------------*) 4 | 5 | (** $(PKG_SYNOPSIS) 6 | 7 | {e %%VERSION%% — {{:%%PKG_HOMEPAGE%% }homepage}} *) 8 | 9 | (** {1 $(NAME,capitalize)} *) 10 | 11 | (*--------------------------------------------------------------------------- 12 | $(SRC_FOOTER,indent(" ")) 13 | ---------------------------------------------------------------------------*) 14 | -------------------------------------------------------------------------------- /etc/opam/topkg: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | maintainer: "$(AUTHOR_NAME) <$(AUTHOR_EMAIL)>" 3 | authors: ["$(AUTHOR_NAME) <$(AUTHOR_EMAIL)>"] 4 | homepage: "$(PKG_HOMEPAGE)" 5 | doc: "$(PKG_DOC)" 6 | license: "$(LICENSE)" 7 | dev-repo: "$(PKG_REPO)" 8 | bug-reports: "$(PKG_ISSUES)" 9 | tags: [] 10 | available: [ ocaml-version >= "4.01.0"] 11 | depends: 12 | [ 13 | "ocamlfind" {build} 14 | "ocamlbuild" {build} 15 | "topkg" {build & >= "0.9.0"} 16 | ] 17 | depopts: [] 18 | build: 19 | [[ 20 | "ocaml" "pkg/pkg.ml" "build" 21 | "--dev-pkg" "%{dev}%" 22 | ]] 23 | -------------------------------------------------------------------------------- /etc/www/_page.html: -------------------------------------------------------------------------------- 1 | 2 | 5 | 6 | 7 | 8 | 9 | 11 | 12 | $(TITLE) 13 | 14 | 15 |

$(TITLE)

16 | $(CARCASS_MATCH_CONTENT) 17 | 18 | 19 | 22 | -------------------------------------------------------------------------------- /etc/ocamlbuild/hello/_build: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | OCAMLBUILD=$${OCAMLBUILD:="ocamlbuild -use-ocamlfind -classic-display \ 6 | -tag debug"} 7 | 8 | action () 9 | { 10 | case $$1 in 11 | default) action bin-native ;; 12 | bin-byte) $$OCAMLBUILD $(NAME,uncapitalize).byte ;; 13 | bin-native) $$OCAMLBUILD $(NAME,uncapitalize).native ;; 14 | clean) $$OCAMLBUILD -clean ;; 15 | *) $$OCAMLBUILD $$* ;; 16 | esac 17 | } 18 | 19 | if [ $$# -eq 0 ]; 20 | then action default ; 21 | else action $$*; fi 22 | -------------------------------------------------------------------------------- /etc/www/_page.js: -------------------------------------------------------------------------------- 1 | /*--------------------------------------------------------------------------- 2 | $(SRC_HEADER,indent(" ")) 3 | ---------------------------------------------------------------------------*/ 4 | 5 | var $(NAME,lowercase) = function () 6 | { 7 | function main () 8 | { 9 | window.console.log ("Hello shitty browser world!") 10 | } 11 | document.addEventListener("DOMContentLoaded", main, false); 12 | } (); 13 | 14 | /*--------------------------------------------------------------------------- 15 | $(SRC_FOOTER,indent(" ")) 16 | ---------------------------------------------------------------------------*/ 17 | -------------------------------------------------------------------------------- /pkg/META: -------------------------------------------------------------------------------- 1 | description = "Define and generate file and directory carcasses" 2 | version = "%%VERSION_NUM%%" 3 | 4 | requires = "unix uchar result rresult astring uutf fmt fpath bos" 5 | archive(byte) = "carcass.cma" 6 | archive(native) = "carcass.cmxa" 7 | plugin(byte) = "carcass.cma" 8 | plugin(native) = "carcass.cmxs" 9 | 10 | package "cli" ( 11 | description = "Cmdliner support for Carcass" 12 | version = "%%VERSION_NUM%%" 13 | requires = "cmdliner carcass" 14 | archive(byte) = "carcass_cli.cma" 15 | archive(native) = "carcass_cli.cmxa" 16 | plugin(byte) = "carcass_cli.cma" 17 | plugin(native) = "carcass_cli.cmxs" 18 | ) 19 | -------------------------------------------------------------------------------- /etc/ocamlbuild/lib-top.body: -------------------------------------------------------------------------------- 1 | doc 2 | "OCaml toplevel support library" 3 | "OCaml toplevel support library loading toplevel directives for another 4 | library. The directives are in the source file 5 | $(NAME)_top_init.ml; it needs to be installed in the same directory 6 | as the support library. 7 | 8 | The bone ocamlfind/lib-top generates a META file fragment for this library." 9 | 10 | var NAME "the library name to support in the toplevel." 11 | 12 | bind $(NAME,uncapitalize)_top_init.ml ocaml/src 13 | bind $(NAME,uncapitalize)_top.ml ocamlbuild/lib-top/_mod_top.ml 14 | bind $(NAME,uncapitalize)_top.mllib ocamlbuild/lib-top/_mod_top.mllib 15 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Daniel C. Bünzli 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /etc/c/hello/_Makefile: -------------------------------------------------------------------------------- 1 | # Compiles all the sources in src/ to a binary executable. 2 | 3 | BDIR := _build 4 | SRC_DIR := src 5 | BIN_NAME := $(NAME,lowercase) 6 | BIN_OBJS := $$(patsubst $$(SRC_DIR)/%.c,$$(BDIR)/%.o,$$(wildcard $$(SRC_DIR)/*.c)) 7 | BIN := $$(BDIR)/$$(BIN_NAME) 8 | 9 | # C compiler 10 | 11 | CC = cc 12 | CINCS := -I $$(SRC_DIR) 13 | CDEBUG := -g 14 | CDEPEND := -MD -MP 15 | CFLAGS := $$(CINCS) $$(CDEPEND) $$(CDEBUG) -Wall 16 | LDFLAGS := 17 | 18 | # Build rules 19 | 20 | RM = rm 21 | mk_bdir := $$(shell mkdir -p $$(BDIR)) 22 | 23 | all: $$(BIN) 24 | 25 | clean: 26 | $$(RM) -rf $$(BDIR) 27 | $$(RM) -f $$(BIN_NAME) 28 | 29 | $$(BIN): $$(BIN_OBJS) 30 | $$(CC) -o $$@ $$^ $$(LDFLAGS) 31 | ln -s -f $$(BIN) $$(BIN_NAME) 32 | 33 | $$(BDIR)/%.o: $$(SRC_DIR)/%.c 34 | $$(CC) $$(CFLAGS) -c -o $$@ $$< 35 | 36 | include $$(wildcard $$(BDIR)/*.d) 37 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Daniel Bünzli " 3 | authors: ["Daniel Bünzli "] 4 | homepage: "https://erratique.ch/software/carcass" 5 | doc: "https://erratique.ch/software/carcass" 6 | dev-repo: "git+http://erratique.ch/repos/carcass.git" 7 | bug-reports: "https://github.com/dbuenzli/carcass/issues" 8 | tags: [ "dev" "text" "org:erratique" ] 9 | license: "ISC" 10 | depends: [ 11 | "ocaml" {>= "4.05.0"} 12 | "ocamlfind" {build} 13 | "ocamlbuild" {build} 14 | "topkg" {build} 15 | "rresult" 16 | "logs" 17 | "astring" 18 | "uutf" {>= "1.0.0"} 19 | "fmt" 20 | "fpath" 21 | "bos" 22 | "cmdliner" {>= "1.0.0"} 23 | ] 24 | build: 25 | [[ "ocaml" "pkg/pkg.ml" "build" 26 | "--pinned" "%{pinned}%" 27 | "--etc-dir" "%{_:etc}%" ]] 28 | 29 | post-messages: 30 | [ 31 | "Run `carcass setup` to setup your personal information." {success} 32 | ] 33 | -------------------------------------------------------------------------------- /etc/topkg/_README.md: -------------------------------------------------------------------------------- 1 | $(NAME) — $(PKG_SYNOPSIS) 2 | ------------------------------------------------------------------------------- 3 | %%VERSION%% 4 | 5 | $(NAME) is TODO 6 | 7 | $(NAME) is distributed under the $(LICENSE) license. 8 | 9 | Homepage: $(PKG_HOMEPAGE) 10 | 11 | ## Installation 12 | 13 | $(NAME) can be installed with `opam`: 14 | 15 | opam install $(NAME,uncapitalize) 16 | 17 | If you don't use `opam` consult the [`opam`](opam) file for build 18 | instructions. 19 | 20 | ## Documentation 21 | 22 | The documentation and API reference is generated from the source 23 | interfaces. It can be consulted [online][doc] or via `odig doc 24 | $(NAME,uncapitalize)`. 25 | 26 | [doc]: $(PKG_DOC) 27 | 28 | ## Sample programs 29 | 30 | If you installed $(NAME) with `opam` sample programs are located in 31 | the directory `opam var $(NAME,uncapitalize):doc`. 32 | 33 | In the distribution sample programs and tests are located in the 34 | [`test`](test) directory. They can be built and run 35 | with: 36 | 37 | topkg build --tests true && topkg test 38 | -------------------------------------------------------------------------------- /src-bin/carcass_bin.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** [carcass] binary main *) 7 | 8 | (*--------------------------------------------------------------------------- 9 | Copyright (c) 2016 Daniel C. Bünzli 10 | 11 | Permission to use, copy, modify, and/or distribute this software for any 12 | purpose with or without fee is hereby granted, provided that the above 13 | copyright notice and this permission notice appear in all copies. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 16 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 17 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 18 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 19 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 20 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 21 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 22 | ---------------------------------------------------------------------------*) 23 | -------------------------------------------------------------------------------- /src-bin/body.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** The [body] command. *) 7 | 8 | val cmd : int Cmdliner.Term.t * Cmdliner.Term.info 9 | 10 | (*--------------------------------------------------------------------------- 11 | Copyright (c) 2016 Daniel C. Bünzli 12 | 13 | Permission to use, copy, modify, and/or distribute this software for any 14 | purpose with or without fee is hereby granted, provided that the above 15 | copyright notice and this permission notice appear in all copies. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 18 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 19 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 20 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 21 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 22 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 23 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 24 | ---------------------------------------------------------------------------*) 25 | -------------------------------------------------------------------------------- /src-bin/bone.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** The [bone] command. *) 7 | 8 | val cmd : int Cmdliner.Term.t * Cmdliner.Term.info 9 | 10 | (*--------------------------------------------------------------------------- 11 | Copyright (c) 2016 Daniel C. Bünzli 12 | 13 | Permission to use, copy, modify, and/or distribute this software for any 14 | purpose with or without fee is hereby granted, provided that the above 15 | copyright notice and this permission notice appear in all copies. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 18 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 19 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 20 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 21 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 22 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 23 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 24 | ---------------------------------------------------------------------------*) 25 | -------------------------------------------------------------------------------- /src-bin/flesh.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** The [flesh] command. *) 7 | 8 | val cmd : int Cmdliner.Term.t * Cmdliner.Term.info 9 | 10 | (*--------------------------------------------------------------------------- 11 | Copyright (c) 2016 Daniel C. Bünzli 12 | 13 | Permission to use, copy, modify, and/or distribute this software for any 14 | purpose with or without fee is hereby granted, provided that the above 15 | copyright notice and this permission notice appear in all copies. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 18 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 19 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 20 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 21 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 22 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 23 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 24 | ---------------------------------------------------------------------------*) 25 | -------------------------------------------------------------------------------- /src-bin/help.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** The [help] command. *) 7 | 8 | val cmd : int Cmdliner.Term.t * Cmdliner.Term.info 9 | 10 | (*--------------------------------------------------------------------------- 11 | Copyright (c) 2016 Daniel C. Bünzli 12 | 13 | Permission to use, copy, modify, and/or distribute this software for any 14 | purpose with or without fee is hereby granted, provided that the above 15 | copyright notice and this permission notice appear in all copies. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 18 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 19 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 20 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 21 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 22 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 23 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 24 | ---------------------------------------------------------------------------*) 25 | -------------------------------------------------------------------------------- /src-bin/info.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** The [info] command. *) 7 | 8 | val cmd : int Cmdliner.Term.t * Cmdliner.Term.info 9 | 10 | (*--------------------------------------------------------------------------- 11 | Copyright (c) 2016 Daniel C. Bünzli 12 | 13 | Permission to use, copy, modify, and/or distribute this software for any 14 | purpose with or without fee is hereby granted, provided that the above 15 | copyright notice and this permission notice appear in all copies. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 18 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 19 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 20 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 21 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 22 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 23 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 24 | ---------------------------------------------------------------------------*) 25 | -------------------------------------------------------------------------------- /src-bin/match.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** The [match] command. *) 7 | 8 | val cmd : int Cmdliner.Term.t * Cmdliner.Term.info 9 | 10 | (*--------------------------------------------------------------------------- 11 | Copyright (c) 2016 Daniel C. Bünzli 12 | 13 | Permission to use, copy, modify, and/or distribute this software for any 14 | purpose with or without fee is hereby granted, provided that the above 15 | copyright notice and this permission notice appear in all copies. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 18 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 19 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 20 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 21 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 22 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 23 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 24 | ---------------------------------------------------------------------------*) 25 | -------------------------------------------------------------------------------- /src-bin/setup.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** The [setup] command. *) 7 | 8 | val cmd : int Cmdliner.Term.t * Cmdliner.Term.info 9 | 10 | (*--------------------------------------------------------------------------- 11 | Copyright (c) 2016 Daniel C. Bünzli 12 | 13 | Permission to use, copy, modify, and/or distribute this software for any 14 | purpose with or without fee is hereby granted, provided that the above 15 | copyright notice and this permission notice appear in all copies. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 18 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 19 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 20 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 21 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 22 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 23 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 24 | ---------------------------------------------------------------------------*) 25 | -------------------------------------------------------------------------------- /pkg/pkg.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | #use "topfind" 3 | #require "topkg" 4 | open Topkg 5 | 6 | let etc_dir = 7 | let doc = "Use $(docv) as the etc install directory" in 8 | Conf.(key "etc-dir" fpath ~absent:"etc" ~doc) 9 | 10 | let etc_config c = match Conf.build_context c with 11 | | `Dev -> Ok () 12 | | `Pin | `Distrib -> 13 | let etc_dir = Conf.value c etc_dir in 14 | let config = strf "let dir = Fpath.v %S\n" etc_dir in 15 | OS.File.write "src/carcass_etc.ml" config 16 | 17 | let install_etc_distrib_files () = 18 | let chop_etc_dir p = String.with_index_range p ~first:4 in 19 | let mv acc p = (Pkg.etc ~built:false p ~dst:(chop_etc_dir p)) :: acc in 20 | OS.File.fold (fun p acc -> p :: acc) [] ["etc"] 21 | >>= fun files -> Ok (List.fold_left mv [] files) 22 | 23 | let build = Pkg.build ~pre:etc_config () 24 | let distrib = 25 | let files_to_watermark () = 26 | let not_etc f = not (String.is_prefix "etc" f) in 27 | Pkg.files_to_watermark () 28 | >>= fun files -> Ok (List.filter not_etc files) 29 | in 30 | Pkg.distrib ~files_to_watermark () 31 | 32 | let () = 33 | Pkg.describe "carcass" ~build ~distrib @@ fun c -> 34 | install_etc_distrib_files () >>| fun etc_distrib_files -> 35 | [ 36 | Pkg.mllib ~api:["Carcass"] "src/carcass.mllib"; 37 | Pkg.mllib ~api:["Carcass_cli"] "src/carcass_cli.mllib"; 38 | Pkg.bin "src-bin/carcass_bin" ~dst:"carcass"; 39 | ] @ etc_distrib_files 40 | -------------------------------------------------------------------------------- /etc/topkg/pkg.body: -------------------------------------------------------------------------------- 1 | doc 2 | "Package for an OCaml library" 3 | "Package for an OCaml library using ocamlbuild and topkg for distribution." 4 | 5 | var AUTHOR_NAME "your author name" 6 | var AUTHOR_EMAIL "your email" 7 | 8 | var NAME "the package and library name" 9 | var LICENSE "the package's license identifier (SPDX)" 10 | var LICENCE_TERMS "the package's license terms" 11 | 12 | var PKG_SYNOPSIS "the package's one-line synopsis" 13 | var PKG_HOMEPAGE "the package's home page URI" 14 | var PKG_DOC "the package's documentation URI" 15 | var PKG_REPO "the package's repository URI" 16 | var PKG_ISSUES "the package's issue tracker URI" 17 | 18 | var OCP_INDENT_CONFIG "ocp-indent identation configuration" 19 | 20 | bind .gitignore topkg/_gitignore 21 | bind .merlin topkg/_merlin 22 | bind .ocp-indent ocaml/ocp-indent 23 | bind README.md topkg/_README.md 24 | bind CHANGES.md topkg/_CHANGES.md 25 | bind LICENSE.md LICENSE.md 26 | bind _tags topkg/_tags 27 | bind src ocamlbuild/lib.body 28 | bind src/$(NAME,lowercase).mli topkg/_src.mli 29 | bind src/$(NAME,lowercase).ml ocaml/src 30 | bind src/$(NAME,lowercase).mllib ocamlbuild/lib/_lib.mllib 31 | bind test/test.ml ocaml/src 32 | bind doc/api.odocl topkg/_doc.odocl 33 | bind doc/dev.odocl topkg/_doc.odocl 34 | bind pkg/META ocamlfind/pkg 35 | bind pkg/pkg.ml topkg/_pkg.ml 36 | bind opam opam/topkg -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Carcass — Define and generate file and directory carcasses 2 | ------------------------------------------------------------------------------- 3 | %%VERSION%% 4 | 5 | > *carcass* /ˈkɑːkəs/ the structural framework of a building, ship, or piece 6 | > of furniture — [*Oxford Dictionary of English*][def] 7 | 8 | Carcass is a command line tool and OCaml library to define and generate 9 | file and directory structures. 10 | 11 | The primary aim of Carcass is to help programmers to quickly setup new 12 | software projects and deal with source and licensing boilerplate 13 | during program development. Carcass is agnostic to content. 14 | 15 | Carcass is distributed under the ISC license. 16 | 17 | Home page: http://erratique.ch/software/carcass 18 | Contact: Daniel Bünzli `` 19 | 20 | [def]: http://www.oxforddictionaries.com/definition/english/carcass 21 | 22 | ## Installation 23 | 24 | Carcass can be installed with `opam`: 25 | 26 | opam install carcass 27 | 28 | If you don't use `opam` consult the [`opam`](opam) file for build 29 | instructions. 30 | 31 | Once you have installed Carcass setup your personal information by running: 32 | ``` 33 | carcass setup 34 | ``` 35 | 36 | ## Documentation 37 | 38 | Carcass is extensively documented in man pages available through it's help 39 | system. Type: 40 | 41 | ``` 42 | carcass help basics # to get started 43 | carcass help # for more help 44 | ``` 45 | 46 | The library documentation and API reference is automatically generated 47 | by `ocamldoc` from the interfaces. It can be consulted [online][doc] 48 | and there is a generated version in the `doc` directory of the 49 | distribution. 50 | 51 | [doc]: http://erratique.ch/software/carcass/doc 52 | 53 | 54 | 55 | 56 | -------------------------------------------------------------------------------- /etc/flesh.setup: -------------------------------------------------------------------------------- 1 | # Personal contact information and links 2 | 3 | AUTHOR_HOMEPAGE $(CARCASS_SETUP_AUTHOR_HOMEPAGE) 4 | AUTHOR_NAME "$(CARCASS_SETUP_AUTHOR_NAME)" 5 | AUTHOR_EMAIL "$(CARCASS_SETUP_AUTHOR_EMAIL)" 6 | 7 | # Packages 8 | 9 | PKG_HOMEPAGE $(CARCASS_SETUP_PKG_HOMEPAGE_ROOT)/$$(NAME,lowercase) 10 | PKG_DOC $$(AUTHOR_HOMEPAGE)/$$(NAME,lowercase)/doc 11 | PKG_REPO $$(PKG_HOMEPAGE).git 12 | PKG_ISSUES $$(PKG_HOMEPAGE)/issues 13 | 14 | # Dev 15 | 16 | OCP_INDENT_CONFIG # See `ocp-indent --help` 17 | "strict_with=always,match_clause=4,strict_else=never" 18 | 19 | # Copyright and licensing 20 | 21 | COPYRIGHT_AUTHOR "$$(AUTHOR_NAME)" 22 | COPYRIGHT_YEAR "$$(CARCASS_YEAR)" 23 | 24 | LICENSE ISC # If you change this also change LICENSE_TERMS appropriately 25 | LICENSE_TERMS 26 | "\ 27 | Copyright (c) $$(COPYRIGHT_YEAR) $$(COPYRIGHT_AUTHOR) 28 | 29 | Permission to use, copy, modify, and/or distribute this software for any 30 | purpose with or without fee is hereby granted, provided that the above 31 | copyright notice and this permission notice appear in all copies. 32 | 33 | THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 34 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 35 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 36 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 37 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 38 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 39 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE." 40 | 41 | # Source headers and footers 42 | 43 | SRC_HEADER 44 | "\ 45 | Copyright (c) $$(COPYRIGHT_YEAR) $$(COPYRIGHT_AUTHOR). All rights reserved. 46 | Distributed under the $$(LICENSE) license, see terms at the end of the file. 47 | 48 | SRC_FOOTER "$$(LICENSE_TERMS)" -------------------------------------------------------------------------------- /src/carcass_cli.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** {!Cmdliner} support for [Carcass]. 7 | 8 | {e %%VERSION%% - {{:%%PKG_HOMEPAGE%% }homepage}} *) 9 | 10 | (** {1 Command lines for setting up the environment} *) 11 | 12 | val env : ?docs:string -> unit -> (unit -> Carcass.Env.t) Cmdliner.Term.t 13 | (** [env ()] is a {!Cmdliner} term that has all the options to setup a 14 | carcass environment. The closure should be called once {!Logs} has 15 | been setup. The options are documented under the [docs] section 16 | (defaults to the default in {!Cmdliner.Arg.info}). *) 17 | 18 | val env_with_cli_flesh : 19 | ?docs:string -> pos:int -> (unit -> Carcass.Env.t) Cmdliner.Term.t 20 | (** [env_with_cli_flesh ~pos] is like {!env} but also defines flesh as 21 | positional command line arguments starting at [pos]. *) 22 | 23 | (*--------------------------------------------------------------------------- 24 | Copyright (c) 2016 Daniel C. Bünzli 25 | 26 | Permission to use, copy, modify, and/or distribute this software for any 27 | purpose with or without fee is hereby granted, provided that the above 28 | copyright notice and this permission notice appear in all copies. 29 | 30 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 31 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 32 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 33 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 34 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 35 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 36 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 37 | ---------------------------------------------------------------------------*) 38 | -------------------------------------------------------------------------------- /src-bin/carcass_bin.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Cmdliner 7 | 8 | let cmds = 9 | [ Setup.cmd; Flesh.cmd; Bone.cmd; Body.cmd; Info.cmd; Match.cmd; Help.cmd;] 10 | 11 | let main _ = `Help (`Pager, None) 12 | 13 | (* Command line interface *) 14 | 15 | let doc = "define file and directory carcasses" 16 | let man = 17 | [ `S "DESCRIPTION"; 18 | `P "$(mname) defines and generates file and directory structures."; 19 | `P "The primary aim of $(mname) is to help programmers to quickly 20 | setup new software projects and deal with source and licensing 21 | boilerplate during program development. $(mname) is agnostic to 22 | content."; 23 | `P "Use '$(mname) help basics' for understanding the basics."; 24 | `Noblank; 25 | `P "Use '$(mname) help lookup' for help about flesh, bone and \ 26 | body lookups."; 27 | `Noblank; 28 | `P "Use '$(mname) help syntax' for help about the syntax of 29 | carcass files."; 30 | `Noblank; 31 | `P "Use '$(mname) help $(i,COMMAND)' for information about 32 | $(i,COMMAND)."; 33 | ] @ Cli.common_opts_man @ [ 34 | `S "ENVIRONMENT VARIABLES"; 35 | `S "BUGS"; 36 | `P "Report them, see $(i,%%PKG_HOMEPAGE%%) for contact information."; 37 | `S "AUTHOR"; 38 | `P "Daniel C. Buenzli, $(i,http://erratique.ch)"; 39 | `S "SEE ALSO"; 40 | `P "$(mname)-basics(7), $(mname)-lookup(5), $(mname)-syntax(5)"; ] 41 | 42 | let main = 43 | let version = "%%VERSION%%" in 44 | let info = Term.info "carcass" ~version ~doc ~sdocs:Cli.common_opts ~man in 45 | let env = Carcass_cli.env ~docs:Cli.common_opts () in 46 | let t = Term.(ret (const main $ Cli.setup env)) in 47 | (t, info) 48 | 49 | let main () = match Term.eval_choice main cmds with 50 | | `Error _ -> exit 3 51 | | `Ok ret when ret <> 0 -> exit ret 52 | | _ -> if Logs.err_count () > 0 then exit 3 else exit 0 53 | 54 | let () = main () 55 | 56 | (*--------------------------------------------------------------------------- 57 | Copyright (c) 2016 Daniel C. Bünzli 58 | 59 | Permission to use, copy, modify, and/or distribute this software for any 60 | purpose with or without fee is hereby granted, provided that the above 61 | copyright notice and this permission notice appear in all copies. 62 | 63 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 64 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 65 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 66 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 67 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 68 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 69 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 70 | ---------------------------------------------------------------------------*) 71 | -------------------------------------------------------------------------------- /src-bin/bone.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Astring 7 | open Rresult 8 | open Bos 9 | 10 | let bone_raw p = 11 | OS.File.read p 12 | >>= fun c -> OS.File.(write dash c) 13 | >>= fun () -> Ok 0 14 | 15 | let bone_eval env no_prompt p id = 16 | Carcass.Bone.of_path p id 17 | >>= fun b -> Carcass.Flesh.of_env env 18 | >>= fun flesh -> Ok (Cli.define_vars ~ppf:Fmt.stderr ~no_prompt) 19 | >>= fun undef -> Ok (Carcass.Pat.env ~undef flesh) 20 | >>= fun penv -> Carcass.Bone.eval penv b 21 | >>= fun contents -> OS.File.(write dash contents) 22 | >>= fun () -> Ok 0 23 | 24 | let bone env raw loc no_prompt id = 25 | begin match Carcass.Bone.find env id with 26 | | None -> R.error_msgf "bone '%a' undefined" Fpath.pp id 27 | | Some p -> 28 | if loc then Fmt.epr "%a@." Cli.pp_path_loc p; 29 | match raw with 30 | | true -> bone_raw p 31 | | false -> bone_eval env no_prompt p id 32 | end 33 | |> Cli.handle_error 34 | 35 | (* Command line interface *) 36 | 37 | open Cmdliner 38 | 39 | let doc = "output a bone (single file)" 40 | let man = 41 | [ `S "DESCRIPTION"; 42 | `P "The $(tname) command evaluates and writes the bone identified by 43 | $(i,BONE_ID) on standard output."; 44 | `P "See $(mname)-lookup(5) for more information on the bone lookup 45 | procedure."; 46 | `S "EXAMPLES"; 47 | `P "Output an empty C file with your copyright information:"; 48 | `Pre " > carcass bone c/src"; 49 | `P "Same as the previous example but override the 50 | COPYRIGHT_YEAR variable:"; 51 | `Pre " > carcass bone c/src copyright_year 2015-2016"; 52 | `P "Output the raw definition and location (on standard error) of the 53 | c/src bone:"; 54 | `Pre " > carcass bone -r -l c/src"; 55 | ] @ Cli.common_man @ Cli.see_also_main_lookup_man 56 | 57 | let cmd = 58 | let info = Term.info "bone" ~sdocs:Cli.common_opts ~doc ~man in 59 | let env = Carcass_cli.env_with_cli_flesh ~docs:Cli.common_opts ~pos:1 in 60 | let t = Term.(pure bone $ Cli.setup env $ Cli.raw $ Cli.loc ~kind:"bone" $ 61 | Cli.no_prompt $ Cli.bone_id ~pos:0) 62 | in 63 | (t, info) 64 | 65 | (*--------------------------------------------------------------------------- 66 | Copyright (c) 2016 Daniel C. Bünzli 67 | 68 | Permission to use, copy, modify, and/or distribute this software for any 69 | purpose with or without fee is hereby granted, provided that the above 70 | copyright notice and this permission notice appear in all copies. 71 | 72 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 73 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 74 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 75 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 76 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 77 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 78 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 79 | ---------------------------------------------------------------------------*) 80 | -------------------------------------------------------------------------------- /doc/style.css: -------------------------------------------------------------------------------- 1 | /* A style for ocamldoc. Daniel C. Buenzli */ 2 | 3 | /* Reset a few things. */ 4 | html,body,div,span,applet,object,iframe,h1,h2,h3,h4,h5,h6,p,blockquote,pre, 5 | a,abbr,acronym,address,big,cite,code,del,dfn,em,font,img,ins,kbd,q,s,samp, 6 | small,strike,strong,sub,sup,tt,var,b,u,i,center,dl,dt,dd,ol,ul,li,fieldset, 7 | form,label,legend,table,caption,tbody,tfoot,thead,tr,th,td 8 | { margin: 0; padding: 0; border: 0 none; outline: 0; font-size: 100%; 9 | font-weight: inherit; font-style:inherit; font-family:inherit; 10 | line-height: inherit; vertical-align: baseline; text-align:inherit; 11 | color:inherit; background: transparent; } 12 | 13 | table { border-collapse: collapse; border-spacing: 0; } 14 | 15 | /* Basic page layout */ 16 | 17 | body { font: normal 10pt/1.375em helvetica, arial, sans-serif; text-align:left; 18 | margin: 1.375em 10%; min-width: 40ex; max-width: 72ex; 19 | color: black; background: transparent /* url(line-height-22.gif) */; } 20 | 21 | b { font-weight: bold } 22 | em { font-style: italic } 23 | 24 | tt, code, pre { font-family: WorkAroundWebKitAndMozilla, monospace; 25 | font-size: 1em; } 26 | pre code { font-size : inherit; } 27 | .codepre { margin-bottom:1.375em /* after code example we introduce space. */ } 28 | 29 | .superscript,.subscript 30 | { font-size : 0.813em; line-height:0; margin-left:0.4ex;} 31 | .superscript { vertical-align: super; } 32 | .subscript { vertical-align: sub; } 33 | 34 | /* ocamldoc markup workaround hacks */ 35 | 36 | 37 | 38 | hr, hr + br, div + br, center + br, span + br, ul + br, ol + br, pre + br 39 | { display: none } /* annoying */ 40 | 41 | div.info + br { display:block} 42 | 43 | .codepre br + br { display: none } 44 | h1 + pre { margin-bottom:1.375em} /* Toplevel module description */ 45 | 46 | /* Sections and document divisions */ 47 | 48 | /* .navbar { margin-bottom: -1.375em } */ 49 | h1 { font-weight: bold; font-size: 1.5em; /* margin-top:1.833em; */ 50 | margin-top:0.917em; padding-top:0.875em; 51 | border-top-style:solid; border-width:1px; border-color:#AAA; } 52 | h2 { font-weight: bold; font-size: 1.313em; margin-top: 1.048em } 53 | h3 { font-weight: bold; font-size: 1.125em; margin-top: 1.222em } 54 | h3 { font-weight: bold; font-size: 1em; margin-top: 1.375em} 55 | h4 { font-style: italic; } 56 | 57 | /* Used by OCaml's own library documentation. */ 58 | h6 { font-weight: bold; font-size: 1.125em; margin-top: 1.222em } 59 | .h7 { font-weight: bold; font-size: 1em; margin-top: 1.375em } 60 | 61 | p { margin-top: 1.375em } 62 | pre { margin-top: 1.375em } 63 | .info { margin: 0.458em 0em -0.458em 2em;}/* Description of types values etc. */ 64 | td .info { margin:0; padding:0; margin-left: 2em;} /* Description in indexes */ 65 | 66 | ul, ol { margin-top:0.688em; padding-bottom:0.687em; 67 | list-style-position:outside} 68 | ul + p, ol + p { margin-top: 0em } 69 | ul { list-style-type: square } 70 | 71 | 72 | /* h2 + ul, h3 + ul, p + ul { } */ 73 | ul > li { margin-left: 1.375em; } 74 | ol > li { margin-left: 1.7em; } 75 | /* Links */ 76 | 77 | a, a:link, a:visited, a:active, a:hover { color : #00B; text-decoration: none } 78 | a:hover { text-decoration : underline } 79 | *:target {background-color: #FFFF99;} /* anchor highlight */ 80 | 81 | /* Code */ 82 | 83 | .keyword { font-weight: bold; } 84 | .comment { color : red } 85 | .constructor { color : green } 86 | .string { color : brown } 87 | .warning { color : red ; font-weight : bold } 88 | 89 | /* Functors */ 90 | 91 | .paramstable { border-style : hidden ; padding-bottom:1.375em} 92 | .paramstable code { margin-left: 1ex; margin-right: 1ex } 93 | .sig_block {margin-left: 1em} 94 | 95 | /* Images */ 96 | 97 | img { margin-top: 1.375em } 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | -------------------------------------------------------------------------------- /src/carcass_cli.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Cmdliner 7 | open Astring 8 | open Rresult 9 | 10 | let pp_var_id = Fmt.(quote ~mark:"'" string) 11 | 12 | (* Argument converters *) 13 | 14 | let path_arg = 15 | let parse s = match Fpath.of_string s with 16 | | Error (`Msg m) -> `Error m 17 | | Ok p -> `Ok p 18 | in 19 | parse, Fpath.pp 20 | 21 | let rec parse_cli_flesh acc = function 22 | | id :: def :: defs -> 23 | let src = Carcass.Loc.Cli in 24 | begin match Carcass.Pat.of_input ~flesh:true ~src (`String def) with 25 | | Ok pat -> parse_cli_flesh ((id, pat) :: acc) defs 26 | | Error (`Carcass_parse (e, _)) -> 27 | `Error (true, 28 | strf "@[definition of %a:@,@[%a@]@]" 29 | pp_var_id id Carcass.Error.pp_parse_err e) 30 | end 31 | | [] -> 32 | `Ok (List.rev acc) 33 | | id :: [] -> 34 | `Error (true, strf "last variable %a has no definition" pp_var_id id) 35 | 36 | (* Command lines *) 37 | 38 | let _env ?docs cli = 39 | let no_user_dir = 40 | let doc = "Do not add ~/.carcass to the carcass search path. It 41 | may still be added by the .carcass directory hierarchy lookup, 42 | use the $(b,--no-dot-dirs) option to prevent that." 43 | in 44 | Arg.(value & flag & info ["no-user-dir"] ~doc ?docs) 45 | in 46 | let no_dot_dirs = 47 | let doc = "Do not add .carcass directories found in current working 48 | directory and up to the root directory to the carcass search 49 | path. The user directory is still added, use the 50 | $(b,--no-user-dir) option to prevent that." 51 | in 52 | Arg.(value & flag & info ["no-dot-dirs"] ~doc ?docs) 53 | in 54 | let dirs = 55 | let doc = "Add $(docv) to the carcass search path."in 56 | let dirs = [] in 57 | Arg.(value & opt_all path_arg dirs & info ["C"; "carcass" ] ~doc 58 | ~docv:"DIR" ?docs) 59 | in 60 | let flesh = 61 | let doc = "Add flesh file $(docv) to flesh lookup." in 62 | let flesh_files = [] in 63 | Arg.(value & opt_all path_arg flesh_files & info ["F"; "flesh"] ~doc 64 | ~docv:"FILE" ?docs) 65 | in 66 | let env no_user_dir no_dot_dirs dirs flesh cli = match cli with 67 | | `Ok cli -> 68 | `Ok (fun () -> Carcass.Env.v ~no_user_dir ~no_dot_dirs ~dirs ~flesh ~cli) 69 | | `Error _ as e -> e 70 | in 71 | Term.(ret (pure env $ no_user_dir $ no_dot_dirs $ dirs $ flesh $ cli)) 72 | 73 | let env ?docs () = _env ?docs (Term.pure (`Ok [])) 74 | 75 | let env_with_cli_flesh ?docs ~pos:p = 76 | let flesh = 77 | let doc = "Bind flesh variable $(i,ID) to definition $(i,DEF). 78 | These optional variable bindings override variable definitions 79 | found in flesh files." 80 | in 81 | Arg.(value & pos_right (p - 1) string [] & info [] ~doc ~docv:"ID DEF") 82 | in 83 | _env ?docs Term.(pure (parse_cli_flesh []) $ flesh) 84 | 85 | (*--------------------------------------------------------------------------- 86 | Copyright (c) 2016 Daniel C. Bünzli 87 | 88 | Permission to use, copy, modify, and/or distribute this software for any 89 | purpose with or without fee is hereby granted, provided that the above 90 | copyright notice and this permission notice appear in all copies. 91 | 92 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 93 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 94 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 95 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 96 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 97 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 98 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 99 | ---------------------------------------------------------------------------*) 100 | -------------------------------------------------------------------------------- /src-bin/body.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Astring 7 | open Rresult 8 | open Bos 9 | 10 | let overwrite ~no_prompt ~force = match force with 11 | | true -> fun _ -> true 12 | | false -> 13 | match no_prompt || not Unix.(isatty stdin) with 14 | | true -> fun p -> Cli.log_path `Skip p; false 15 | | false -> 16 | fun p -> 17 | if Cli.user_wants_overwrite p then true else 18 | (Cli.log_path `Skip p; false) 19 | 20 | let body_raw p = 21 | OS.File.read p 22 | >>= fun bytes -> OS.File.(write dash bytes) 23 | >>= fun () -> Ok 0 24 | 25 | let body_write env no_prompt dry_run force p id root = 26 | Carcass.Body.of_path p id 27 | >>= fun body -> Carcass.Flesh.of_env env 28 | >>= fun flesh -> Ok (Carcass.Body.var_docs body) 29 | >>= fun var_docs -> Ok (Cli.define_vars ~var_docs ~no_prompt) 30 | >>= fun undef -> Ok (Carcass.Pat.env ~undef flesh) 31 | >>= fun penv -> Carcass.Body.eval_paths env penv body 32 | >>= fun m -> Carcass.Body.eval_bones env penv m 33 | >>= fun m -> match dry_run with 34 | | true -> 35 | (* We could do this after eval_paths, but that way we report errors *) 36 | Fpath.Map.iter (fun p _ -> Cli.log_path `Write Fpath.(root // p)) m; 37 | Ok 0 38 | | false -> 39 | let over = overwrite ~no_prompt ~force in 40 | Carcass.Body.write ~wrote:(Cli.log_path `Wrote) ~over ~dst:root m 41 | >>= fun () -> Ok 0 42 | 43 | let body env raw loc no_prompt dry_run force id root = 44 | begin match Carcass.Body.find env id with 45 | | None -> R.error_msgf "body '%a' undefined" Fpath.pp id 46 | | Some p -> 47 | if loc then Fmt.epr "%a@." Cli.pp_path_loc p; 48 | match raw with 49 | | true -> body_raw p 50 | | false -> 51 | match root with 52 | | None -> R.error_msgf "no destination directory specified" 53 | | Some root -> body_write env no_prompt dry_run force p id root 54 | end 55 | |> Cli.handle_error 56 | 57 | (* Command line interface *) 58 | 59 | open Cmdliner 60 | 61 | let root = 62 | let doc = "Root destination directory of the body. Mandatory, can only be 63 | ommited in raw mode (see $(b,--raw))." 64 | in 65 | Arg.(value & pos 1 (some Cli.path_arg) None & info [] ~doc ~docv:"DEST") 66 | 67 | let doc = "output a body (file hierarchy)" 68 | let man = 69 | [ `S "DESCRIPTION"; 70 | `P "The $(tname) command evaluates and write the file hierarchy 71 | of the body identified by $(i,BODY_ID) relative to the root 72 | directory $(i,DEST)."; 73 | `P "See carcass-lookup(5) for more information on the body lookup 74 | procedure."; 75 | `S "EXAMPLES"; 76 | `P "In the current directory, create a C compilation unit u with 77 | your copyright information:"; 78 | `Pre " > carcass body c/unit . name u"; 79 | `P "Same as the previous example but the NAME variable, corresponding 80 | to the name of the compilation unit, will be asked interactively:"; 81 | `Pre " > carcass body c/unit ."; 82 | `P "Output the raw definition and location (on standard error) of the 83 | c/unit body:"; 84 | `Pre " > carcass body -r -l c/unit"; 85 | ] @ Cli.common_man @ Cli.see_also_main_lookup_man 86 | 87 | let cmd = 88 | let info = Term.info "body" ~sdocs:Cli.common_opts ~doc ~man in 89 | let env = Carcass_cli.env_with_cli_flesh ~docs:Cli.common_opts ~pos:2 in 90 | let t = Term.(pure body $ Cli.setup env $ Cli.raw $ Cli.loc ~kind:"body" $ 91 | Cli.no_prompt $ Cli.dry_run $ Cli.force $ Cli.body_id ~pos:0 $ 92 | root) 93 | in 94 | (t, info) 95 | 96 | (*--------------------------------------------------------------------------- 97 | Copyright (c) 2016 Daniel C. Bünzli 98 | 99 | Permission to use, copy, modify, and/or distribute this software for any 100 | purpose with or without fee is hereby granted, provided that the above 101 | copyright notice and this permission notice appear in all copies. 102 | 103 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 104 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 105 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 106 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 107 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 108 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 109 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 110 | ---------------------------------------------------------------------------*) 111 | -------------------------------------------------------------------------------- /src-bin/cli.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** {!Cmdliner} and common definitions for commands. *) 7 | 8 | open Rresult 9 | open Astring 10 | open Cmdliner 11 | 12 | (** {1 Formatters} *) 13 | 14 | val pp_loc : cond:bool -> Carcass.Loc.t Fmt.t 15 | (** [pp_loc cond] is {!Fmt.nop} if [cond] is [false] and 16 | {!Carcass.Loc.pp} followed by a space otherwise. *) 17 | 18 | val pp_path_loc : Fpath.t Fmt.t 19 | (** [pp_path_loc] formats a location to the start position of 20 | the path using {!Carcass.Loc.pp}. *) 21 | 22 | (** {1 Manual section for common options} *) 23 | 24 | val common_opts : string 25 | (** [common_opts] is the manual section were common options are 26 | documented. *) 27 | 28 | val common_opts_man : Cmdliner.Manpage.block list 29 | (** [common_opts_man] is the manual section for common options. *) 30 | 31 | val common_man : Cmdliner.Manpage.block list 32 | (** [common_man] is a manual fragment common to many commands. *) 33 | 34 | val see_also_main_man : Cmdliner.Manpage.block list 35 | (** [see_also_main_man] is a "see also" manpage fragment. *) 36 | 37 | val see_also_main_lookup_man : Cmdliner.Manpage.block list 38 | (** [see_also_main_lookup_man] is a "see also" manpage fragment. *) 39 | 40 | (** {1 Converters and arguments} *) 41 | 42 | val path_arg : Fpath.t Arg.converter 43 | (** [path_arg] is a path argument converter. *) 44 | 45 | val loc : kind:string -> bool Term.t 46 | (** A [--loc] option to report locations for elements of kind [kind]. *) 47 | 48 | val raw : bool Term.t 49 | (** A [--raw] option to require raw output. *) 50 | 51 | val no_prompt : bool Term.t 52 | (** A [--no-prompt] option to disable human interaction if 53 | [stdin] is a tty. *) 54 | 55 | val dry_run : bool Term.t 56 | (** A [--dry-run] option to report written files without writting them. *) 57 | 58 | val force : bool Term.t 59 | (** A [--force] option to disable human interaction on file overwrites. *) 60 | 61 | val bone_id : pos:int -> Fpath.t Term.t 62 | (** A bone identifier positional argument at position [pos]. *) 63 | 64 | val body_id : pos:int -> Fpath.t Term.t 65 | (** A body identifier positional argument at position [pos]. *) 66 | 67 | (** {1 User interaction} *) 68 | 69 | val define_vars : 70 | ?ppf:Format.formatter -> 71 | ?var_docs:string String.Map.t -> no_prompt:bool -> 72 | (string -> (Carcass.Pat.t, Carcass.Error.parse) result option) 73 | (** [define_vars ~var_docs ~no_prompt] is a function [f] that given a 74 | variable name asks the user on [ppf] to define a value for it by 75 | reading from standard input; but only if [stdin] is a tty and 76 | [no_prompt] is [false]. If [var_docs] contains a binding for the 77 | asked variable name it is used to document the questions, defaults 78 | to {!String.Map.empty}. *) 79 | 80 | val user_wants_overwrite : Fpath.t -> bool 81 | (** [user_wants_overwrite p] asks if [p] should be overwritten, 82 | and returns the answer. *) 83 | 84 | (** {1 Basic setup for every command} *) 85 | 86 | val setup : (unit -> Carcass.Env.t) Term.t -> Carcass.Env.t Term.t 87 | (** [setup env] defines a basic setup common to all commands. This 88 | includes, by side effect, setting log verbosity for {!Logs}, 89 | ajusting colored output and finally calling [env] to create 90 | a carcass environment. *) 91 | 92 | (** {1 Logging and error handling} *) 93 | 94 | val log_path : [`Write | `Wrote | `Skip ] -> Fpath.t -> unit 95 | (** [log_path action p] logs action [a] for path. *) 96 | 97 | val log_on_error : 98 | ?level:Logs.level -> 99 | use:(unit -> 'a) -> 100 | ('a, [< `Msg of string | Carcass.Error.parse | Carcass.Error.eval]) result -> 101 | 'a 102 | (** [log_on_error] is like {!Logs.on_error}. *) 103 | 104 | val handle_error : 105 | (int, [< `Msg of string | Carcass.Error.parse | Carcass.Error.eval]) result -> 106 | int 107 | (** [handle_error r] is [r]'s result or logs [r]'s error and returns 3. *) 108 | 109 | (*--------------------------------------------------------------------------- 110 | Copyright (c) 2016 Daniel C. Bünzli 111 | 112 | Permission to use, copy, modify, and/or distribute this software for any 113 | purpose with or without fee is hereby granted, provided that the above 114 | copyright notice and this permission notice appear in all copies. 115 | 116 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 117 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 118 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 119 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 120 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 121 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 122 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 123 | ---------------------------------------------------------------------------*) 124 | -------------------------------------------------------------------------------- /src-bin/match.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Astring 7 | open Rresult 8 | open Bos 9 | 10 | let pp_cst_flesh ppf map = 11 | let pp_binding ppf (var, value) = 12 | let def = Carcass.([Pat.Lit value, Loc.nil], Loc.nil) in 13 | Fmt.pf ppf "%s %a" var Carcass.Flesh.pp_def def 14 | in 15 | Fmt.pf ppf "@[%a@]" (String.Map.pp pp_binding) map 16 | 17 | let match_bone env no_trim all_vars file bone_id = 18 | let trim = not no_trim in 19 | begin match Carcass.Bone.find env bone_id with 20 | | None -> R.error_msgf "bone '%a' undefined" Fpath.pp bone_id 21 | | Some path -> 22 | Carcass.Bone.of_path ~trim path bone_id >>= fun b -> 23 | match Carcass.Bone.content b with 24 | | Carcass.Bone.Binary _ -> 25 | R.error_msgf "bone '%a' is a binary bone" Fpath.pp bone_id 26 | | Carcass.Bone.Pat pat -> 27 | OS.File.read file >>= fun data -> 28 | let data = if trim then String.trim data else data in 29 | match Carcass.Pat.query pat data with 30 | | None -> Ok 1 (* no match *) 31 | | Some map -> 32 | let map = 33 | let is_match_var v _ = String.is_prefix "CARCASS_MATCH_" v in 34 | if all_vars then map else String.Map.filter is_match_var map 35 | in 36 | if String.Map.is_empty map then Ok 0 else 37 | (Fmt.pr "%a@." pp_cst_flesh map; Ok 0) 38 | end 39 | |> Cli.handle_error 40 | 41 | (* Command line interface *) 42 | 43 | open Cmdliner 44 | 45 | let no_trim = 46 | let doc = "Do not trim leading and trailing white space in matched file 47 | and bone." 48 | in 49 | Arg.(value & flag & info ["no-trim"] ~doc) 50 | 51 | let all_vars = 52 | let doc = "Output all matched variables, not only those that are prefixed 53 | by 'CARCASS_MATCH_'." 54 | in 55 | Arg.(value & flag & info ["a"; "all"] ~doc) 56 | 57 | let file = 58 | let doc = "The file to match against. Use '-' for standard input." in 59 | Arg.(required & pos 0 (some Cli.path_arg) None & info [] ~doc ~docv:"FILE") 60 | 61 | let doc = "match a file against a bone" 62 | let man = 63 | [ `S "DESCRIPTION"; 64 | `P "The $(tname) command matches $(i,FILE) against the structure 65 | of the bone identified by $(i,BONE_ID)."; 66 | `P "If the file matches, bone variables that start with 'CARCASS_MATCH_' 67 | are written in flesh syntax with their matched value on standard 68 | output; use the option $(b,--all) to output all bone variables. 69 | If it doesn't match, nothing is written and the tool exits with 1."; 70 | `P "Variables greedily match from zero to more characters of the 71 | file, this is .* in regexp speak."; 72 | `P "By default leading and trailing white space is trimmed both in the 73 | file and in the bone to avoid mismatches due to editors adding 74 | white space at the end of files. This can be disabled with the 75 | $(b,--no-trim) option."; 76 | `S "EXAMPLES"; 77 | `P "Add your source header and footer to a C file:"; 78 | `Pre " > carcass match myfile.c content | carcass bone c/src -F - "; 79 | `P "Update the source header and footer of a C file that matches the 80 | structure of the bone 'c/src':"; 81 | `Pre " > carcass match myfile.c c/src | carcass bone c/src -F - "; 82 | `P "Same as previous example but also override the COPYRIGHT_YEAR 83 | variable:"; 84 | `Pre " > carcass match myfile.c c/src | \\\\ 85 | carcass bone c/src -F - copyright_year 2010-2016"; 86 | ] @ Cli.common_man @ [ 87 | `S "EXIT STATUS"; 88 | `P "The $(tname) command exits with one of the following values:"; 89 | `I ("0", "the file matched the bone."); 90 | `I ("1", "the file did not match the bone."); 91 | `I (">1", "an error occured."); 92 | ] @ Cli.see_also_main_lookup_man 93 | 94 | let cmd = 95 | let info = Term.info "match" ~sdocs:Cli.common_opts ~doc ~man in 96 | let env = Carcass_cli.env ~docs:Cli.common_opts () in 97 | let t = Term.(pure match_bone $ Cli.setup env $ no_trim $ all_vars $ 98 | file $ Cli.bone_id ~pos:1) 99 | in 100 | (t, info) 101 | 102 | (*--------------------------------------------------------------------------- 103 | Copyright (c) 2016 Daniel C. Bünzli 104 | 105 | Permission to use, copy, modify, and/or distribute this software for any 106 | purpose with or without fee is hereby granted, provided that the above 107 | copyright notice and this permission notice appear in all copies. 108 | 109 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 110 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 111 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 112 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 113 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 114 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 115 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 116 | ---------------------------------------------------------------------------*) 117 | -------------------------------------------------------------------------------- /src-bin/cli.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Rresult 7 | open Astring 8 | open Cmdliner 9 | 10 | (* Formatters *) 11 | 12 | let pp_loc ~cond = 13 | if not cond then Fmt.nop else 14 | (fun ppf l -> Fmt.pf ppf "%a " Carcass.Loc.pp l) 15 | 16 | let pp_path_loc ppf p = 17 | Fmt.pf ppf "%a" Carcass.Loc.pp (Carcass.Loc.for_path p) 18 | 19 | (* Manual *) 20 | 21 | let common_opts = "COMMON OPTIONS" 22 | 23 | let common_opts_man = 24 | [ `S common_opts; `P "These options are common to all commands." ] 25 | 26 | let common_man = 27 | [ `S "ARGUMENTS"; 28 | `S "OPTIONS"; 29 | ] @ common_opts_man @ [ 30 | `S "ENVIRONMENT VARIABLES"; ] 31 | 32 | let see_also_main_man = 33 | [ `S "SEE ALSO"; 34 | `P "carcass(1)" ] 35 | 36 | let see_also_main_lookup_man = 37 | [ `S "SEE ALSO"; 38 | `P "carcass(1), carcass-lookup(5)" ] 39 | 40 | (* Converters and arguments *) 41 | 42 | let path_arg = 43 | let parse s = match Fpath.of_string s with 44 | | Error _ -> `Error (strf "%a: not a path" String.dump s) 45 | | Ok s -> `Ok s 46 | in 47 | parse, Fpath.pp 48 | 49 | let loc ~kind = 50 | let doc = strf "Output the %s's location on standard error." kind in 51 | Arg.(value & flag & info ["l"; "loc"] ~doc) 52 | 53 | let raw = 54 | let doc = "Output raw definition, without variable evaluation." in 55 | Arg.(value & flag & info ["r"; "raw"] ~doc) 56 | 57 | let no_prompt = 58 | let doc = "Do not prompt user for information if stdin is a tty, use 59 | default answer or, lacking a default, fail instead." 60 | in 61 | Arg.(value & flag & info ["n"; "no-prompt"] ~doc) 62 | 63 | let dry_run = 64 | let doc = "Do not write files, only report paths that would be written." in 65 | Arg.(value & flag & info ["dry-run"] ~doc) 66 | 67 | let force = 68 | let doc = "Do not prompt before overwriting files." in 69 | Arg.(value & flag & info [ "force" ] ~doc) 70 | 71 | let id kind ~docv ~pos:p = 72 | let doc = 73 | strf "The %s identifier. If $(docv) is absolute or starts with ./ \ 74 | the corresponding file path is read as the %s. If it is '-' 75 | the %s is read on standard input. Otherwise it is looked up 76 | in carcass directories." kind kind kind 77 | in 78 | Arg.(required & pos p (some path_arg) None & info [] ~doc ~docv) 79 | 80 | let bone_id = id "bone" ~docv:"BONE_ID" 81 | let body_id = id "body" ~docv:"BODY_ID" 82 | 83 | (* User interaction *) 84 | 85 | let define_vars ?ppf ?(var_docs = String.Map.empty) ~no_prompt = 86 | if no_prompt || not (Unix.(isatty stdin)) then (fun _ -> None) else 87 | fun v -> 88 | Some begin match String.Map.find v var_docs with 89 | | None -> Carcass.Ask.pattern ?ppf "Enter value for %s: " v 90 | | Some d -> Carcass.Ask.pattern ?ppf "Enter value for %s (%s): " d v 91 | end 92 | 93 | let user_wants_overwrite p = 94 | Carcass.Ask.bool ~default:false "File %a exists, overwrite ?" Fpath.pp p 95 | 96 | (* Basic setup for every command *) 97 | 98 | let setup env style_renderer log_level = 99 | Fmt_tty.setup_std_outputs ?style_renderer (); 100 | Logs.set_level log_level; 101 | Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ()); 102 | env () 103 | 104 | let setup env = 105 | let style_renderer = 106 | let env = Arg.env_var "CARCASS_COLOR" in 107 | Fmt_cli.style_renderer ~docs:common_opts ~env () 108 | in 109 | let log_level = 110 | let env = Arg.env_var "CARCASS_VERBOSITY" in 111 | Logs_cli.level ~docs:common_opts ~env () 112 | in 113 | Term.(const setup $ env $ style_renderer $ log_level) 114 | 115 | (* Logging and error handling *) 116 | 117 | let log_path = 118 | let act = function `Write -> "WRITE" | `Wrote -> "WROTE" | `Skip -> "SKIP" in 119 | fun a p -> Logs.app (fun m -> m ~header:(act a) "%a" Fpath.pp p) 120 | 121 | let log_on_error ?(level = Logs.Error) ~use = function 122 | | Ok v -> v 123 | | Error e -> 124 | begin match e with 125 | | `Msg e -> 126 | Logs.msg level (fun m -> m "%a" Fmt.text e) 127 | | `Carcass_parse _ as e -> 128 | Logs.msg level (fun m -> m "%a" Carcass.Error.pp_parse e) 129 | | `Carcass_eval _ as e -> 130 | Logs.msg level (fun m -> m "%a" Carcass.Error.pp_eval e) 131 | end; 132 | use () 133 | 134 | let handle_error = log_on_error ~level:Logs.Error ~use:(fun _ -> 3) 135 | 136 | (*--------------------------------------------------------------------------- 137 | Copyright (c) 2016 Daniel C. Bünzli 138 | 139 | Permission to use, copy, modify, and/or distribute this software for any 140 | purpose with or without fee is hereby granted, provided that the above 141 | copyright notice and this permission notice appear in all copies. 142 | 143 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 144 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 145 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 146 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 147 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 148 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 149 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 150 | ---------------------------------------------------------------------------*) 151 | -------------------------------------------------------------------------------- /src-bin/flesh.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Astring 7 | open Rresult 8 | 9 | (* Single variable output *) 10 | 11 | let err_undef var = R.error_msgf "variable '%a' undefined" String.pp var 12 | 13 | let var_raw loc flesh var = match String.Map.find var flesh with 14 | | None -> err_undef var 15 | | Some (_, l as pat) -> 16 | if loc then Fmt.epr "%a@." Carcass.Loc.pp l; 17 | Fmt.pr "%a@." Carcass.Flesh.pp_def pat; 18 | Ok 0 19 | 20 | let var_eval loc flesh var = 21 | let env = Carcass.Pat.env flesh in 22 | match Carcass.Pat.env_var_value env var with 23 | | None -> err_undef var 24 | | Some ret -> 25 | ret >>= fun (value, l) -> 26 | if loc then Fmt.epr "%a@." Carcass.Loc.pp l; 27 | Fmt.pr "%s@." value; 28 | Ok 0 29 | 30 | let flesh_var raw loc flesh var = match raw with 31 | | true -> var_raw loc flesh var 32 | | false -> var_eval loc flesh var 33 | 34 | (* Multiple variable output (in flesh syntax) *) 35 | 36 | let pp_binding loc ppf (var, (_, l as def)) = 37 | Fmt.pf ppf "%a%s %a@," (Cli.pp_loc ~cond:loc) l var Carcass.Flesh.pp_def def 38 | 39 | let eval_pp_binding loc env ppf (var, _) = 40 | match Carcass.Pat.env_var_value env var with 41 | | None -> assert false 42 | | Some res -> 43 | begin 44 | res >>| fun (value, l) -> 45 | pp_binding loc ppf (var, Carcass.Pat.([Lit value, l], l)) 46 | end 47 | |> Cli.log_on_error ~use:(fun _ -> ()) 48 | 49 | let vars_raw loc flesh prefix = 50 | let vars = String.Map.filter (fun v _ -> String.is_prefix prefix v) flesh in 51 | if not (String.Map.is_empty vars) 52 | then Fmt.pr "@[%a@]@." (String.Map.pp ~sep:Fmt.nop (pp_binding loc)) vars; 53 | Ok 0 54 | 55 | let vars_eval loc flesh prefix = 56 | let env = Carcass.Pat.env flesh in 57 | let vars = String.Map.filter (fun v _ -> String.is_prefix prefix v) flesh in 58 | if not (String.Map.is_empty vars) 59 | then Fmt.pr "@[%a@]@." 60 | (String.Map.pp ~sep:Fmt.nop (eval_pp_binding loc env)) vars; 61 | Ok 0 62 | 63 | let flesh_vars raw loc flesh prefix = match raw with 64 | | true -> vars_raw loc flesh prefix 65 | | false -> vars_eval loc flesh prefix 66 | 67 | (* Flesh command *) 68 | 69 | let flesh env raw loc prefix var = 70 | begin 71 | let var = String.Ascii.uppercase var in 72 | Carcass.Flesh.of_env env 73 | >>= fun flesh -> match prefix with 74 | | false -> flesh_var raw loc flesh var 75 | | true -> flesh_vars raw loc flesh var 76 | end 77 | |> Cli.handle_error 78 | 79 | (* Command line interface *) 80 | 81 | open Cmdliner 82 | 83 | let loc = 84 | let doc = "Output the variable's location on standard error or, in prefix 85 | mode (see $(b,--prefix)), before the variable's definition." 86 | in 87 | Arg.(value & flag & info ["l"; "loc"] ~doc) 88 | 89 | let var = 90 | let doc = "The variable to lookup." in 91 | Arg.(required & pos 0 (some string) None & info [] ~doc ~docv:"VAR") 92 | 93 | let prefix = 94 | let doc = "Treat $(i,VAR) as a prefix and output in flesh syntax the 95 | information for all variables that match the prefix." 96 | in 97 | Arg.(value & flag & info ["p"; "prefix"] ~doc) 98 | 99 | let doc = "output a flesh variable value" 100 | let man = 101 | [ `S "DESCRIPTION"; 102 | `P "The $(b,flesh) command evaluates and writes the value of variable 103 | $(i,VAR) on standard output."; 104 | `P "See $(mname)-lookup(5) for more information on the variable 105 | lookup procedure."; 106 | `S "EXAMPLES"; 107 | `P "Output the value of the AUTHOR_EMAIL variable:"; 108 | `Pre " > carcass flesh author_email"; 109 | `P "Output the value of the COPYRIGHT_YEAR variable in an environment 110 | where the CARCASS_YEAR variable is set to 1999:"; 111 | `Pre " > carcass flesh copyright_year carcass_year 1999"; 112 | `P "Output the raw definition of the COPYRIGHT_YEAR variable and 113 | its location on standard error:"; 114 | `Pre " > carcass flesh -r -l copyright_year"; 115 | `P "Output the values of variables that start with LICENSE in flesh 116 | syntax:"; 117 | `Pre " > carcass flesh -p LICENSE"; 118 | `P "Output all variable definitions (the empty string 119 | is the prefix of any variable) in flesh syntax with their location:"; 120 | `Pre " > carcass flesh -r -l -p \"\""; 121 | ] @ Cli.common_man @ Cli.see_also_main_lookup_man 122 | 123 | let cmd = 124 | let info = Term.info "flesh" ~sdocs:Cli.common_opts ~doc ~man in 125 | let env = Carcass_cli.env_with_cli_flesh ~docs:Cli.common_opts ~pos:1 in 126 | let t = Term.(pure flesh $ Cli.setup env $ Cli.raw $ loc $ prefix $ var) in 127 | (t, info) 128 | 129 | (*--------------------------------------------------------------------------- 130 | Copyright (c) 2016 Daniel C. Bünzli 131 | 132 | Permission to use, copy, modify, and/or distribute this software for any 133 | purpose with or without fee is hereby granted, provided that the above 134 | copyright notice and this permission notice appear in all copies. 135 | 136 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 137 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 138 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 139 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 140 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 141 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 142 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 143 | ---------------------------------------------------------------------------*) 144 | -------------------------------------------------------------------------------- /src-bin/info.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Astring 7 | open Rresult 8 | 9 | let flesh_info env loc hidden prefix = 10 | let pp_loc = Cli.pp_loc ~cond:loc in 11 | let pp_var ppf var (pat, loc) = Fmt.pf ppf "%a%s@," pp_loc loc var in 12 | let pp_flesh ppf m = String.Map.iter (pp_var ppf) m in 13 | let keep var _ = 14 | String.is_prefix prefix var && (hidden || not (String.is_prefix "_" var)) 15 | in 16 | Carcass.Flesh.of_env env >>= fun flesh -> 17 | let flesh = String.Map.filter keep flesh in 18 | Fmt.pr "@[%a@]@?" pp_flesh flesh; 19 | Ok 0 20 | 21 | let bone_info env loc hidden prefix = 22 | let pp_loc = Cli.pp_loc ~cond:loc in 23 | let pp_id = Fmt.styled `Bold Fpath.pp in 24 | let pp_bone ppf id p = 25 | Fmt.pf ppf "%a%a@," pp_loc (Carcass.Loc.for_path p) pp_id id 26 | in 27 | let pp_bones ppf m = Fpath.Map.iter (pp_bone ppf) m in 28 | let keep id _ = String.is_prefix prefix (Fpath.to_string id) in 29 | let bones = Carcass.Bone.list ~hidden env in 30 | let bones = Fpath.Map.filter keep bones in 31 | Fmt.pr "@[%a@]@?" pp_bones bones; 32 | Ok 0 33 | 34 | let body_info env doc loc hidden prefix = 35 | let pp_loc = Cli.pp_loc ~cond:loc in 36 | let pp_id = Fmt.styled `Bold Fpath.pp in 37 | let pp_body doc ppf id p = 38 | let path_loc = Carcass.Loc.for_path p in 39 | let id = Fpath.rem_ext id in 40 | match Carcass.Body.of_path p id with 41 | | Error _ as e -> 42 | Cli.log_on_error ~use:(fun () -> ()) e; 43 | Fmt.pf ppf "%a%a@," pp_loc path_loc pp_id id 44 | | Ok b -> 45 | let syn, descr = Carcass.Body.doc b in 46 | if not doc then begin 47 | Fmt.pf ppf "%a@[<1>%a@ @ %a@]@," 48 | pp_loc path_loc pp_id id Fmt.text syn 49 | end else begin 50 | let pp_doc_var ppf v doc = 51 | Fmt.pf ppf " @[<2>* %a@ @ @[%a@].@]@," 52 | Fmt.(styled `Underline string) v Fmt.text doc 53 | in 54 | Fmt.pf ppf "@["; 55 | if loc then Fmt.pf ppf "%a@," pp_loc path_loc; 56 | Fmt.pf ppf "# @[@[%a@] – @[%a@]@]@,@," pp_id id Fmt.words syn; 57 | Fmt.pf ppf " @[%a@]@,@," Fmt.paragraphs descr; 58 | String.Map.iter (pp_doc_var ppf) (Carcass.Body.var_docs b); 59 | Fmt.pf ppf "@]@," 60 | end 61 | in 62 | let pp_bodies doc ppf m = Fpath.Map.iter (pp_body doc ppf) m in 63 | let keep id _ = String.is_prefix prefix (Fpath.to_string id) in 64 | let bodies = Carcass.Body.list ~hidden env in 65 | let bodies = Fpath.Map.filter keep bodies in 66 | Fmt.pr "@[%a@]@?" (pp_bodies doc) bodies; 67 | Ok 0 68 | 69 | let env_info env = 70 | Fmt.pr "@[%a@]@." Fpath.pp Carcass.Env.etc_dir; 71 | Ok 0 72 | 73 | let kind_info env doc loc hidden prefix kind = 74 | begin match kind with 75 | | `Flesh -> flesh_info env loc hidden prefix 76 | | `Bone -> bone_info env loc hidden prefix 77 | | `Body -> body_info env doc loc hidden prefix 78 | | `Env -> env_info env 79 | end 80 | |> Cli.handle_error 81 | 82 | (* Command line interface *) 83 | 84 | open Cmdliner 85 | 86 | let doc_opt = 87 | let doc = "Show documentation of the element in the output (if available)." in 88 | Arg.(value & flag & info ["d"; "doc"] ~doc) 89 | 90 | let loc = 91 | let doc = "Show the element's location of definition in the output." in 92 | Arg.(value & flag & info ["l"; "loc"] ~doc) 93 | 94 | let hidden = 95 | let doc = "Show hidden elements in the output. An element is hidden 96 | if the last path component of its identifier starts with a '_' 97 | character." 98 | in 99 | Arg.(value & flag & info ["h"; "hidden"] ~doc) 100 | 101 | let kind = 102 | let kind = ["flesh", `Flesh; "bone", `Bone; "bones", `Bone; "body", `Body; 103 | "bodies", `Body; "env", `Env; ] 104 | in 105 | let doc = 106 | strf "Kind of elements to consider. $(docv) must be one of %s (singular 107 | and plural forms are equivalent)." 108 | (Arg.doc_alts_enum kind) 109 | in 110 | let kind = Arg.enum kind in 111 | Arg.(required & pos 0 (some kind) None & info [] ~doc ~docv:"KIND") 112 | 113 | let prefix = 114 | let doc = "Only output elements whose identifier starts with $(docv)." in 115 | Arg.(value & pos 1 string "" & info [] ~doc ~docv:"PREFIX") 116 | 117 | let doc = "output information about flesh variables, bones and bodies" 118 | let man = 119 | [ `S "DESCRIPTION"; 120 | `P "The $(b,info) command outputs, depending on $(i,KIND), information 121 | about flesh variables, bones or bodies defined in the current 122 | environment."; 123 | `P "Only information about elements whose identifier starts with $(i,PREFIX) 124 | is output; if unspecified this is the empty string and all elements 125 | are listed."; 126 | `S "EXAMPLES"; 127 | `P "List all flesh variable identifiers in the current environment and 128 | where they are defined:"; 129 | `Pre " > carcass info -l flesh"; 130 | `P "List all bone identifiers, including hidden ones, in the current 131 | environment and where they are defined:"; 132 | `Pre " > carcass info -h -l bone "; 133 | `P "Show documentation about bodies whose identifiers start with 'www':"; 134 | `Pre " > carcass info -d body www"; 135 | ] @ Cli.common_man @ Cli.see_also_main_lookup_man 136 | 137 | let cmd = 138 | let info = Term.info "info" ~sdocs:Cli.common_opts ~doc ~man in 139 | let env = Carcass_cli.env ~docs:Cli.common_opts () in 140 | let term = Term.(pure kind_info $ Cli.setup env $ doc_opt $ loc $ hidden $ 141 | prefix $ kind) 142 | in 143 | term, info 144 | 145 | (*--------------------------------------------------------------------------- 146 | Copyright (c) 2016 Daniel C. Bünzli 147 | 148 | Permission to use, copy, modify, and/or distribute this software for any 149 | purpose with or without fee is hereby granted, provided that the above 150 | copyright notice and this permission notice appear in all copies. 151 | 152 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 153 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 154 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 155 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 156 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 157 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 158 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 159 | ---------------------------------------------------------------------------*) 160 | -------------------------------------------------------------------------------- /src-bin/setup.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Astring 7 | open Rresult 8 | open Bos 9 | 10 | let flesh_setup_bone = Fpath.(Carcass.Env.etc_dir / "flesh.setup") 11 | 12 | (* Carcasses setup *) 13 | 14 | let user_wants_carcasses () = 15 | Carcass.Ask.bool ~default:true 16 | "Do@ you@ want@ to@ install@ the@ sample@ bones@ and@ bodies ?" 17 | 18 | let work_around_opam_install mode data = 19 | (* see https://github.com/ocaml/opam/issues/2430 *) 20 | if String.is_prefix "#!" data then 0o755 else mode 21 | 22 | let install_carcasses dry_run force setup_dir = 23 | let copy src () = 24 | if Fpath.equal src flesh_setup_bone then () else 25 | let dst = match Fpath.rem_prefix (Carcass.Env.etc_dir) src with 26 | | None -> assert false 27 | | Some rel -> Fpath.(setup_dir // rel) 28 | in 29 | begin match dry_run with 30 | | true -> Cli.log_path `Write dst; Ok () 31 | | false -> 32 | OS.File.exists dst >>= function 33 | | true when not force && not (Cli.user_wants_overwrite dst) -> 34 | Cli.log_path `Skip dst; Ok () 35 | | _ -> 36 | OS.Path.Mode.get src 37 | >>= fun mode -> OS.File.read src 38 | >>= fun data -> Ok (work_around_opam_install mode data) 39 | >>= fun mode -> OS.Dir.create (Fpath.parent dst) 40 | >>= fun _ -> OS.File.write ~mode dst data 41 | >>= fun () -> Cli.log_path `Wrote dst; Ok () 42 | end 43 | |> Logs.on_error_msg ~use:(fun () -> ()) 44 | in 45 | if force || (user_wants_carcasses ()) 46 | then OS.Dir.fold_contents ~elements:`Files copy () Carcass.Env.etc_dir 47 | else Ok () 48 | 49 | (* Flesh setup *) 50 | 51 | let pr_flesh_start () = 52 | Fmt.pr "@\n@[%a@]@\n@." Fmt.text "Please answer the following questions." 53 | 54 | let pr_flesh_end flesh_file = 55 | Fmt.pr "@\n@[Thanks,@ consult@ and@ edit@ "; 56 | Fmt.pr "%a" Fpath.pp flesh_file; 57 | Fmt.pr "@ for@ further@ adjustments.@]@\n@." 58 | 59 | let git_conf key = 60 | let parse = function "" -> None | v -> Some v in 61 | OS.Cmd.(run_out Cmd.(v "git" % "config" % key) |> to_string) >>| parse 62 | |> Logs.on_error_msg ~level:Logs.Debug ~use:(fun () -> None) 63 | 64 | let ask ~guess ~default what = match guess with 65 | | None -> Carcass.Ask.string ~default " What@ is@ %a ? " Fmt.text what 66 | | Some default -> 67 | Carcass.Ask.string ~default " What is@ %a ?@ [enter for '%s'] " 68 | Fmt.text what default 69 | 70 | let ask_name () = 71 | ask ~guess:(git_conf "user.name") ~default:"nobody" "your name" 72 | 73 | let ask_email () = 74 | ask ~guess:(git_conf "user.email") ~default:"nobody@example.org" "your email" 75 | 76 | let ask_homepage gh_user = 77 | let guess = match gh_user with 78 | | None -> None | Some u -> Some (strf "https://%s.github.io" u) 79 | in 80 | ask ~guess ~default:"https://www.example.org" "your homepage" 81 | 82 | let ask_pkg_homepage_root gh_username = 83 | let guess = match gh_username with 84 | | None -> None | Some u -> Some (strf "https://github.com/%s" u) 85 | in 86 | ask ~guess ~default:"https://www.example.org/software" 87 | "the root address for the homepage of your packages" 88 | 89 | let user_uses_github () = 90 | Carcass.Ask.bool ~default:true " Are@ you@ using@ github@ ?" 91 | 92 | let ask_github_username () = 93 | if not (user_uses_github ()) then None else 94 | Some (Carcass.Ask.string ~default:"_" " What@ is@ your@ github@ username ? ") 95 | 96 | let setup_flesh_env name email homepage pkg_homepage_root = 97 | let lit s = 98 | let loc = Carcass.Loc.for_cli s in 99 | [Carcass.Pat.Lit s, loc], loc 100 | in 101 | Carcass.Pat.env @@ 102 | String.Map.(empty 103 | |> add "CARCASS_SETUP_AUTHOR_HOMEPAGE" (lit homepage) 104 | |> add "CARCASS_SETUP_AUTHOR_NAME" (lit name) 105 | |> add "CARCASS_SETUP_AUTHOR_EMAIL" (lit email) 106 | |> add "CARCASS_SETUP_PKG_HOMEPAGE_ROOT" (lit pkg_homepage_root)) 107 | 108 | let ask_env () = 109 | let name = ask_name () in 110 | let email = ask_email () in 111 | let gh_username = ask_github_username () in 112 | let homepage = ask_homepage gh_username in 113 | let pkg_homepage_root = ask_pkg_homepage_root gh_username in 114 | Fmt.pr "@."; 115 | setup_flesh_env name email homepage pkg_homepage_root 116 | 117 | let setup_flesh dry_run force setup_dir = 118 | let flesh_file = Fpath.(setup_dir / "flesh") in 119 | OS.File.exists flesh_file >>= function 120 | | true when not force && not (Cli.user_wants_overwrite flesh_file) -> Ok () 121 | | _ -> 122 | Carcass.Bone.of_path flesh_setup_bone flesh_setup_bone 123 | >>= fun bone -> pr_flesh_start (); Ok (ask_env ()) 124 | >>= fun env -> Carcass.Bone.eval env bone 125 | >>= fun flesh -> match dry_run with 126 | | true -> Cli.log_path `Write flesh_file; Ok () 127 | | false -> 128 | OS.Dir.create setup_dir 129 | >>= fun _ -> OS.File.write flesh_file flesh 130 | >>| fun () -> Cli.log_path `Wrote flesh_file; pr_flesh_end flesh_file 131 | 132 | (* Setup command *) 133 | 134 | let pr_setup_end () = 135 | Fmt.pr "@\n@[%a@]@\n@." Fmt.text 136 | "Setup is complete. Run `carcass help basics` for a short introduction \ 137 | to carcass." 138 | 139 | let setup env dry_run force kind setup_dir = 140 | let do_flesh = kind <> `Carcass in 141 | let do_carcass = kind <> `Flesh in 142 | begin 143 | (match setup_dir with None -> Carcass.Env.user_dir () | Some d -> Ok d) 144 | >>= fun d -> (if do_flesh then setup_flesh dry_run force d else Ok ()) 145 | >>= fun () -> 146 | (if do_carcass then install_carcasses dry_run force d else Ok ()) 147 | >>= fun () -> pr_setup_end (); Ok 0 148 | end 149 | |> Cli.handle_error 150 | 151 | (* Command line interface *) 152 | 153 | open Cmdliner 154 | 155 | let setup_dir = 156 | let doc = "The directory in which to perform the setup." in 157 | let dir p = match Fpath.to_string p with 158 | | "~/.carcass" -> None | _ -> Some p 159 | in 160 | let arg = 161 | Arg.(value & opt Cli.path_arg (Fpath.v "~/.carcass") & 162 | info ["dir"] ~doc ~docv:"DIR") 163 | in 164 | Term.(const dir $ arg) 165 | 166 | let kind = 167 | let kind = Arg.enum ["all", `All; "flesh", `Flesh; "carcass", `Carcass] in 168 | let doc = "Kind of setup to perform. `flesh` for flesh setup, `carcass` 169 | for sample bones and bodies installation and `all` for both." 170 | in 171 | Arg.(value & pos 0 kind `All & info [] ~doc ~docv:"KIND") 172 | 173 | let doc = "setup the user ~/.carcass directory" 174 | let man = 175 | [ `S "DESCRIPTION"; 176 | `P "The $(tname) command asks the user a few questions to 177 | write the personal ~/.carcass/flesh file and copies 178 | a few sample bones and bodies from carcass's etc directory to 179 | ~/.carcass."; 180 | ] @ Cli.common_opts_man @ [ 181 | `S "ENVIRONMENT VARIABLES"; 182 | ] 183 | @ Cli.see_also_main_lookup_man 184 | 185 | let cmd = 186 | let info = Term.info "setup" ~sdocs:Cli.common_opts ~doc ~man in 187 | let env = Carcass_cli.env ~docs:Cli.common_opts () in 188 | let t = Term.(pure setup $ Cli.setup env $ Cli.dry_run $ 189 | Cli.force $ kind $ setup_dir) 190 | in 191 | (t, info) 192 | 193 | (*--------------------------------------------------------------------------- 194 | Copyright (c) 2016 Daniel C. Bünzli 195 | 196 | Permission to use, copy, modify, and/or distribute this software for any 197 | purpose with or without fee is hereby granted, provided that the above 198 | copyright notice and this permission notice appear in all copies. 199 | 200 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 201 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 202 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 203 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 204 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 205 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 206 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 207 | ---------------------------------------------------------------------------*) 208 | -------------------------------------------------------------------------------- /src/carcass.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** Define file and directory carcasses. *) 7 | 8 | (** {1 Carcass} *) 9 | 10 | open Astring 11 | open Rresult 12 | 13 | (** Locating text in input data. *) 14 | module Loc : sig 15 | 16 | (** {1 Positions} *) 17 | 18 | type pos = int * int 19 | (** The type for positions. A one-based line number and and a 20 | zero-based column number. Each Unicode scalar value on a line 21 | increments column number by one. *) 22 | 23 | val nil_pos : pos 24 | (** [nil_pos] is an invalid position. *) 25 | 26 | val zero_pos : pos 27 | (** [zero_pos] is [(1,0)]. *) 28 | 29 | (** {1 Ranges} *) 30 | 31 | type range = pos * pos 32 | (** The type for ranges. Start and stop position. *) 33 | 34 | val nil_range : range 35 | (** [nil_range] is an invalid range. *) 36 | 37 | val zero_range : range 38 | (** [zero_range] is [(zero_pos, zero_pos)]. *) 39 | 40 | (** {1 Locations} *) 41 | 42 | (** The type for location sources. *) 43 | type src = Builtin | Cli | File of Fpath.t 44 | 45 | type t = src * range 46 | (** The type for locations. *) 47 | 48 | val nil : t 49 | (** [nil] is an invalid builtin location. *) 50 | 51 | val for_builtin : string -> t 52 | (** [for_builtin s] is a builtin location for string [s]. *) 53 | 54 | val for_cli : string -> t 55 | (** [for_cli s] is a cli location for string [s]. *) 56 | 57 | val for_path : ?range:range -> Fpath.t -> t 58 | (** [for_path ~range p] is the range [range] (defaults to {!zero_range}) 59 | of [p]. *) 60 | 61 | val pp : t Fmt.t 62 | (** [pp] formats locations according to 63 | {{:http://www.gnu.org/prep/standards/standards.html#Errors}GNU 64 | conventions}. *) 65 | 66 | (** {1 Traces} *) 67 | 68 | type trace = t list 69 | (** The type for traces. Lists of locations. *) 70 | 71 | val nil_trace : trace 72 | (** [nil] is an empty trace. *) 73 | 74 | val pp_trace : trace Fmt.t 75 | (** [pp_trace] formats traces using {!pp}. *) 76 | end 77 | 78 | (** Parse and evaluation errors. *) 79 | module Error : sig 80 | 81 | (** {1 Parse errors} *) 82 | 83 | type unexpected = [ `Uchar of Uchar.t | `Lexeme of string | `Eoi ] 84 | (** The type for unexpected parse input. *) 85 | 86 | type expected = 87 | [ `Keyword of string | `Id | `Lpar | `Rpar | `Qmark | `Comma | `Dollar 88 | | `Escaped_char | `Atom ] 89 | (** The type for expected parse input. *) 90 | 91 | (** The type for parse errors cases. *) 92 | type parse_err = 93 | | Illegal_bytes of string 94 | | Illegal_escape of Uchar.t 95 | | Illegal_variable_transform of string 96 | | Illegal_binding_id of string 97 | | Unclosed of [ `Quoted_atom | `Var_ref ] 98 | | Unexpected of unexpected * expected list 99 | 100 | (** The type for parse errors. *) 101 | type parse = [ `Carcass_parse of parse_err * Loc.t ] 102 | 103 | val pp_parse_err : parse_err Fmt.t 104 | (** [pp_parse_err] is a formatter for parse error cases. *) 105 | 106 | val pp_parse : parse Fmt.t 107 | (** [pp_parse] is a formatter for parse errors. *) 108 | 109 | (** {1 Evaluation errors} *) 110 | 111 | type eval_id = [ `Var of string | `Bone of string | `Body of string ] 112 | (** The type for evaluated identifiers. *) 113 | 114 | (** The type for evaluation errors cases. *) 115 | type eval_err = 116 | | Circular of eval_id 117 | | Parse of eval_id * [ parse | R.msg ] 118 | | Undefined of eval_id 119 | | Bound_path of string * [ `Illegal | `Escapes ] 120 | 121 | (** The type for evaluation errors. *) 122 | type eval = [ `Carcass_eval of eval_err * Loc.trace ] 123 | 124 | val pp_eval_id : eval_id Fmt.t 125 | (** [pp_eval_def] is a formatter for evaluated identifiers. *) 126 | 127 | val pp_eval_err : eval_err Fmt.t 128 | (** [pp_eval_err] is a formatter for evaluation error cases. *) 129 | 130 | val pp_eval : eval Fmt.t 131 | (** [pp_eval] is a formatter for evaluation errors. *) 132 | end 133 | 134 | (** Patterns. 135 | 136 | Patterns are strings with variable references of the form 137 | [$(VAR[,transform])]. In patterns any literal [$] must be written 138 | [$$]. 139 | 140 | See [carcass-syntax(5)] for more information. *) 141 | module Pat : sig 142 | 143 | (** {1 Variable reference transforms} *) 144 | 145 | (** The type for variable reference transforms. *) 146 | type transform = 147 | | Uppercase | Lowercase | Capitalize | Uncapitalize | Indent of string 148 | 149 | val transform_to_string : transform -> string 150 | (** [transform_of_string t] parses a transform from [s]. *) 151 | 152 | val pp_transform : transform Fmt.t 153 | (** [pp_transform] is a pretty printer for transforms. *) 154 | 155 | (** {1 Patterns} *) 156 | 157 | (** The type for pattern lexemes. Either a string literal (where 158 | $ are unescaped) or a variable reference. *) 159 | type lexeme = Lit of string | Var of string * transform option 160 | 161 | type t = (lexeme * Loc.t) list * Loc.t 162 | (** The type for patterns. A list of localized pattern lexemes tupled 163 | with a location spanning the whole pattern. *) 164 | 165 | val empty : t 166 | (** [empty] is an empty builtin pattern. *) 167 | 168 | val dom : t -> String.set 169 | (** [dom p] is the set of variable references in [p]. *) 170 | 171 | val equal : t -> t -> bool 172 | (** [equal p p'] is [p = p']. *) 173 | 174 | val compare : t -> t -> int 175 | (** [compare p p'] is [Pervasives.compare p p']. *) 176 | 177 | val to_string : ?flesh:bool -> t -> string 178 | (** [to_string ~flesh p] converts [p] to a string according the carcass 179 | syntax for variable references. Escapes the $ in lexeme 180 | literals to $$. 181 | 182 | If [flesh] is [true] (defaults to [false]) also escapes double 183 | quote characters ['"'] (U+0022) with the sequence ["\\\""] 184 | () and backslash characters ['\\'] (U+005C) with 185 | the sequence ["\\\\"] (). *) 186 | 187 | val of_input : 188 | ?flesh:bool -> 189 | src:Loc.src -> 190 | [ `String of string | `Channel of in_channel ] -> 191 | (t, [> Error.parse]) Result.result 192 | (** [of_input ~flesh ~src i] considers [i] as a single atom and 193 | returns its pattern. If [flesh] is [true] carcass escapes are 194 | recognized and interpreted; if [false] (defaults) only variable 195 | references are recognized. *) 196 | 197 | val pp : ?flesh:bool -> t Fmt.t 198 | (** [pp] formats patterns verbatim like {!to_string}. *) 199 | 200 | (** {1 Substitution} *) 201 | 202 | val subst : (string -> string option) -> t -> t 203 | (** [subst defs p] substitutes variables in [p] by the value they map 204 | to in [defs]. *) 205 | 206 | (** {1 Evaluation} *) 207 | 208 | type env 209 | (** The type for evaluation environments. *) 210 | 211 | val env : 212 | ?undef:(string -> (t, Error.parse) result option) -> t String.map -> env 213 | (** [env ~undef m] is an evaluation environment in which variables are 214 | defined according to the map [m]. [undef] is called on undefined 215 | variables; its result is cached by the environement, defaults to 216 | [(fun _ -> None]). *) 217 | 218 | val env_var_value : env -> string -> 219 | (string * Loc.t, [> Error.eval]) result option 220 | (** [env_var_value env var] is value of variable [var] in [env], if 221 | defined. *) 222 | 223 | val eval : env -> t -> (string * Loc.t, [> Error.eval]) result 224 | (** [eval env pat] is the evaluation of pattern [pat] 225 | in environment [env]. *) 226 | 227 | (** {1 Matching} *) 228 | 229 | val query : ?init:string String.map -> t -> string -> string String.map option 230 | (** [query ~init p s] returns an environment mapping each pattern variable 231 | of [p] to its matched part in [s], if [s] matches [p]. Variables are 232 | added to [init]. Variables greedily match from zero to more 233 | characters of the file, i.e. .* in regexp speak. *) 234 | end 235 | 236 | (** Ask values on standard input. *) 237 | module Ask : sig 238 | 239 | (** {1 Asking values} *) 240 | 241 | type ('a, 'b) t = ('a, Format.formatter, unit, 'b) format4 -> 'a 242 | (** The type for questions formatted according to ['a] and whose result is 243 | ['b]. *) 244 | 245 | val value : 246 | ?ppf:Format.formatter -> 247 | parse:(string -> ('a, 'b) Result.result) -> 248 | ('c, ('a, 'b) Result.result) t 249 | (** [value ~parse] asks for a value parsed according to [parse]. 250 | The question is written on [ppf] (Defaults to {!Fmt.stdout}). *) 251 | 252 | val pattern : 253 | ?ppf:Format.formatter -> 254 | ('a, (Pat.t, [> Error.parse]) Result.result) t 255 | (** [pattern] asks for a pattern. *) 256 | 257 | val bool : ?ppf:Format.formatter -> default:bool -> ('a, bool) t 258 | (** [bool] asks for a boolean value. If no input is provided or 259 | no boolean sense can be made from the input, defaults to [default]. *) 260 | 261 | val string : ?ppf:Format.formatter -> default:string -> ('a, string) t 262 | (** [string] asks for a string value. If no input is provided 263 | defaults to [default]. *) 264 | end 265 | 266 | (** Carcass environment. 267 | 268 | A carcass environement defines how {{!Flesh}flesh}, 269 | {{!Bone}bone} and {{!Body}body} lookups get resolved. *) 270 | module Env : sig 271 | 272 | (** {1 Directories} *) 273 | 274 | val etc_dir : Fpath.t 275 | (** [etc_dir] is the path to the install's [etc] directory. *) 276 | 277 | val user_dir : unit -> (Fpath.t, [> R.msg]) result 278 | (** [user_dir] is the path to the user's carcass directory. *) 279 | 280 | (** {1 Environments} *) 281 | 282 | type t 283 | (** The type for environments. *) 284 | 285 | val v : 286 | no_user_dir:bool -> 287 | no_dot_dirs:bool -> 288 | dirs:Fpath.t list -> 289 | flesh:Fpath.t list -> 290 | cli:(string * Pat.t) list -> t 291 | (** [v ~no_user_dir ~no_dot_dirs ~dirs ~flesh ~cli] is an environment such 292 | that looks up are done, in order: 293 | {ul 294 | {- For flesh, first in [cli], followed by [flesh] files (starting from 295 | the last one), followed by files [d/flesh] with [d] in [dirs] 296 | (starting from the last one).} 297 | {- For bones and bodies, first in directory [dirs] (starting from 298 | the last one), then in [.carcass] directories from current 299 | directory up to root (except if [no_dot_dirs] is [true]), then 300 | in [~/.carcass] (except if [no_user_dir] is [true]).}} *) 301 | end 302 | 303 | (** Flesh (variable definitions). 304 | 305 | See [carcass-syntax(5)] for more information about the syntax 306 | of flesh files. *) 307 | module Flesh : sig 308 | 309 | (** {1 Flesh} *) 310 | 311 | type t = Pat.t String.map 312 | (** The type for flesh. Maps variable names to their definition. *) 313 | 314 | val builtins : t 315 | (** [builtins] are the built-in variable definitions. *) 316 | 317 | val of_input : 318 | ?init:Pat.t String.map -> 319 | src:Loc.src -> 320 | [ `String of string | `Channel of in_channel ] -> 321 | (t, [> Error.parse]) Result.result 322 | (** [of_input ~init ~src input] reads flesh variable bindings from [input] 323 | and adds them to [init] (defaults to {!builtins}). *) 324 | 325 | val of_env : 326 | ?init:Pat.t String.map -> 327 | Env.t -> 328 | (t, [> Error.parse]) Result.result 329 | (** [of_env init env] are the variable bindings available in 330 | environment [env] added to [init] (defaults to {!builtins}). *) 331 | 332 | val pp_def : Pat.t Fmt.t 333 | (** [pp_def] formats a pattern like a flesh variable definition. *) 334 | 335 | val pp : t Fmt.t 336 | (** [pp] formats flesh as valid carcass flesh syntax. *) 337 | end 338 | 339 | (** Bones (single files). *) 340 | module Bone : sig 341 | 342 | (** {1 Lookup} *) 343 | 344 | type id = Fpath.t 345 | (** The type for bone ids. *) 346 | 347 | val find : Env.t -> id -> Fpath.t option 348 | (** [find env id] finds the full path to the bone identified by [id] 349 | in environment [env]. If [id] is {!OS.File.dash} or an absolute path or 350 | starts with [./] and the path exists, [Some id] is returned. *) 351 | 352 | val list : ?hidden:bool -> Env.t -> Fpath.t Fpath.map 353 | (** [list ~hidden env] maps bone identifiers found in the environment [env] 354 | to their [path]. If [hidden] is [true] hidden bones (those whose 355 | last segment start with a ['_']) are also in the map (defaults to 356 | [false]). *) 357 | 358 | (** {1 Bones} *) 359 | 360 | type content = 361 | | Binary of string (** Binary bone. *) 362 | | Pat of Pat.t (** Textual bone. *) 363 | (** The type for bone contents. A bone is deemed binary if a null byte 364 | is found in its content. *) 365 | 366 | type t 367 | (** The type for bones. *) 368 | 369 | val id : t -> id 370 | (** [id b] is the bone's id. *) 371 | 372 | val content : t -> content 373 | (** [content b] is the bone's content. *) 374 | 375 | val is_exec : t -> bool 376 | (** [is_exec b] is [true] if the bone is executable. *) 377 | 378 | val of_input : 379 | ?trim:bool -> 380 | src:Loc.src -> 381 | [ `String of string ] -> is_exec:bool -> id -> 382 | (t, [> Error.parse]) Result.result 383 | (** [of_input ~src input is_exec id] reads a bone with id [id] from 384 | [input]. [is_exec] is the value for {!is_exec}. If [trim] is 385 | [true] (defaults to [false]), a textual bone's leading and 386 | trailing white space is trimmed with {!String.trim}. *) 387 | 388 | val of_path : 389 | ?trim:bool -> Fpath.t -> id -> (t, [> Error.parse | `Msg of string ]) result 390 | (** [of_path ~trim p] reads a bone with id [id] from path [p] using 391 | {!of_input}. The resulting bone's {!is_exec} is [true] iff the path 392 | is executable for the user. *) 393 | 394 | (** {1 Evaluation} *) 395 | 396 | val eval : Pat.env -> t -> (string, [> Error.eval]) result 397 | (** [eval env b] evaluates [b] to a string in the pattern evaluation 398 | environment [env]. *) 399 | end 400 | 401 | (** Bodies (file system hierarchies). *) 402 | module Body : sig 403 | 404 | (** {1 Lookup} *) 405 | 406 | type id = Fpath.t 407 | (** The type for body ids. *) 408 | 409 | val find : Env.t -> id -> Fpath.t option 410 | (** [find env id] finds the full path to the bone identified by [id] 411 | in environment [env]. If [id] is an absolute path or starts with 412 | [./] and the path exists, [Some id] is returned. If it is looked up 413 | in the environment and [id] has no [.body] extension one is added. *) 414 | 415 | val list : ?hidden:bool -> Env.t -> Fpath.t Fpath.map 416 | (** [list ~hidden env] maps body ids found in the environment [env] to 417 | their [path]. If [hidden] is [true] hidden bodies (those whose 418 | last segment start with a ['_']) are also in the map (defaults to 419 | [false]). *) 420 | 421 | (** {1 Bodies} *) 422 | 423 | type binding_id = Fpath.t 424 | (** The type for binding ids, either a bone id or a body id. Must be 425 | a relative path that doesn't start with ./. *) 426 | 427 | type t 428 | (** The type for bodies *) 429 | 430 | val id : t -> id 431 | (** [id b] is the body's id. The id always has [.body] file extension. *) 432 | 433 | val doc : t -> string * string 434 | (** [doc b] is the synopsis and documentation of [b]. *) 435 | 436 | val var_docs : t -> string String.map 437 | (** [var_docs b] maps a selection of variables to a documentation 438 | string. *) 439 | 440 | val bindings : t -> (Pat.t * (binding_id * Loc.t)) list 441 | (** [bindings b] are the uninterpreted path bindings found in [b]. *) 442 | 443 | val of_input : 444 | src:Loc.src -> 445 | [ `String of string | `Channel of in_channel ] -> id -> 446 | (t, [> Error.parse]) Result.result 447 | (** [of_input ~src input id] reads a body with id [id] from [input]. *) 448 | 449 | val of_path : Fpath.t -> id -> (t, [> Error.parse | R.msg]) result 450 | (** [of_path p id] reads a body with id [id] from path [p] using 451 | {!of_input}. *) 452 | 453 | (** {1 Evaluation} *) 454 | 455 | val eval_paths : 456 | Env.t -> Pat.env -> t -> 457 | ((Bone.id * Loc.trace) Fpath.map, [> Error.eval | R.msg ]) result 458 | (** [eval_paths env penv id b] evaluates all the paths of bone [b]'s 459 | bindings and maps them to their bone id using [env] to lookup 460 | sub-bodies and [penv] to evaluate the path patterns. *) 461 | 462 | val eval_bones : 463 | Env.t -> Pat.env -> (Bone.id * Loc.trace) Fpath.map -> 464 | ((string * bool) Fpath.map, [> Error.eval | R.msg]) result 465 | (** [eval_bones env penv m] evaluates all the bone ids in the 466 | path map [m] to their content and executable status using [env] to 467 | look them up and [penv] to evaluate textual bones. *) 468 | 469 | (** {1 Output} *) 470 | 471 | val write : 472 | ?wrote:(Fpath.t -> unit) -> ?over:(Fpath.t -> bool) -> 473 | dst:Fpath.t -> (string * bool) Fpath.map -> (unit, [> R.msg]) result 474 | (** [write ~log ~over ~dst m] writes the paths defined in [m] (creating 475 | directories if needed) relative to [dst] according to the 476 | content they map to and setting the executable bit according to 477 | the boolean. If the complete path to write already exists it is called 478 | with [over] to determine if it should be overwritten, defaults 479 | to [(fun _ -> Ok false)]. [wrote] is called with each complete path that 480 | was written (default to (fun _ -> ())) *) 481 | end 482 | 483 | 484 | (*--------------------------------------------------------------------------- 485 | Copyright (c) 2016 Daniel C. Bünzli 486 | 487 | Permission to use, copy, modify, and/or distribute this software for any 488 | purpose with or without fee is hereby granted, provided that the above 489 | copyright notice and this permission notice appear in all copies. 490 | 491 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 492 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 493 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 494 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 495 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 496 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 497 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 498 | ---------------------------------------------------------------------------*) 499 | -------------------------------------------------------------------------------- /src-bin/help.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | let carcass_manual = "Carcass manual" 7 | let version = "%%VERSION%%" 8 | 9 | (* Help manuals *) 10 | 11 | let basics = 12 | ("CARCASS-BASICS", 7, "", version, carcass_manual), 13 | [ `S "NAME"; 14 | `P "carcass-basics - short introduction to carcass"; 15 | `S "DESCRIPTION"; 16 | `P "carcass helps you to create software project boilerplate. This can 17 | range from a single source file with your copyright and licensing 18 | information to whole project scaffoldings."; 19 | `S "SETUP"; 20 | `P "The first thing you should do after having installed carcass is 21 | to invoke:"; 22 | `Pre "> carcass setup"; 23 | `P "This will ask you a few questions to setup your personal information 24 | in the ~/.carcass/flesh file and copy a few default bones and bodies 25 | to ~/.carcass."; 26 | `P "Having done this take the time to further adjust your personal 27 | variables in ~/.carcass/flesh according to your wishes."; 28 | `S "CONCEPTS"; 29 | `P "There are three kinds of files in carcass:"; 30 | `I ("$(i,flesh) files", "These files hold sequences of variable definitions. 31 | See for example the ~/.carcass/flesh file."); 32 | `I ("$(i,bone) files", "Bone files allow to create a single file. They 33 | are arbitrary files located in a carcass directory. Files which 34 | are detected as text files (i.e. without a null byte) will be parsed 35 | as UTF-8 encoded file and have variable references of the 36 | form \\$(VAR) substituted with the definitions found in flesh 37 | files."); 38 | `I ("$(i,body) files", "Body files allow to create whole file hierarchies 39 | out of bones and flesh. They are the files located in a carcass 40 | directory that end with `.body`."); 41 | `P "To each kind of file there is a corresponding carcass command. Let's 42 | review them in turn."; 43 | `S "FLESH"; 44 | `P "The $(b,flesh) command looks up a flesh variable by its identifier, 45 | evaluates its definition and writes the result on stdout. For example:"; 46 | `Pre "> carcass flesh contact"; 47 | `P "To see the raw, unevaluated, definition of a variable, use the 48 | $(b,-r) option."; 49 | `Pre "> carcass flesh -r copyright_year"; 50 | `P "The $(b,-p) option outputs all variables, in flesh file syntax, that 51 | are prefixed by the given identifier. The $(b,-l) option prepends the 52 | output with the location of the definition. Using this, the following 53 | invocation:"; 54 | `Pre "> carcass flesh -r -l -p \"\""; 55 | `P "Lists all variable definitions with their location; the empty string 56 | is the prefix of any any string. See carcass-flesh(1) for 57 | more information about the $(b,flesh) command."; 58 | `S "BONE"; 59 | `P "The $(b,bone) command looks up a bone by its identifier, 60 | evaluates its variable references according to the flesh in 61 | the environment and writes the result on stdout."; 62 | `Pre "> carcass bone ocaml/src"; 63 | `P "If a variable definition can't be found, it will ask for it 64 | interactively. It is also possible to define or 65 | override variables on the command line:"; 66 | `Pre "> carcass bone ocaml/src copyright_year 2008"; 67 | `P "The bone command also supports the $(b,-r) and $(b,-l) options 68 | to access the raw definition and output, on stderr, 69 | the location of the bone."; 70 | `Pre "> carcass bone -r -l ocaml/src"; 71 | `P "To get the list of available bones use:"; 72 | `Pre "> carcass info bones"; 73 | `P "See carcass-bone(1) for more information about the $(b,bone) command. 74 | Regarding bones you may also find the $(b,match) command useful but 75 | I let you read about it in carcass-match(1)."; 76 | `S "BODY"; 77 | `P "The $(b,body) command looks up a body by its identifier. This in turn 78 | looks up the bones and bodies it is made of, evaluates their variable 79 | references according to the flesh in the environment and creates the 80 | file hierarchy it defines in a given destination directory. For example 81 | the following creates an OCaml module (mli/ml files) in the /tmp 82 | directory:"; 83 | `Pre "> carcass body ocaml/mod /tmp"; 84 | `P "Here again it is possible to specify flesh variables on the command 85 | line."; 86 | `Pre "> carcass body ocaml/mod /tmp name m"; 87 | `P "Carcass never overwrites files without confirming, unless the 88 | option $(b,--force) is used. The raw definition and location of the 89 | bone can be consulted with the usual options:"; 90 | `Pre "> carcass body -r -l ocaml/mod"; 91 | `P "To get the list of available bodies issue:"; 92 | `Pre "> carcass info bodies"; 93 | `P "And if you'd like more information about their variables and purpose 94 | use:"; 95 | `Pre "> carcass info bodies -d"; 96 | `P "See carcass-body(1) for more information about the $(b,body) command."; 97 | `S "LOOKUP PROCEDURES"; 98 | `P "Flesh, bones and bodies definitions are looked up according to 99 | procedures that are defined precisely in carcass-lookup(5)."; 100 | `S "ADDING NEW BONES AND BODIES"; 101 | `P "To add new bones and bodies simply create files in your ~/.carcass 102 | directory. The examples there with the help of the formal 103 | definitions of carcass-syntax(5) should be sufficient to get 104 | you started."; 105 | `P "One note about the bones and bodies that you find in ~/.carcass 106 | that start with an '_'. These can be consulted like any other body 107 | or bone, however they don't get listed by 'carcass info'; unless the 108 | $(b,--hidden) option is used."; 109 | `S "TROUBLESHOOTING"; 110 | `P "If the output doesn't quite correspond to what you expect, remember 111 | that most commands have the $(b,-r) and $(b,-l) options to output 112 | raw definitions and their location. Invoking the tool with $(b,-v) may 113 | also help in figuring out where the bones and bodies are picked 114 | up from."; 115 | `S "SEE ALSO"; 116 | `P "carcass(1), carcass-syntax(5), carcass-lookup(5)" ] 117 | 118 | let lookup = 119 | ("CARCASS-LOOKUP", 5, "", version, carcass_manual), 120 | [ `S "NAME"; 121 | `P "carcass-lookup - carcass lookup procedures"; 122 | `S "FLESH VARIABLE LOOKUP"; 123 | `P "Most commands allow to define variables: on the command line as 124 | positional arguments, in flesh files specified via the 125 | $(b,--flesh) option and in carcass directories specified via 126 | the $(b,--carcass) option."; 127 | `P "In a flesh file the last (re)definition takes over."; 128 | `P "For a given variable identifier the first definition found in 129 | the following order takes over the others:"; 130 | `I ("1. Positional command line arguments", "Starting from the rightmost 131 | $(i,ID) $(i,DEF) pair."); 132 | `I ("2. Command line flesh files", "Starting from the rightmost one, any 133 | file specified with the $(b,--flesh) option."); 134 | `I ("3. Command line carcass directory flesh files", 135 | "Starting from the rightmost one, 136 | any file $(i,DIR)/flesh with $(i,DIR) specified by the 137 | $(b,--carcass) option."); 138 | `I ("4. Default carcass directories", "First the .carcass/flesh files 139 | from the current working directory up to the root path 140 | unless the option $(b,--no-dot-dirs) is specified. Then in the 141 | ~/.carcass/flesh file unless the option $(b,--no-user-dir) is 142 | specified."); 143 | `P "The following variables, if undefined by the lookup procedure are 144 | automatically defined by carcass:"; 145 | `I ("CARCASS_YEAR", 146 | "Holds the year CE in which the program was started."); 147 | `I ("CARCASS_MATCH_*", 148 | "All variables of this form hold the empty string."); 149 | `P "Depending on the command, remaining undefined variables may be asked 150 | interactively."; 151 | `S "BONE LOOKUP"; 152 | `P "If a bone identifier is absolute or starts with './', then the 153 | corresponding file, if it exists, is read as the bone. If the bone 154 | identifier is '-' then it is read from standard input. Otherwise 155 | if the bone identifier is a relative path, the first file matching 156 | the path in the list of carcass directories is taken as the bone."; 157 | `P "For a given bone identifier $(i,BONE_ID) the lookup order is the 158 | following:"; 159 | `I ("1. Command line carcass directories", "Starting from the 160 | rightmost one, the file $(i,DIR)/$(i,BONE_ID) if it exists 161 | with $(i,DIR) specified by the $(b,--carcass) option."); 162 | `I ("2. Default carcass directories", "First the .carcass/$(i,BONE_ID) 163 | from the current working directory up to the root path 164 | unless the option $(b,--no-dot-dirs) is specified. Then the the 165 | ~/.carcass/$(i,BONE_ID) file unless the option $(b,--no-user-dir) is 166 | specified."); 167 | `S "BODY LOOKUP"; 168 | `P "Body lookup works exactly like bone lookup (see above) except that 169 | it can be specified either by $(i,BODY_ID) or $(i,BODY_ID).body. 170 | In the first case the '.body' extension is automatically added 171 | to the requested path identifier before looking up. Note that in 172 | body files, body identifiers must be specified with the extension 173 | otherwise they are taken as being bone identifiers." 174 | ] @ Cli.see_also_main_man 175 | 176 | let syntax = 177 | ("CARCASS-SYNTAX", 5, "", version, carcass_manual), 178 | [ `S "NAME"; 179 | `P "carcass-syntax - syntax of carcass files"; 180 | `S "DESCRIPTION"; 181 | `P "At the lexical level, carcass files are sequences of keywords 182 | and $(b,atoms) separated by $(b,white space) and $(b,comments)."; 183 | `P "$(b,variable identifiers) are restricted forms of atoms and 184 | $(b,variable references) are used to refer to the value of 185 | variables. Atoms with variable references are called $(b,patterns)."; 186 | `P "We first describe these basic elements before proceding to the 187 | definition of the syntax of $(b,flesh), $(b,bone) and 188 | $(b,body) files."; 189 | `S "CHARACTER STREAM PROCESSING"; 190 | `P "Leaving out binary bone files, carcass only interprets valid 191 | UTF-8 \ encoded files."; 192 | `P "If an initial BOM character (U+FEFF) is present it is 193 | discarded. In flesh and body files the newline functions CR 194 | (U+000D), CRLF () and NEL (U+0085) are 195 | normalized to LF (U+000A). The newlines of bone files are however 196 | left untouched."; 197 | `P "The grammar productions below are defined on the resulting 198 | stream of Unicode scalar values."; 199 | `S "WHITE SPACE"; 200 | `P "White space is space, horizontal tabulation, line feed, line tabulation 201 | and form feed. White space delineates atoms and keywords."; 202 | `Pre "$(i,white) ::= U+0020 | U+0009 | 0x000A | U+000B | U+000C"; 203 | `S "COMMENTS"; 204 | `P "Outside quoted atoms (see below) a hash 205 | (#, U+0023) and anything that follows is ignored until the next LF 206 | (\\\\n, U+000A) and treated as white space."; 207 | `Pre "\ 208 | $(i,comment) ::= $(i,hash) [^$(i,lf)]* $(i,lf) 209 | $(i,lf) ::= U+000A 210 | $(i,hash) ::= U+0023"; 211 | `S "ATOMS"; 212 | `P "An atom is either any sequence of characters except white space 213 | or a quoted atom, any sequence sequence of characters 214 | between quotation marks (\", U+0022). For example abc and \"abc\" 215 | are respectively an atom and a quoted atom and represent the same 216 | atom."; 217 | `P "Quoted atoms can be split across lines using a backslash 218 | (\\\\, U+005C); in this case initial spaces (U+0020) or 219 | tabs (U+0009) on the following line are discarded. Quoted atoms can 220 | also contain white space and escape sequences which are started 221 | by a backslash character (\\\\, U+005C). The following 222 | escape sequences are recognized:"; 223 | `I ("\\\\\\\\", 224 | "denotes U+005C, a backslash character"); `Noblank; 225 | `I ("\\\\\"", 226 | "denotes U+0022, a double quote character"); `Noblank; 227 | `I ("\\\\ ", 228 | "denotes U+0020, a space character"); `Noblank; 229 | `I ("\\\\n", 230 | "denotes U+000A, a line feed character"); 231 | `P "Any other character following a backslash is an illegal sequence 232 | of characters."; 233 | `P "The grammar of atoms is:"; 234 | `Pre "\ 235 | \ $(i,atom) ::= [^$(i,aend)]+ | $(i,quote) $(i,qachar)* $(i,quote) 236 | $(i,aend) ::= $(i,white) | $(i,quote) | $(i,hash) 237 | $(i,qachar) ::= [^$(i,quote) $(i,bslash)] | $(i,bslash) ($(i,bslash) \ 238 | | $(i,quote) | $(i,space) | $(i,n)) 239 | $(i,quote) ::= U+0022 240 | $(i,bslash) ::= U+005C 241 | $(i,space) ::= U+0020 242 | $(i,n) ::= U+006E"; 243 | `S "VARIABLE IDENTIFIERS"; 244 | `P "Variable identifiers are sequences of any US-ASCII letter, 245 | digit or underscore ('_', U+005F). Variable identifiers are case 246 | insensitive with respect to US-ASCII case maps."; 247 | `Pre 248 | "$(i,id) ::= (U+0030-U+0039 | U+0041-U+005A | U+0061-U+007A | U+005F)+"; 249 | `S "VARIABLE REFERENCES"; 250 | `P "Variables references are of the form \\$(VAR) where VAR is a 251 | $(b,variable identifier). In the context where variable references \ 252 | are interpreted a literal \\$ must always be escaped by \\$\\$."; 253 | `P "Variable references can be followed by an optional transform using 254 | the syntax \\$(VAR,transform). The following transforms are defined."; 255 | `I ("\\$(VAR,uncapitalize)", "Uncapitalizes the first letter of VAR's 256 | definition according to US-ASCII case maps."); 257 | `I ("\\$(VAR,capitalize)", "Capitalizes the first letter of VAR's 258 | definition according to US-ASCII case maps."); 259 | `I ("\\$(VAR,lowercase)", "Lowercases the letters of VAR's 260 | definition according to US-ASCII case maps."); 261 | `I ("\\$(VAR,uppercase)", "Uppercases the letters of VAR's 262 | definition according to US-ASCII case maps."); 263 | `I ("\\$(VAR,indent(ATOM))", "Prefixes each line of VAR's 264 | definition with the string ATOM. Lines that result in whitespace 265 | only are collapsed to an empty line."); 266 | `P "In context where variable references need to be recognized they 267 | are according to the following grammar."; 268 | `Pre "\ 269 | \ $(i,ref) ::= $(i,dollar) $(i,lpar) $(i,refc) $(i,rpar) 270 | $(i,refc) ::= $(i,id) | $(i,id) $(i,comma) $(i,transform) 271 | $(i,transform) ::= $(i,id) [ $(i,lpar) $(i,atom) $(i,rpar) ] 272 | $(i,dollar) ::= U+0024 273 | $(i,comma) ::= U+002C 274 | $(i,lpar) ::= U+0028 275 | $(i,rpar) ::= U+0029"; 276 | `S "PATTERNS"; 277 | `P "Patterns are atoms (quoted or not) in which variable references are 278 | recognized"; 279 | `Pre "$(i,pat) ::= $(i,atom)"; 280 | `S "FLESH FILES"; 281 | `P "Flesh files are sequences of variable definitions. A variable 282 | definition is a variable identifier and a pattern defining 283 | the variable value."; 284 | `Pre "\ 285 | $(i,flesh) ::= ($(i,id) $(i,pat))* 286 | "; 287 | `S "BONE FILES"; 288 | `P "Bone files are either UTF-8 encoded files in which variable references 289 | are recognized or binary files (detected by the presence of a NULL 290 | byte) which are arbitrary, uninterpreted, sequence of bytes."; 291 | `S "BODY FILES"; 292 | `P "Body files start with a documentation directive, followed 293 | by a sequence of variable documentation directives and end 294 | with a sequence of bind directives."; 295 | `P "The body documentation directive 'doc' specifies a synopsis and 296 | long description for the body."; 297 | `P "A variable documentation directive 'var' specifies documentation 298 | for a variable identifier (used for interactive variable 299 | definition)."; 300 | `P "A bind directive 'bind' specifies a relative path as a pattern 301 | and a bone or body identifier to bind to the path's content. Note 302 | that unlike command line tool arguments these identifiers cannot 303 | be absolute or start with ./, and body identifiers have to be 304 | specified with their .body extension otherwise they are taken 305 | to be bone identifiers."; 306 | `Pre "\ 307 | $(i,body) ::= $(i,doc) $(i,var)* $(i,bind)* 308 | $(i,doc) ::= \"doc\" $(i,atom) $(i,atom) 309 | $(i,var) ::= \"var\" $(i,id) $(i,atom) 310 | $(i,bind) ::= \"bind\" $(i,pat) $(i,atom)"; 311 | ] @ Cli.see_also_main_man 312 | 313 | (* Help command *) 314 | 315 | let pages = 316 | [ "basics", basics; 317 | "lookup", lookup; 318 | "syntax", syntax; ] 319 | 320 | let help man_format topic commands = match topic with 321 | | None -> `Help (man_format, None) 322 | | Some topic -> 323 | let topics = "topics" :: commands @ (List.map fst pages) in 324 | let topics = List.sort compare topics in 325 | let conv, _ = Cmdliner.Arg.enum (List.rev_map (fun s -> (s, s)) topics) in 326 | match conv topic with 327 | | `Error e -> `Error (false, e) 328 | | `Ok t when List.mem t commands -> `Help (man_format, Some t) 329 | | `Ok t when t = "topics" -> 330 | Fmt.pr "@[%a@]@." Fmt.(list string) topics; 331 | `Ok 0 332 | | `Ok t -> 333 | let man = try List.assoc t pages with Not_found -> assert false in 334 | Fmt.pr "%a" (Cmdliner.Manpage.print man_format) man; 335 | `Ok 0 336 | 337 | (* Command line interface *) 338 | 339 | open Cmdliner 340 | 341 | let topic = 342 | let doc = "The topic to get help on, `topics' lists the topic." in 343 | Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc) 344 | 345 | let doc = "show help about carcass" 346 | let man = 347 | [ `S "DESCRIPTION"; 348 | `P "The $(tname) command shows help about carcass."; 349 | `P "Use `topics' as $(i,TOPIC) to get a list of topics."; 350 | ] @ Cli.see_also_main_man 351 | 352 | let cmd = 353 | let info = Term.info "help" ~doc ~man in 354 | let t = Term.(ret (const help $ Term.man_format $ topic $ 355 | Term.choice_names)) 356 | in 357 | (t, info) 358 | 359 | (*--------------------------------------------------------------------------- 360 | Copyright (c) 2016 Daniel C. Bünzli 361 | 362 | Permission to use, copy, modify, and/or distribute this software for any 363 | purpose with or without fee is hereby granted, provided that the above 364 | copyright notice and this permission notice appear in all copies. 365 | 366 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 367 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 368 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 369 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 370 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 371 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 372 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 373 | ---------------------------------------------------------------------------*) 374 | -------------------------------------------------------------------------------- /src/carcass.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Astring 7 | open Rresult 8 | open Bos 9 | 10 | let uchar_to_string u = 11 | let b = Buffer.create 4 in 12 | Uutf.Buffer.add_utf_8 b u; 13 | Buffer.contents b 14 | 15 | let u_lf = Uchar.of_int 0x000A 16 | let u_lpar = Uchar.of_int 0x0028 17 | let u_rpar = Uchar.of_int 0x0029 18 | let u_dollar = Uchar.of_int 0x0024 19 | 20 | let pp_uchar ppf u = Fmt.pf ppf "%s" (uchar_to_string u) 21 | let pp_ucharq = Fmt.quote ~mark:"'" @@ pp_uchar 22 | 23 | (* Logging *) 24 | 25 | module Log = 26 | (val Logs.(src_log (Src.create "carcass" ~doc:"Carcass library")) : Logs.LOG) 27 | 28 | (* Locations *) 29 | 30 | module Loc = struct 31 | 32 | (* Positions *) 33 | 34 | type pos = int * int 35 | 36 | let nil_pos = (0, -1) 37 | let zero_pos = (1, 0) 38 | 39 | (* Ranges *) 40 | 41 | type range = pos * pos 42 | 43 | let nil_range = nil_pos, nil_pos 44 | let zero_range = zero_pos, zero_pos 45 | 46 | (* Locations *) 47 | 48 | type src = Builtin | Cli | File of Fpath.t 49 | type t = src * range 50 | 51 | let nil = Builtin, nil_range 52 | let for_builtin s = Builtin, (zero_pos, (1, String.length s)) 53 | let for_cli s = Cli, (zero_pos, (1, String.length s)) 54 | let for_path ?(range = zero_range) p = File p, range 55 | 56 | let pp ppf = function 57 | | Builtin, loc -> Fmt.pf ppf ":%a:" Fmt.text_loc loc 58 | | Cli, loc -> Fmt.pf ppf ":%a:" Fmt.text_loc loc 59 | | File f, loc -> Fmt.pf ppf "%a:%a:" Fpath.pp f Fmt.text_loc loc 60 | 61 | (* Traces *) 62 | 63 | type trace = t list 64 | let nil_trace = [] 65 | let pp_trace = Fmt.(vbox (list pp)) 66 | end 67 | 68 | (* Errors *) 69 | 70 | module Error = struct 71 | 72 | type unexpected = [ `Uchar of Uchar.t | `Lexeme of string | `Eoi ] 73 | 74 | let pp_unexpected ppf = function 75 | | `Uchar u -> Fmt.pf ppf "character %a (U+%04X)" pp_ucharq u (Uchar.to_int u) 76 | | `Lexeme l -> Fmt.pf ppf "lexeme %a" Fmt.(quote ~mark:"'" string) l 77 | | `Eoi -> Fmt.string ppf "end of input" 78 | 79 | type expected = 80 | [ `Keyword of string | `Id | `Lpar | `Rpar | `Qmark | `Comma | `Dollar 81 | | `Escaped_char | `Atom ] 82 | 83 | let pp_expected ppf = function 84 | | `Keyword k -> Fmt.pf ppf "%a" Fmt.(quote ~mark:"'" string) k 85 | | `Id -> Fmt.string ppf "identifier" 86 | | `Lpar -> Fmt.pf ppf "opening@ parenthesis '('" 87 | | `Rpar -> Fmt.pf ppf "closing@ parenthesis ')'" 88 | | `Qmark -> Fmt.pf ppf "closing@ quotation mark '\"'" 89 | | `Comma -> Fmt.string ppf "comma ','" 90 | | `Dollar -> Fmt.string ppf "dollar '$'" 91 | | `Escaped_char -> Fmt.pf ppf "escape@ character" 92 | | `Atom -> Fmt.string ppf "atom" 93 | 94 | type parse_err = 95 | | Illegal_bytes of string 96 | | Illegal_escape of Uchar.t 97 | | Illegal_variable_transform of string 98 | | Illegal_binding_id of string 99 | | Unclosed of [ `Quoted_atom | `Var_ref ] 100 | | Unexpected of unexpected * expected list 101 | 102 | type parse = [`Carcass_parse of parse_err * Loc.t ] 103 | 104 | let pp_exp_one_of ~pp_v ppf = function 105 | | [] -> assert false 106 | | [v] -> Fmt.pf ppf "expected@ %a" pp_v v 107 | | l -> Fmt.pf ppf "expected@ one@ of@ %a" Fmt.(list ~sep:(unit ",@ ") pp_v) l 108 | 109 | let pp_parse_err ppf = function 110 | | Illegal_bytes b -> 111 | Fmt.pf ppf "illegal@ byte@ sequence@ %a" String.dump b 112 | | Illegal_escape u -> 113 | Fmt.pf ppf "illegal@ escape@ character@ (U+%04X)" (Uchar.to_int u) 114 | | Illegal_variable_transform t -> 115 | Fmt.pf ppf "illegal@ variable@ transform@ %a" String.dump t 116 | | Illegal_binding_id id -> 117 | Fmt.pf ppf "illegal@ binding@ identifier (%a)" String.dump id 118 | | Unclosed `Quoted_atom -> 119 | Fmt.pf ppf "unclosed quoted@ atom" 120 | | Unclosed `Var_ref -> 121 | Fmt.pf ppf "unclosed variable@ reference" 122 | | Unexpected (u, exps) -> 123 | Fmt.pf ppf "unexpected@ %a@ %a" 124 | pp_unexpected u (pp_exp_one_of ~pp_v:pp_expected) exps 125 | 126 | let pp_parse ppf (`Carcass_parse (e, loc)) = 127 | Fmt.pf ppf "@[@[syntax error, %a@]@,%a@]" 128 | pp_parse_err e Loc.pp loc 129 | 130 | exception Parse_exn of parse 131 | let parse e l = raise (Parse_exn (`Carcass_parse (e, l))) 132 | 133 | (* Evaluation errors *) 134 | 135 | type eval_id = [ `Var of string | `Bone of string | `Body of string ] 136 | 137 | type eval_err = 138 | | Circular of eval_id 139 | | Parse of eval_id * [ parse | R.msg ] 140 | | Undefined of eval_id 141 | | Bound_path of string * [ `Illegal | `Escapes ] 142 | 143 | type eval = [`Carcass_eval of eval_err * Loc.trace ] 144 | 145 | let pp_eval_id ppf = function 146 | | `Var var -> Fmt.pf ppf "variable@ '%s'" var 147 | | `Body id -> Fmt.pf ppf "body@ '%s'" id 148 | | `Bone id -> Fmt.pf ppf "bone@ '%s'" id 149 | 150 | let pp_eval_err ppf = function 151 | | Circular id -> 152 | Fmt.pf ppf "circular@ definition@ of@ %a" pp_eval_id id 153 | | Parse (id, parse) -> 154 | Fmt.pf ppf "definition of %a:@ " pp_eval_id id; 155 | begin match parse with 156 | | `Carcass_parse _ as parse -> pp_parse ppf parse 157 | | `Msg _ as msg -> R.pp_msg ppf msg 158 | end 159 | | Undefined id -> 160 | Fmt.pf ppf "undefined@ %a" pp_eval_id id 161 | | Bound_path (p, `Illegal) -> 162 | Fmt.pf ppf "illegal@ bound@ path@ '%s'" p 163 | | Bound_path (p, `Escapes) -> 164 | Fmt.pf ppf "bound@ path@ '%s'@ escapes@ the@ body@ root" p 165 | 166 | let pp_eval ppf (`Carcass_eval (e, trace)) = 167 | Fmt.pf ppf "@[@[%a@]@,%a@]" pp_eval_err e Loc.pp_trace trace 168 | 169 | exception Eval of eval 170 | let eval e locs = raise (Eval (`Carcass_eval (e, locs))) 171 | end 172 | 173 | (* Carcass lexer. *) 174 | 175 | module Lexer : sig 176 | type t 177 | 178 | val create : 179 | ?nln:bool -> src:Loc.src -> 180 | [ `String of string | `Channel of in_channel ] -> t 181 | 182 | val peek_pos : t -> Loc.pos 183 | val prev_pos : t -> Loc.pos 184 | val peek_loc : t -> Loc.t 185 | val loc : t -> Loc.pos -> Loc.pos -> Loc.t 186 | val peek : t -> [`Uchar of Uchar.t | `End ] 187 | val next : t -> unit 188 | 189 | val add : t -> Uchar.t -> unit 190 | val add_escape : t -> unit 191 | val lexeme : t -> string 192 | 193 | val skip_white : t -> unit 194 | val lex_while : t -> (Uchar.t -> bool) -> string 195 | val lex_uchar : t -> Uchar.t -> Error.expected -> unit 196 | val lex_id : t -> string * Loc.t 197 | val lex_id_or_eoi : t -> (string * Loc.t) option 198 | val lex_keyword : Error.expected list -> t -> (string * Loc.t) option 199 | 200 | val is_atom_end : Uchar.t -> bool 201 | val is_quoted_atom_end : Uchar.t -> bool 202 | val lex_atom : t -> string * Loc.t 203 | end = struct 204 | 205 | type t = 206 | { src : Loc.src; 207 | d : Uutf.decoder; 208 | buf : Buffer.t; 209 | mutable prev_line : int; 210 | mutable prev_col : int; 211 | mutable peek : [ `Uchar of Uchar.t | `End | `Start ]; } 212 | 213 | let nln_lf = Some (`ASCII u_lf (* LF *)) 214 | let create ?(nln = true) ~src input = 215 | let nln = if nln then nln_lf else None in 216 | let d = Uutf.decoder ~encoding:`UTF_8 ?nln input in 217 | { src; d; buf = Buffer.create 1024; 218 | prev_line = 0; prev_col = 0; 219 | peek = `Start } 220 | 221 | let peek_pos l = Uutf.decoder_line l.d, Uutf.decoder_col l.d 222 | let peek_loc l = let loc = peek_pos l in l.src, (loc, loc) 223 | let prev_pos l = l.prev_line, l.prev_col 224 | let loc l start stop = l.src, (start, stop) 225 | 226 | let next l = 227 | l.prev_line <- Uutf.decoder_line l.d; 228 | l.prev_col <- Uutf.decoder_col l.d; 229 | match Uutf.decode l.d with 230 | | (`Uchar _ | `End) as c -> l.peek <- c 231 | | `Malformed b -> Error.(parse (Illegal_bytes b) (peek_loc l)) 232 | | `Await -> assert false 233 | 234 | let rec peek l = match l.peek with 235 | | `Start -> next l; peek l 236 | | (`Uchar _ | `End) as d -> d 237 | 238 | let add l u = Uutf.Buffer.add_utf_8 l.buf u 239 | let add_escape l = match peek l with 240 | | `End -> 241 | Error.(parse (Unexpected (`Eoi, [`Escaped_char])) (peek_loc l)) 242 | | `Uchar u -> 243 | match Uchar.to_int u with 244 | | (0x0020 (* space *) | 0x0022 (* quote *) | 0x005C (* \ *)) -> 245 | next l; add l u 246 | | 0x006E (* n *) -> 247 | next l; add l u_lf 248 | | 0x000A (* LF *) -> 249 | let rec loop l = match peek l with (* skip initial white *) 250 | | `Uchar u -> 251 | begin match Uchar.to_int u with 252 | | 0x0020 (* space *) | 0x0009 (* tab *) -> next l; loop l 253 | | _ -> () 254 | end 255 | | _ -> () 256 | in 257 | next l; loop l 258 | | _ -> 259 | Error.(parse (Illegal_escape u) (peek_loc l)) 260 | 261 | let lexeme l = 262 | let s = Buffer.contents l.buf in Buffer.clear l.buf; s 263 | 264 | let is_sharp u = Uchar.to_int u = 0x0023 265 | let is_white u = match Uchar.to_int u with 266 | | 0x0020 (* sp *) | 0x0009 (* tab *) | 0x000A (* LF *) 267 | | 0x000B (* vt *) | 0x000C (* FF *) -> true 268 | | _ -> false 269 | 270 | let rec skip_white l = match peek l with 271 | | `Uchar u when is_white u -> 272 | let rec loop l = match peek l with 273 | | `Uchar u when is_white u -> next l; loop l 274 | | _ -> () 275 | in 276 | next l; loop l; skip_white l 277 | | `Uchar u when is_sharp u (* #, comment *) -> 278 | let rec loop l = match peek l with 279 | | `Uchar u when Uchar.equal u u_lf -> () 280 | | _ -> next l; loop l 281 | in 282 | next l; loop l; next l; skip_white l 283 | | `End | `Uchar _ -> () 284 | 285 | let rec lex_while l sat = match peek l with 286 | | `Uchar u when sat u -> add l u; next l; lex_while l sat 287 | | _ -> lexeme l 288 | 289 | let is_id_char u = 290 | let u = Uchar.to_int u in 291 | (0x0030 <= u && u <= 0x0039) || (* 0 .. 9 *) 292 | (0x0041 <= u && u <= 0x005A) || (* A .. Z *) 293 | (0x0061 <= u && u <= 0x007A) || (* a .. z *) 294 | (0x005F = u) (* _ *) 295 | 296 | let lex_uchar l u exp = match (skip_white l; peek l) with 297 | | `Uchar u' when Uchar.equal u' u -> () 298 | | `Uchar u' -> 299 | Error.(parse (Unexpected (`Uchar u', [exp])) (peek_loc l)) 300 | | `End -> 301 | Error.(parse (Unexpected (`Eoi, [exp])) (peek_loc l)) 302 | 303 | let lex_id_or_eoi l = match (skip_white l; peek l) with 304 | | `Uchar u when is_id_char u -> 305 | let start = peek_pos l in 306 | let id = lex_while l is_id_char in 307 | Some (id, loc l start (prev_pos l)) 308 | | `Uchar u -> 309 | Error.(parse (Unexpected (`Uchar u, [`Id])) (peek_loc l)) 310 | | `End -> None 311 | 312 | let lex_id l = match lex_id_or_eoi l with 313 | | None -> Error.(parse (Unexpected (`Eoi, [`Id])) (peek_loc l)) 314 | | Some id -> id 315 | 316 | let is_keyword_char u = 317 | let u = Uchar.to_int u in 318 | (0x0061 <= u && u <= 0x007A) (* a .. z *) 319 | 320 | let lex_keyword ks l = match (skip_white l; peek l) with 321 | | `Uchar u when is_keyword_char u -> 322 | let start = peek_pos l in 323 | let keyword = lex_while l is_keyword_char in 324 | Some (keyword, loc l start (prev_pos l)) 325 | | `Uchar u -> Error.(parse (Unexpected (`Uchar u, ks)) (peek_loc l)) 326 | | `End -> None 327 | 328 | (* Lexing atoms *) 329 | 330 | let is_quoted_atom_end u = match Uchar.to_int u with 331 | | 0x0022 (* quote *) -> true | _ -> false 332 | 333 | let is_atom_end = function 334 | | u when is_white u -> true 335 | | u -> 336 | match Uchar.to_int u with 337 | | 0x0022 (* qmark *) | 0x0023 (* # *) -> true 338 | | _ -> false 339 | 340 | let lex_quoted_atom l = 341 | let rec loop l start = match peek l with 342 | | `End -> 343 | Error.(parse (Unclosed `Quoted_atom) (loc l start (peek_pos l))) 344 | | `Uchar u -> 345 | match Uchar.to_int u with 346 | | 0x005C (* \ *) -> next l; add_escape l; loop l start 347 | | 0x0022 (* qmark *) -> next l; lexeme l, loc l start (prev_pos l) 348 | | _ -> add l u; next l; loop l start 349 | in 350 | let start = peek_pos l in 351 | next l; loop l start 352 | 353 | let lex_simple_atom l = 354 | let rec loop l start = match peek l with 355 | | `Uchar u when not (is_atom_end u) -> add l u; next l; loop l start 356 | | _ -> lexeme l, loc l start (prev_pos l) 357 | in 358 | loop l (peek_pos l) 359 | 360 | let lex_atom l = match (skip_white l; peek l) with 361 | | `End -> Error.(parse (Unexpected (`Eoi, [`Atom])) (peek_loc l)) 362 | | `Uchar u -> 363 | match Uchar.to_int u with 364 | | 0x0022 (* qmark *) -> lex_quoted_atom l 365 | | _ -> lex_simple_atom l 366 | end 367 | 368 | (* Patterns *) 369 | 370 | module Pat = struct 371 | 372 | (* Variable reference transforms *) 373 | 374 | type transform = 375 | | Uppercase | Lowercase | Capitalize | Uncapitalize | Indent of string 376 | 377 | let transform t s = match t with 378 | | None -> s 379 | | Some Uppercase -> String.Ascii.uppercase s 380 | | Some Lowercase -> String.Ascii.lowercase s 381 | | Some Capitalize -> String.Ascii.capitalize s 382 | | Some Uncapitalize -> String.Ascii.uncapitalize s 383 | | Some Indent prefix -> 384 | let lines = String.cuts ~sep:"\n" s in 385 | let add_prefix l = 386 | let p = prefix ^ l in 387 | if String.for_all Char.Ascii.is_white p then "" else p 388 | in 389 | String.concat ~sep:"\n" (List.rev @@ List.rev_map add_prefix lines) 390 | 391 | let transform_to_string = function 392 | | Uppercase -> "uppercase" 393 | | Lowercase -> "lowercase" 394 | | Capitalize -> "capitalize" 395 | | Uncapitalize -> "uncapitalize" 396 | | Indent prefix -> strf "indent(%a)" String.dump prefix 397 | 398 | let pp_transform = Fmt.of_to_string transform_to_string 399 | 400 | (* Patterns *) 401 | 402 | type lexeme = Lit of string | Var of string * transform option 403 | type t = (lexeme * Loc.t) list * Loc.t 404 | 405 | (* Parsing *) 406 | 407 | let parse_transform_arg l = 408 | Lexer.lex_uchar l u_lpar `Lpar; 409 | let atom, _ = Lexer.(next l; skip_white l; lex_atom l) in 410 | Lexer.lex_uchar l u_rpar `Rpar; 411 | Lexer.next l; 412 | atom 413 | 414 | let parse_transform l = 415 | let tr, loc = Lexer.lex_id l in 416 | match tr with 417 | | "uppercase" -> Uppercase 418 | | "lowercase" -> Lowercase 419 | | "capitalize" -> Capitalize 420 | | "uncapitalize" -> Uncapitalize 421 | | "indent" -> Indent (parse_transform_arg l) 422 | | _ -> Error.(parse (Illegal_variable_transform tr) loc) 423 | 424 | let parse_variable_reference l start = (* $( already eaten *) 425 | let id = String.Ascii.uppercase @@ fst (Lexer.lex_id l) in 426 | match (Lexer.skip_white l; Lexer.peek l) with 427 | | `End -> 428 | Error.(parse (Unclosed `Var_ref) (Lexer.peek_loc l)) 429 | | `Uchar u -> 430 | match Uchar.to_int u with 431 | | 0x0029 (* ) *) -> 432 | Lexer.next l; 433 | Var (id, None), Lexer.(loc l start (prev_pos l)) 434 | | 0x002C (* , *) -> 435 | let tr = (Lexer.next l; parse_transform l) in 436 | begin match Lexer.peek l with 437 | | `Uchar u -> 438 | begin match Uchar.to_int u with 439 | | 0x0029 (* ) *) -> 440 | Lexer.next l; 441 | Var (id, Some tr), Lexer.(loc l start (prev_pos l)) 442 | | _ -> 443 | Error.(parse (Unexpected (`Uchar u, [`Rpar])) 444 | (Lexer.peek_loc l)) 445 | end 446 | | `End -> 447 | Error.(parse (Unclosed (`Var_ref)) (Lexer.peek_loc l)) 448 | end 449 | | _ -> 450 | Error.(parse (Unexpected (`Uchar u, [`Rpar; `Comma])) 451 | (Lexer.peek_loc l)) 452 | 453 | let parse_pat l ~escapes stop = 454 | let rec loop l start acc = match Lexer.peek l with 455 | | `Uchar u -> 456 | begin match Uchar.to_int u with 457 | | 0x0024 (* $ *) -> 458 | let vref_start = Lexer.peek_pos l in 459 | begin match (Lexer.next l; Lexer.peek l) with 460 | | `Uchar u -> 461 | begin match Uchar.to_int u with 462 | | 0x0024 (* $ *) -> (* $$ escape *) 463 | Lexer.add l u_dollar; Lexer.next l; loop l start acc 464 | | 0x0028 (* ( *) -> 465 | let acc = match Lexer.lexeme l with 466 | | "" (* no running litteral *) -> acc 467 | | lit -> (Lit lit, Lexer.loc l start vref_start) :: acc 468 | in 469 | let vref = 470 | (Lexer.next l; parse_variable_reference l vref_start) in 471 | loop l (Lexer.peek_pos l) (vref :: acc) 472 | | _ -> 473 | Error.(parse (Unexpected (`Uchar u, [`Lpar; `Dollar])) 474 | (Lexer.peek_loc l)) 475 | end 476 | | `End -> 477 | Error.(parse (Unclosed `Var_ref) (Lexer.peek_loc l)) 478 | end 479 | 480 | | 0x005C (* \ *) when escapes -> 481 | Lexer.next l; Lexer.add_escape l; loop l start acc 482 | | _ when not (stop u) -> 483 | Lexer.add l u; Lexer.next l; loop l start acc 484 | | _ -> 485 | let lit = Lexer.(Lit (lexeme l), loc l start (prev_pos l)) in 486 | List.rev (lit :: acc) 487 | end 488 | | `End -> 489 | let lit = Lexer.(Lit (lexeme l), loc l start (prev_pos l)) in 490 | List.rev (lit :: acc) 491 | in 492 | loop l (Lexer.peek_pos l) [] 493 | 494 | let parse_or_eoi l = match (Lexer.skip_white l; Lexer.peek l) with 495 | | `End -> None 496 | | `Uchar u -> 497 | match Uchar.to_int u with 498 | | 0x0022 (* qmark *) -> 499 | let start = Lexer.peek_pos l in 500 | let pat = (Lexer.next l; 501 | parse_pat l ~escapes:true Lexer.is_quoted_atom_end) 502 | in 503 | begin match Lexer.peek l with 504 | | `End -> 505 | Error.(parse (Unclosed `Quoted_atom) 506 | Lexer.(loc l start (peek_pos l))) 507 | | `Uchar u -> 508 | begin match Uchar.to_int u with 509 | | 0x0022 (* qmark *) -> 510 | Lexer.next l; Some (pat, Lexer.(loc l start (prev_pos l))) 511 | | _ -> 512 | Error.(parse (Unexpected (`Uchar u, [`Qmark])) 513 | (Lexer.peek_loc l)) 514 | end 515 | end 516 | | _ -> 517 | let start = Lexer.peek_pos l in 518 | let pat = parse_pat l ~escapes:false Lexer.is_atom_end in 519 | Some (pat, Lexer.(loc l start (prev_pos l))) 520 | 521 | let parse l = match parse_or_eoi l with 522 | | None -> Error.(parse (Unexpected (`Eoi, [`Atom])) (Lexer.peek_loc l)) 523 | | Some pat -> pat 524 | 525 | let empty = [], Loc.for_builtin "" 526 | 527 | let dom (p, _) = 528 | let rec loop acc = function 529 | | (Lit _, _) :: ls -> loop acc ls 530 | | (Var (id, _), _) :: ls -> loop (String.Set.add id acc) ls 531 | | [] -> acc 532 | in 533 | loop String.Set.empty p 534 | 535 | let equal p p' = p = p' 536 | let compare p p' = compare p p' 537 | let to_string ?(flesh = false) (p, _) = 538 | let b = Buffer.create 255 in 539 | let add = function 540 | | (Lit l, _) -> 541 | let max_i = String.length l - 1 in 542 | let rec loop start i = 543 | if i > max_i then Buffer.add_substring b l start (i - start) else 544 | let next = i + 1 in 545 | match l.[i] with 546 | | '$' -> (* escape $ *) 547 | Buffer.add_substring b l start (next - start); 548 | Buffer.add_char b '$'; 549 | loop next next 550 | | ('"' | '\\' as c) when flesh -> (* escape '"' and '\\' *) 551 | Buffer.add_substring b l start (next - start - 1); 552 | Buffer.add_char b '\\'; 553 | Buffer.add_char b c; 554 | loop next next 555 | | _ -> loop start next 556 | in 557 | loop 0 0 558 | | (Var (v, tr), _) -> 559 | Buffer.add_string b "$("; 560 | Buffer.add_string b v; 561 | begin match tr with 562 | | None -> () 563 | | Some tr -> 564 | Buffer.add_char b ','; 565 | Buffer.add_string b (transform_to_string tr) 566 | end; 567 | Buffer.add_string b ")"; 568 | in 569 | List.iter add p; 570 | Buffer.contents b 571 | 572 | let of_input ?(flesh = false) ~src i = 573 | try 574 | let l = Lexer.create ~nln:false ~src i in 575 | let start = Lexer.peek_pos l in 576 | let pat = parse_pat l ~escapes:flesh (fun _ -> false) in 577 | let stop = Lexer.peek_pos l in 578 | let loc = src, (start, stop) in 579 | Ok (pat, loc) 580 | with Error.Parse_exn (`Carcass_parse _ as e) -> Error e 581 | 582 | let pp ?flesh = Fmt.of_to_string (to_string ?flesh) 583 | 584 | (* Substitution *) 585 | 586 | let subst subst (p, loc) = 587 | let rec loop acc = function 588 | | (Lit _, _ as lit) :: p -> loop (lit :: acc) p 589 | | (Var (v, tr), loc as var) :: p -> 590 | begin match subst v with 591 | | None -> loop (var :: acc) p 592 | | Some lit -> loop ((Lit (transform tr lit), loc) :: acc) p 593 | end 594 | | [] -> List.rev acc 595 | in 596 | loop [] p, loc 597 | 598 | (* Evaluation *) 599 | 600 | type env = 601 | { defs : t String.map; 602 | undef : string -> (t, Error.parse) result option; 603 | mutable eval_cache : string String.map; } 604 | 605 | let env ?(undef = fun _ -> None) defs = 606 | { defs; undef; eval_cache = String.Map.empty } 607 | 608 | let eval_cache env var = String.Map.find var env.eval_cache 609 | let var_def locs env var = match String.Map.find var env.defs with 610 | | Some pat -> pat 611 | | None -> 612 | if String.is_prefix "CARCASS_MATCH_" var then empty else 613 | match env.undef var with 614 | | Some (Ok pat) -> pat 615 | | None -> Error.(eval (Undefined (`Var var)) locs) 616 | | Some Error (`Carcass_parse _ as e) -> 617 | Error.(eval (Parse (`Var var, e)) locs) 618 | let rec eval env stack b seen locs = function 619 | | [] -> 620 | begin match stack with 621 | | [] -> Buffer.contents b 622 | | (b', seen, locs, pat, var) :: stack -> 623 | let value = Buffer.contents b in 624 | env.eval_cache <- String.Map.add var value env.eval_cache; 625 | eval env stack b' seen locs pat 626 | end 627 | | (Lit lit, _) :: p -> 628 | Buffer.add_string b lit; eval env stack b seen locs p 629 | | (Var (var, tr), ref_loc) :: p as pat -> 630 | if String.Set.mem var seen 631 | then Error.(eval (Circular (`Var var)) (ref_loc :: locs)) else 632 | match eval_cache env var with 633 | | Some value -> 634 | Buffer.add_string b (transform tr value); 635 | eval env stack b seen locs p 636 | | None -> 637 | let stack = (b, seen, locs, pat, var) :: stack in 638 | let pat, def_loc = var_def (ref_loc :: locs) env var in 639 | let b = Buffer.create 255 in 640 | let locs = def_loc :: ref_loc :: locs in 641 | let seen = String.Set.add var seen in 642 | eval env stack b seen locs pat 643 | 644 | let env_var_value env var = 645 | match String.Map.find var env.defs with 646 | | None -> None 647 | | Some (_, loc) -> 648 | let pat = [Var (var, None), Loc.nil] in 649 | let result = 650 | try Ok (eval env [] (Buffer.create 255) String.Set.empty [] pat, loc) 651 | with Error.Eval (`Carcass_eval (e, trace)) -> 652 | let trace = List.(rev (tl (rev trace))) in 653 | (Result.Error (`Carcass_eval (e, trace))) 654 | in 655 | Some result 656 | 657 | let eval env (pat, loc) = 658 | try Ok (eval env [] (Buffer.create 255) String.Set.empty [loc] pat, loc) 659 | with Error.Eval (`Carcass_eval _ as e) -> Error e 660 | 661 | (* Matching *) 662 | 663 | let match_lit ~lit start s = (* matches [lit] at [start] in [s]. *) 664 | let l_max = String.length lit - 1 in 665 | let s_max = String.length s - start - 1 in 666 | if l_max > s_max then None else 667 | let rec loop i = 668 | if i > l_max then Some (start + l_max + 1) else 669 | if lit.[i] <> s.[start + i] then None else 670 | loop (i + 1) 671 | in 672 | loop 0 673 | 674 | let query ?(init = String.Map.empty) (p, _) s = 675 | (* Not tail-recursive but bounded by number of variables *) 676 | let rec loop env start s = function 677 | | [] -> if start = String.length s then Some env else None 678 | | (Lit lit, _) :: p -> 679 | begin match (match_lit ~lit start s) with 680 | | None -> None 681 | | Some start -> loop env start s p 682 | end 683 | | (Var (v, _), _) :: p -> 684 | let rec try_match next_start = 685 | if next_start < start then None else 686 | match loop env next_start s p with 687 | | None -> try_match (next_start - 1) 688 | | Some env' -> 689 | let value = 690 | String.with_index_range s ~first:start ~last:(next_start - 1) 691 | in 692 | Some (String.Map.add v value env') 693 | in 694 | try_match (String.length s) (* Longest match first. *) 695 | in 696 | loop init 0 s p 697 | end 698 | 699 | (* Environments *) 700 | 701 | module Env = struct 702 | 703 | (* Directories *) 704 | 705 | let etc_dir = Carcass_etc.dir 706 | let user_dir () = OS.Dir.user () >>| fun home -> Fpath.(home / ".carcass") 707 | 708 | (* Environments *) 709 | 710 | type t = 711 | { dirs : Fpath.t list; 712 | flesh : Fpath.t list; 713 | cli : (string * Pat.t) list; } 714 | 715 | let v ~no_user_dir ~no_dot_dirs ~dirs ~flesh ~cli = 716 | let dirs = 717 | if no_dot_dirs then dirs else 718 | let rec loop dir dirs = 719 | let carcass = Fpath.(dir / ".carcass") in 720 | let dirs = 721 | begin OS.Dir.exists carcass >>| function 722 | | true -> carcass :: dirs 723 | | false -> dirs 724 | end 725 | |> Log.on_error_msg ~level:Logs.Warning ~use:(fun () -> dirs) 726 | in 727 | let dir = Fpath.parent dir in 728 | if Fpath.is_root dir then dirs else loop dir dirs 729 | in 730 | (OS.Dir.current () >>| fun dir -> loop dir dirs) 731 | |> Log.on_error_msg ~level:Logs.Warning ~use:(fun () -> dirs) 732 | in 733 | let dirs = 734 | if no_user_dir then dirs else 735 | begin user_dir () >>| fun u -> 736 | if List.exists (Fpath.equal u) dirs then dirs else (u :: dirs) 737 | end 738 | |> R.reword_error_msg ~replace:true 739 | (fun err -> R.msgf "No user ~/.carcass directory: %s" err) 740 | |> Log.on_error_msg ~level:Logs.Warning ~use:(fun () -> dirs) 741 | in 742 | { dirs; flesh; cli } 743 | 744 | let flesh_files env = 745 | let add_dir_flesh acc dir = 746 | let flesh = Fpath.(dir / "flesh") in 747 | begin OS.File.exists flesh >>| function 748 | | true -> flesh :: acc 749 | | false -> acc 750 | end 751 | |> Log.on_error_msg ~level:Logs.Warning ~use:(fun () -> acc) 752 | in 753 | List.(rev_append (fold_left add_dir_flesh [] env.dirs) env.flesh) 754 | 755 | let path_exists p = 756 | OS.Path.exists p 757 | |> Log.on_error_msg ~level:Logs.Warning ~use:(fun () -> false) 758 | 759 | let file_with_id ?ext env id = 760 | if Fpath.(filename id = "flesh") then None else 761 | if Fpath.(equal id OS.File.dash) then Some id else 762 | if Fpath.(is_current_dir ~prefix:true id || is_abs id) then 763 | (if path_exists id then Some id else None) 764 | else 765 | let id = match ext with 766 | | None -> id 767 | | Some e -> if Fpath.has_ext e id then id else Fpath.(id + e) 768 | in 769 | let rec loop = function 770 | | [] -> None 771 | | d :: dirs -> 772 | let p = Fpath.(d // id) in 773 | if path_exists p 774 | then (Log.info (fun m -> m "Hit %a" Fpath.pp p); Some p) 775 | else (Log.info (fun m -> m "Miss %a" Fpath.pp p); loop dirs) 776 | in 777 | loop (List.rev env.dirs) 778 | 779 | let list_ids ?(hidden = false) ~is_kind env = 780 | let is_id p = 781 | OS.File.exists p >>| function 782 | | false -> false 783 | | true -> 784 | let fname = Fpath.filename p in 785 | let hidden_id = String.is_prefix "_" fname in 786 | let flesh_file = fname = "flesh" in 787 | let is_kind = is_kind p in 788 | not flesh_file && is_kind && (not hidden_id || hidden) 789 | in 790 | let rec loop acc = function 791 | | [] -> acc 792 | | d :: dirs -> 793 | let add_bone p acc = 794 | let id = match Fpath.rem_prefix d p with 795 | | None -> assert false 796 | | Some id -> id 797 | in 798 | if Fpath.Map.mem id acc then acc else Fpath.Map.add id p acc 799 | in 800 | let acc = 801 | if not (path_exists d) then acc else 802 | (OS.Dir.fold_contents ~elements:(`Sat is_id) add_bone acc d) 803 | |> Log.on_error_msg ~level:Logs.Warning ~use:(fun () -> acc) 804 | in 805 | loop acc dirs 806 | in 807 | loop Fpath.Map.empty (List.rev env.dirs) 808 | end 809 | 810 | (* Ask values *) 811 | 812 | module Ask = struct 813 | 814 | type ('a, 'b) t = ('a, Format.formatter, unit, 'b) format4 -> 'a 815 | 816 | let _value ?(ppf = Fmt.stdout) ~parse fmt = 817 | let k ppf = try parse (input_line stdin) with 818 | | End_of_file -> parse "" 819 | in 820 | Format.kfprintf k ppf ("@[<1>" ^^ fmt ^^ "@]@?") 821 | 822 | let value = _value 823 | 824 | let pattern ?ppf fmt = 825 | let parse s = 826 | Pat.of_input ~flesh:true ~src:(Loc.File OS.File.dash) (`String s) 827 | in 828 | _value ?ppf ~parse fmt 829 | 830 | let bool ?ppf ~default fmt = 831 | let choices = format_of_string @@ match default with 832 | | true -> " [Y/n] " 833 | | false -> " [y/N] " 834 | in 835 | let parse s = match String.Ascii.lowercase s with 836 | | "yes" | "y" | "1" -> true 837 | | "no" | "n" | "0" -> false 838 | | _ -> default 839 | in 840 | _value ?ppf ~parse (fmt ^^ choices) 841 | 842 | let string ?ppf ~default fmt = 843 | let parse = function "" -> default | s -> s in 844 | _value ?ppf ~parse fmt 845 | end 846 | 847 | (* Flesh (variable definitions) *) 848 | 849 | module Flesh = struct 850 | 851 | (* Builtins *) 852 | 853 | let carcass_year () = 854 | let current_year = strf "%d" @@ Unix.((gmtime @@ time ()).tm_year) + 1900 in 855 | let loc = Loc.for_builtin current_year in 856 | [Pat.Lit current_year, loc], loc 857 | 858 | let builtins = 859 | String.Map.(empty |> add "CARCASS_YEAR" (carcass_year ())) 860 | 861 | (* Flesh *) 862 | 863 | type t = Pat.t String.map 864 | 865 | let _of_input ~src acc i = 866 | let l = Lexer.create ~src i in 867 | let rec loop l acc = match Lexer.lex_id_or_eoi l with 868 | | None -> Ok acc 869 | | Some (id, (src, (def_start, _))) -> 870 | let id = String.Ascii.uppercase id in 871 | let (pat, (_, (_, def_end))) = Pat.parse l in 872 | let loc = src, (def_start, def_end) in 873 | loop l (String.Map.add id (pat, loc) acc) 874 | in 875 | try loop l acc with Error.Parse_exn (`Carcass_parse _ as e) -> Error e 876 | 877 | let of_input ?(init = builtins) ~src i = _of_input ~src builtins i 878 | 879 | let add_flesh_file acc f = 880 | let read ic acc = _of_input ~src:(Loc.File f) acc (`Channel ic) in 881 | OS.File.with_ic f read acc 882 | |> Log.on_error_msg ~level:Logs.Warning ~use:(fun () -> Ok acc) 883 | 884 | let rec add_flesh_files acc = function 885 | | [] -> Ok acc 886 | | f :: fs -> 887 | Log.info (fun m -> m "Reading flesh %a" Fpath.pp f); 888 | add_flesh_file acc f >>= fun acc -> add_flesh_files acc fs 889 | 890 | let rec add_cli_flesh acc defs = 891 | let add acc (id, pat) = 892 | String.Map.add (String.Ascii.uppercase id) pat acc 893 | in 894 | List.fold_left add acc defs 895 | 896 | let of_env ?(init = builtins) env = 897 | Ok init 898 | >>= fun defs -> add_flesh_files defs (Env.flesh_files env) 899 | >>= fun defs -> Ok (add_cli_flesh defs env.Env.cli) 900 | 901 | let pp_def = Fmt.quote (Pat.pp ~flesh:true) 902 | let pp = 903 | let pp_binding ppf (var, def) = Fmt.pf ppf "%s %a" var pp_def def in 904 | Fmt.vbox (String.Map.pp pp_binding) 905 | end 906 | 907 | (* Bones *) 908 | 909 | module Bone = struct 910 | 911 | (* Lookup *) 912 | 913 | type id = Fpath.t 914 | 915 | let find env id = 916 | if Fpath.(has_ext ".body" id) then None else Env.file_with_id env id 917 | 918 | let list ?hidden env = 919 | let is_bone p = not Fpath.(has_ext ".body" p) in 920 | Env.list_ids ?hidden ~is_kind:is_bone env 921 | 922 | (* Bones *) 923 | 924 | type content = Binary of string | Pat of Pat.t 925 | type t = { id : id; content : content; is_exec : bool } 926 | 927 | let id b = b.id 928 | let content b = b.content 929 | let is_exec b = b.is_exec 930 | 931 | let of_input ?(trim = false) ~src (`String bytes) ~is_exec id = 932 | match String.exists (Char.equal '\x00') bytes with 933 | | true -> Ok { id; content = Binary bytes; is_exec } 934 | | false -> 935 | let bytes = if trim then String.trim bytes else bytes in 936 | Pat.of_input ~flesh:false ~src (`String bytes) 937 | >>= fun pat -> Ok { id; content = Pat pat; is_exec } 938 | 939 | let of_path ?trim p id = 940 | OS.Path.Mode.get p 941 | >>= fun mode -> OS.File.read p 942 | >>= fun bytes -> 943 | let is_exec = (mode land 0o100) <> 0 in 944 | of_input ?trim ~src:(Loc.File p) (`String bytes) ~is_exec id 945 | 946 | let eval env b = match b.content with 947 | | Binary b -> Ok b 948 | | Pat p -> 949 | match Pat.eval env p with 950 | | Error _ as e -> e 951 | | Ok (s, _) -> Ok s 952 | end 953 | 954 | module Body = struct 955 | 956 | (* Lookup *) 957 | 958 | type id = Fpath.t 959 | 960 | let find env id = Env.file_with_id ~ext:".body" env id 961 | let list ?hidden env = 962 | let is_body p = Fpath.(has_ext ".body" p) in 963 | Env.list_ids ?hidden ~is_kind:is_body env 964 | 965 | (* Bodies *) 966 | 967 | type binding_id = Fpath.t 968 | type t = 969 | { id : Fpath.t; 970 | doc : string * string; 971 | var_docs : string String.map; 972 | bindings : (Pat.t * (binding_id * Loc.t)) list; } 973 | 974 | let id b = b.id 975 | let doc b = b.doc 976 | let var_docs b = b.var_docs 977 | let bindings b = b.bindings 978 | 979 | let parse_doc l = 980 | let exp = [`Keyword "doc" ] in 981 | match Lexer.lex_keyword exp l with 982 | | None -> 983 | Error.(parse (Unexpected (`Eoi, exp)) (Lexer.peek_loc l)) 984 | | Some (k, loc) when k <> "doc" -> 985 | Error.(parse (Unexpected (`Lexeme k, exp)) loc) 986 | | Some _ -> 987 | let synopsis, _ = Lexer.lex_atom l in 988 | let descr, _ = Lexer.lex_atom l in 989 | synopsis, descr 990 | 991 | let rec parse_var_docs l = 992 | let exp = [`Keyword "var"; `Keyword "bind"] in 993 | let rec loop acc = match Lexer.lex_keyword exp l with 994 | | None -> 995 | acc, None 996 | | Some (k, loc) as lexeme when k <> "var" -> 997 | if k <> "bind" 998 | then Error.(parse (Unexpected (`Lexeme k, exp)) loc) 999 | else acc, lexeme 1000 | | Some _ -> 1001 | let var = String.Ascii.uppercase @@ fst (Lexer.lex_id l) in 1002 | let doc = fst (Lexer.lex_atom l) in 1003 | loop (String.Map.add var doc acc) 1004 | in 1005 | loop String.Map.empty 1006 | 1007 | let parse_bindings l peek = 1008 | let exp = [ `Keyword "bind" ] in 1009 | let rec loop acc = function 1010 | | None -> 1011 | List.rev acc 1012 | | Some (k, loc) when k <> "bind" -> 1013 | Error.(parse (Unexpected (`Lexeme k, exp)) loc) 1014 | | Some _ -> 1015 | let pat = Pat.parse l in 1016 | let atom, loc = Lexer.lex_atom l in 1017 | match Fpath.of_string atom with 1018 | | Error _ -> Error.(parse (Illegal_binding_id atom) loc) 1019 | | Ok id -> 1020 | if Fpath.(is_current_dir ~prefix:true id || is_abs id) 1021 | then Error.(parse (Illegal_binding_id atom) loc) 1022 | else loop ((pat, (id, loc)) :: acc) (Lexer.lex_keyword exp l) 1023 | in 1024 | loop [] peek 1025 | 1026 | let of_input ~src i id = 1027 | let id = if Fpath.has_ext ".body" id then id else Fpath.(id + ".body") in 1028 | let l = Lexer.create ~src i in 1029 | try 1030 | let doc = parse_doc l in 1031 | let var_docs, peek = parse_var_docs l in 1032 | let bindings = parse_bindings l peek in 1033 | Ok { id; doc; var_docs; bindings } 1034 | with Error.Parse_exn (`Carcass_parse _ as e) -> Error e 1035 | 1036 | let of_path p id = 1037 | OS.File.read p >>= fun bytes -> 1038 | of_input ~src:(Loc.File p) (`String bytes) id 1039 | 1040 | (* Evaluation *) 1041 | 1042 | let eval_paths env penv b = 1043 | let rec loop stack acc seen locs root = function 1044 | | [] -> 1045 | begin match stack with 1046 | | [] -> Ok acc 1047 | | (seen, locs, root, binds) :: stack -> 1048 | loop stack acc seen locs root binds 1049 | end 1050 | | (ppat, (id, loc)) :: binds -> 1051 | let path = match Pat.eval penv ppat with 1052 | | Error (`Carcass_eval (e, t)) -> 1053 | Error.(eval e (List.(rev (rev_append locs (rev t))))) 1054 | | Ok (p, ploc) -> 1055 | match Fpath.of_string p with 1056 | | Error _ -> Error.(eval (Bound_path (p, `Illegal)) (ploc :: locs)) 1057 | | Ok p -> 1058 | let p' = Fpath.(root // p) in 1059 | if (Fpath.is_rooted ~root p') then p' else 1060 | let p' = Fpath.to_string p' in 1061 | Error.(eval (Bound_path (p', `Escapes)) (ploc :: locs)) 1062 | in 1063 | if not (Fpath.has_ext ".body" id) then begin 1064 | let path = Fpath.normalize path in 1065 | let acc = Fpath.Map.add path (id, loc :: locs) acc in 1066 | loop stack acc seen locs root binds 1067 | end else begin 1068 | let locs = loc :: locs in 1069 | if Fpath.Set.mem id seen 1070 | then Error.(eval (Circular (`Body (Fpath.to_string id))) locs) else 1071 | match find env id with 1072 | | None -> 1073 | Error.(eval (Undefined (`Body (Fpath.to_string id))) locs) 1074 | | Some p -> 1075 | match of_path p id with 1076 | | Error err -> 1077 | Error.(eval (Parse ((`Body (Fpath.to_string id)), err)) locs) 1078 | | Ok b -> 1079 | let stack = (seen, List.tl locs, root, binds) :: stack in 1080 | let seen = Fpath.Set.add id seen in 1081 | loop stack acc seen locs path b.bindings 1082 | end 1083 | in 1084 | try 1085 | let seen = Fpath.Set.singleton b.id in 1086 | loop [] Fpath.Map.empty seen [] (Fpath.v ".") b.bindings 1087 | with Error.Eval (`Carcass_eval _ as e) -> Error e 1088 | 1089 | let eval_bones env penv m = 1090 | let eval bpath (id, locs) acc = match Bone.find env id with 1091 | | None -> Error.(eval (Undefined (`Bone (Fpath.to_string id))) locs) 1092 | | Some p -> 1093 | match Bone.of_path p id with 1094 | | Error e -> Error.(eval (Parse (`Bone (Fpath.to_string id), e)) locs) 1095 | | Ok b -> 1096 | match Bone.eval penv b with 1097 | | Error (`Carcass_eval (e, t)) -> 1098 | Error.(eval e (List.(rev_append (rev locs) t))) 1099 | | Ok contents -> 1100 | Fpath.Map.add bpath (contents, Bone.is_exec b) acc 1101 | in 1102 | try Ok (Fpath.Map.fold eval m Fpath.Map.empty) 1103 | with Error.Eval (`Carcass_eval _ as e) -> Error e 1104 | 1105 | let write ?(wrote = fun _ -> ()) ?(over = fun _ -> false) ~dst m = 1106 | let do_write p = OS.File.exists p >>| fun exists -> not exists || over p in 1107 | let write_path p (c, exec) acc = match acc with 1108 | | Error _ as e -> e 1109 | | Ok () -> 1110 | let p = Fpath.(dst // p) in 1111 | let dir = Fpath.parent p in 1112 | let mode = if exec then 0o733 else 0o622 in 1113 | do_write p >>= function 1114 | | false -> Ok () 1115 | | true -> 1116 | OS.Dir.create ~path:true dir 1117 | >>= fun _ -> OS.File.write ~mode p c 1118 | >>| fun () -> wrote p 1119 | in 1120 | Fpath.Map.fold write_path m (Ok ()) 1121 | end 1122 | 1123 | (*--------------------------------------------------------------------------- 1124 | Copyright (c) 2016 Daniel C. Bünzli 1125 | 1126 | Permission to use, copy, modify, and/or distribute this software for any 1127 | purpose with or without fee is hereby granted, provided that the above 1128 | copyright notice and this permission notice appear in all copies. 1129 | 1130 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 1131 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 1132 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 1133 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 1134 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 1135 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 1136 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 1137 | ---------------------------------------------------------------------------*) 1138 | --------------------------------------------------------------------------------