├── .gitignore ├── .travis.yml ├── CHANGES.md ├── LICENSE.md ├── Makefile ├── README.md ├── app ├── dune ├── functoria_app.ml ├── functoria_app.mli ├── functoria_command_line.ml ├── functoria_command_line.mli ├── functoria_graph.ml └── functoria_graph.mli ├── dune-project ├── functoria-runtime.opam ├── functoria.opam ├── lib ├── dune ├── functoria.ml ├── functoria.mli ├── functoria_key.ml ├── functoria_key.mli ├── functoria_misc.ml └── functoria_misc.mli ├── runtime ├── dune ├── functoria_info.ml ├── functoria_info.mli ├── functoria_runtime.ml └── functoria_runtime.mli └── tests ├── app ├── app.ml └── config.ml ├── dune ├── lib ├── dune └── test_app.ml ├── test_core.ml ├── test_core.mli ├── test_full.ml └── test_full.mli /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *~ 3 | \.\#* 4 | \#*# 5 | *.merlin 6 | *.install 7 | _opam 8 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh 3 | script: bash -ex .travis-docker.sh 4 | services: 5 | - docker 6 | sudo: false 7 | env: 8 | global: 9 | - PINS="functoria.dev:. functoria-runtime.dev:." 10 | - REVDEPS=true 11 | - DISTRO=alpine 12 | - TESTS=true 13 | matrix: 14 | - OCAML_VERSION=4.04 PACKAGE="functoria" 15 | - OCAML_VERSION=4.05 PACKAGE="functoria" 16 | - OCAML_VERSION=4.06 PACKAGE="functoria" 17 | - OCAML_VERSION=4.07 PACKAGE="functoria" 18 | - OCAML_VERSION=4.04 PACKAGE="functoria-runtime" 19 | - OCAML_VERSION=4.05 PACKAGE="functoria-runtime" 20 | - OCAML_VERSION=4.06 PACKAGE="functoria-runtime" 21 | - OCAML_VERSION=4.07 PACKAGE="functoria-runtime" 22 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## v3.1.2 (2022-03-07) 2 | 3 | * Support cmdliner 1.1.0, alcotest 1.4.0 and avoid fmt 0.8.7 deprecations 4 | (#201 @hannesm) 5 | * Disable deprecation alerts in dune files to allow CI to pass (#201 @hannesm) 6 | 7 | ## v3.1.1 (2020-06-10) 8 | 9 | * Ensure that keys with different defaults are distinguished by functoria. 10 | `Functoria.Key.equal` has been introduced in #188 but it was not precise 11 | enough when two keys were sharing the same name (e.g. `interface`) 12 | but with different default values (e.g. `tap0` or `service`). 13 | This was causing non-deterministic bugs where some devices were 14 | not configured properly (mirage/mirage#1157, fixed by #194 by @samoht) 15 | 16 | ## v3.1.0 (2020-03-09) 17 | 18 | * Always use `-warn-error -A` when compiling `config.ml`. This allows 19 | to use deprecated devices without failing (#193, @samoht) 20 | 21 | ## v3.0.3 (2019-12-17) 22 | 23 | * Fix equality for `'a impl` values, which caused issue in `mirage configure` 24 | when multiple keys share the same name (issue #187, fix #188 by @samoht) 25 | * App_info: avoid `opam list --rec` which uses the CUDF solver, instead do 26 | fixpoint manually. Fixes reproducibility with `orb` (#189 @hannesm) 27 | 28 | ## v3.0.2 (2019-11-03) 29 | 30 | * Remove custom opam version comparison code, instead collect min and max as 31 | sets and output them all (#183, @hannesm fixes #143) 32 | for `package ~min:"1.0" ~max:"2.0" "a" ; package ~min:"1.5" ~max:"2.0" "a"`, 33 | the output is now `"a" {>= "1.0" & >= "1.5" & < "2.0"}`, it used to be 34 | `"a" {>= "1.5" & < "2.0"}`. 35 | 36 | The advantage of avoiding to parse version numbers is that it can't be 37 | incompatible with how opam works (functoria's approach used to not support 38 | "1.0~beta", "1.0-5", "v1.0"; and it used to handle "1.0" and "1.0.0" 39 | differently than opam). 40 | 41 | ## v3.0.1 (2019-10-21) 42 | 43 | * Use `dune` to compile `config.ml` into an executable and run it. 44 | This replaces the use of `ocamlbuild` and dynlinking of `config.ml` 45 | (#176, @samoht) 46 | The new compilation scheme: 47 | - generates `dune`, `dune.config` and `dune.build` with sensible 48 | configuration values. Each file can be overwritten by the user, 49 | in that case functoria will detect it and will not remove during 50 | the clean step; 51 | - by default, `dune` just includes `dune.config` and `dune.build`; 52 | - by default, `dune.config` contains the rules to build `config.ml` 53 | into `config.exe`; 54 | - by default, `dune.build` is empty -- functoria users such as 55 | `mirage` can just overwrite that file with the rigth build rules. 56 | * Invoke `opam list` with `--color=never` (#177, @ehmry) 57 | * Use different exit codes in `Functoria_runtime.with_argv` (#180, @hannesm) 58 | 59 | ## v2.2.5 (2019-10-14) 60 | 61 | * Functoria_runtime.with_argv now uses (#179, by @hannesm) 62 | - exit 63 when `Help or `Version is requested (used to exit with 0) 63 | - exit 64 when Term.eval returns with an error (used to raise an exception) 64 | 65 | ## v3.0.0 (2019-07-25) 66 | 67 | * use `dune` to build `config.ml` (@TheLortex, #167) 68 | * add the ability to use external libraries un `config.ml` via an optional 69 | `dune.config` file (@TheLortex, #167) 70 | * Replace dynlink method by a 2-stage build (@TheLortex, #167) 71 | 72 | ## v2.2.4 (2019-05-27) 73 | 74 | * fix app_info - executing "opam list --installed" (#170, by @hannesm) 75 | 76 | ## 2.2.3 (21/11/2018) 77 | 78 | * fix support for pin-depends (#165, by @hannesm) 79 | 80 | ## 2.2.2 (16/11/2018) 81 | 82 | * compute all transitive opam dependencies for info (#151, by @hannesm) 83 | * support pin-depends in generated opam file (#163, by @hannesm) 84 | * use dune as build system (#158, by @emillon) 85 | * use Ptime for time printing (#160, by @emillon) 86 | * inject global arguments into generated header (#159, by @emillon) 87 | * add Functoria_key.add_to_context (#161, by @emillon) 88 | * output opam2 files (#157, by @hannesm) 89 | 90 | ## 2.2.1 (01/08/2018) 91 | 92 | * expand signatures manually for 4.07.0 support (#153, by @Drup) 93 | * fix serialization of negative ints (#152, by @samoht) 94 | * fix example in README (#144, by @samoht) 95 | 96 | ## 2.2.0 (01/08/2017) 97 | 98 | * API improvements: add `Functoria_app.packages` and `ignore_dirs` 99 | functions. Also add prettyprinting functions to the CLI module. (@samoht) 100 | * rename the man pages from "Unikernel" references to "Application" 101 | * Add end-to-end tests for the tool (@samoht) 102 | 103 | ## 2.1.0 (03/07/2017) 104 | 105 | * port build to Jbuilder (#115 @djs55) 106 | * add `--output` option to configure so that the name of hte output target can be overridden (#108 @samoht) 107 | * improve README formatting (@olleolleolle) 108 | * fix formatting error in the `help` subcommand (#112 @neatonk) 109 | * do not munge the name of the output opam package twice (#113 @hannesm) 110 | 111 | ## 2.0.2 (07/03/2017) 112 | 113 | * don't complain about command-line options when config.ml is unbuildable (#109, by @yomimono and @talex5) 114 | 115 | ## 2.0.1 (13/02/2017) 116 | 117 | * raise an exception with useful information when Univ.new_key fails (#102, by @yomimono) 118 | * remove `-f ` command option to unbreak `--help` with subcommands 119 | and unikernel present (which config.ml is dynamically loaded to present 120 | possible command-line keys (#101 (superseeding #100), discussion in #91 and 121 | #97, fixes #72 by @hannesm) 122 | 123 | ## 2.0.0 (19/01/2017) 124 | 125 | * invoke ocamlbuild with quiet (#93 by @hannesm) 126 | * restrict -f command line argument to items in current working directory (#91 by @hannesm) 127 | * ocamlify opam filename (#89 by @yomimono) 128 | * persist configuration arguments (#85, #87 by @hannesm, @Drup) 129 | * remove Functoria_misc.Log (#84 by @hannesm) 130 | * remove Functoria_misc.Cmd (#84 by @hannesm) 131 | * separate configure from build step, both are now done on the graph. opam file is now generated during configure (#76, #84 by @hannesm) 132 | * check presence of vertex before removing (#83 by #Drup) 133 | * split into functoria and functoria-runtime opam packages (#80 by @hannesm) 134 | * use Astring instead of custom Functoria_misc.String (#77 by @hannesm) 135 | * expose Functoria_key.name, and use it to generate a list of runtime keys (#68 by @yomimono) 136 | * remove Functoria_misc.Set (provided `of_list`), now depend on 4.03+ (#75 by @hannesm) 137 | * signature of `connect` changed: value is now `'a io`, no result (fail hard instead!) (#71 by @hannesm) 138 | * remove base_context (#65 by @yomimono) 139 | * Switch to topkg (#64 by @samoht) 140 | 141 | ## 1.1.0 (29/04/2016) 142 | 143 | * Add init jobs to start before every other ones (@talex5, @Drup, @samoht) 144 | 145 | ## 1.0.0 (16/02/2016) 146 | 147 | * Initial release 148 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | ## ISC License 2 | 3 | Copyright (c) 2015-2018, Thomas Gazagnaire, Anil Madhavapeddy, Dave Scott, Thomas Leonard, Gabriel Radanne 4 | 5 | Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 8 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build clean test 2 | 3 | build: 4 | dune build 5 | 6 | test: 7 | dune runtest && \ 8 | INSIDE_FUNCTORIA_TESTS=1 dune exec -- tests/test_full.exe 9 | 10 | clean: 11 | dune clean 12 | 13 | doc: 14 | dune build @doc 15 | 16 | # until we have https://github.com/ocaml/opam-publish/issues/38 17 | 18 | REPO=../opam-repository 19 | PACKAGES=$(REPO)/packages 20 | 21 | pkg-%: 22 | topkg opam pkg -n $* 23 | mkdir -p $(PACKAGES)/$* 24 | cp -r _build/$*.* $(PACKAGES)/$*/ 25 | rm -f $(PACKAGES)/$*/$*.opam 26 | cd $(PACKAGES) && git add $* 27 | 28 | PKGS=$(basename $(wildcard *.opam)) 29 | opam-pkg: 30 | $(MAKE) $(PKGS:%=pkg-%) 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | **This repository is deprecated -- check [mirage/mirage](https://github.com/mirage/mirage) instead** 2 | 3 | --- 4 | 5 | # Functoria - A DSL to organize functor applications 6 | 7 | [![Build Status](https://travis-ci.org/mirage/functoria.svg?branch=master)](https://travis-ci.org/mirage/functoria) 8 | [![docs](https://img.shields.io/badge/doc-online-blue.svg)](https://mirage.github.io/functoria/index.html) 9 | 10 | ## What is this for? 11 | 12 | Functoria is a DSL to describe a set of modules and functors, their types and how to apply them in order to produce a complete application. 13 | 14 | The main use case is mirage. See the [mirage][] repository for details. 15 | 16 | ## How to write a configuration file? 17 | 18 | There are numerous examples of configuration files in [mirage-skeleton][]. Most of them should be fairly general and understandable, even outside the context of mirage. We can distinguish two parts in a `config.ml`: Defining new modules and using them. 19 | 20 | In order to define a new module, we use the `foreign` function. Among its various arguments, it takes a module name and a type. The type is assembled with the DSL's combinators and the `@->` operator, which symbols a functor arrow. 21 | 22 | ```ocaml 23 | let main = foreign "Unikernel.Main" (console @-> job) 24 | ``` 25 | 26 | Here, we declare the functor `Unikernel.Main` that takes a module that should be a `console` and returns a module that is a `job`. It is up to the user to ensure that the declaration matches the implementation (or be punished by a compiler error later on). If the declaration is correct, everything that follows will be. 27 | 28 | We can now use this declaration: 29 | 30 | ```ocaml 31 | let () = register "console" [main $ default_console] 32 | ``` 33 | 34 | Here, we register a new application with the `register` function. This function should only be called once and takes as argument the name of the application and a list of jobs. We use the `$` operator to apply the functor `main` (aka `Unikernel.Main`) to the default console. 35 | 36 | Now that everything is ready, you can use the `configure` subcommand! 37 | 38 | ### What is a job? 39 | 40 | A job is a module containing a function `start`. This function will receive one argument per functor argument and one per dependency, in this order. `foreign` assumes the function `start` returns `unit`. 41 | 42 | ### Defining new keys 43 | 44 | A key is composed of: 45 | 46 | - _name_ : The name of the value in the program. 47 | - _description_ : How it should be displayed/serialized. 48 | - _stage_ : Is the key available only at runtime, at configure time or both? 49 | - _documentation_ : It is not optional so you should really write it. 50 | 51 | Consider a multilingual application: we want to pass the default language as a parameter. We will use a simple string, so we can use the predefined description `Key.Desc.string`. We want to be able to define it both at configure and run time, so we use the stage `` `Both``. This gives us the following code: 52 | 53 | ```ocaml 54 | let lang_key = 55 | let doc = Key.Arg.info 56 | ~doc:"The default language for the application." [ "l" ; "lang" ] 57 | in 58 | Key.create "language" @@ Key.Arg.(opt ~stage:`Both string "en" doc) 59 | ``` 60 | 61 | Here, we defined both a long option `--lang` and a short one `-l` (the format is similar to the one used by [Cmdliner][cmdliner]). 62 | In the application code, the value is retrieved with `Key_gen.language ()`. 63 | 64 | The option is also documented in the `--help` option for both the `configure` subcommand (at configure time) and `./my_application` (at startup time). 65 | 66 | ``` 67 | -l VAL, --lang=VAL (absent=en) 68 | The default language for the application. 69 | ``` 70 | 71 | [cmdliner]: http://erratique.ch/software/cmdliner 72 | 73 | ### Using switching keys 74 | 75 | We can do much more with keys: we can use them to switch implementation at configure time. Imagine we want to completely change some implementation based on the language. Finns are special snowflakes, they deserve their special application! 76 | 77 | First, we have to compute a boolean value from `lang`: 78 | 79 | ```ocaml 80 | let is_fi = Key.(pure ((=) "fi") $ value lang_key) 81 | ``` 82 | 83 | We can use the `if_impl` combinator to choose between two implementations depending on the value of the key: 84 | 85 | ```ocaml 86 | let dynamic_storage = 87 | if_impl is_fi 88 | finnish_implementation 89 | not_finnish_implementation 90 | ``` 91 | 92 | This distinction will be visible using the `describe` subcommand and a dot diagram is available with the `--dot` option! 93 | 94 | ## Internals 95 | 96 | ### Phases 97 | 98 | Configuration is separated into phases: 99 | 100 | 1. Specialized DSL keys 101 | The specialized DSL's keys (along with functoria's keys) are resolved. 102 | 2. Compilation and dynlink of the config file. 103 | 3. Registering. 104 | When the `register` function is called, the list of jobs is recorded and 105 | immediately transformed into a graph. 106 | 4. Switching keys and tree evaluation. 107 | The switching keys are the keys inside the [If]. 108 | Those keys are resolved and the graph is simplified. At this point, 109 | the actual modules used are fully known. 110 | Note: for the `describe` command, Only _partial_ evaluation is done, which 111 | means decision nodes are resolved only if the value was given on the command 112 | line, disregarding default values. 113 | 5. Full Key resolution. 114 | Once the actual modules are known, we can resolve all the keys and figure out 115 | libraries and packages. 116 | 6. Dependency handling, configuration and code emission. 117 | 118 | Phases 1. to 4. are also applied for the `clean` command. 119 | 120 | 121 | 122 | [mirage]: https://github.com/mirage/mirage 123 | [mirage-skeleton]: https://github.com/mirage/mirage-skeleton 124 | -------------------------------------------------------------------------------- /app/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name functoria_app) 3 | (public_name functoria.app) 4 | (libraries functoria dynlink cmdliner rresult fmt.tty fmt.cli ocamlgraph astring fpath bos logs logs.cli logs.fmt) 5 | (wrapped false) 6 | (flags (:standard (-w -3))) 7 | ) 8 | -------------------------------------------------------------------------------- /app/functoria_app.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Thomas Gazagnaire 3 | * Copyright (c) 2013 Anil Madhavapeddy 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | open Rresult 19 | open Astring 20 | 21 | open Functoria 22 | include Functoria_misc 23 | 24 | module Graph = Functoria_graph 25 | module Key = Functoria_key 26 | module Cmd = Functoria_command_line 27 | 28 | (* Noop, the job that does nothing. *) 29 | let noop = impl @@ object 30 | inherit base_configurable 31 | method ty = job 32 | method name = "noop" 33 | method module_name = "Pervasives" 34 | end 35 | 36 | (* Default argv *) 37 | type argv = ARGV 38 | let argv = Type ARGV 39 | 40 | let sys_argv = impl @@ object 41 | inherit base_configurable 42 | method ty = argv 43 | method name = "argv" 44 | method module_name = "Sys" 45 | method !connect _info _m _ = "return Sys.argv" 46 | end 47 | 48 | let src = Logs.Src.create "functoria" ~doc:"functoria library" 49 | module Log = (val Logs.src_log src : Logs.LOG) 50 | 51 | let wrap f err = 52 | match f () with 53 | | Ok b -> b 54 | | Error _ -> R.error_msg err 55 | 56 | let with_output f k = 57 | wrap 58 | (Bos.OS.File.with_oc f k) 59 | ("couldn't open output channel " ^ Fpath.to_string f) 60 | 61 | let with_current f k err = 62 | wrap 63 | (Bos.OS.Dir.with_current f k) 64 | ("failed to change directory for " ^ err) 65 | 66 | (* Keys *) 67 | 68 | module Keys = struct 69 | 70 | let file = Fpath.(v (String.Ascii.lowercase Key.module_name) + "ml") 71 | 72 | let configure i = 73 | Log.info (fun m -> m "Generating: %a" Fpath.pp file); 74 | with_output file 75 | (fun oc () -> 76 | let fmt = Format.formatter_of_out_channel oc in 77 | Codegen.append fmt "(* %s *)" (Codegen.generated_header ()); 78 | Codegen.newline fmt; 79 | let keys = Key.Set.of_list @@ Info.keys i in 80 | let pp_var k = Key.serialize (Info.context i) k in 81 | Fmt.pf fmt "@[%a@]@." (Fmt.iter Key.Set.iter pp_var) keys; 82 | let runvars = Key.Set.elements (Key.filter_stage `Run keys) in 83 | let pp_runvar ppf v = Fmt.pf ppf "%s_t" (Key.ocaml_name v) in 84 | let pp_names ppf v = Fmt.pf ppf "%S" (Key.name v) in 85 | Codegen.append fmt "let runtime_keys = List.combine %a %a" 86 | Fmt.Dump.(list pp_runvar) runvars Fmt.Dump.(list pp_names) runvars; 87 | Codegen.newline fmt; 88 | R.ok ()) 89 | 90 | let clean _i = Bos.OS.Path.delete file 91 | 92 | let name = "key" 93 | 94 | end 95 | 96 | let keys (argv: argv impl) = impl @@ object 97 | inherit base_configurable 98 | method ty = job 99 | method name = Keys.name 100 | method module_name = Key.module_name 101 | method !configure = Keys.configure 102 | method !clean = Keys.clean 103 | method !packages = Key.pure [package "functoria-runtime"] 104 | method !deps = [ abstract argv ] 105 | method !connect info modname = function 106 | | [ argv ] -> 107 | Fmt.str 108 | "return (Functoria_runtime.with_argv (List.map fst %s.runtime_keys) %S %s)" 109 | modname (Info.name info) argv 110 | | _ -> failwith "The keys connect should receive exactly one argument." 111 | end 112 | 113 | (* Module emiting a file containing all the build information. *) 114 | 115 | type info = Info 116 | let info = Type Info 117 | 118 | let pp_libraries fmt l = 119 | Fmt.pf fmt "[@ %a]" 120 | Fmt.(iter ~sep:(any ";@ ") List.iter @@ fmt "%S") l 121 | 122 | let pp_packages fmt l = 123 | Fmt.pf fmt "[@ %a]" 124 | Fmt.(iter ~sep:(any ";@ ") List.iter @@ 125 | (fun fmt x -> pf fmt "%S, \"%%{%s:version}%%\"" x x) 126 | ) l 127 | 128 | let pp_dump_pkgs module_name fmt (name, pkg, libs) = 129 | Fmt.pf fmt 130 | "%s.{@ name = %S;@ \ 131 | @[packages = %a@]@ ;@ @[libraries = %a@]@ }" 132 | module_name name 133 | pp_packages (String.Set.elements pkg) 134 | pp_libraries (String.Set.elements libs) 135 | 136 | let app_info ?(type_modname="Functoria_info") ?(gen_modname="Info_gen") () = 137 | impl @@ object 138 | inherit base_configurable 139 | method ty = info 140 | method name = "info" 141 | val file = Fpath.(v (String.Ascii.lowercase gen_modname) + "ml") 142 | method module_name = gen_modname 143 | method !packages = Key.pure [package "functoria-runtime"] 144 | method !connect _ modname _ = Fmt.str "return %s.info" modname 145 | 146 | method !clean _i = 147 | Bos.OS.Path.delete file >>= fun () -> 148 | Bos.OS.Path.delete Fpath.(file + "in") 149 | 150 | method !configure _i = Ok () 151 | 152 | method !build i = 153 | Log.info (fun m -> m "Generating: %a" Fpath.pp file); 154 | (* this used to call 'opam list --rec ..', but that leads to 155 | non-reproducibility, since this uses the opam CUDF solver which 156 | drops some packages (which are in the repositories configured for the 157 | switch), see https://github.com/mirage/functoria/pull/189 for further 158 | discussion on this before changing the code below. *) 159 | let rec opam_deps args collected = 160 | Log.debug (fun m -> m 161 | "opam_deps %d args %d collected\nargs: %a\ncollected: %a" 162 | (String.Set.cardinal args) (String.Set.cardinal collected) 163 | (String.Set.pp ~sep:(Fmt.any ",") Fmt.string) args 164 | (String.Set.pp ~sep:(Fmt.any ",") Fmt.string) collected); 165 | if String.Set.is_empty args then Ok collected 166 | else 167 | let pkgs = String.concat ~sep:"," (String.Set.elements args) in 168 | let cmd = 169 | Bos.Cmd.(v "opam" % "list" % "--installed" % "-s" % "--color=never" % "--depopts" % "--required-by" % pkgs) 170 | in 171 | (Bos.OS.Cmd.run_out cmd |> Bos.OS.Cmd.out_lines) >>= fun (rdeps, _) -> 172 | let reqd = String.Set.of_list rdeps in 173 | let collected' = String.Set.union collected reqd in 174 | opam_deps (String.Set.diff collected' collected) collected' 175 | in 176 | opam_deps (String.Set.of_list (Info.package_names i)) String.Set.empty >>= fun opam -> 177 | let ocl = String.Set.of_list (Info.libraries i) 178 | in 179 | Bos.OS.File.writef Fpath.(file + "in") 180 | "@[let info = %a@]" (pp_dump_pkgs type_modname) (Info.name i, opam, ocl) >>= fun () -> 181 | Bos.OS.Cmd.run Bos.Cmd.(v "opam" % "config" % "subst" % p file) 182 | end 183 | 184 | module Engine = struct 185 | 186 | let if_context = 187 | let open Graph in 188 | Graph.collect (module Key.Set) @@ function 189 | | If cond -> Key.deps cond 190 | | App | Impl _ -> Key.Set.empty 191 | 192 | let keys = 193 | let open Graph in 194 | Graph.collect (module Key.Set) @@ function 195 | | Impl c -> Key.Set.of_list c#keys 196 | | If cond -> Key.deps cond 197 | | App -> Key.Set.empty 198 | 199 | module M = struct 200 | type t = package list Key.value 201 | let union x y = Key.(pure List.append $ x $ y) 202 | let empty = Key.pure [] 203 | end 204 | 205 | let packages = 206 | let open Graph in 207 | Graph.collect (module M) @@ function 208 | | Impl c -> c#packages 209 | | If _ | App -> M.empty 210 | 211 | (* Return a unique variable name holding the state of the given 212 | module construction. *) 213 | let name c id = 214 | let prefix = Name.ocamlify c#name in 215 | Name.create (Fmt.str "%s%i" prefix id) ~prefix 216 | 217 | (* [module_expresion tbl c args] returns the module expression of 218 | the functor [c] applies to [args]. *) 219 | let module_expression tbl fmt (c, args) = 220 | Fmt.pf fmt "%s%a" 221 | c#module_name 222 | Fmt.(list (parens @@ of_to_string @@ Graph.Tbl.find tbl)) 223 | args 224 | 225 | (* [module_name tbl c args] return the module name of the result of 226 | the functor application. If [args = []], it returns 227 | [c#module_name]. *) 228 | let module_name c id args = 229 | let base = c#module_name in 230 | if args = [] then base 231 | else 232 | let prefix = match String.cut ~sep:"." base with 233 | | Some (l, _) -> l 234 | | None -> base 235 | in 236 | let prefix = Name.ocamlify prefix in 237 | Name.create (Fmt.str "%s%i" prefix id) ~prefix 238 | 239 | (* FIXME: Can we do better than lookup by name? *) 240 | let find_device info g impl = 241 | let ctx = Info.context info in 242 | let rec name: type a . a impl -> string = fun impl -> 243 | match explode impl with 244 | | `Impl c -> c#name 245 | | `App (Abstract x, _) -> name x 246 | | `If (b, x, y) -> if Key.eval ctx b then name x else name y 247 | in 248 | let name = name impl in 249 | let open Graph in 250 | let p = function 251 | | Impl c -> c#name = name 252 | | App | If _ -> false 253 | in 254 | match Graph.find_all g p with 255 | | [] -> invalid_arg "Functoria.find_device: no device" 256 | | [x] -> x 257 | | _ -> invalid_arg "Functoria.find_device: too many devices." 258 | 259 | let build info (_init, job) = 260 | let f v = match Graph.explode job v with 261 | | `App _ | `If _ -> R.ok () 262 | | `Impl (c, _, _) -> c#build info 263 | in 264 | let f v res = res >>= fun () -> f v in 265 | Graph.fold f job @@ R.ok () 266 | 267 | let configure info (_init, job) = 268 | let tbl = Graph.Tbl.create 17 in 269 | let f v = match Graph.explode job v with 270 | | `App _ | `If _ -> assert false 271 | | `Impl (c, `Args args, `Deps _) -> 272 | let modname = module_name c (Graph.hash v) args in 273 | Graph.Tbl.add tbl v modname; 274 | c#configure info >>| fun () -> 275 | if args = [] then () 276 | else begin 277 | Codegen.append_main 278 | "@[<2>module %s =@ %a@]" 279 | modname 280 | (module_expression tbl) (c,args); 281 | Codegen.newline_main (); 282 | end 283 | in 284 | let f v res = res >>= fun () -> f v in 285 | Graph.fold f job @@ R.ok () >>| fun () -> 286 | tbl 287 | 288 | let meta_init fmt (connect_name, result_name) = 289 | Fmt.pf fmt "let _%s =@[@ Lazy.force %s @]in@ " result_name connect_name 290 | 291 | let emit_connect fmt (iname, names, connect_string) = 292 | (* We avoid potential collision between double application 293 | by prefixing with "_". This also avoid warnings. *) 294 | let rnames = List.map (fun x -> "_"^x) names in 295 | let bind ppf name = 296 | Fmt.pf ppf "_%s >>= fun %s ->@ " name name 297 | in 298 | Fmt.pf fmt 299 | "@[let %s = lazy (@ \ 300 | %a\ 301 | %a\ 302 | %s@ )@]@." 303 | iname 304 | Fmt.(list ~sep:nop meta_init) (List.combine names rnames) 305 | Fmt.(list ~sep:nop bind) rnames 306 | (connect_string rnames) 307 | 308 | let emit_run init main = 309 | (* "exit 1" is ok in this code, since cmdliner will print help. *) 310 | let force ppf name = 311 | Fmt.pf ppf "Lazy.force %s >>= fun _ ->@ " name 312 | in 313 | Codegen.append_main 314 | "@[\ 315 | let () =@ \ 316 | let t =@ @[%aLazy.force %s@]@ \ 317 | in run t@]" 318 | Fmt.(list ~sep:nop force) init main 319 | 320 | let connect modtbl info (init, job) = 321 | let tbl = Graph.Tbl.create 17 in 322 | let f v = match Graph.explode job v with 323 | | `App _ | `If _ -> assert false 324 | | `Impl (c, `Args args, `Deps deps) -> 325 | let ident = name c (Graph.hash v) in 326 | let modname = Graph.Tbl.find modtbl v in 327 | Graph.Tbl.add tbl v ident; 328 | let names = List.map (Graph.Tbl.find tbl) (args @ deps) in 329 | Codegen.append_main "%a" 330 | emit_connect (ident, names, c#connect info modname) 331 | in 332 | Graph.fold (fun v () -> f v) job (); 333 | let main_name = Graph.Tbl.find tbl @@ Graph.find_root job in 334 | let init_names = 335 | List.map (fun name -> Graph.Tbl.find tbl @@ find_device info job name) init 336 | in 337 | emit_run init_names main_name; 338 | () 339 | 340 | let configure_and_connect info g = 341 | configure info g >>| fun modtbl -> 342 | connect modtbl info g 343 | 344 | let clean i g = 345 | let f v = match Graph.explode g v with 346 | | `Impl (c,_,_) -> c#clean i 347 | | _ -> R.ok () 348 | in 349 | let f v res = res >>= fun () -> f v in 350 | Graph.fold f g @@ R.ok () 351 | 352 | end 353 | 354 | module Config = struct 355 | 356 | type t = { 357 | name : string; 358 | build_dir: Fpath.t; 359 | packages : package list Key.value; 360 | keys : Key.Set.t; 361 | init : job impl list; 362 | jobs : Graph.t; 363 | } 364 | 365 | (* In practice, we get all the keys associated to [if] cases, and 366 | all the keys that have a setter to them. *) 367 | let get_if_context jobs = 368 | let all_keys = Engine.keys jobs in 369 | let skeys = Engine.if_context jobs in 370 | let f k s = 371 | if Key.Set.is_empty @@ Key.Set.inter (Key.aliases k) skeys 372 | then s 373 | else Key.Set.add k s 374 | in 375 | Key.Set.fold f all_keys skeys 376 | 377 | let make ?(keys=[]) ?(packages=[]) ?(init=[]) name build_dir main_dev = 378 | let name = Name.ocamlify name in 379 | let jobs = Graph.create main_dev in 380 | let packages = Key.pure @@ packages in 381 | let keys = Key.Set.(union (of_list keys) (get_if_context jobs)) in 382 | { packages; keys; name; build_dir; init; jobs } 383 | 384 | let eval ~partial context 385 | { name = n; build_dir; packages; keys; jobs; init } 386 | = 387 | let e = Graph.eval ~partial ~context jobs in 388 | let packages = Key.(pure List.append $ packages $ Engine.packages e) in 389 | let keys = Key.Set.elements (Key.Set.union keys @@ Engine.keys e) in 390 | Key.(pure (fun packages _ context -> 391 | ((init, e), 392 | Info.create 393 | ~packages 394 | ~keys ~context ~name:n ~build_dir)) 395 | $ packages 396 | $ of_deps (Set.of_list keys)) 397 | 398 | (* Extract all the keys directly. Useful to pre-resolve the keys 399 | provided by the specialized DSL. *) 400 | let extract_keys impl = 401 | Engine.keys @@ Graph.create impl 402 | 403 | let keys t = t.keys 404 | 405 | let gen_pp pp fmt jobs = 406 | pp fmt @@ Graph.simplify jobs 407 | 408 | let pp = gen_pp Graph.pp 409 | let pp_dot = gen_pp Graph.pp_dot 410 | 411 | end 412 | 413 | (** Cached configuration in [.mirage.config]. 414 | Currently, we cache Sys.argv directly 415 | *) 416 | module Cache : sig 417 | val save : argv:string array -> Fpath.t -> (unit, [> Rresult.R.msg ]) result 418 | val clean : Fpath.t -> (unit, [> Rresult.R.msg ]) result 419 | val get_context : Fpath.t -> context Cmdliner.Term.t -> 420 | [> `Error of bool * string | `Ok of context option ] 421 | val get_output: Fpath.t -> [> `Error of bool * string | `Ok of string option ] 422 | val require : [< `Error of bool * string | `Ok of context option ] -> 423 | context Cmdliner.Term.ret 424 | val merge : 425 | cache:[< `Error of bool * string | `Ok of context option ] -> 426 | context -> context 427 | val present : 428 | [< `Error of bool * string | `Ok of context option ] -> bool 429 | end = struct 430 | let filename root = 431 | Fpath.(root / ".mirage" + "config") 432 | 433 | let save ~argv root = 434 | let file = filename root in 435 | Log.info (fun m -> m "Preserving arguments in %a" Fpath.pp file); 436 | let args = List.tl (Array.to_list argv) in (* Only keep args *) 437 | let args = List.map String.Ascii.escape args in 438 | let args = String.concat ~sep:"\n" args in 439 | Bos.OS.File.write file args 440 | 441 | let clean root = 442 | Bos.OS.File.delete (filename root) 443 | 444 | let read root = 445 | Log.info (fun l -> l "reading cache"); 446 | match Bos.OS.File.read (filename root) with 447 | | Error _ -> None 448 | | Ok args -> 449 | let contents = Array.of_list @@ String.cuts ~sep:"\n" args in 450 | let contents = 451 | Array.map (fun x -> match String.Ascii.unescape x with 452 | | Some s -> s 453 | | None -> failwith "cannot parse cached context" 454 | ) contents 455 | in 456 | Some contents 457 | 458 | let get_context root context_args = 459 | match read root with 460 | | None -> `Ok None 461 | | Some argv -> 462 | match Cmdliner.Term.eval_peek_opts ~argv context_args with 463 | | _, `Ok c -> `Ok (Some c) 464 | | _ -> 465 | let msg = 466 | "Invalid cached configuration. Please run configure again." 467 | in 468 | `Error (false, msg) 469 | 470 | let get_output root = 471 | match get_context root Cmd.output with 472 | | `Ok (Some None) -> `Ok None 473 | | `Ok (Some x) -> `Ok x 474 | | `Ok None -> `Ok None 475 | | `Error e -> `Error e 476 | 477 | let require cache : _ Cmdliner.Term.ret = 478 | match cache with 479 | | `Ok None -> 480 | `Error (false, "Configuration is not available. Please run configure.") 481 | | `Ok (Some x) -> `Ok x 482 | | `Error err -> `Error err 483 | 484 | let merge ~cache context = 485 | match cache with 486 | | `Ok None | `Error _ -> context 487 | | `Ok (Some default) -> Key.merge_context ~default context 488 | 489 | let present cache = match cache with 490 | | `Ok None | `Error _ -> false 491 | | `Ok (Some _) -> true 492 | end 493 | 494 | module type S = sig 495 | val prelude: string 496 | val name: string 497 | val packages: package list 498 | val ignore_dirs: string list 499 | val version: string 500 | val create: job impl list -> job impl 501 | end 502 | 503 | module type DSL = module type of struct include Functoria end 504 | 505 | module Make (P: S) = struct 506 | 507 | (* GLOBAL STATE *) 508 | 509 | (* this needs to be set-up beforce any calls to {!register} *) 510 | let build_dir = ref None 511 | let default_init = [keys sys_argv] 512 | let config_file = ref Fpath.(v "config.ml") 513 | 514 | let init_global_state argv = 515 | build_dir := None; 516 | config_file := Fpath.(v "config.ml"); 517 | ignore (Cmdliner.Term.eval_peek_opts ~argv Cmd.setup_log); 518 | ignore (Cmdliner.Term.eval_peek_opts ~argv @@ 519 | Cmd.config_file (fun c -> config_file := c)); 520 | ignore (Cmdliner.Term.eval_peek_opts ~argv @@ 521 | Cmd.build_dir (fun r -> 522 | let (_:bool) = R.get_ok @@ Bos.OS.Dir.create ~path:true r in 523 | build_dir := Some r)) 524 | 525 | let get_project_root () = R.get_ok @@ Bos.OS.Dir.current () 526 | 527 | let relativize ~root p = 528 | let p = if Fpath.is_abs p then p else Fpath.(get_project_root () // p) in 529 | match Fpath.relativize ~root p with 530 | | Some p -> p 531 | | None -> Fmt.failwith "relativize: root=%a %a" Fpath.pp root Fpath.pp p 532 | 533 | let get_relative_source_dir () = 534 | let dir = Fpath.parent !config_file in 535 | let root = get_project_root () in 536 | relativize ~root dir 537 | 538 | let get_build_dir () = 539 | let dir = match !build_dir with 540 | | None -> get_relative_source_dir () 541 | | Some p -> p 542 | in 543 | let dir = 544 | if Fpath.is_abs dir then dir 545 | else Fpath.(get_project_root () // dir) 546 | in 547 | let root = get_project_root () in 548 | let rel = relativize ~root dir in 549 | match Fpath.segs rel with 550 | | ".." :: _ -> failwith "--build-dir should be a sub-directory." 551 | | _ -> dir 552 | 553 | let auto_generated = 554 | ";; auto-generated by 'mirage configure -- remove these comments to\n\ 555 | ;; preserve the file after a `mirage clean`" 556 | 557 | let can_overwrite file = 558 | Bos.OS.File.exists file >>= function 559 | | false -> Ok true 560 | | true -> 561 | if Fpath.basename file = "dune-project" then 562 | Bos.OS.File.read_lines file >>| function 563 | | [] -> true 564 | | _ :: x :: y :: _ -> x ^ "\n" ^ y = auto_generated 565 | | _ -> false 566 | else 567 | Bos.OS.File.read_lines file >>| function 568 | | [] | [_] -> true 569 | | x :: y :: _ -> x ^ "\n" ^ y = auto_generated 570 | 571 | (* STAGE 1 *) 572 | 573 | let generate ~file ~contents = 574 | can_overwrite file >>= function 575 | | false -> Ok () 576 | | true -> 577 | Bos.OS.File.delete file >>= fun () -> 578 | Bos.OS.File.write file contents 579 | 580 | let list_files dir = 581 | Bos.OS.Path.matches ~dotfiles:true Fpath.(dir / "$(file)") >>= fun l -> 582 | List.fold_left (fun acc src -> 583 | acc >>= fun acc -> 584 | match Fpath.basename src with 585 | | "_build" | "main.ml" | "key_gen.ml" -> Ok acc 586 | | s when Filename.extension s = ".exe" -> Ok acc 587 | | _ -> Ok (src :: acc) 588 | ) (Ok []) l 589 | 590 | (* Generate a `dune.config` file in the build directory. *) 591 | let generate_dune_config ~project_root ~source_dir () = 592 | let file = Fpath.v "dune.config" in 593 | let pkgs = match P.packages with 594 | | [] -> "" 595 | | pkgs -> 596 | let pkgs = 597 | List.fold_left (fun acc pkg -> 598 | String.Set.union pkg.ocamlfind acc 599 | ) String.Set.empty pkgs 600 | |> String.Set.elements 601 | in 602 | String.concat ~sep:" " pkgs 603 | in 604 | let copy_rule file = match !build_dir with 605 | | None -> "" 606 | | Some root -> 607 | let root = Fpath.(project_root // root) in 608 | let src = relativize ~root file in 609 | let file = Fpath.basename file in 610 | Fmt.str "(rule (copy %a %s))\n\n" Fpath.pp src file 611 | in 612 | list_files Fpath.(project_root // source_dir) >>= fun files -> 613 | let copy_rules = List.map copy_rule files in 614 | let config_file = Fpath.(basename (rem_ext !config_file)) in 615 | let contents = 616 | Fmt.str 617 | {|%s 618 | 619 | %a(executable 620 | (name config) 621 | (flags (:standard -warn-error -A)) 622 | (modules %s) 623 | (libraries %s)) 624 | |} 625 | auto_generated Fmt.(list ~sep:(any "") string) copy_rules 626 | config_file pkgs 627 | in 628 | generate ~file ~contents 629 | 630 | (* Generate a `dune.config` file in the build directory. *) 631 | let generate_empty_dune_build () = 632 | let file = Fpath.v "dune.build" in 633 | let contents = auto_generated ^ "\n" in 634 | generate ~file ~contents 635 | 636 | (* Generate a `dune` file in the build directory. *) 637 | let generate_dune () = 638 | let file = Fpath.v "dune" in 639 | let contents = 640 | Fmt.str "%s 641 | 642 | (include dune.config)\n\n(include dune.build)\n" 643 | auto_generated 644 | in 645 | generate ~file ~contents 646 | 647 | (* Generate a `dune-project` file at the project root. *) 648 | let generate_dune_project ~project_root = 649 | let file = Fpath.(project_root / "dune-project") in 650 | let contents = Fmt.str "(lang dune 1.1)\n%s\n" auto_generated in 651 | generate ~file ~contents 652 | 653 | (* Generate the configuration files in the the build directory *) 654 | let generate_configuration_files 655 | ~project_root ~source_dir ~build_dir ~config_file 656 | = 657 | Log.info (fun m -> m "Compiling: %a" Fpath.pp config_file); 658 | Log.info (fun m -> m "Project root: %a" Fpath.pp project_root); 659 | Log.info (fun m -> m "Build dir: %a" Fpath.pp build_dir); 660 | ( match Bos.OS.File.must_exist config_file with 661 | | Ok _ -> Ok () 662 | | Error _ -> 663 | R.error_msgf "configuration file %a missing" Fpath.pp config_file 664 | ) >>= fun () -> 665 | generate_dune_project ~project_root >>= fun () -> 666 | Bos.OS.Dir.with_current build_dir (fun () -> 667 | generate_dune_config ~project_root ~source_dir () >>= fun () -> 668 | generate_empty_dune_build () >>= fun () -> 669 | generate_dune () 670 | ) () >>= fun result -> 671 | result 672 | 673 | (* Compile the configuration files and execute it. *) 674 | let build_and_execute ?help_ppf ?err_ppf argv = 675 | let build_dir = get_build_dir () in 676 | let config_file = !config_file in 677 | let project_root = get_project_root () in 678 | let source_dir = get_relative_source_dir () in 679 | generate_configuration_files 680 | ~project_root ~source_dir ~build_dir ~config_file 681 | >>= fun () -> 682 | let args = Bos.Cmd.of_list (List.tl (Array.to_list argv)) in 683 | let target_dir = relativize ~root:project_root build_dir in 684 | let command = 685 | Bos.Cmd.(v "dune" % "exec" 686 | % "--root" % p project_root 687 | % "--" % p Fpath.(target_dir / "config.exe") %% args) 688 | in 689 | match help_ppf, err_ppf with 690 | | None, None -> Bos.OS.Cmd.run command 691 | | _, _ -> ( 692 | let dune_exec_cmd = Bos.OS.Cmd.run_out command in 693 | let command_result = Bos.OS.Cmd.to_string dune_exec_cmd in 694 | match command_result, help_ppf, err_ppf with 695 | | Ok output, Some help_ppf, _ -> Format.fprintf help_ppf "%s" output; Ok () 696 | | Error `Msg err, _, Some err_ppf -> Format.fprintf err_ppf "%s" err; Ok () 697 | | _ -> Ok () 698 | ) 699 | 700 | let exit_err = function 701 | | Ok v -> v 702 | | Error (`Msg m) -> 703 | R.pp_msg Format.std_formatter (`Msg m) ; 704 | print_newline (); 705 | flush_all (); 706 | exit 1 707 | 708 | let handle_parse_args_no_config ?help_ppf ?err_ppf error argv = 709 | let base_keys = Config.extract_keys (P.create []) in 710 | let base_context = 711 | Key.context base_keys ~with_required:false ~stage:`Configure 712 | in 713 | let result = 714 | Cmd.parse_args ?help_ppf ?err_ppf ~name:P.name ~version:P.version 715 | ~configure:(Cmdliner.Term.pure ()) 716 | ~describe:(Cmdliner.Term.pure ()) 717 | ~build:(Cmdliner.Term.pure ()) 718 | ~clean:(Cmdliner.Term.pure ()) 719 | ~help:base_context 720 | argv 721 | in 722 | match result with 723 | | `Ok Cmd.Help -> () 724 | | `Error _ 725 | | `Ok (Cmd.Configure _ | Cmd.Describe _ | Cmd.Build _ | Cmd.Clean _) -> 726 | exit_err (Error error) 727 | | `Version 728 | | `Help -> () 729 | 730 | let run_with_argv ?help_ppf ?err_ppf argv = 731 | (* 1. Pre-parse the arguments set the log level, config file 732 | and root directory. *) 733 | init_global_state argv; 734 | (* 2. Build the config from the config file. *) 735 | (* There are three possible outcomes: 736 | 1. the config file is found and built successfully 737 | 2. no config file is specified 738 | 3. an attempt is made to access the base keys at this point. 739 | when they weren't loaded *) 740 | 741 | match build_and_execute ?help_ppf ?err_ppf argv with 742 | | Error (`Invalid_config_ml err) -> exit_err (Error (`Msg err)) 743 | | Error (`Msg _ as err) -> 744 | handle_parse_args_no_config ?help_ppf ?err_ppf err argv 745 | | Ok () -> () 746 | 747 | let run () = 748 | run_with_argv Sys.argv 749 | 750 | (* STAGE 2 *) 751 | 752 | let src = Logs.Src.create (P.name^"-configure") ~doc:"functoria generated" 753 | module Log = (val Logs.src_log src : Logs.LOG) 754 | 755 | module Config' = struct 756 | let pp_info (f:('a, Format.formatter, unit) format -> 'a) level info = 757 | let verbose = Logs.level () >= level in 758 | f "@[%a@]" (Info.pp verbose) info 759 | 760 | let eval_cached ~partial cached_context t = 761 | let f c = 762 | let info = Config.eval ~partial c t in 763 | let keys = Key.deps info in 764 | let term = Key.context ~stage:`Configure ~with_required:false keys in 765 | match Cache.get_context t.Config.build_dir term with 766 | | `Ok (Some c) -> `Ok (Key.eval c info c) 767 | | `Ok None -> let c = Key.empty_context in`Ok (Key.eval c info c) 768 | | `Error _ | `Help _ as err -> err 769 | in 770 | Cmdliner.Term.(ret (pure f $ ret @@ pure @@ Cache.require cached_context)) 771 | 772 | let eval ~partial ~with_required context t = 773 | let info = Config.eval ~partial context t in 774 | let context = 775 | Key.context ~with_required ~stage:`Configure (Key.deps info) 776 | in 777 | let f map = Key.eval map info map in 778 | Cmdliner.Term.(pure f $ context) 779 | end 780 | 781 | let set_output config term = 782 | match Cache.get_output config.Config.build_dir with 783 | | `Ok (Some o) -> 784 | let update_output (r, i) = r, Info.with_output i o in 785 | Cmdliner.Term.(app (const update_output) term) 786 | | _ -> term 787 | 788 | let exit_err = function 789 | | Ok v -> v 790 | | Error (`Msg m) -> 791 | R.pp_msg Format.std_formatter (`Msg m) ; 792 | print_newline (); 793 | flush_all (); 794 | exit 1 795 | 796 | (* FIXME: describe init *) 797 | let describe _info ~dotcmd ~dot ~output (_init, job) = 798 | let f fmt = (if dot then Config.pp_dot else Config.pp) fmt job in 799 | let with_fmt f = match output with 800 | | None when dot -> 801 | f Format.str_formatter ; 802 | let data = Format.flush_str_formatter () in 803 | Bos.OS.File.tmp ~mode:0o644 "graph%s.dot" >>= fun tmp -> 804 | Bos.OS.File.write tmp data >>= fun () -> 805 | Bos.OS.Cmd.run Bos.Cmd.(v dotcmd % p tmp) 806 | | None -> Ok (f Fmt.stdout) 807 | | Some s -> 808 | with_output (Fpath.v s) 809 | (fun oc () -> Ok (f (Format.formatter_of_out_channel oc))) 810 | in 811 | with_fmt f 812 | 813 | let with_output i = function 814 | | None -> i 815 | | Some o -> Info.with_output i o 816 | 817 | let configure_main ~argv i jobs = 818 | let main = match Info.output i with None -> "main" | Some f -> f in 819 | let file = main ^ ".ml" in 820 | Log.info (fun m -> m "Generating: %s" file); 821 | Codegen.set_main_ml file; 822 | Codegen.append_main "(* %s *)" (Codegen.generated_header ()); 823 | Codegen.newline_main (); 824 | Codegen.append_main "%a" Fmt.text P.prelude; 825 | Codegen.newline_main (); 826 | Codegen.append_main "let _ = Printexc.record_backtrace true"; 827 | Codegen.newline_main (); 828 | Cache.save ~argv (Info.build_dir i) >>= fun () -> 829 | Engine.configure_and_connect i jobs >>| fun () -> 830 | Codegen.newline_main () 831 | 832 | let clean_main i jobs = 833 | Engine.clean i jobs >>= fun () -> 834 | Bos.OS.File.delete Fpath.(v "main.ml") 835 | 836 | let configure ~argv i jobs = 837 | let source_dir = get_relative_source_dir () in 838 | Log.debug (fun l -> l "source-dir=%a" Fpath.pp source_dir); 839 | Log.info (fun m -> m "Configuration: %a" Fpath.pp !config_file); 840 | Log.info (fun m -> m "Output : %a" Fmt.(option string) (Info.output i)); 841 | Log.info (fun m -> m "Build-dir : %a" Fpath.pp (Info.build_dir i)); 842 | with_current 843 | (Info.build_dir i) 844 | (fun () -> configure_main ~argv i jobs) 845 | "configure" 846 | 847 | let build i jobs = 848 | Log.info (fun m -> m "Building: %a" Fpath.pp !config_file); 849 | with_current 850 | (Info.build_dir i) 851 | (fun () -> Engine.build i jobs) 852 | "build" 853 | 854 | let clean i (_init, job) = 855 | Log.info (fun m -> m "Cleaning: %a" Fpath.pp !config_file); 856 | let clean_file file = 857 | can_overwrite file >>= function 858 | | false -> Ok () 859 | | true -> Bos.OS.File.delete file 860 | in 861 | clean_file Fpath.(v "dune-project") >>= fun () -> 862 | Cache.clean (Info.build_dir i) >>= fun () -> 863 | (match Sys.getenv "INSIDE_FUNCTORIA_TESTS" with 864 | | "1" -> Ok () 865 | | exception Not_found -> Bos.OS.Dir.delete ~recurse:true Fpath.(v "_build") 866 | | _ -> Bos.OS.Dir.delete ~recurse:true Fpath.(v "_build") 867 | ) >>= fun () -> 868 | with_current 869 | (Info.build_dir i) 870 | (fun () -> 871 | clean_main i job >>= fun () -> 872 | clean_file Fpath.(v "dune") >>= fun () -> 873 | clean_file Fpath.(v "dune.config") >>= fun () -> 874 | clean_file Fpath.(v "dune.build") >>= fun () -> 875 | Bos.OS.File.delete Fpath.(v ".merlin")) 876 | "clean" 877 | 878 | let handle_parse_args_result argv = function 879 | | `Error _ -> exit 1 880 | | `Ok Cmd.Help -> () 881 | | `Ok (Cmd.Configure { result = (jobs, info); output }) -> 882 | let info = with_output info output in 883 | Log.info (fun m -> Config'.pp_info m (Some Logs.Debug) info); 884 | exit_err (configure ~argv info jobs) 885 | | `Ok (Cmd.Build (jobs, info)) -> 886 | Log.info (fun m -> Config'.pp_info m (Some Logs.Debug) info); 887 | exit_err (build info jobs) 888 | | `Ok (Cmd.Describe { result = (jobs, info); dotcmd; dot; output }) -> 889 | Config'.pp_info Fmt.(pf stdout) (Some Logs.Info) info; 890 | R.error_msg_to_invalid_arg (describe info jobs ~dotcmd ~dot ~output) 891 | | `Ok (Cmd.Clean (jobs, info)) -> 892 | Log.info (fun m -> Config'.pp_info m (Some Logs.Debug) info); 893 | exit_err (clean info jobs) 894 | | `Version 895 | | `Help -> () 896 | 897 | let run_configure_with_argv argv config = 898 | (* whether to fully evaluate the graph *) 899 | let full_eval = Cmd.read_full_eval argv in 900 | (* Consider only the 'if' keys. *) 901 | let if_term = 902 | let if_keys = Config.keys config in 903 | Key.context ~stage:`Configure ~with_required:false if_keys 904 | in 905 | 906 | let context = match Cmdliner.Term.eval_peek_opts ~argv if_term with 907 | | _, `Ok context -> context 908 | | _ -> Key.empty_context 909 | in 910 | 911 | (* this is a trim-down version of the cached context, with only 912 | the values corresponding to 'if' keys. This is useful to 913 | start reducing the config into something consistent. *) 914 | let cached_context = Cache.get_context config.build_dir if_term in 915 | 916 | (* 3. Parse the command-line and handle the result. *) 917 | 918 | let configure = 919 | Config'.eval ~with_required:true ~partial:false context config 920 | and describe = 921 | let context = Cache.merge ~cache:cached_context context in 922 | let partial = match full_eval with 923 | | Some true -> false 924 | | Some false -> true 925 | | None -> not (Cache.present cached_context) 926 | in 927 | Config'.eval ~with_required:false ~partial context config 928 | and build = 929 | Config'.eval_cached ~partial:false cached_context config 930 | |> set_output config 931 | and clean = 932 | Config'.eval_cached ~partial:false cached_context config 933 | |> set_output config 934 | and help = 935 | let context = Cache.merge ~cache:cached_context context in 936 | let info = Config.eval ~partial:false context config in 937 | let keys = Key.deps info in 938 | Key.context ~stage:`Configure ~with_required:false keys 939 | in 940 | 941 | handle_parse_args_result argv 942 | (Cmd.parse_args ~name:P.name ~version:P.version 943 | ~configure 944 | ~describe 945 | ~build 946 | ~clean 947 | ~help 948 | argv) 949 | 950 | let register ?packages ?keys ?(init=default_init) name jobs = 951 | (* 1. Pre-parse the arguments set the log level, config file 952 | and root directory. *) 953 | init_global_state Sys.argv; 954 | let build_dir = get_build_dir () in 955 | let main_dev = P.create (init @ jobs) in 956 | let c = Config.make ?keys ?packages ~init name build_dir main_dev in 957 | run_configure_with_argv Sys.argv c 958 | 959 | end 960 | -------------------------------------------------------------------------------- /app/functoria_app.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Thomas Gazagnaire 3 | * Copyright (c) 2013 Anil Madhavapeddy 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | (** Application builder. *) 19 | 20 | open Functoria 21 | 22 | (** {1 Useful module implementations} *) 23 | 24 | val noop: job impl 25 | (** [noop] is an implementation of {!Functoria.job} that holds no 26 | state, does nothing and has no dependency. *) 27 | 28 | type argv 29 | (** The type for command-line arguments, similar to the usual 30 | [Sys.argv]. *) 31 | 32 | val argv: argv typ 33 | (** [argv] is a value representing {!argv} module types. *) 34 | 35 | val sys_argv: argv impl 36 | (** [sys_argv] is a device providing command-line arguments by using 37 | {!Sys.argv}. *) 38 | 39 | val keys: argv impl -> job impl 40 | (** [keys a] is an implementation of {!Functoria.job} that holds the 41 | parsed command-line arguments. *) 42 | 43 | type info 44 | (** The type for application about the application being built. *) 45 | 46 | val info: info typ 47 | (** [info] is a value representing {!info} module types. *) 48 | 49 | val app_info: ?type_modname:string -> ?gen_modname:string -> unit -> info impl 50 | (** [app_info] is the module implementation whose state contains all 51 | the information available at configure-time. The type of the 52 | generated value lives in the module [type_modname]: if not set, it 53 | is [Functoria_info]. The value is stored into a generated module 54 | name [gen_modname]: if not set, it is [Info_gen]. *) 55 | 56 | (** {1 Builders} *) 57 | 58 | (** [S] is the signature that application builders have to provide. *) 59 | module type S = sig 60 | 61 | open Functoria 62 | 63 | val prelude: string 64 | (** Prelude printed at the beginning of [main.ml]. 65 | 66 | It should put in scope: 67 | 68 | - a [run] function of type ['a t -> 'a] 69 | - a [return] function of type ['a -> 'a t] 70 | - a [>>=] operator of type ['a t -> ('a -> 'b t) -> 'b t] 71 | *) 72 | 73 | val name: string 74 | (** Name of the custom DSL. *) 75 | 76 | val packages: package list 77 | (** The packages to load when compiling the configuration file. *) 78 | 79 | val ignore_dirs: string list 80 | (** Directories to ignore when compiling the configuration file. *) 81 | 82 | val version: string 83 | (** Version of the custom DSL. *) 84 | 85 | val create: job impl list -> job impl 86 | (** [create jobs] is the top-level job in the custom DSL which will 87 | execute the given list of [job]. *) 88 | 89 | end 90 | 91 | module Make (P: S): sig 92 | 93 | open Functoria 94 | 95 | (** Configuration builder: stage 1 *) 96 | 97 | val run: unit -> unit 98 | (** Run the configuration builder. This should be called exactly once 99 | to run the configuration builder: command-line arguments will be 100 | parsed, and some code will be generated and compiled. *) 101 | 102 | val run_with_argv: 103 | ?help_ppf:Format.formatter -> ?err_ppf:Format.formatter -> 104 | string array -> unit 105 | (** [run_with_argv a] is the same as {!run} but parses [a] instead 106 | of the process command line arguments. It also allows to set 107 | the error and help channels using [help_ppf] and [err_ppf]. *) 108 | 109 | 110 | (** Configuration module: stage 2 *) 111 | 112 | val register: 113 | ?packages:package list -> 114 | ?keys:key list -> 115 | ?init:job impl list -> 116 | string -> job impl list -> unit 117 | (** [register name jobs] registers the application named by [name] 118 | which will execute the given [jobs]. Same optional arguments as 119 | {!Functoria.foreign}. 120 | 121 | [init] is the list of job to execute before anything else (such 122 | as command-line argument parsing, log reporter setup, etc.). The 123 | jobs are always executed in the sequence specified by the 124 | caller. *) 125 | end 126 | 127 | 128 | module type DSL = module type of struct include Functoria end 129 | (** The signature of Functoria-like DSLs. *) 130 | 131 | (** {1 Misc} *) 132 | 133 | (** Name helpers. *) 134 | module Name: sig 135 | 136 | val ocamlify: string -> string 137 | (** [ocamlify n] is an OCaml identifier looking very much like [n], 138 | but where invalid characters have been removed or replaced: all 139 | characters outside of ['a'-'z''A'-'Z''0''9''_''-'], and 140 | replacing '-' with '_'. If the resulting string starts with a 141 | digit or is empty then it raises [Invalid_argument]. *) 142 | 143 | val create: string -> prefix:string -> string 144 | (** [name key ~prefix] is an deterministic name starting by 145 | [prefix]. The name is derived from [key]. *) 146 | 147 | end 148 | 149 | (** Code generation helpers. *) 150 | module Codegen: sig 151 | 152 | val generated_header: ?argv:string array -> ?time:Ptime.t -> unit -> string 153 | 154 | val append: 155 | Format.formatter -> ('a, Format.formatter, unit, unit, unit, unit) format6 -> 'a 156 | 157 | val newline: Format.formatter -> unit 158 | 159 | val set_main_ml: string -> unit 160 | (** Define the current main file. *) 161 | 162 | val append_main: ('a, Format.formatter, unit, unit, unit, unit) format6 -> 'a 163 | (** Add some string to [main.ml]. *) 164 | 165 | val newline_main: unit -> unit 166 | (** Add a newline to [main.ml]. *) 167 | 168 | end 169 | -------------------------------------------------------------------------------- /app/functoria_command_line.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | let setup_log style_renderer level = 18 | Fmt_tty.setup_std_outputs ?style_renderer (); 19 | Logs.set_level level; 20 | Logs.set_reporter (Logs_fmt.reporter ()) 21 | 22 | open Cmdliner 23 | 24 | let common_section = "COMMON OPTIONS" 25 | let configuration_section = "CONFIGURE OPTIONS" 26 | let description_section = "DESCRIBE OPTIONS" 27 | 28 | let setup_log = 29 | Term.(const setup_log 30 | $ Fmt_cli.style_renderer ~docs:common_section () 31 | $ Logs_cli.level ~docs:common_section ()) 32 | 33 | let config_file f = 34 | let doc = 35 | Arg.info 36 | ~docs:configuration_section 37 | ~docv:"FILE" 38 | ~doc:"The configuration file to use." 39 | ["f"; "file"] 40 | in 41 | Term.(const (fun x -> f (Fpath.v x)) 42 | $ Arg.(value & opt string "config.ml" & doc)) 43 | 44 | let build_dir f = 45 | let doc = 46 | Arg.info 47 | ~docs:configuration_section 48 | ~docv:"DIR" 49 | ~doc:"The directory where the build is done." 50 | ["b"; "build-dir"] 51 | in 52 | Term.(const (function None -> () | Some x -> f (Fpath.v x)) 53 | $ Arg.(value & opt (some string) None & doc)) 54 | 55 | (** 56 | * Argument specifications 57 | *) 58 | 59 | (** Argument specification for --eval *) 60 | let full_eval = 61 | let eval_doc = 62 | Arg.info ~docs:description_section ["eval"] 63 | ~doc:"Fully evaluate the graph before showing it. \ 64 | The default when the unikernel has already been configured." 65 | in 66 | let no_eval_doc = 67 | Arg.info ~docs:description_section ["no-eval"] 68 | ~doc:"Do not evaluate the graph before showing it. See $(b,--eval). \ 69 | The default when the unikernel has not been configured." 70 | in 71 | let eval_opts = [ (Some true, eval_doc) ; (Some false, no_eval_doc) ] in 72 | Arg.(value & vflag None eval_opts) 73 | 74 | (** Argument specification for --dot *) 75 | let dot = 76 | let doc = 77 | Arg.info ~docs:description_section ["dot"] 78 | ~doc:"Output a dot description. If no output file is given, it will \ 79 | display the dot file using the command given to \ 80 | $(b,--dot-command)." 81 | in 82 | Arg.(value & flag doc) 83 | 84 | (** Argument specification for --dot-command=COMMAND *) 85 | let dotcmd = 86 | let doc = 87 | Arg.info ~docs:description_section ~docv:"COMMAND" [ "dot-command" ] 88 | ~doc:"Command used to show a dot file. This command should accept a \ 89 | dot file on its standard input." 90 | in 91 | Arg.(value & opt string "xdot" & doc) 92 | 93 | (** Argument specification for -o FILE or --output=FILE *) 94 | let output = 95 | let doc = 96 | Arg.info ~docs:configuration_section ~docv:"FILE" ["o"; "output"] 97 | ~doc:"Name of the output file." 98 | in 99 | Arg.(value & opt (some string) None & doc) 100 | 101 | type 'a describe_args = { 102 | result: 'a; 103 | dotcmd: string; 104 | dot: bool; 105 | output: string option; 106 | } 107 | 108 | type 'a configure_args = { 109 | result: 'a; 110 | output: string option; 111 | } 112 | 113 | type 'a action = 114 | Configure of 'a configure_args 115 | | Describe of 'a describe_args 116 | | Build of 'a 117 | | Clean of 'a 118 | | Help 119 | 120 | 121 | (* 122 | * Pretty-printing 123 | *) 124 | let pp_configure pp_a ppf (c: 'a configure_args) = 125 | Fmt.pf ppf "@[result:%a@;output:%a@]" 126 | pp_a c.result Fmt.(option string) c.output 127 | 128 | let pp_describe pp_a ppf (d: 'a describe_args) = 129 | Fmt.pf ppf "@[result:%a@;dotcmd:%s@;dot:%a@;output:%a@]" 130 | pp_a d.result d.dotcmd Fmt.bool d.dot Fmt.(option string) d.output 131 | 132 | let pp_action pp_a ppf = function 133 | | Configure c -> Fmt.pf ppf "@[configure:@ @[<2>%a@]@]" (pp_configure pp_a) c 134 | | Describe d -> Fmt.pf ppf "@[describe:@ @[<2>%a@]@]" (pp_describe pp_a) d 135 | | Build b -> Fmt.pf ppf "@[build:@ @[<2>%a@]@]" pp_a b 136 | | Clean c -> Fmt.pf ppf "@[clean:@ @[<2>%a@]@]" pp_a c 137 | | Help -> Fmt.string ppf "help" 138 | 139 | let setup = 140 | let noop _ = () in 141 | Term.(const (fun () () () -> ()) 142 | $ setup_log 143 | $ config_file noop 144 | $ build_dir noop) 145 | 146 | (* 147 | * Subcommand specifications 148 | *) 149 | module Subcommands = 150 | struct 151 | (** The 'configure' subcommand *) 152 | let configure result = 153 | Term.(const (fun _ output result -> Configure { output; result }) 154 | $ setup 155 | $ output 156 | $ result), 157 | Term.info "configure" 158 | ~doc:"Configure a $(mname) application." 159 | ~man:[ 160 | `S "DESCRIPTION"; 161 | `P "The $(b,configure) command initializes a fresh $(mname) \ 162 | application." 163 | ] 164 | 165 | (** The 'describe' subcommand *) 166 | let describe result = 167 | Term.(const (fun _ _ info output dotcmd dot -> 168 | Describe { result = info; dotcmd; dot; output }) 169 | $ setup 170 | $ full_eval 171 | $ result 172 | $ output 173 | $ dotcmd 174 | $ dot), 175 | Term.info "describe" 176 | ~doc:"Describe a $(mname) application." 177 | ~man:[ 178 | `S "DESCRIPTION"; 179 | `P "The $(b,describe) command describes the configuration of a \ 180 | $(mname) application."; 181 | `P "The dot output contains the following elements:"; 182 | `Noblank; 183 | `I ("If vertices", 184 | "Represented as circles. Branches are dotted, and the default branch \ 185 | is in bold."); 186 | `Noblank; 187 | `I ("Configurables", 188 | "Represented as rectangles. The order of the output arrows is \ 189 | the order of the functor arguments."); 190 | `Noblank; 191 | `I ("Data dependencies", 192 | "Represented as dashed arrows."); 193 | `Noblank; 194 | `I ("App vertices", 195 | "Represented as diamonds. The bold arrow is the functor part."); 196 | ] 197 | 198 | (** The 'build' subcommand *) 199 | let build result = 200 | let doc = "Build a $(mname) application." in 201 | Term.(const (fun _ info -> Build info) 202 | $ setup 203 | $ result), 204 | Term.info "build" ~doc 205 | ~man:[ 206 | `S "DESCRIPTION"; 207 | `P doc; 208 | ] 209 | 210 | (** The 'clean' subcommand *) 211 | let clean info_ = 212 | let doc = "Clean the files produced by $(mname) for a given application." in 213 | Term.(const (fun _ info -> Clean info) 214 | $ setup 215 | $ info_), 216 | Term.info "clean" ~doc 217 | ~man:[ 218 | `S "DESCRIPTION"; 219 | `P doc; 220 | ] 221 | 222 | (** The 'help' subcommand *) 223 | let help base_context = 224 | let topic = 225 | let doc = Arg.info [] ~docv:"TOPIC" ~doc:"The topic to get help on." in 226 | Arg.(value & pos 0 (some string) None & doc ) 227 | in 228 | let help man_format cmds topic _keys = 229 | match topic with 230 | | None -> `Help (`Pager, None) 231 | | Some topic -> 232 | let parser, _ = Arg.enum (List.rev_map (fun s -> (s, s)) ("topics" :: cmds)) in 233 | match parser topic with 234 | | `Error e -> `Error (false, e) 235 | | `Ok t when t = "topics" -> List.iter print_endline cmds; `Ok () 236 | | `Ok t -> `Help (man_format, Some t) 237 | in 238 | Term.(const (fun _ _ () -> Help) 239 | $ setup 240 | $ output 241 | $ ret (const help 242 | $ Term.man_format 243 | $ Term.choice_names 244 | $ topic 245 | $ base_context)), 246 | Term.info "help" 247 | ~doc:"Display help about $(mname) commands." 248 | ~man:[ 249 | `S "DESCRIPTION"; 250 | `P "Prints help."; 251 | `P "Use `$(mname) help topics' to get the full list of help topics."; 252 | ] 253 | 254 | let default ~name ~version = 255 | let usage = `Help (`Plain, None) 256 | in 257 | Term.(ret (pure usage) $ setup), 258 | Term.info name 259 | ~version 260 | ~doc:"The $(mname) application builder" 261 | ~man:[ 262 | `S "DESCRIPTION"; 263 | `P "The $(mname) application builder. It glues together a set of \ 264 | libraries and configuration (e.g. network and storage) into a \ 265 | standalone unikernel or UNIX binary."; 266 | `P "Use $(mname) $(b,help ) for more information on a \ 267 | specific command."; 268 | ] 269 | end 270 | 271 | (* 272 | * Functions for extracting particular flags from the command line. 273 | *) 274 | let read_full_eval : string array -> bool option = 275 | fun argv -> match Term.eval_peek_opts ~argv full_eval with 276 | | _, `Ok b -> b 277 | | _ -> None 278 | 279 | let parse_args ?help_ppf ?err_ppf 280 | ~name ~version ~configure ~describe ~build ~clean ~help argv 281 | = 282 | Cmdliner.Term.eval_choice ?help:help_ppf ?err:err_ppf ~argv ~catch:false 283 | (Subcommands.default ~name ~version) [ 284 | Subcommands.configure configure; 285 | Subcommands.describe describe; 286 | Subcommands.build build; 287 | Subcommands.clean clean; 288 | Subcommands.help help; 289 | ] 290 | -------------------------------------------------------------------------------- /app/functoria_command_line.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (** Functions for reading various options from a command line. *) 18 | 19 | val setup_log : unit Cmdliner.Term.t 20 | val config_file : (Fpath.t -> unit) -> unit Cmdliner.Term.t 21 | val build_dir: (Fpath.t -> unit) -> unit Cmdliner.Term.t 22 | val output: string option Cmdliner.Term.t 23 | 24 | val read_full_eval : string array -> bool option 25 | (** [read_full_eval argv] reads the --eval option from [argv]; the return 26 | value is [None] if option is absent in [argv]. *) 27 | 28 | type 'a configure_args = { 29 | result: 'a; 30 | output: string option; 31 | } 32 | (** A value of type [configure_args] is the result of parsing the arguments of 33 | a [configure] subcommand. *) 34 | 35 | type 'a describe_args = { 36 | result: 'a; 37 | dotcmd: string; 38 | dot: bool; 39 | output: string option; 40 | } 41 | (** A value of type [describe_args] is the result of parsing the arguments to 42 | a [describe] subcommand. 43 | 44 | The [result] field holds the result of parsing the "additional" arguments 45 | whose specification is passed as the [describe] argument to 46 | {!parse_args}. *) 47 | 48 | type 'a action = 49 | Configure of 'a configure_args 50 | | Describe of 'a describe_args 51 | | Build of 'a 52 | | Clean of 'a 53 | | Help 54 | (** A value of type [action] is the result of parsing command-line arguments using 55 | [parse_args]. *) 56 | 57 | val pp_action: 'a Fmt.t -> 'a action Fmt.t 58 | (** [pp_action] is the pretty-printer for actions. *) 59 | 60 | open Cmdliner.Term 61 | 62 | val parse_args : 63 | ?help_ppf:Format.formatter -> 64 | ?err_ppf:Format.formatter -> 65 | name:string -> version:string -> 66 | configure:'a t -> 67 | describe:'a t -> 68 | build:'a t -> 69 | clean:'a t -> 70 | help:_ t -> 71 | string array -> 72 | 'a action result 73 | (** Parse the functoria command line. The arguments to [~configure], 74 | [~describe], etc., describe extra command-line arguments that should be 75 | accepted by the corresponding subcommands. The full argument 76 | specification is as follows: 77 | 78 | name configure [-v|--verbose] 79 | [--color=(auto|always|never)] 80 | [extra arguments] 81 | name describe [--eval] 82 | [-v|--verbose] 83 | [--color=(auto|always|never)] 84 | [-o FILE | --output=FILE] 85 | [--dot-command=COMMAND] 86 | [--dot] 87 | [extra arguments] 88 | name build [-v|--verbose] 89 | [--color=(auto|always|never)] 90 | [extra arguments] 91 | name clean [-v|--verbose] 92 | [--color=(auto|always|never)] 93 | [extra arguments] 94 | name help [-v|--verbose] 95 | [--color=(auto|always|never)] 96 | [--man-format=(groff|pager|plain)] 97 | [configure|describe|build|clean|help|topics] 98 | [extra arguments] 99 | name [-v|--verbose] 100 | [--color=(auto|always|never)] 101 | 102 | There are no side effects, save for the printing of usage messages and 103 | other help when either the 'help' subcommand or no subcommand is specified. *) 104 | -------------------------------------------------------------------------------- /app/functoria_graph.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Gabriel Radanne 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (* {1 Graph engine} *) 18 | 19 | (* This module is not optimized for speed, it's optimized for correctness 20 | and readability. If you need to make it faster: 21 | - Good luck. 22 | - Please update the invariant section. 23 | *) 24 | 25 | open Graph 26 | open Functoria_misc 27 | open Functoria 28 | 29 | module Key = Functoria_key 30 | 31 | (* {2 Utility} *) 32 | 33 | let fold_lefti f l z = 34 | fst @@ List.fold_left (fun (s,i) x -> f i x s, i+1) (z,0) l 35 | 36 | (* Check if [l] is an increasing sequence from [O] to [len-1]. *) 37 | let is_sequence l = 38 | snd @@ 39 | List.fold_left 40 | (fun (i,b) (j,_) -> i+1, b && (i = j)) 41 | (0,true) 42 | l 43 | 44 | (* {2 Graph} *) 45 | 46 | type subconf = < 47 | name: string; 48 | module_name: string; 49 | keys: Key.t list; 50 | packages: package list Key.value; 51 | connect: Info.t -> string -> string list -> string; 52 | build: Info.t -> (unit, Rresult.R.msg) result; 53 | configure: Info.t -> (unit, Rresult.R.msg) result; 54 | clean: Info.t -> (unit, Rresult.R.msg) result; 55 | > 56 | 57 | (* Helpers for If nodes. *) 58 | module If = struct 59 | type dir = Else | Then 60 | type path = dir list * dir 61 | let append (l,z) (l',z') = (l@z::l', z') 62 | let singleton z = ([],z) 63 | let dir b = if b then singleton Then else singleton Else 64 | let fuse path v l = if v = path then append path l else path 65 | let reduce f ~path ~add : path Key.value = Key.(pure (fuse path) $ f $ add) 66 | end 67 | 68 | type label = 69 | | If of If.path Key.value 70 | | Impl of subconf 71 | | App 72 | 73 | type edge_label = 74 | | Parameter of int 75 | | Dependency of int 76 | | Condition of If.path 77 | | Functor 78 | 79 | 80 | 81 | module V_ = struct 82 | type t = label 83 | end 84 | 85 | module E_ = struct 86 | type t = edge_label 87 | let default = Parameter 0 88 | let compare = compare 89 | end 90 | 91 | module G = Persistent.Digraph.AbstractLabeled (V_) (E_) 92 | module Tbl = Hashtbl.Make(G.V) 93 | 94 | type t = G.t 95 | type vertex = G.V.t 96 | 97 | module Dfs = Traverse.Dfs(G) 98 | module Topo = Topological.Make(G) 99 | 100 | (* The invariants of graphs manipulated here are: 101 | 102 | - [If] vertices have exactly [n] [Condition] children. 103 | 104 | - [Impl] vertices have [n] [Parameter] children and [m] 105 | [Dependency] children. [Parameter] (resp. [Dependency]) children 106 | are labeled from [0] to [n-1] (resp. [m-1]). They do not have 107 | [Condition] nor [Functor] children. 108 | 109 | - [App] vertices have one [Functor] child and [n] [Parameter] 110 | children (with [n >= 1]) following the [Impl] convention. They 111 | have neither [Condition] nor [Dependency] children. 112 | 113 | - There are no cycles. 114 | 115 | - There is only one root (vertex with a degree 1). There are no orphans. 116 | 117 | *) 118 | 119 | (* {3 Graph utilities} *) 120 | 121 | let hash = G.V.hash 122 | 123 | let add_edge e1 label e2 graph = 124 | G.add_edge_e graph @@ G.E.create e1 label e2 125 | 126 | let for_all_vertex f g = 127 | G.fold_vertex (fun v b -> b && f v) g true 128 | 129 | (* Remove a vertex and all its orphan successors, recursively. *) 130 | let rec remove_rec g v = 131 | let children = G.succ g v in 132 | let g = G.remove_vertex g v in 133 | List.fold_right 134 | (fun c g -> remove_rec_if_orphan g c) 135 | children 136 | g 137 | 138 | and remove_rec_if_orphan g c = 139 | if G.mem_vertex g c && G.in_degree g c = 0 140 | then remove_rec g c 141 | else g 142 | 143 | (* [add_pred_with_subst g preds v] add the edges [pred] to [g] 144 | with the destination replaced by [v]. *) 145 | let add_pred_with_subst g preds v = 146 | List.fold_left 147 | (fun g e -> G.add_edge_e g @@ G.E.(create (src e) (label e) v)) 148 | g 149 | preds 150 | 151 | (* {2 Graph construction} *) 152 | 153 | let add_impl graph ~impl ~args ~deps = 154 | let v = G.V.create (Impl impl) in 155 | v, 156 | G.add_vertex graph v 157 | |> fold_lefti (fun i -> add_edge v (Parameter i)) args 158 | |> fold_lefti (fun i -> add_edge v (Dependency i)) deps 159 | 160 | let add_switch graph ~cond l = 161 | let v = G.V.create (If cond) in 162 | v, 163 | List.fold_right (fun (p,v') -> add_edge v (Condition p) v') l @@ 164 | G.add_vertex graph v 165 | 166 | let add_if graph ~cond ~else_ ~then_ = 167 | add_switch graph ~cond:(Key.map If.dir cond) 168 | [ If.(singleton Else), else_; If.(singleton Then), then_ ] 169 | 170 | let add_app graph ~f ~args = 171 | let v = G.V.create App in 172 | v, 173 | G.add_vertex graph v 174 | |> add_edge v Functor f 175 | |> fold_lefti (fun i -> add_edge v (Parameter i)) args 176 | 177 | let create impl = 178 | let module H = ImplTbl in 179 | let tbl = H.create 50 in 180 | let rec aux: type t . G.t -> t impl -> G.vertex * G.t 181 | = fun g impl -> 182 | if H.mem tbl @@ abstract impl 183 | then H.find tbl (abstract impl), g 184 | else 185 | let v, g = match explode impl with 186 | | `Impl c -> 187 | let deps, g = 188 | List.fold_right 189 | (fun (Abstract x) (l,g) -> let v, g = aux g x in v::l, g) 190 | c#deps ([], g) 191 | in 192 | add_impl g ~impl:(c :> subconf) ~args:[] ~deps 193 | | `If (cond, then_, else_) -> 194 | let then_, g = aux g then_ in 195 | let else_, g = aux g else_ in 196 | add_if g ~cond ~then_ ~else_ 197 | | `App (Abstract f , Abstract x) -> 198 | let f, g = aux g f in 199 | let x, g = aux g x in 200 | add_app g ~f ~args:[x] 201 | in 202 | H.add tbl (abstract impl) v; 203 | v, g 204 | in 205 | snd @@ aux G.empty impl 206 | 207 | let is_impl v = match G.V.label v with 208 | | Impl _ -> true 209 | | App | If _ -> false 210 | 211 | (* {2 Graph destruction/extraction} *) 212 | 213 | let collect 214 | : type ty. (module Monoid with type t = ty) -> 215 | (label -> ty) -> G.t -> ty 216 | = fun (module M) f g -> 217 | G.fold_vertex (fun v s -> M.union s @@ f (G.V.label v)) g M.empty 218 | 219 | let get_children g v = 220 | let split l = 221 | List.fold_right 222 | (fun e (args, deps, conds, funct) -> 223 | let v = G.E.dst e in match G.E.label e with 224 | | Parameter i -> (i, v)::args, deps, conds, funct 225 | | Dependency i -> args, (i, v)::deps, conds, funct 226 | | Condition path -> args, deps, (path, v)::conds, funct 227 | | Functor -> args, deps, conds, v :: funct 228 | ) 229 | l 230 | ([],[],[],[]) 231 | in 232 | let args, deps, cond, funct = split @@ G.succ_e g v in 233 | let args = List.sort (fun (i,_) (j,_) -> compare i j) args in 234 | let deps = List.sort (fun (i,_) (j,_) -> compare i j) deps in 235 | let funct = match funct with 236 | | [] -> None | [ x ] -> Some x 237 | | _ -> assert false 238 | in 239 | assert (is_sequence args); 240 | assert (is_sequence deps); 241 | `Args (List.map snd args), `Deps (List.map snd deps), cond, funct 242 | 243 | let explode g v = 244 | match G.V.label v, get_children g v with 245 | | Impl i , (args , deps , [], None ) -> `Impl (i, args, deps) 246 | | If cond, (`Args [] , `Deps [], l , None ) -> `If (cond, l) 247 | | App , (`Args args, `Deps [], [], Some f) -> `App (f, args) 248 | | (Impl _ | If _ | App), _ -> assert false 249 | 250 | let fold f g z = 251 | if Dfs.has_cycle g then 252 | invalid_arg "Functoria_graph.iter: A graph should not have cycles."; 253 | (* We iter in *reversed* topological order. *) 254 | let l = Topo.fold (fun x l -> x :: l) g [] in 255 | List.fold_left (fun z l -> f l z) z l 256 | 257 | let find_all_v g p = 258 | G.fold_vertex 259 | (fun v l -> if p v then v :: l else l) 260 | g [] 261 | 262 | let find_all g p = find_all_v g (fun x -> p @@ G.V.label x) 263 | 264 | let find_root g = 265 | let l = find_all_v g (fun v -> G.in_degree g v = 0) in 266 | match l with 267 | | [ x ] -> x 268 | | _ -> invalid_arg 269 | "Functoria_graph.find_root: A graph should have only one root." 270 | 271 | (* {2 Graph manipulation} *) 272 | 273 | (* Find a pattern in a graph. *) 274 | exception Found 275 | let find g predicate = 276 | let r = ref None in 277 | try 278 | G.iter_vertex 279 | (fun v -> match predicate g v with 280 | | Some _ as x -> r := x; raise Found 281 | | None -> ()) 282 | g; None 283 | with Found -> !r 284 | 285 | (* Find a pattern and apply the transformation, repeatedly. This could 286 | probably be made more efficient, but it would be complicated. *) 287 | let rec transform ~predicate ~apply g = 288 | match find g predicate with 289 | | Some v_if -> 290 | transform ~predicate ~apply @@ apply g v_if 291 | | None -> g 292 | 293 | module RemovePartialApp = struct 294 | (* Remove [App] vertices. 295 | 296 | The goal here is to remove partial application of functor. If we 297 | find an [App] vertex with an implementation as first children, We 298 | fuse them and create one [Impl] vertex. 299 | 300 | If we find successive [App] vertices, we merge them. 301 | *) 302 | 303 | let predicate g v = match explode g v with 304 | | `App (v',args) -> begin match explode g v' with 305 | | `Impl (impl, `Args args', `Deps deps) -> 306 | let add g = add_impl g ~impl ~args:(args'@args) ~deps in 307 | Some (v, v', add) 308 | | `App (f, args') -> 309 | let add g = add_app g ~f ~args:(args' @ args) in 310 | Some (v, v', add) 311 | | _ -> None 312 | end 313 | | _ -> None 314 | 315 | let apply g (v_app, v_f, add) = 316 | let preds = G.pred_e g v_app in 317 | let g = G.remove_vertex g v_app in 318 | let v_impl', g = add g in 319 | let g = add_pred_with_subst g preds v_impl' in 320 | remove_rec_if_orphan g v_f 321 | 322 | end 323 | 324 | module MergeNode = struct 325 | (* Merge successive If nodes with the same set of dependencies. 326 | 327 | This is completely useless for evaluation but very helpful for 328 | graph visualization by humans. 329 | *) 330 | 331 | let set_equal l1 l2 = 332 | Key.Set.equal (Key.deps l1) (Key.deps l2) 333 | 334 | let predicate g v = match explode g v with 335 | | `If (cond, l) -> 336 | if List.exists (fun (_,v) -> 337 | match G.V.label v with 338 | | If cond' -> set_equal cond cond' 339 | | App 340 | | Impl _ -> false 341 | ) l 342 | then Some (v, cond, l) 343 | else None 344 | | _ -> None 345 | 346 | 347 | let apply g (v_if, cond, l) = 348 | let f (new_cond, new_l) (path, v) = match explode g v with 349 | | `If (cond', l') when set_equal cond cond' -> 350 | If.reduce cond ~path ~add:cond', 351 | List.map (fun (p,v) -> If.append path p, v) l' @ new_l 352 | | _ -> 353 | new_cond, (path,v) :: new_l 354 | in 355 | let new_cond, new_l = List.fold_left f (cond,[]) l in 356 | let preds = G.pred_e g v_if in 357 | let g = G.remove_vertex g v_if in 358 | let v_new, g = add_switch g ~cond:new_cond new_l in 359 | let g = add_pred_with_subst g preds v_new in 360 | List.fold_left remove_rec_if_orphan g @@ List.map snd l 361 | 362 | end 363 | 364 | module EvalIf = struct 365 | (* Evaluate the [If] vertices and remove them. *) 366 | 367 | let predicate ~partial ~context _ v = match G.V.label v with 368 | | If cond when not partial || Key.mem context cond -> Some v 369 | | If _ | App | Impl _ -> None 370 | 371 | let extract path l = 372 | let rec aux = function 373 | | [] -> invalid_arg "Path is not present." 374 | | (path',v) :: t when path = path' -> v, List.map snd t 375 | | (_ ,v) :: t -> let v_found, l = aux t in v_found, v::l 376 | in 377 | aux l 378 | 379 | let apply ~partial ~context g v_if = 380 | let path, l = 381 | match explode g v_if with 382 | | `If x -> x | _ -> assert false 383 | in 384 | let preds = G.pred_e g v_if in 385 | if partial && not @@ Key.mem context path then g 386 | else 387 | let v_new, v_others = extract (Key.eval context path) l in 388 | let g = G.remove_vertex g v_if in 389 | let g = List.fold_left remove_rec_if_orphan g v_others in 390 | add_pred_with_subst g preds v_new 391 | 392 | end 393 | 394 | let simplify = MergeNode.(transform ~predicate ~apply) 395 | 396 | let normalize = RemovePartialApp.(transform ~predicate ~apply) 397 | 398 | let eval ?(partial=false) ~context g = 399 | normalize @@ 400 | EvalIf.(transform 401 | ~predicate:(predicate ~partial ~context) 402 | ~apply:(apply ~partial ~context) 403 | g) 404 | 405 | let is_fully_reduced g = 406 | for_all_vertex (fun v -> is_impl v) g 407 | 408 | 409 | (* {2 Dot output} *) 410 | 411 | module Dot = Graphviz.Dot(struct 412 | include G 413 | 414 | (* If you change the styling, please update the documentation of the 415 | describe command in {!Functorial_tool}. *) 416 | 417 | let graph_attributes _g = [ `OrderingOut ] 418 | let default_vertex_attributes _g = [] 419 | 420 | let vertex_name v = string_of_int @@ V.hash v 421 | 422 | let vertex_attributes v = match V.label v with 423 | | App -> [ `Label "$"; `Shape `Diamond ] 424 | | If cond -> 425 | [ `Label (Fmt.str "If\n%a" Key.pp_deps cond) ] 426 | | Impl f -> 427 | let label = 428 | Fmt.str 429 | "%s\n%s\n%a" 430 | f#name f#module_name 431 | Fmt.(list ~sep:(any ", ") Key.pp) 432 | f#keys 433 | in 434 | [ `Label label; `Shape `Box; ] 435 | 436 | let get_subgraph _g = None 437 | 438 | let default_edge_attributes _g = [] 439 | let edge_attributes e = match E.label e with 440 | | Functor -> [ `Style `Bold; `Tailport `SW] 441 | | Parameter _ -> [ ] 442 | | Dependency _ -> [ `Style `Dashed ] 443 | 444 | | Condition path -> 445 | let cond = 446 | match V.label @@ E.src e with 447 | | If cond -> cond | App | Impl _ -> assert false 448 | in 449 | let l = [ `Style `Dotted; `Headport `N ] in 450 | if Key.default cond = path then `Style `Bold :: l else l 451 | 452 | end ) 453 | 454 | let pp_dot = Dot.fprint_graph 455 | let pp = Fmt.nop 456 | -------------------------------------------------------------------------------- /app/functoria_graph.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Gabriel Radanne 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (** Graph engine *) 18 | 19 | open Functoria 20 | 21 | type subconf = < 22 | name : string; 23 | module_name: string; 24 | keys : key list; 25 | packages : package list value ; 26 | connect : Info.t -> string -> string list -> string; 27 | build : Info.t -> (unit, Rresult.R.msg) result; 28 | configure : Info.t -> (unit, Rresult.R.msg) result; 29 | clean : Info.t -> (unit, Rresult.R.msg) result; 30 | > 31 | (** A subset of {!configurable} with neither polymorphism nor recursion. *) 32 | 33 | type t 34 | type vertex 35 | 36 | module If: sig 37 | type path 38 | end 39 | 40 | (** The description of a vertex *) 41 | type label = 42 | | If of If.path value 43 | | Impl of subconf 44 | | App 45 | 46 | module Tbl: Hashtbl.S with type key = vertex 47 | 48 | val create: _ impl -> t 49 | (** [create impl] creates a graph based [impl]. *) 50 | 51 | val normalize: t -> t 52 | (** [normalize g] normalize the graph [g] by removing the [App] vertices. *) 53 | 54 | val simplify: t -> t 55 | (** [simplify g] simplifies the graph so that it's easier to read for humans. *) 56 | 57 | val eval: ?partial:bool -> context:context -> t -> t 58 | (** [eval ~keys g] will removes all the [If] vertices by resolving the 59 | keys using [keys]. It will then call {!normalize} 60 | 61 | If [partial] is [true], then it will only evaluate [If] vertices 62 | which condition is resolved. 63 | *) 64 | 65 | val is_fully_reduced: t -> bool 66 | (** [is_fully_reduced g] is true if [g] contains only 67 | [Impl] vertices. *) 68 | 69 | val fold: (vertex -> 'a -> 'a) -> t -> 'a -> 'a 70 | (** [fold f g z] applies [f] on each vertex of [g] in topological order. *) 71 | 72 | val find_all: t -> (label -> bool) -> vertex list 73 | (** [find_all g p] returns all the vertices in [g] such as [p v] is true. *) 74 | 75 | val find_root: t -> vertex 76 | (** [find_root g] returns the only vertex of [g] that has no predecessors. *) 77 | 78 | val explode: 79 | t -> vertex -> 80 | [ `App of vertex * vertex list 81 | | `If of If.path value * (If.path * vertex) list 82 | | `Impl of subconf 83 | * [> `Args of vertex list ] 84 | * [> `Deps of vertex list ] ] 85 | (** [explode g v] deconstructs the vertex [v] in the graph [g] 86 | into it's possible components. 87 | It also checks that the local invariants are respected. *) 88 | 89 | val collect: 90 | (module Functoria_misc.Monoid with type t = 'ty) -> 91 | (label -> 'ty) -> t -> 'ty 92 | (** [collect (module M) f g] collects the content of [f v] for 93 | each vertex [v] in [g]. *) 94 | 95 | val hash: vertex -> int 96 | 97 | val pp: t Fmt.t 98 | (** Textual representation of the graph. *) 99 | 100 | val pp_dot: t Fmt.t 101 | (** Dot representation of the graph. *) 102 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.1) 2 | (name functoria) 3 | -------------------------------------------------------------------------------- /functoria-runtime.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Gabriel Radanne " 3 | authors: [ "Thomas Gazagnaire" 4 | "Anil Madhavapeddy" 5 | "Dave Scott" 6 | "Thomas Leonard" 7 | "Gabriel Radanne" ] 8 | homepage: "https://github.com/mirage/functoria" 9 | bug-reports: "https://github.com/mirage/functoria/issues" 10 | dev-repo: "git+https://github.com/mirage/functoria.git" 11 | doc: "https://mirage.github.io/functoria/" 12 | license: "ISC" 13 | tags: ["org:mirage"] 14 | 15 | build: [ 16 | ["dune" "subst"] {dev} 17 | ["dune" "build" "-p" name "-j" jobs] 18 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 19 | ["env" "INSIDE_FUNCTORIA_TESTS=1" "dune" "exec" "-p" name "-j" jobs "--" "tests/test_full.exe"] {with-test} 20 | ] 21 | 22 | depends: [ 23 | "ocaml" {>= "4.08.0"} 24 | "dune" {>= "1.1.0"} 25 | "cmdliner" {>= "0.9.8"} 26 | "functoria" {with-test & = version} 27 | "alcotest" {with-test} 28 | ] 29 | 30 | synopsis: "Runtime support library for functoria-generated code" 31 | description: """ 32 | This is the runtime support library for code generated by functoria. 33 | """ 34 | -------------------------------------------------------------------------------- /functoria.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Gabriel Radanne " 3 | authors: [ "Thomas Gazagnaire" 4 | "Anil Madhavapeddy" 5 | "Dave Scott" 6 | "Thomas Leonard" 7 | "Gabriel Radanne" ] 8 | homepage: "https://github.com/mirage/functoria" 9 | bug-reports: "https://github.com/mirage/functoria/issues" 10 | dev-repo: "git+https://github.com/mirage/functoria.git" 11 | doc: "https://mirage.github.io/functoria/" 12 | license: "ISC" 13 | tags: ["org:mirage"] 14 | 15 | build: [ 16 | ["dune" "subst"] {dev} 17 | ["dune" "build" "-p" name "-j" jobs] 18 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 19 | ] 20 | 21 | depends: [ 22 | "ocaml" {>= "4.08.0"} 23 | "dune" {>= "1.1.0"} 24 | "cmdliner" {>= "0.9.8"} 25 | "rresult" 26 | "astring" 27 | "fmt" {>= "0.8.7"} 28 | "ocamlgraph" 29 | "logs" 30 | "bos" 31 | "fpath" 32 | "alcotest" {with-test} 33 | "ptime" 34 | ] 35 | synopsis: "A DSL to organize functor applications" 36 | description: """ 37 | Functoria is a DSL to describe a set of modules and functors, their types and 38 | how to apply them in order to produce a complete application. 39 | 40 | The main use case is mirage. See the [mirage](https://github.com/mirage/mirage) 41 | repository for details. 42 | """ 43 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name functoria) 3 | (public_name functoria) 4 | (libraries unix cmdliner rresult fmt astring fpath ptime.clock.os) 5 | (wrapped false) 6 | (flags (:standard (-w -3))) 7 | ) 8 | -------------------------------------------------------------------------------- /lib/functoria.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Gabriel Radanne 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Rresult 18 | open Astring 19 | 20 | open Functoria_misc 21 | 22 | module Key = Functoria_key 23 | 24 | type package = { 25 | opam : string ; 26 | pin : string option ; 27 | build : bool ; 28 | ocamlfind : String.Set.t ; 29 | min : String.Set.t ; 30 | max : String.Set.t ; 31 | } 32 | 33 | module Package = struct 34 | let merge opam a b = 35 | let ocamlfind = String.Set.union a.ocamlfind b.ocamlfind 36 | and min = String.Set.union a.min b.min 37 | and max = String.Set.union a.max b.max 38 | and pin = 39 | match a.pin, b.pin with 40 | | None, None -> None 41 | | None, Some a | Some a, None -> Some a 42 | | Some a, Some b when String.equal a b -> Some a 43 | | _ -> invalid_arg ("conflicting pin depends for " ^ opam) 44 | and build = a.build || b.build 45 | in 46 | match pin with 47 | | Some _ -> 48 | (* pin wins over min and max *) 49 | Some { opam ; build ; ocamlfind ; min = String.Set.empty ; max = String.Set.empty ; pin } 50 | | None -> 51 | Some { opam ; build ; ocamlfind ; min ; max ; pin } 52 | 53 | let package ?(build = false) ?sublibs ?ocamlfind ?min ?max ?pin opam = 54 | let ocamlfind = match sublibs, ocamlfind with 55 | | None, None -> [opam] 56 | | Some xs, None -> opam :: List.map (fun x -> opam ^ "." ^ x) xs 57 | | None, Some a -> a 58 | | Some _, Some _ -> 59 | invalid_arg ("dependent package " ^ opam ^ " may either specify ~sublibs or ~ocamlfind") 60 | in 61 | let ocamlfind = String.Set.of_list ocamlfind in 62 | let to_set = function None -> String.Set.empty | Some m -> String.Set.singleton m in 63 | let min = to_set min and max = to_set max in 64 | { opam ; build ; ocamlfind ; min ; max ; pin } 65 | 66 | let libraries ps = 67 | let ocamlfind p = if p.build then String.Set.empty else p.ocamlfind in 68 | String.Set.elements 69 | (List.fold_left String.Set.union String.Set.empty 70 | (List.map ocamlfind ps)) 71 | 72 | let package_names ps = 73 | List.fold_left (fun acc p -> if p.build then acc else p.opam :: acc) [] ps 74 | 75 | let exts_to_string min max build = 76 | let bui = if build then "build & " else "" in 77 | let esc_prefix prefix e = Printf.sprintf "%s %S" prefix e in 78 | let min_strs = List.map (esc_prefix ">=") (String.Set.elements min) 79 | and max_strs = List.map (esc_prefix "<") (String.Set.elements max) 80 | and flat xs = String.concat ~sep:" & " xs 81 | in 82 | match String.Set.is_empty min, String.Set.is_empty max with 83 | | true, true -> if build then "{build}" else "" 84 | | false, true -> Printf.sprintf "{%s %s}" bui (flat min_strs) 85 | | true, false -> Printf.sprintf "{%s %s}" bui (flat max_strs) 86 | | false, false -> 87 | Printf.sprintf "{%s %s & %s}" bui (flat min_strs) (flat max_strs) 88 | 89 | let pp_package t ppf p = 90 | Fmt.pf ppf "%s%s%s %s" t p.opam t (exts_to_string p.min p.max p.build) 91 | end 92 | 93 | let package = Package.package 94 | 95 | module Info = struct 96 | type t = { 97 | name: string; 98 | output: string option; 99 | build_dir: Fpath.t; 100 | keys: Key.Set.t; 101 | context: Key.context; 102 | packages: package String.Map.t; 103 | } 104 | 105 | let name t = t.name 106 | let build_dir t = t.build_dir 107 | let output t = t.output 108 | let with_output t output = { t with output = Some output } 109 | 110 | let packages t = List.map snd (String.Map.bindings t.packages) 111 | let libraries t = Package.libraries (packages t) 112 | let package_names t = Package.package_names (packages t) 113 | let pins t = 114 | List.fold_left 115 | (fun acc p -> match p.pin with None -> acc | Some u -> (p.opam, u) :: acc) 116 | [] (packages t) 117 | 118 | let keys t = Key.Set.elements t.keys 119 | let context t = t.context 120 | 121 | let create ~packages ~keys ~context ~name ~build_dir = 122 | let keys = Key.Set.of_list keys in 123 | let packages = List.fold_left (fun m p -> 124 | let n = p.opam in 125 | match String.Map.find p.opam m with 126 | | None -> String.Map.add n p m 127 | | Some p' -> match Package.merge p.opam p p' with 128 | | Some p -> String.Map.add n p m 129 | | None -> invalid_arg ("bad version constraints in " ^ p.opam)) 130 | String.Map.empty packages 131 | in 132 | { name; build_dir; keys; packages; context; output = None } 133 | 134 | let pp_packages ?(surround = "") ?sep ppf t = 135 | Fmt.pf ppf "%a" (Fmt.iter ?sep List.iter (Package.pp_package surround)) (packages t) 136 | 137 | let pp verbose ppf ({ name ; build_dir ; keys ; context ; output; _ } as t) = 138 | let show name = Fmt.pf ppf "@[<2>%s@ %a@]@," name in 139 | let list = Fmt.iter ~sep:(Fmt.any ",@ ") List.iter Fmt.string in 140 | show "Name " Fmt.string name; 141 | show "Build-dir " Fpath.pp build_dir; 142 | show "Keys " (Key.pps context) keys; 143 | show "Output " Fmt.(option string) output; 144 | if verbose then show "Libraries " list (libraries t); 145 | if verbose then 146 | show "Packages " 147 | (pp_packages ?surround:None ~sep:(Fmt.any ",@ ")) t 148 | 149 | let opam ?name ppf t = 150 | let name = match name with None -> t.name | Some x -> x in 151 | Fmt.pf ppf "opam-version: \"2.0\"@." ; 152 | Fmt.pf ppf "name: \"%s\"@." name ; 153 | Fmt.pf ppf "depends: [ @[%a@]@ ]@." 154 | (pp_packages ~surround:"\"" ~sep:(Fmt.any "@ ")) t ; 155 | match pins t with 156 | | [] -> () 157 | | pin_depends -> 158 | let pp_pin ppf (package, url) = 159 | Fmt.pf ppf "[\"%s.dev\" %S]" package url 160 | in 161 | Fmt.pf ppf "pin-depends: [ @[%a@]@ ]@." 162 | Fmt.(list ~sep:(any "@ ") pp_pin) pin_depends 163 | end 164 | 165 | type _ typ = 166 | | Type: 'a -> 'a typ 167 | | Function: 'a typ * 'b typ -> ('a -> 'b) typ 168 | 169 | let (@->) f t = Function (f, t) 170 | 171 | let typ ty = Type ty 172 | 173 | module rec Typ: sig 174 | 175 | type _ impl = 176 | | Impl: 'ty Typ.configurable -> 'ty impl (* base implementation *) 177 | | App: ('a, 'b) app -> 'b impl (* functor application *) 178 | | If: bool Key.value * 'a impl * 'a impl -> 'a impl 179 | 180 | and ('a, 'b) app = { 181 | f: ('a -> 'b) impl; (* functor *) 182 | x: 'a impl; (* parameter *) 183 | } 184 | 185 | and abstract_impl = Abstract: _ impl -> abstract_impl 186 | 187 | class type ['ty] configurable = object 188 | method ty: 'ty typ 189 | method name: string 190 | method module_name: string 191 | method keys: Key.t list 192 | method packages: package list Key.value 193 | method connect: Info.t -> string -> string list -> string 194 | method configure: Info.t -> (unit, R.msg) R.t 195 | method build: Info.t -> (unit, R.msg) R.t 196 | method clean: Info.t -> (unit, R.msg) R.t 197 | method deps: abstract_impl list 198 | end 199 | 200 | end = Typ 201 | 202 | include Typ 203 | 204 | let ($) f x = App { f; x } 205 | let impl x = Impl x 206 | let abstract x = Abstract x 207 | let if_impl b x y = If(b,x,y) 208 | 209 | let rec match_impl kv ~default = function 210 | | [] -> default 211 | | (f, i) :: t -> If (Key.(pure ((=) f) $ kv), i, match_impl kv ~default t) 212 | 213 | class base_configurable = object 214 | method packages: package list Key.value = Key.pure [] 215 | method keys: Key.t list = [] 216 | method connect (_:Info.t) (_:string) l = 217 | Printf.sprintf "return (%s)" (String.concat ~sep:", " l) 218 | method configure (_: Info.t): (unit, R.msg) R.t = R.ok () 219 | method build (_: Info.t): (unit, R.msg) R.t = R.ok () 220 | method clean (_: Info.t): (unit, R.msg) R.t = R.ok () 221 | method deps: abstract_impl list = [] 222 | end 223 | 224 | type job = JOB 225 | let job = Type JOB 226 | 227 | class ['ty] foreign 228 | ?(packages=[]) ?(keys=[]) ?(deps=[]) module_name ty 229 | : ['ty] configurable 230 | = 231 | let name = Name.create module_name ~prefix:"f" in 232 | object 233 | method ty = ty 234 | method name = name 235 | method module_name = module_name 236 | method keys = keys 237 | method packages = Key.pure packages 238 | method connect _ modname args = 239 | Fmt.str 240 | "@[%s.start@ %a@]" 241 | modname 242 | Fmt.(list ~sep:sp string) args 243 | method clean _ = R.ok () 244 | method configure _ = R.ok () 245 | method build _ = R.ok () 246 | method deps = deps 247 | end 248 | 249 | let foreign ?packages ?keys ?deps module_name ty = 250 | Impl (new foreign ?packages ?keys ?deps module_name ty) 251 | 252 | (* {Misc} *) 253 | 254 | let rec equal 255 | : type t1 t2. t1 impl -> t2 impl -> bool 256 | = fun x y -> match x, y with 257 | | Impl c, Impl c' -> 258 | c#name = c'#name 259 | && List.for_all2 Key.equal c#keys c'#keys 260 | && List.for_all2 equal_any c#deps c'#deps 261 | | App a, App b -> equal a.f b.f && equal a.x b.x 262 | | If (cond1, t1, e1), If (cond2, t2, e2) -> 263 | (* Key.value is a functional value (it contains a closure for eval). 264 | There is no prettier way than physical equality. *) 265 | cond1 == cond2 && equal t1 t2 && equal e1 e2 266 | | Impl _, (If _ | App _) 267 | | App _ , (If _ | Impl _) 268 | | If _ , (App _ | Impl _) -> false 269 | 270 | and equal_any (Abstract x) (Abstract y) = equal x y 271 | 272 | let rec hash: type t . t impl -> int = function 273 | | Impl c -> 274 | Hashtbl.hash 275 | (c#name, List.map Key.hash c#keys, List.map hash_any c#deps) 276 | | App { f; x } -> Hashtbl.hash (`Bla (hash f, hash x)) 277 | | If (cond, t, e) -> 278 | Hashtbl.hash (`If (cond, hash t, hash e)) 279 | 280 | and hash_any (Abstract x) = hash x 281 | 282 | module ImplTbl = Hashtbl.Make (struct 283 | type t = abstract_impl 284 | let hash = hash_any 285 | let equal = equal_any 286 | end) 287 | 288 | let explode x = match x with 289 | | Impl c -> `Impl c 290 | | App { f; x } -> `App (Abstract f, Abstract x) 291 | | If (cond, x, y) -> `If (cond, x, y) 292 | 293 | type key = Functoria_key.t 294 | type context = Functoria_key.context 295 | type 'a value = 'a Functoria_key.value 296 | 297 | module type KEY = 298 | module type of Functoria_key 299 | with type 'a Arg.converter = 'a Functoria_key.Arg.converter 300 | and type 'a Arg.t = 'a Functoria_key.Arg.t 301 | and type Arg.info = Functoria_key.Arg.info 302 | and type 'a value = 'a Functoria_key.value 303 | and type 'a key = 'a Functoria_key.key 304 | and type t = Functoria_key.t 305 | and type Set.t = Functoria_key.Set.t 306 | and type 'a Alias.t = 'a Functoria_key.Alias.t 307 | and type context = Functoria_key.context 308 | -------------------------------------------------------------------------------- /lib/functoria.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Gabriel Radanne 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (** The Functoria DSL. 18 | 19 | The Functoria DSL allows users to describe how to create portable 20 | and flexible applications. It allows to pass application 21 | parameters easily using command-line arguments either at 22 | configure-time or at runtime. 23 | 24 | Users of the Functoria DSL composes their application by defining 25 | a list of {{!foreign}module} implementations, specify the 26 | command-line {!keys} that are required and {{!combinators}combine} 27 | all of them together using 28 | {{:http://dx.doi.org/10.1017/S0956796807006326}applicative} 29 | operators. 30 | 31 | The DSL expression is then compiled into an {{!app}application 32 | builder}, which will, once evaluated, produced the final portable 33 | and flexible application. 34 | 35 | *) 36 | 37 | (** {1:combinators Combinators} *) 38 | 39 | (** The type for values representing module types. *) 40 | type _ typ = 41 | | Type : 'a -> 'a typ 42 | | Function: 'b typ * 'c typ -> ('b -> 'c) typ 43 | 44 | val typ: 'a -> 'a typ 45 | (** [type t] is a value representing the module type [t]. *) 46 | 47 | val (@->): 'a typ -> 'b typ -> ('a -> 'b) typ 48 | (** Construct a functor type from a type and an existing functor 49 | type. This corresponds to prepending a parameter to the list of 50 | functor parameters. For example: 51 | 52 | {[ kv_ro @-> ip @-> kv_ro ]} 53 | 54 | This describes a functor type that accepts two arguments -- a 55 | [kv_ro] and an [ip] device -- and returns a [kv_ro]. 56 | *) 57 | 58 | type job 59 | (** Type for job values. *) 60 | 61 | val job: job typ 62 | (** [job] is the signature for user's application main module. *) 63 | 64 | type 'a impl 65 | (** The type for values representing module implementations. *) 66 | 67 | val ($): ('a -> 'b) impl -> 'a impl -> 'b impl 68 | (** [m $ a] applies the functor [m] to the module [a]. *) 69 | 70 | (** The type for abstract implementations. *) 71 | type abstract_impl = Abstract: _ impl -> abstract_impl 72 | 73 | val abstract: _ impl -> abstract_impl 74 | (** [abstract t] is [t] but with its type variable abstracted. Useful 75 | for dependencies. *) 76 | 77 | (** {1:keys Keys} *) 78 | 79 | type key = Functoria_key.t 80 | (** The type for command-line keys. See {!Functoria_key.t}. *) 81 | 82 | type context = Functoria_key.context 83 | (** The type for keys' parsing context. See {!Functoria_key.context}. *) 84 | 85 | type 'a value = 'a Functoria_key.value 86 | (** The type for values parsed from the command-line. See 87 | {!Functoria_key.value}. *) 88 | 89 | val if_impl: bool value -> 'a impl -> 'a impl -> 'a impl 90 | (** [if_impl v impl1 impl2] is [impl1] if [v] is resolved to true and 91 | [impl2] otherwise. *) 92 | 93 | val match_impl: 'b value -> default:'a impl -> ('b * 'a impl) list -> 'a impl 94 | (** [match_impl v cases ~default] chooses the implementation amongst 95 | [cases] by matching the [v]'s value. [default] is chosen if no 96 | value matches. *) 97 | 98 | 99 | module type KEY = 100 | module type of Functoria_key 101 | with type 'a Arg.converter = 'a Functoria_key.Arg.converter 102 | and type 'a Arg.t = 'a Functoria_key.Arg.t 103 | and type Arg.info = Functoria_key.Arg.info 104 | and type 'a value = 'a Functoria_key.value 105 | and type 'a key = 'a Functoria_key.key 106 | and type t = Functoria_key.t 107 | and type Set.t = Functoria_key.Set.t 108 | and type 'a Alias.t = 'a Functoria_key.Alias.t 109 | and type context = Functoria_key.context 110 | (** The signature for run-time and configure-time command-line 111 | keys. *) 112 | 113 | (** {1:pkg Package dependencies} 114 | 115 | For specifying opam package dependencies, the type {!package} is used. It 116 | consists of the opam package name, the ocamlfind names, and optional lower 117 | and upper bounds. The version constraints are merged with other modules. 118 | *) 119 | 120 | type package = private { 121 | opam : string ; 122 | pin : string option ; 123 | build : bool ; 124 | ocamlfind : Astring.String.Set.t ; 125 | min : Astring.String.Set.t ; 126 | max : Astring.String.Set.t ; 127 | } 128 | (** The type of a package *) 129 | 130 | val package : 131 | ?build:bool -> 132 | ?sublibs:string list -> 133 | ?ocamlfind:string list -> 134 | ?min:string -> 135 | ?max:string -> 136 | ?pin:string -> 137 | string -> package 138 | (** [package ~build ~sublibs ~ocamlfind ~min ~max ~pin opam] is a [package]. [Build] 139 | indicates a build-time dependency only, defaults to [false]. The ocamlfind 140 | name is by default the same as [opam], you can specify [~sublibs] to add 141 | additional sublibraries (e.g. [~sublibs:["mirage"] "foo"] will result in the 142 | findlib names [ ["foo"; "foo.mirage"] ]. In case the findlib name is 143 | disjoint (or empty), use [~ocamlfind]. Specifying both [~ocamlfind] and 144 | [~sublibs] leads to an invalid argument. Version constraints are given as 145 | [min] (inclusive) and [max] (exclusive). If [pin] is provided, a 146 | {{:https://opam.ocaml.org/doc/Manual.html#opamfield-pin-depends}pin-depends} 147 | is generated. *) 148 | 149 | (** {1:app Application Builder} 150 | 151 | Values of type {!impl} are tied to concrete module implementation 152 | with the {!foreign} construct. Module implementations of type 153 | {!job} can then be {{!Functoria_app.Make.register}registered} into 154 | an application builder. The builder is in charge if parsing the 155 | command-line arguments and of generating code for the final 156 | application. See {!Functoria_app} for details. *) 157 | 158 | val foreign: 159 | ?packages:package list -> 160 | ?keys:key list -> 161 | ?deps:abstract_impl list -> 162 | string -> 'a typ -> 'a impl 163 | (** [foreign name typ] is the module [name], having the module type 164 | [typ]. 165 | 166 | {ul 167 | {- If [packages] is set, then the given packages are 168 | installed before compiling the current application.} 169 | {- If [keys] is set, use the given {{!Functoria_key.key}keys} to 170 | parse at configure and runtime the command-line arguments 171 | before calling [name.connect].} 172 | {- If [deps] is set, the given list of {{!abstract_impl}abstract} 173 | implementations is added as data-dependencies: they will be 174 | initialized before calling [name.connect]. } 175 | } 176 | 177 | For a more flexible definition of packages, or for a custom configuration 178 | step, see the {!configurable} class type and the {!class:foreign} class. 179 | *) 180 | 181 | (** Information about the final application. *) 182 | module Info: sig 183 | 184 | type t 185 | (** The type for information about the final application. *) 186 | 187 | val name: t -> string 188 | (** [name t] is the name of the application. *) 189 | 190 | val output: t -> string option 191 | (** [output t] is the name of [t]'s output. Derived from {!name} if 192 | not set. *) 193 | 194 | val with_output: t -> string -> t 195 | (** [with_output t o] is similar to [t] but with the output set to 196 | [Some o]. *) 197 | 198 | val build_dir: t -> Fpath.t 199 | (** Directory in which the build is done. *) 200 | 201 | val libraries: t -> string list 202 | (** [libraries t] are the direct OCamlfind dependencies. *) 203 | 204 | val package_names: t -> string list 205 | (** [package_names t] are the opam package dependencies. *) 206 | 207 | val packages: t -> package list 208 | (** [packages t] are the opam package dependencies by the project. *) 209 | 210 | val keys: t -> key list 211 | (** [keys t] are the keys declared by the project. *) 212 | 213 | val context: t -> context 214 | (** [parsed t] is a value representing the command-line argument 215 | being parsed. *) 216 | 217 | (** [create context n r] contains information about the application 218 | being built. *) 219 | val create: 220 | packages:package list -> 221 | keys:key list -> 222 | context:context -> 223 | name:string -> 224 | build_dir:Fpath.t -> t 225 | 226 | val pp: bool -> t Fmt.t 227 | 228 | val opam: ?name:string -> t Fmt.t 229 | (** [opam t] generates an opam file including all dependencies. If 230 | set, [name] will be used as package name, otherwise use 231 | {!name}. *) 232 | 233 | end 234 | 235 | (** Signature for configurable module implementations. A 236 | [configurable] is a module implementation which contains a runtime 237 | state which can be set either at configuration time (by the 238 | application builder) or at runtime, using command-line 239 | arguments. *) 240 | class type ['ty] configurable = object 241 | 242 | method ty: 'ty typ 243 | (** [ty] is the module type of the configurable. *) 244 | 245 | method name: string 246 | (** [name] is the unique variable name holding the runtime state of 247 | the configurable. *) 248 | 249 | method module_name: string 250 | (** [module_name] is the name of the module implementing the 251 | configurable. *) 252 | 253 | method packages: package list value 254 | (** [packages] is the list of OPAM packages which needs to be 255 | installed before compiling the configurable. *) 256 | 257 | method connect: Info.t -> string -> string list -> string 258 | (** [connect info mod args] is the code to execute in order to 259 | initialize the state associated with the module [mod] (usually 260 | calling [mod.connect]) with the arguments [args], in the context 261 | of the project information [info]. *) 262 | 263 | method configure: Info.t -> (unit, Rresult.R.msg) result 264 | (** [configure info] is the code to execute in order to configure 265 | the device. During the configuration phase, the specficied 266 | {!packages} might not yet be there. The code might involve 267 | generating more OCaml code, running shell scripts, etc. *) 268 | 269 | method build: Info.t -> (unit, Rresult.R.msg) result 270 | (** [build info] is the code to execute in order to build 271 | the device. During the build phase, you can rely that all 272 | {!packages} are installed (via opam). The code might involve 273 | generating more OCaml code (crunching directories), running 274 | shell scripts, etc. *) 275 | 276 | method clean: Info.t -> (unit, Rresult.R.msg) result 277 | (** [clean info] is the code to clean-up what has been generated 278 | by {!build} and {!configure}. *) 279 | 280 | method keys: key list 281 | (** [keys] is the list of command-line keys to set-up the 282 | configurable. *) 283 | 284 | method deps: abstract_impl list 285 | (** [deps] is the list of {{!abstract_impl} abstract 286 | implementations} that must be initialized before calling 287 | {!connect}. *) 288 | 289 | end 290 | 291 | 292 | val impl: 'a configurable -> 'a impl 293 | (** [impl c] is the implementation of the configurable [c]. *) 294 | 295 | (** [base_configurable] pre-defining many methods from the 296 | {!configurable} class. To be used as follow: 297 | 298 | {[ 299 | let time_conf = object 300 | inherit base_configurable 301 | method ty = time 302 | method name = "time" 303 | method module_name = "OS.Time" 304 | end 305 | ]} 306 | *) 307 | class base_configurable: object 308 | method packages: package list value 309 | method keys: key list 310 | method connect: Info.t -> string -> string list -> string 311 | method configure: Info.t -> (unit, Rresult.R.msg) result 312 | method build: Info.t -> (unit, Rresult.R.msg) result 313 | method clean: Info.t -> (unit, Rresult.R.msg) result 314 | method deps: abstract_impl list 315 | end 316 | 317 | class ['a] foreign: 318 | ?packages:package list -> 319 | ?keys:key list -> 320 | ?deps:abstract_impl list -> 321 | string -> 'a typ -> ['a] configurable 322 | (** This class can be inherited to define a {!configurable} with an API 323 | similar to {!foreign}. 324 | 325 | In particular, it allows dynamic packages. Here is an example: 326 | {[ 327 | let main = impl @@ object 328 | inherit [_] foreign 329 | "Unikernel.Main" (console @-> job) 330 | method packages = Key.(if_ is_xen) 331 | [package ~sublibs:["xen"] "vchan"] 332 | [package ~sublibs:["lwt"] "vchan"] 333 | end 334 | ]} 335 | *) 336 | 337 | (** {1 Sharing} *) 338 | 339 | val hash: 'a impl -> int 340 | (** [hash] is the hash function on implementations. FIXME(samoht) 341 | expand on how it works. *) 342 | 343 | val equal: 'a impl -> 'a impl -> bool 344 | (** [equal] is the equality over implementations. *) 345 | 346 | module ImplTbl: Hashtbl.S with type key = abstract_impl 347 | (** Hashtbl of implementations. *) 348 | 349 | (**/**) 350 | 351 | val explode: 'a impl -> 352 | [ `App of abstract_impl * abstract_impl 353 | | `If of bool value * 'a impl * 'a impl 354 | | `Impl of 'a configurable ] 355 | -------------------------------------------------------------------------------- /lib/functoria_key.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Gabriel Radanne 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Functoria_misc 18 | 19 | module Serialize = struct 20 | let string fmt s = Format.fprintf fmt "%S" s 21 | let option x = Fmt.(parens @@ Dump.option x) 22 | let list x = Fmt.Dump.list x 23 | end 24 | 25 | module Arg = struct 26 | 27 | (** {1 Converters} *) 28 | 29 | type 'a serialize = Format.formatter -> 'a -> unit 30 | type 'a runtime_conv = string 31 | 32 | type 'a converter = { 33 | conv: 'a Cmdliner.Arg.converter; 34 | serialize: 'a serialize; 35 | runtime_conv: 'a runtime_conv; 36 | } 37 | 38 | let conv ~conv ~serialize ~runtime_conv = { conv; serialize; runtime_conv } 39 | 40 | let converter x = x.conv 41 | let serialize x = x.serialize 42 | let runtime_conv x = x.runtime_conv 43 | 44 | let string = conv 45 | ~conv:Cmdliner.Arg.string ~runtime_conv:"Cmdliner.Arg.string" 46 | ~serialize:(fun fmt -> Format.fprintf fmt "%S") 47 | 48 | let bool = conv 49 | ~conv:Cmdliner.Arg.bool ~runtime_conv:"Cmdliner.Arg.bool" 50 | ~serialize:(fun fmt -> Format.fprintf fmt "%b") 51 | 52 | let int = conv 53 | ~conv:Cmdliner.Arg.int ~runtime_conv:"Cmdliner.Arg.int" 54 | ~serialize:(fun fmt i -> Format.fprintf fmt "(%i)" i) 55 | 56 | let list d = conv 57 | ~conv:(Cmdliner.Arg.list (converter d)) 58 | ~runtime_conv:(Fmt.str "(Cmdliner.Arg.list %s)" (runtime_conv d)) 59 | ~serialize:(Serialize.list (serialize d)) 60 | 61 | let some d = conv 62 | ~conv:(Cmdliner.Arg.some (converter d)) 63 | ~runtime_conv:(Fmt.str "(Cmdliner.Arg.some %s)" (runtime_conv d)) 64 | ~serialize:(Serialize.option (serialize d)) 65 | 66 | (** {1 Information about arguments} *) 67 | 68 | type info = { 69 | doc : string option; 70 | docs : string; 71 | docv : string option; 72 | names: string list; 73 | env : string option; 74 | } 75 | 76 | let info ?(docs="APPLICATION OPTIONS") ?docv ?doc ?env names = 77 | { doc; docs; docv; names; env } 78 | 79 | let cmdliner_of_info { docs; docv; doc; env; names } = 80 | let env = match env with 81 | | Some s -> Some (Cmdliner.Arg.env_var s) 82 | | None -> None 83 | in 84 | Cmdliner.Arg.info ~docs ?docv ?doc ?env names 85 | 86 | let serialize_env fmt = 87 | Fmt.pf fmt "(Cmdliner.Arg.env_var %a)" Serialize.string 88 | 89 | let serialize_info fmt { docs; docv; doc; env; names } = 90 | Format.fprintf fmt 91 | "(Cmdliner.Arg.info@ ~docs:%a@ ?docv:%a@ ?doc:%a@ ?env:%a@ %a)" 92 | Serialize.string docs 93 | Serialize.(option string) docv 94 | Serialize.(option string) doc 95 | Serialize.(option serialize_env) env 96 | Serialize.(list string) names 97 | 98 | (** {1 Arguments} *) 99 | 100 | type 'a kind = 101 | | Opt : 'a * 'a converter -> 'a kind 102 | | Required : 'a converter -> 'a option kind 103 | | Flag: bool kind 104 | 105 | type stage = [ 106 | | `Configure 107 | | `Run 108 | | `Both 109 | ] 110 | 111 | let pp_conv c = snd (converter c) 112 | 113 | let pp_kind: type a . a kind -> a Fmt.t = function 114 | | Opt (_, c) -> pp_conv c 115 | | Required c -> pp_conv (some c) 116 | | Flag -> Fmt.bool 117 | 118 | let hash_of_kind : type a. a kind -> int = function 119 | | Opt (x, _) -> Hashtbl.hash (`Opt x) 120 | | Required _ -> Hashtbl.hash `Required 121 | | Flag -> Hashtbl.hash `Flag 122 | 123 | let compare_kind : type a b. a kind -> b kind -> int = fun a b -> 124 | let default cx x = Fmt.to_to_string (snd cx.conv) x in 125 | match a, b with 126 | | Opt (x, cx), Opt (y, cy) -> String.compare (default cx x) (default cy y) 127 | | Required _, Required _ -> 0 128 | | Flag, Flag -> 0 129 | | Opt _, _ -> 1 130 | | _, Opt _ -> -1 131 | | Required _, _ -> 1 132 | | _, Required _ -> -1 133 | 134 | type 'a t = { 135 | stage : stage; 136 | info : info; 137 | kind : 'a kind; 138 | } 139 | 140 | let pp t = pp_kind t.kind 141 | 142 | let equal x y = 143 | x.stage = y.stage && x.info = y.info && compare_kind x.kind y.kind = 0 144 | 145 | let compare x y = 146 | match compare x.stage y.stage with 147 | | 0 -> ( 148 | match compare x.info y.info with 149 | | 0 -> compare_kind x.kind y.kind 150 | | i -> i) 151 | | i -> i 152 | 153 | let hash x = 154 | Hashtbl.hash ( 155 | Hashtbl.hash x.stage, 156 | Hashtbl.hash x.info, 157 | hash_of_kind x.kind 158 | ) 159 | 160 | let stage t = t.stage 161 | 162 | let opt ?(stage=`Both) conv default info = 163 | { stage; info; kind = Opt (default, conv) } 164 | 165 | let flag ?(stage=`Both) info = 166 | { stage; info; kind = Flag } 167 | 168 | let required ?(stage=`Both) conv info = 169 | { stage; info; kind = Required conv } 170 | 171 | let make_opt_cmdliner wrap i default f desc = 172 | let none = match default with 173 | | Some d -> Some (Fmt.str "%a" (pp_conv desc) d) 174 | | None -> None 175 | in 176 | let f_desc v z = match v with 177 | | Some v -> f v z 178 | | None -> z 179 | in 180 | Cmdliner.Term.(app @@ pure f_desc) 181 | Cmdliner.Arg.(wrap @@ opt (some ?none @@ converter desc) None i) 182 | 183 | let to_cmdliner ~with_required (type a) (t: a t) (f: a -> _) = 184 | let i = cmdliner_of_info t.info in 185 | match t.kind with 186 | | Flag -> Cmdliner.Term.(app @@ pure f) Cmdliner.Arg.(value @@ flag i) 187 | | Opt (default, desc) -> 188 | make_opt_cmdliner Cmdliner.Arg.value i (Some default) f desc 189 | | Required desc when with_required && t.stage = `Configure -> 190 | make_opt_cmdliner Cmdliner.Arg.required i None f (some (some desc)) 191 | | Required desc -> 192 | make_opt_cmdliner Cmdliner.Arg.value i None f (some desc) 193 | 194 | let serialize_value (type a) (v:a) ppf (t: a t) = 195 | match t.kind with 196 | | Flag -> (serialize bool) ppf v 197 | | Opt (_, c) -> (serialize c) ppf v 198 | | Required c -> match v with 199 | | Some v -> (serialize c) ppf v 200 | | None -> assert false 201 | (* This is only called by serialize_ro, hence a configure time 202 | key, so the value is known. *) 203 | 204 | let serialize (type a): a -> a t serialize = fun v ppf t -> 205 | match t.kind with 206 | | Flag -> Fmt.pf ppf "Functoria_runtime.Arg.flag %a" serialize_info t.info 207 | | Opt (_, c) -> 208 | Fmt.pf ppf "Functoria_runtime.Arg.opt %s %a %a" 209 | (runtime_conv c) (serialize c) v serialize_info t.info 210 | | Required c -> 211 | Fmt.pf ppf "Functoria_runtime.Arg.key ?default:(%a) %s %a" 212 | (serialize @@ some c) v (runtime_conv c) serialize_info t.info 213 | 214 | end 215 | 216 | type 'a key = { 217 | name : string; 218 | arg : 'a Arg.t; 219 | key : 'a Univ.key; 220 | setters: 'a setter list; 221 | } 222 | 223 | and -'a setter = Setter: 'b key * ('a -> 'b option) -> 'a setter 224 | 225 | type t = Any: 'a key -> t 226 | 227 | let rec equal (Any x) (Any y) = 228 | String.equal x.name y.name 229 | && Arg.equal x.arg y.arg 230 | && equal_setters x.setters y.setters 231 | 232 | and equal_setters : type a b. a setter list -> b setter list -> bool = 233 | fun x y -> 234 | List.length x = List.length y 235 | && List.for_all2 (fun (Setter (x, _)) (Setter (y, _)) -> 236 | equal (Any x) (Any y) 237 | ) x y 238 | 239 | let rec hash (Any x) = 240 | Hashtbl.hash ( 241 | Hashtbl.hash x.name, 242 | Arg.hash x.arg, 243 | List.map hash_setter x.setters 244 | ) 245 | 246 | and hash_setter : type a. a setter -> int = fun (Setter (x, _)) -> hash (Any x) 247 | 248 | let rec compare (Any x) (Any y) = 249 | match String.compare x.name y.name with 250 | | 0 -> ( 251 | match Arg.compare x.arg y.arg with 252 | | 0 -> compare_setters x.setters y.setters 253 | | i -> i) 254 | | i -> i 255 | 256 | and compare_setters: type a b. a setter list -> b setter list -> int = 257 | fun x y -> match x, y with 258 | | [], [] -> 0 259 | | [], _ -> -1 260 | | _, [] -> 1 261 | | (Setter (x, _))::tx, (Setter (y, _))::ty -> 262 | match compare (Any x) (Any y) with 263 | | 0 -> compare_setters tx ty 264 | | i -> i 265 | 266 | module Set = struct 267 | module M = struct 268 | type nonrec t = t 269 | let compare = compare 270 | end 271 | include Set.Make(M) 272 | 273 | let add k set = 274 | if mem k set then 275 | if k != find k set then 276 | let Any k' = k in 277 | invalid_arg ("Duplicate key name: " ^ k'.name) 278 | else 279 | set 280 | else 281 | add k set 282 | 283 | let pp = Fmt.iter ~sep:(Fmt.any ",@ ") iter 284 | 285 | end 286 | 287 | module Alias = struct 288 | 289 | type 'a t = { 290 | a_setters: 'a setter list; 291 | a_arg : 'a Arg.t; 292 | } 293 | 294 | let setters t = t.a_setters 295 | let arg t = t.a_arg 296 | let create a_arg = { a_setters = []; a_arg } 297 | let flag doc = create (Arg.flag ~stage:`Configure doc) 298 | (* let opt conv d i = create (Arg.opt ~stage:`Configure conv d i) *) 299 | let add k f t = { t with a_setters = Setter (k, f) :: t.a_setters } 300 | 301 | let apply_one v map (Setter (k,f)) = match f v with 302 | | None -> map 303 | | Some v -> 304 | if Univ.mem k.key map then map 305 | else Univ.add k.key v map 306 | 307 | let apply v l map = List.fold_left (apply_one v) map l 308 | let keys l = Set.of_list @@ List.map (fun (Setter (k,_)) -> Any k) l 309 | 310 | end 311 | 312 | let abstract x = Any x 313 | let arg k = k.arg 314 | let aliases (Any k) = Alias.keys k.setters 315 | let name (Any k) = k.name 316 | let stage (Any k) = Arg.stage k.arg 317 | 318 | let is_runtime k = match stage k with 319 | | `Run | `Both -> true 320 | | `Configure -> false 321 | 322 | let is_configure k = match stage k with 323 | | `Configure | `Both -> true 324 | | `Run -> false 325 | 326 | let filter_stage stage s = match stage with 327 | | `Run -> Set.filter is_runtime s 328 | | `Configure 329 | | `NoEmit -> Set.filter is_configure s 330 | | `Both -> s 331 | 332 | (* Key Map *) 333 | 334 | type context = Univ.t 335 | let empty_context = Univ.empty 336 | let merge_context = Univ.merge 337 | let add_to_context t = Univ.add t.key 338 | 339 | let get (type a) ctx (t : a key) : a = 340 | match t.arg.Arg.kind, Univ.find t.key ctx with 341 | | Arg.Required _ , Some (Some x) -> Some x 342 | | Arg.Required _ , (None | Some None) -> None 343 | | Arg.Flag , Some x -> x 344 | | Arg.Opt _, Some x -> x 345 | | Arg.Opt (d,_), None -> d 346 | | Arg.Flag, None -> false 347 | 348 | let mem_u ctx t = Univ.mem t.key ctx 349 | 350 | (* {2 Values} *) 351 | 352 | type +'a value = { deps: Set.t; v: context -> 'a } 353 | 354 | let eval p v = v.v p 355 | let pure x = { deps = Set.empty; v = fun _ -> x } 356 | 357 | let app f x = { 358 | deps = Set.union f.deps x.deps; 359 | v = fun p -> (eval p f) (eval p x); 360 | } 361 | 362 | let map f x = app (pure f) x 363 | let pipe x f = map f x 364 | let if_ c t e = pipe c @@ fun b -> if b then t else e 365 | let match_ v f = map f v 366 | let ($) = app 367 | let value k = let v c = get c k in { deps = Set.singleton (Any k); v } 368 | let of_deps deps = {(pure ()) with deps} 369 | let deps k = k.deps 370 | let mem p v = Set.for_all (fun (Any x) -> mem_u p x) v.deps 371 | let peek p v = if mem p v then Some (eval p v) else None 372 | let default v = eval Univ.empty v 373 | 374 | (* {2 Pretty printing} *) 375 | 376 | let dump_context = Univ.dump 377 | let pp fmt k = Fmt.string fmt (name k) 378 | let pp_deps fmt v = Set.pp pp fmt v.deps 379 | 380 | let pps p = 381 | let pp' fmt k v = 382 | let default = if mem_u p k then Fmt.nop else Fmt.any " (default)" in 383 | Fmt.pf fmt "%a=%a%a" 384 | Fmt.(styled `Bold string) k.name 385 | (Arg.pp k.arg) v 386 | default () 387 | in 388 | let f fmt (Any k) = match k.arg.Arg.kind, get p k with 389 | | Arg.Required _, None -> 390 | Fmt.(styled `Bold string) fmt k.name 391 | | Arg.Opt _ ,v -> pp' fmt k v 392 | | Arg.Required _,v -> pp' fmt k v 393 | | Arg.Flag ,v -> pp' fmt k v 394 | (* Warning 4 and GADT don't interact well. *) 395 | in 396 | fun ppf s -> Set.(pp f ppf @@ s) 397 | 398 | (* {2 Automatic documentation} *) 399 | 400 | let info_alias setters = 401 | let f fmt k = Fmt.pf fmt "$(b,%s)" (name k) in 402 | match setters with 403 | | [] -> "" 404 | | [ _ ] -> 405 | Fmt.str "Will automatically set %a." (Set.pp f) (Alias.keys setters) 406 | | _ -> 407 | Fmt.str "Will automatically set the following keys: %a." 408 | (Set.pp f) (Alias.keys setters) 409 | 410 | let info_arg (type a) (arg: a Arg.kind) = match arg with 411 | | Arg.Required _ -> "This key is required." 412 | | Arg.Flag -> "" 413 | | Arg.Opt _ -> "" 414 | 415 | let add_extra_info setters arg = 416 | match arg.Arg.info.doc with 417 | | None -> arg 418 | | Some doc -> 419 | let doc = String.concat " " [ 420 | doc ; 421 | info_alias setters ; 422 | info_arg arg.kind ; 423 | ] 424 | in 425 | {arg with info = {arg.info with doc = Some doc}} 426 | 427 | (* {2 Key creation} *) 428 | 429 | (* Unexposed smart constructor. *) 430 | let make ~setters ~arg ~name = 431 | let key = Univ.new_key name in 432 | let arg = add_extra_info setters arg in 433 | { setters ; arg ; name ; key } 434 | 435 | let alias name a = 436 | let setters = Alias.setters a in 437 | let arg = Alias.arg a in 438 | make ~setters ~arg ~name 439 | 440 | let create name arg = 441 | let setters = [] in 442 | make ~setters ~arg ~name 443 | 444 | (* {2 Cmdliner interface} *) 445 | 446 | let parse_key t = Arg.to_cmdliner t.arg 447 | 448 | let context ?(stage=`Both) ~with_required l = 449 | let gather (Any k) rest = 450 | let f v p = Alias.apply v k.setters (Univ.add k.key v p) in 451 | Cmdliner.Term.(parse_key ~with_required k f $ rest) 452 | in 453 | Set.fold gather (filter_stage stage l) (Cmdliner.Term.pure empty_context) 454 | 455 | (* {2 Code emission} *) 456 | 457 | let module_name = "Key_gen" 458 | let ocaml_name k = Name.ocamlify (name k) 459 | let serialize_call fmt k = Fmt.pf fmt "(%s.%s ())" module_name (ocaml_name k) 460 | let serialize ctx ppf (Any k) = Arg.serialize (get ctx k) ppf (arg k) 461 | 462 | let serialize_rw ctx fmt t = 463 | Format.fprintf fmt 464 | "@[<2>let %s =@,Functoria_runtime.Key.create@ %a@]@,\ 465 | @[<2>let %s_t =@ Functoria_runtime.Key.term %s@]@,\ 466 | @[<2>let %s () =@ Functoria_runtime.Key.get %s@]@," 467 | (ocaml_name t) Fmt.(parens (serialize ctx)) t 468 | (ocaml_name t) (ocaml_name t) 469 | (ocaml_name t) (ocaml_name t) 470 | 471 | let serialize_ro ctx fmt t = 472 | let Any k = t in 473 | Format.fprintf fmt "@[<2>let %s () =@ %a@]@," (ocaml_name t) 474 | (Arg.serialize_value (get ctx k)) (arg k) 475 | 476 | let serialize ctx fmt k = 477 | if is_runtime k 478 | then serialize_rw ctx fmt k 479 | else serialize_ro ctx fmt k 480 | -------------------------------------------------------------------------------- /lib/functoria_key.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Nicolas Ojeda Bar 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (** Configuration and runtime command-line arguments. *) 18 | 19 | (** Cross-stage command-line arguments. *) 20 | module Arg: sig 21 | (** Terms for cross-stage arguments. 22 | 23 | This module extends 24 | {{:http://erratique.ch/software/cmdliner/doc/Cmdliner.Arg.html} 25 | Cmdliner.Arg} to allow MetaOCaml-style typed cross-stage 26 | persistency of command-line arguments. *) 27 | 28 | (** {1 Argument converters} *) 29 | 30 | type 'a serialize = Format.formatter -> 'a -> unit 31 | (** The type for command-line argument serializers. A value of type 32 | ['a serialize] generates a syntactically valid OCaml 33 | representation which evaluates to a value of type ['a]. *) 34 | 35 | type 'a runtime_conv = string 36 | (** The type for command-line argument converters used at 37 | runtime. A value of type ['a runtime_conv] is a symbol name of 38 | type 39 | {{:http://erratique.ch/software/cmdliner/doc/Cmdliner.Arg.html#TYPEconverter} 40 | Cmdliner.Arg.converter}. *) 41 | 42 | type 'a converter 43 | (** The type for argument converters. *) 44 | 45 | val conv: 46 | conv:'a Cmdliner.Arg.converter -> 47 | serialize:'a serialize -> 48 | runtime_conv:'a runtime_conv -> 49 | 'a converter 50 | (** [conv c s r] is the argument converter using [c] to convert user 51 | strings into OCaml value, [s] to convert OCaml values into 52 | strings interpretable as OCaml expressions, and the function 53 | named [r] to convert user strings into OCaml values at 54 | runtime. *) 55 | 56 | val string: string converter 57 | (** [string] converts strings. *) 58 | 59 | val bool: bool converter 60 | (** [bool] converts booleans. *) 61 | 62 | val int: int converter 63 | (** [int] converts integers. *) 64 | 65 | val list: 'a converter -> 'a list converter 66 | (** [list t] converts lists of [t]s. *) 67 | 68 | val some: 'a converter -> 'a option converter 69 | (** [some t] converts [t] options. *) 70 | 71 | (** {1 Arguments and their information} *) 72 | 73 | type 'a t 74 | (** The type for arguments holding data of type ['a]. *) 75 | 76 | type info 77 | (** The type for information about cross-stage command-line 78 | arguments. See 79 | {{:http://erratique.ch/software/cmdliner/doc/Cmdliner.Arg.html#arginfo} 80 | Cmdliner's arguments}. *) 81 | 82 | val info: 83 | ?docs:string -> ?docv:string -> ?doc:string -> ?env:string -> 84 | string list -> info 85 | (** Define cross-stage information for an argument. See 86 | {{:http://erratique.ch/software/cmdliner/doc/Cmdliner.Arg.html#TYPEinfo} 87 | Cmdliner.Arg.info}. If not set, [docs] is ["UNIKERNEL PARAMETERS"]. *) 88 | 89 | 90 | (** {1 Optional Arguments} *) 91 | 92 | (** The type for specifying at which stage an argument is available. 93 | 94 | {ul 95 | {- [`Configure] means that the argument is read on the 96 | command-line at configuration-time.} 97 | {- [`Run] means that the argument is read on the command-line at 98 | runtime.} 99 | {- [`Both] means that the argument is read on the command-line 100 | both at configuration-time and run-time.} 101 | } *) 102 | type stage = [ 103 | | `Configure 104 | | `Run 105 | | `Both 106 | ] 107 | 108 | val opt: ?stage:stage -> 'a converter -> 'a -> info -> 'a t 109 | (** [opt conv v i] is similar to 110 | {{:http://erratique.ch/software/cmdliner/doc/Cmdliner.Arg.html#VALopt} 111 | Cmdliner.Arg.opt} but for cross-stage optional command-line 112 | arguments. If not set, [stage] is [`Both]. *) 113 | 114 | val required: ?stage:stage -> 'a converter -> info -> 'a option t 115 | (** [required conv i] is similar to 116 | {{:http://erratique.ch/software/cmdliner/doc/Cmdliner.Arg.html#VALrequired} 117 | Cmdliner.Arg.required} but for cross-stage required command-line 118 | arguments. If not set, [stage] is [`Both]. *) 119 | 120 | val flag: ?stage:stage -> info -> bool t 121 | (** [flag i] is similar to 122 | {{:http://erratique.ch/software/cmdliner/doc/Cmdliner.Arg.html#VALflag} 123 | Cmdliner.Arg.flag} but for cross-stage command-line flags. If not 124 | set, [stage] is [`Both]. *) 125 | 126 | end 127 | 128 | type +'a value 129 | (** The type for configure-time and run-time values. Values are either 130 | {!pure} or obtained by composing other values. Values might have 131 | {{!deps}data dependencies}, which form an (implicit) directed and 132 | acyclic graph that need to be evaluated. *) 133 | 134 | val pure: 'a -> 'a value 135 | (** [pure x] is a value without any dependency. *) 136 | 137 | val ($): ('a -> 'b) value -> 'a value -> 'b value 138 | (** [f $ v] is is the value resulting from the application of 139 | [f]'value to [v]'s value. [$] is the usual {i app} operator for 140 | {{:http://dx.doi.org/10.1017/S0956796807006326}applicative 141 | functor}. *) 142 | 143 | val map: ('a -> 'b) -> 'a value -> 'b value 144 | (** [map f v] is [pure f $ v]. *) 145 | 146 | val if_: bool value -> 'a -> 'a -> 'a value 147 | (** [if_ v x y] is [map (fun b -> if b then x else y) v]. *) 148 | 149 | val match_: 'a value -> ('a -> 'b) -> 'b value 150 | (** [match_ v pattern] is [map pattern v]. *) 151 | 152 | val default: 'a value -> 'a 153 | (** [default v] returns the default value for [v]. *) 154 | 155 | (** {1 Configuration Keys} *) 156 | 157 | type 'a key 158 | (** The type for configuration keys. Keys are used to retrieve the 159 | cross-stage values they are holding (by indexing contents in the 160 | autogenerated [Bootgen_var] module) but also to parameterize the 161 | choice of {{!Functoria.if_impl}module implementation}. *) 162 | 163 | val create: string -> 'a Arg.t -> 'a key 164 | (** [create n a] is the key named [n] whose contents is determined by 165 | parsing the command-line argument [a]. *) 166 | 167 | val value: 'a key -> 'a value 168 | (** [value k] is the value parsed by [k]. *) 169 | 170 | type t 171 | (** The type for abstract {{!key}keys}. *) 172 | 173 | (** [Set] implements sets over [t] elements. *) 174 | module Set: sig 175 | include Set.S with type elt = t 176 | 177 | val pp: elt Fmt.t -> t Fmt.t 178 | (** [pp] pretty-prints sets of keys. *) 179 | 180 | end 181 | 182 | val abstract: 'a key -> t 183 | (** [hide k] is the [k] with its type hidden. *) 184 | 185 | val equal : t -> t -> bool 186 | (** [equal] is the equality function of untyped keys. *) 187 | 188 | val hash: t -> int 189 | (** [hash] is the hash function for untyped keys. *) 190 | 191 | val compare: t -> t -> int 192 | (** [compare] compares untyped keys. *) 193 | 194 | val pp: t Fmt.t 195 | (** [pp fmt k] prints the name of [k]. *) 196 | 197 | val of_deps: Set.t -> unit value 198 | (** [of_deps keys] is a value with [keys] as data-dependencies. *) 199 | 200 | val deps: 'a value -> Set.t 201 | (** [deps v] are [v]'s data-dependencies. *) 202 | 203 | val pp_deps: 'a value Fmt.t 204 | (** [pp_deps fmt v] prints the name of the dependencies of [v]. *) 205 | 206 | (** {1 Stages} *) 207 | 208 | val is_runtime: t -> bool 209 | (** [is_runtime k] is true if [k]'s stage is [`Run] or [`Both]. *) 210 | 211 | val is_configure: t -> bool 212 | (** [is_configure k] is true if [k]'s stage is [`Configure] or [`Both]. *) 213 | 214 | val filter_stage: Arg.stage -> Set.t -> Set.t 215 | (** [filter_stage s ks] is [ks] but with only keys available at stage 216 | [s]. *) 217 | 218 | (** Alias allows to define virtual keys in terms of other keys at 219 | configuration time only. *) 220 | module Alias: sig 221 | (** {1 Alias} *) 222 | 223 | type 'a t 224 | (** The type for key alias. *) 225 | 226 | val add: 'b key -> ('a -> 'b option) -> 'a t -> 'a t 227 | (** [add k f a] set [a] as an alias for the key [k]: setting [a] on 228 | the command-line will set [k] to [f] applied to [a]'s value. If 229 | [f] returns [None], no value is set. *) 230 | 231 | val flag: Arg.info -> bool t 232 | (** [flag] is similar to {!Arg.flag} but defines configure-only 233 | command-line flag alias. Set [stage] to [`Configure]. *) 234 | 235 | (* 236 | val opt: 'a Arg.converter -> 'a -> Arg.info -> 'a t 237 | (** [opt] is similar to {!Arg.opt} but defines configure-only 238 | optional command-line arguments. Set [stage] to [`Configure]. *) 239 | *) 240 | 241 | end 242 | 243 | val alias: string -> 'a Alias.t -> 'a key 244 | (** Similar to {!create} but for command-line alias. *) 245 | 246 | val aliases: t -> Set.t 247 | (** [aliases t] is the list of [t]'s aliases. *) 248 | 249 | val name : t -> string 250 | (** [name t] is the string given as [t]'s name when [t] was created. *) 251 | 252 | (** {1 Parsing context} *) 253 | 254 | type context 255 | (** The type for values holding parsing context. *) 256 | 257 | val dump_context: context Fmt.t 258 | (** [dump_context] dumps the contents of a context. *) 259 | 260 | val empty_context : context 261 | 262 | val merge_context : default:context -> context -> context 263 | 264 | (** Add a binding to a context. *) 265 | val add_to_context : 'a key -> 'a -> context -> context 266 | 267 | val context: 268 | ?stage:Arg.stage -> with_required: bool -> 269 | Set.t -> context Cmdliner.Term.t 270 | (** [context ~with_required ks] is a [Cmdliner] 271 | {{:http://erratique.ch/software/cmdliner/doc/Cmdliner.Term.html#TYPt} 272 | term} that evaluates into a parsing context for command-line 273 | arguments. 274 | If [with_required] is false, it will only produce optional keys. 275 | *) 276 | 277 | val mem: context -> 'a value -> bool 278 | (** [mem c v] is [true] iff all the dependencies of [v] have been 279 | evaluated. *) 280 | 281 | val peek: context -> 'a value -> 'a option 282 | (** [peek c v] is [Some x] if [mem v] and [None] otherwise. *) 283 | 284 | val eval: context -> 'a value -> 'a 285 | (** [eval c v] evaluates [v] in [c]'s context, using default values if 286 | necessary. *) 287 | 288 | val get: context -> 'a key -> 'a 289 | (** [get c k] is [k]'s value in [c]'s context. *) 290 | 291 | val pps: context -> Set.t Fmt.t 292 | (** [pps c fmt ks] prints the keys [ks] using the context [c] to get 293 | their value. *) 294 | 295 | (** {1 Code Serialization} *) 296 | 297 | val ocaml_name: t -> string 298 | (** [ocaml_name k] is the ocaml name of [k]. *) 299 | 300 | val serialize_call: t Fmt.t 301 | (** [serialize_call fmt k] outputs [Key_gen.n ()] to [fmt], where 302 | [n] is [k]'s {{!ocaml_name}OCaml name}. *) 303 | 304 | val serialize: context -> t Fmt.t 305 | (** [serialize ctx ppf k] outputs the [Cmdliner] runes to parse 306 | command-line arguments represented by [k] at runtime. *) 307 | 308 | (**/**) 309 | 310 | val module_name: string 311 | (** Name of the generated module containing the keys. *) 312 | -------------------------------------------------------------------------------- /lib/functoria_misc.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Thomas Gazagnaire 3 | * Copyright (c) 2013 Anil Madhavapeddy 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | open Rresult 19 | open Astring 20 | 21 | let err_cmdliner ?(usage=false) = function 22 | | Ok x -> `Ok x 23 | | Error s -> `Error (usage, s) 24 | 25 | module type Monoid = sig 26 | type t 27 | val empty: t 28 | val union: t -> t -> t 29 | end 30 | 31 | (* {Misc informations} *) 32 | 33 | module Name = struct 34 | 35 | let ocamlify s = 36 | let b = Buffer.create (String.length s) in 37 | String.iter begin function 38 | | 'a'..'z' | 'A'..'Z' 39 | | '0'..'9' | '_' as c -> Buffer.add_char b c 40 | | '-' -> Buffer.add_char b '_' 41 | | _ -> () 42 | end s; 43 | let s' = Buffer.contents b in 44 | if String.length s' = 0 || ('0' <= s'.[0] && s'.[0] <= '9') then 45 | raise (Invalid_argument s); 46 | s' 47 | 48 | let ids = Hashtbl.create 1024 49 | 50 | let names = Hashtbl.create 1024 51 | 52 | let create name = 53 | let n = 54 | try 1 + Hashtbl.find ids name 55 | with Not_found -> 1 in 56 | Hashtbl.replace ids name n; 57 | Format.sprintf "%s%d" name n 58 | 59 | let find_or_create tbl key create_value = 60 | try Hashtbl.find tbl key 61 | with Not_found -> 62 | let value = create_value () in 63 | Hashtbl.add tbl key value; 64 | value 65 | 66 | let create key ~prefix = 67 | find_or_create names key (fun () -> create prefix) 68 | 69 | end 70 | 71 | module Codegen = struct 72 | 73 | let main_ml = ref None 74 | 75 | let generated_header ?(argv=Sys.argv) ?(time=Ptime_clock.now ()) () = 76 | Format.asprintf "Generated by %s (%a)." 77 | (String.concat ~sep:" " (Array.to_list argv)) 78 | (Ptime.pp_rfc3339 ~space:true ~frac_s:0 ()) time 79 | 80 | let append oc fmt = Format.fprintf oc (fmt ^^ "@.") 81 | let newline oc = append oc "" 82 | 83 | let append_main fmt = match !main_ml with 84 | | None -> failwith "main_ml" 85 | | Some oc -> append oc fmt 86 | 87 | let newline_main () = match !main_ml with 88 | | None -> failwith "main_ml" 89 | | Some oc -> newline oc 90 | 91 | let set_main_ml file = 92 | let oc = Format.formatter_of_out_channel @@ open_out file in 93 | main_ml := Some oc 94 | 95 | end 96 | 97 | module Univ = struct 98 | 99 | type 'a key = string * ('a -> exn) * (exn -> 'a) 100 | 101 | let new_key: string -> 'a key = 102 | fun s (type a) -> 103 | let module M = struct 104 | exception E of a 105 | end 106 | in 107 | ( s 108 | , (fun a -> M.E a) 109 | , (function M.E a -> a | _ -> raise @@ Invalid_argument ("duplicate key: " ^ s)) 110 | ) 111 | 112 | module Map = Map.Make(String) 113 | 114 | type t = exn Map.t 115 | 116 | let empty = Map.empty 117 | 118 | let add (kn, kput, _kget) v t = 119 | Map.add kn (kput v) t 120 | 121 | let mem (kn, _, _) t = 122 | Map.mem kn t 123 | 124 | let find (kn, _kput, kget) t = 125 | if Map.mem kn t then Some (kget @@ Map.find kn t) 126 | else None 127 | 128 | let merge ~default m = 129 | let aux _k _def v = Some v in 130 | Map.union aux default m 131 | 132 | let dump = 133 | let pp_elt ppf (k, v) = Fmt.pf ppf "%s: %a@ " k Fmt.exn v in 134 | let map_iter f = Map.iter (fun k v -> f (k, v)) in 135 | Fmt.(iter ~sep:(any ", ")) map_iter pp_elt 136 | 137 | end 138 | -------------------------------------------------------------------------------- /lib/functoria_misc.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Thomas Gazagnaire 3 | * Copyright (c) 2013 Anil Madhavapeddy 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | (** Utility module. *) 19 | 20 | (** {2 Misc} *) 21 | 22 | open Rresult 23 | 24 | val err_cmdliner: ?usage:bool -> ('a, string) result -> 'a Cmdliner.Term.ret 25 | 26 | module type Monoid = sig 27 | type t 28 | val empty: t 29 | val union: t -> t -> t 30 | end 31 | 32 | (** Generation of fresh names *) 33 | module Name: sig 34 | val ocamlify: string -> string 35 | val create: string -> prefix:string -> string 36 | end 37 | 38 | module Codegen: sig 39 | val generated_header: ?argv:string array -> ?time:Ptime.t -> unit -> string 40 | val append: Format.formatter -> ('a, Format.formatter, unit) format -> 'a 41 | val newline: Format.formatter -> unit 42 | val set_main_ml: string -> unit 43 | val append_main: ('a, Format.formatter, unit) format -> 'a 44 | val newline_main: unit -> unit 45 | end 46 | 47 | (** Universal map *) 48 | module Univ: sig 49 | type 'a key 50 | val new_key: string -> 'a key 51 | type t 52 | val empty: t 53 | val add: 'a key -> 'a -> t -> t 54 | val mem: 'a key -> t -> bool 55 | val find: 'a key -> t -> 'a option 56 | val merge: default:t -> t -> t 57 | val dump: t Fmt.t 58 | end 59 | -------------------------------------------------------------------------------- /runtime/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name functoria_runtime) 3 | (public_name functoria-runtime) 4 | (libraries cmdliner) 5 | (wrapped false) 6 | (flags (:standard (-w -3))) 7 | ) 8 | -------------------------------------------------------------------------------- /runtime/functoria_info.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Gabriel Radanne 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | type info = { 17 | name: string; 18 | libraries: string list; 19 | packages: (string * string) list; 20 | } 21 | -------------------------------------------------------------------------------- /runtime/functoria_info.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Gabriel Radanne 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (** Information about Functoria applications. *) 18 | 19 | type info = { 20 | name: string; 21 | libraries: string list; 22 | packages: (string * string) list; 23 | } 24 | (** The type for information about applications. 25 | 26 | {ul 27 | {- [name] is the name of the application.} 28 | {- [libraries] is the list of OCamlfind libraries linked to form the 29 | application.} 30 | {- [packages] is the list of package name and version used to create 31 | the application.} 32 | } 33 | *) 34 | -------------------------------------------------------------------------------- /runtime/functoria_runtime.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Gabriel Radanne 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module Arg = struct 18 | 19 | type 'a kind = 20 | | Opt : 'a * 'a Cmdliner.Arg.converter -> 'a kind 21 | | Flag: bool kind 22 | | Required : 'a Cmdliner.Arg.converter -> 'a kind 23 | 24 | type 'a t = { 25 | info : Cmdliner.Arg.info; 26 | kind : 'a kind; 27 | } 28 | 29 | let flag info = { info; kind = Flag } 30 | let opt conv default info = { info; kind = Opt (default, conv) } 31 | let required conv info = { info; kind = Required conv } 32 | let key ?default c i = match default with 33 | | None -> required c i 34 | | Some d -> opt c d i 35 | 36 | let default (type a) (t : a t) = match t.kind with 37 | | Opt (d,_) -> Some d 38 | | Flag -> Some false 39 | | Required _ -> None 40 | 41 | let kind t = t.kind 42 | let info t = t.info 43 | 44 | end 45 | 46 | module Key = struct 47 | 48 | type 'a t = { 49 | arg : 'a Arg.t; 50 | mutable value: 'a option; 51 | } 52 | 53 | let create arg = { arg; value = None } 54 | 55 | let get t = match t.value with 56 | | None -> invalid_arg "Key.get: Called too early. Please delay this call after cmdliner's evaluation." 57 | | Some v -> v 58 | 59 | let default t = Arg.default t.arg 60 | 61 | let term (type a) (t: a t) = 62 | let set w = t.value <- Some w in 63 | let doc = Arg.info t.arg in 64 | let term arg = Cmdliner.Term.(pure set $ arg) in 65 | match Arg.kind t.arg with 66 | | Arg.Flag -> term @@ Cmdliner.Arg.(value & flag doc) 67 | | Arg.Opt (default, desc) -> 68 | term @@ Cmdliner.Arg.(value & opt desc default doc) 69 | | Arg.Required desc -> 70 | term @@ Cmdliner.Arg.(required & opt (some desc) None doc) 71 | 72 | end 73 | 74 | let initialized = ref false 75 | let with_argv keys s argv = 76 | let open Cmdliner in 77 | if !initialized then () 78 | else 79 | let gather k rest = Term.(pure (fun () () -> ()) $ k $ rest) in 80 | let t = List.fold_right gather keys (Term.pure ()) in 81 | match Term.(eval ~argv (t, info s)) with 82 | | `Ok _ -> initialized := true; () 83 | | `Error _ -> exit 64 84 | | `Help | `Version -> exit 63 85 | -------------------------------------------------------------------------------- /runtime/functoria_runtime.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Gabriel Radanne 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (** Functoria runtime. *) 18 | 19 | (** [Arg] defines command-line arguments which can be set at runtime. 20 | This module is the runtime companion of {!Functoria_key}. It 21 | exposes a subset of 22 | {{:http://erratique.ch/software/cmdliner/doc/Cmdliner.Arg.html} 23 | Cmdliner.Arg}. *) 24 | module Arg: sig 25 | 26 | (** {1 Runtime command-line arguments} *) 27 | 28 | type 'a t 29 | (** The type for runtime command-line arguments. Similar to 30 | {!Functoria_key.Arg.t} but only available at runtime. *) 31 | 32 | val opt: 'a Cmdliner.Arg.converter -> 'a -> Cmdliner.Arg.info -> 'a t 33 | (** [opt] is the runtime companion of {!Functoria_key.Arg.opt}. *) 34 | 35 | val required: 'a Cmdliner.Arg.converter -> Cmdliner.Arg.info -> 'a t 36 | (** [required] is the runtime companion of {!Functoria_key.Arg.required}. *) 37 | 38 | val key: ?default:'a -> 'a Cmdliner.Arg.converter -> Cmdliner.Arg.info -> 'a t 39 | (** [key] is either {!opt} or {!runtime}, depending if [~default] is provided. *) 40 | 41 | val flag: Cmdliner.Arg.info -> bool t 42 | (** [flag] is the runtime companion of {!Functoria_key.Arg.flag}. *) 43 | 44 | end 45 | 46 | (** [Key] defines values that can be set by runtime command-line 47 | arguments. This module is the runtime companion of 48 | {!Functoria_key}. *) 49 | module Key: sig 50 | 51 | (** {1 Runtime keys} *) 52 | 53 | type 'a t 54 | (** The type for runtime keys containing a value of type ['a]. *) 55 | 56 | val create: 'a Arg.t -> 'a t 57 | (** [create conv] create a new runtime key. *) 58 | 59 | val get: 'a t -> 'a 60 | (** [get k] is the value of the key [k]. Use the default value if no 61 | command-line argument is provided. 62 | @raise Invalid_argument if called before cmdliner's evaluation. 63 | *) 64 | 65 | val default : 'a t -> 'a option 66 | (** [default k] is the default value of [k], if one is available. 67 | This function can be called before cmdliner's evaluation. 68 | *) 69 | 70 | val term: 'a t -> unit Cmdliner.Term.t 71 | (** [term k] is the [Cmdliner] term whose evaluation sets [k]s' 72 | value to the parsed command-line argument. *) 73 | 74 | end 75 | 76 | (** [with_argv keys name argv] evaluates the [keys] {{!Key.term}terms} on the 77 | command-line [argv]. [name] is the executable name. On evaluation error the 78 | application calls [exit(3)] with status [64]. If [`Help] or [`Version] were 79 | evaluated, [exit(3)] is called with status [63]. *) 80 | val with_argv : unit Cmdliner.Term.t list -> string -> string array -> unit 81 | -------------------------------------------------------------------------------- /tests/app/app.ml: -------------------------------------------------------------------------------- 1 | let start = 2 | Fmt.pr "Success: vote=%s hello=%s\n%!" Key_gen.(vote ()) Key_gen.(hello ()) 3 | -------------------------------------------------------------------------------- /tests/app/config.ml: -------------------------------------------------------------------------------- 1 | open Test_app 2 | module Key = Functoria_key 3 | 4 | let main = Functoria.(foreign "App" job) 5 | 6 | let key = 7 | let doc = Key.Arg.info ~doc:"How to say hello." ["hello"] in 8 | Key.(create "hello" Arg.(opt string "Hello World!" doc)) 9 | 10 | let () = register ~keys:[Key.abstract key] "noop" [main] 11 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_core) 3 | (modules test_core) 4 | (libraries test_app alcotest cmdliner rresult astring) 5 | (package functoria) 6 | (deps app/config.ml app/app.ml) 7 | (flags (:standard (-w -3)))) 8 | 9 | (executable 10 | (name test_full) 11 | (modules test_full) 12 | (libraries functoria.test alcotest cmdliner rresult astring) 13 | (flags (:standard (-w -3)))) 14 | -------------------------------------------------------------------------------- /tests/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_app) 3 | (public_name functoria.test) 4 | (libraries functoria.app) 5 | (wrapped false) 6 | (modules test_app) 7 | ) 8 | -------------------------------------------------------------------------------- /tests/lib/test_app.ml: -------------------------------------------------------------------------------- 1 | open Rresult 2 | module Key = Functoria_key 3 | 4 | let warn_error = 5 | let doc = "Enable -warn-error when compiling OCaml sources." in 6 | let doc = Key.Arg.info ~docv:"BOOL" ~doc ["warn-error"] in 7 | let key = Key.Arg.(opt ~stage:`Configure bool false doc) in 8 | Key.create "warn_error" key 9 | 10 | let vote = 11 | let doc = "Vote." in 12 | let doc = Key.Arg.info ~docv:"VOTE" ~doc ["vote"] in 13 | let key = Key.Arg.(opt ~stage:`Configure string "cat" doc) in 14 | Key.create "vote" key 15 | 16 | let output i = match Functoria.Info.output i with 17 | | None -> "main" 18 | | Some o -> o 19 | 20 | let run cmd = 21 | match Bos.OS.Cmd.run_out cmd |> Bos.OS.Cmd.out_string with 22 | | Error (`Msg e) -> failwith e 23 | | Ok (out, status) -> match snd status with 24 | | `Exited 0 -> () 25 | | `Exited _ 26 | | `Signaled _ -> 27 | Format.fprintf Format.str_formatter "error while executing %a\n%s" 28 | Bos.Cmd.pp cmd out ; 29 | let err = Format.flush_str_formatter () in 30 | failwith err 31 | 32 | let rec root path = 33 | Bos.OS.File.exists Fpath.(path / "functoria-runtime.opam") >>= function 34 | | true -> Ok path 35 | | false -> root (Fpath.parent path) 36 | 37 | let root () = R.get_ok @@ (Bos.OS.Dir.current () >>= root) 38 | 39 | let dune_file i = Fpath.(Functoria.Info.build_dir i / "dune.build") 40 | 41 | let write_key i k f = 42 | let context = Functoria.Info.context i in 43 | let file = Key.(name @@ abstract k) in 44 | let contents = f (Key.get context k) in 45 | R.get_ok @@ Bos.OS.File.write Fpath.(v file) contents 46 | 47 | let split_root () = 48 | let cwd = R.get_ok @@ Bos.OS.Dir.current () in 49 | let root = root () in 50 | match Fpath.relativize ~root cwd with 51 | | None -> failwith "split root" 52 | | Some path -> root, path 53 | 54 | module C = struct 55 | let prelude = "let (>>=) x f = f x\n\ 56 | let return x = x\n\ 57 | let run x = x" 58 | let name = "test" 59 | let version = "1.0" 60 | let packages = [Functoria.package "functoria"; Functoria.package "test_app"] 61 | let ignore_dirs = [] 62 | 63 | let create jobs = Functoria.impl @@ object (self) 64 | inherit Functoria.base_configurable 65 | method ty = Functoria.job 66 | method name = "test_app" 67 | method module_name = "Test_app" 68 | method! connect _ _ _ = "()" 69 | method! keys = [ 70 | Functoria_key.(abstract vote); 71 | Functoria_key.(abstract warn_error); 72 | ] 73 | method! packages = Key.pure [ 74 | Functoria.package "fmt"; 75 | ] 76 | 77 | method! configure i = 78 | let dune = Fmt.str 79 | "(executable\n\ 80 | \ (name %s)\n\ 81 | \ (modules (:standard \\ config))\n\ 82 | \ (libraries cmdliner fmt functoria-runtime))\n" 83 | (output i) 84 | in 85 | Bos.OS.File.write (dune_file i) dune 86 | 87 | method! clean i = 88 | Bos.OS.File.delete (dune_file i) >>= fun () -> 89 | Bos.OS.File.delete Fpath.(v @@ output i ^ ".exe") >>= fun () -> 90 | List.fold_left (fun acc key -> 91 | acc >>= fun () -> 92 | let file = Fpath.v (Key.name key) in 93 | Bos.OS.File.delete file 94 | ) (Ok ()) self#keys 95 | 96 | method! build i = 97 | Bos.OS.Dir.with_current (Functoria.Info.build_dir i) (fun () -> 98 | let root, prefix = split_root () in 99 | let exe = Fpath.(prefix / output i + "exe") in 100 | write_key i vote (fun x -> x); 101 | write_key i warn_error string_of_bool; 102 | run @@ Bos.Cmd.(v "dune" % "build" 103 | % "--root" % Fpath.to_string root 104 | % Fpath.(to_string exe)); 105 | run @@ Bos.Cmd.(v "mv" % Fpath.(to_string @@ root / "_build" / "default" // exe) 106 | % (output i ^ ".exe")); 107 | ) () 108 | 109 | method! deps = List.map Functoria.abstract jobs 110 | end 111 | end 112 | 113 | include Functoria_app.Make(C) 114 | -------------------------------------------------------------------------------- /tests/test_core.ml: -------------------------------------------------------------------------------- 1 | module Key = Functoria_key 2 | module Cmd = Functoria_command_line 3 | 4 | let result_t = 5 | let pp ppf = function 6 | | `Error `Exn -> Fmt.string ppf "error exn" 7 | | `Error `Parse -> Fmt.string ppf "error parse" 8 | | `Error `Term -> Fmt.string ppf "error term" 9 | | `Help -> Fmt.string ppf "help" 10 | | `Version -> Fmt.string ppf "version" 11 | | `Ok action -> 12 | let pp = Cmd.pp_action Fmt.(Dump.pair bool bool) in 13 | Fmt.pf ppf "ok %a" pp action 14 | in 15 | Alcotest.testable pp (=) 16 | 17 | let key = Alcotest.testable Key.pp Key.equal 18 | 19 | let test_keys () = 20 | let k1 = 21 | Key.(abstract @@ create "foo" Arg.(opt int 1 (info ["foo"]))) 22 | in 23 | let k2 = 24 | Key.(abstract @@ create "foo" Arg.(opt int 2 (info ["foo"]))) 25 | in 26 | let k3 = 27 | Key.(abstract @@ create "foo" Arg.(opt int 1 (info ["foo"]))) 28 | in 29 | Alcotest.(check @@ neg key) "different defaults" k1 k2; 30 | Alcotest.(check @@ key) "same defaults" k1 k3 31 | 32 | let test_configure () = 33 | let extra_term = Cmdliner.(Term.( 34 | pure (fun xyz cde -> (xyz, cde)) 35 | $ Arg.(value (flag (info ["x"; "xyz"]))) 36 | $ Arg.(value (flag (info ["c"; "cde"]))) 37 | )) 38 | in 39 | let result = 40 | Cmd.parse_args ~name:"name" ~version:"0.2" 41 | ~configure:extra_term 42 | ~describe:extra_term 43 | ~build:extra_term 44 | ~clean:extra_term 45 | ~help:extra_term 46 | [|"name"; "configure"; "--xyz"; "--verbose"|] 47 | in 48 | Alcotest.(check result_t) "configure" 49 | (`Ok (Cmd.Configure { result = (true, false); output = None })) 50 | result 51 | 52 | let test_describe () = 53 | let extra_term = Cmdliner.(Term.( 54 | pure (fun xyz cde -> (xyz, cde)) 55 | $ Arg.(value (flag (info ["x"; "xyz"]))) 56 | $ Arg.(value (flag (info ["c"; "cde"]))) 57 | )) 58 | in 59 | let result = 60 | Cmd.parse_args ~name:"name" ~version:"0.2" 61 | ~configure:extra_term 62 | ~describe:extra_term 63 | ~build:extra_term 64 | ~clean:extra_term 65 | ~help:extra_term 66 | [|"name"; "describe"; "--cde"; 67 | "--color=always"; "--dot-command=dot"; "--eval"|] 68 | in 69 | Alcotest.(check result_t) "describe" 70 | (`Ok (Cmd.Describe { result = (false, true); 71 | dotcmd = "dot"; 72 | dot = false; 73 | output = None })) 74 | result 75 | 76 | let test_build () = 77 | let extra_term = Cmdliner.(Term.( 78 | pure (fun xyz cde -> (xyz, cde)) 79 | $ Arg.(value (flag (info ["x"; "xyz"]))) 80 | $ Arg.(value (flag (info ["c"; "cde"]))) 81 | )) 82 | in 83 | let result = 84 | Cmd.parse_args ~name:"name" ~version:"0.2" 85 | ~configure:extra_term 86 | ~describe:extra_term 87 | ~build:extra_term 88 | ~clean:extra_term 89 | ~help:extra_term 90 | [|"name"; "build"; "--cde"; "-x"; "--color=never"; "-v"; "-v"|] 91 | in 92 | Alcotest.(check result_t) "build" 93 | (`Ok (Cmd.Build (true, true))) 94 | result 95 | 96 | let test_clean () = 97 | let extra_term = Cmdliner.(Term.( 98 | pure (fun xyz cde -> (xyz, cde)) 99 | $ Arg.(value (flag (info ["x"; "xyz"]))) 100 | $ Arg.(value (flag (info ["c"; "cde"]))) 101 | )) 102 | in 103 | let result = 104 | Cmd.parse_args ~name:"name" ~version:"0.2" 105 | ~configure:extra_term 106 | ~describe:extra_term 107 | ~build:extra_term 108 | ~clean:extra_term 109 | ~help:extra_term 110 | [|"name"; "clean"|] 111 | in 112 | Alcotest.(check result_t) "clean" 113 | (`Ok (Cmd.Clean (false, false))) 114 | result 115 | 116 | let test_help () = 117 | let extra_term = Cmdliner.(Term.( 118 | pure (fun xyz cde -> (xyz, cde)) 119 | $ Arg.(value (flag (info ["x"; "xyz"]))) 120 | $ Arg.(value (flag (info ["c"; "cde"]))) 121 | )) 122 | in 123 | let result = 124 | Cmd.parse_args ~name:"name" ~version:"0.2" 125 | ~configure:extra_term 126 | ~describe:extra_term 127 | ~build:extra_term 128 | ~clean:extra_term 129 | ~help:extra_term 130 | [|"name"; "help"; "--help"; "plain"|] 131 | in 132 | Alcotest.(check result_t) "help" `Help result 133 | 134 | let test_default () = 135 | let extra_term = Cmdliner.(Term.( 136 | pure (fun xyz cde -> (xyz, cde)) 137 | $ Arg.(value (flag (info ["x"; "xyz"]))) 138 | $ Arg.(value (flag (info ["c"; "cde"]))) 139 | )) 140 | in 141 | let result = 142 | Cmd.parse_args ~name:"name" ~version:"0.2" 143 | ~configure:extra_term 144 | ~describe:extra_term 145 | ~build:extra_term 146 | ~clean:extra_term 147 | ~help:extra_term 148 | [|"name"|] 149 | in 150 | Alcotest.(check result_t) "default" `Help result 151 | 152 | let test_read_full_eval () = 153 | let check = Alcotest.(check @@ option bool) in 154 | begin 155 | check "test" None 156 | (Cmd.read_full_eval [|"test"|]); 157 | 158 | check "test --eval" (Some true) 159 | (Cmd.read_full_eval [|"test"; "--eval"|]); 160 | 161 | check "test blah --eval blah" (Some true) 162 | (Cmd.read_full_eval [|"test"; "blah"; "--eval"; "blah"|]); 163 | 164 | check "test --no-eval" (Some false) 165 | (Cmd.read_full_eval [|"test"; "--no-eval"|]); 166 | 167 | check "test blah --no-eval blah" (Some false) 168 | (Cmd.read_full_eval [|"test"; "blah"; "--no-eval"; "blah"|]); 169 | 170 | check "--no-eval test --eval" (Some true) 171 | (Cmd.read_full_eval [|"--no-eval"; "test"; "--eval"|]); 172 | 173 | check "--eval test --no-eval" (Some false) 174 | (Cmd.read_full_eval [|"--eval"; "test"; "--no-eval"|]); 175 | end 176 | 177 | let test_generated_header () = 178 | let expected = "Generated by prog arg1 arg2 (1970-01-01 00:00:00-00:00)." in 179 | let got = 180 | Functoria_app.Codegen.generated_header 181 | ~argv:[|"prog"; "arg1"; "arg2"|] 182 | ~time:Ptime.epoch 183 | () 184 | in 185 | Alcotest.check Alcotest.string "generated_header" expected got 186 | 187 | let suite = [ 188 | "keys" , `Quick, test_keys; 189 | "read_full_eval", `Quick, test_read_full_eval; 190 | "configure" , `Quick, test_configure; 191 | "describe" , `Quick, test_describe; 192 | "build" , `Quick, test_build; 193 | "clean" , `Quick, test_clean; 194 | "help" , `Quick, test_help; 195 | "default" , `Quick, test_default; 196 | "generated_header", `Quick, test_generated_header; 197 | ] 198 | 199 | let () = Alcotest.run "functoria" ["core", suite] 200 | -------------------------------------------------------------------------------- /tests/test_core.mli: -------------------------------------------------------------------------------- 1 | (* empty *) 2 | -------------------------------------------------------------------------------- /tests/test_full.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Jeremy Yallop 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Astring 18 | module Cmd = Functoria_command_line 19 | 20 | let list_files dir = 21 | let l = Bos.OS.Path.matches ~dotfiles:true Fpath.(dir / "$(file)") in 22 | match l with 23 | | Error (`Msg e) -> Fmt.kstr (fun s -> Alcotest.fail s) "list_files: %s" e 24 | | Ok l -> 25 | List.filter (fun f -> not (String.equal ".merlin" f)) @@ 26 | List.sort String.compare @@ 27 | List.rev_map (fun x -> 28 | match Fpath.relativize ~root:dir x with 29 | | None -> assert false 30 | | Some d -> Fpath.to_string d 31 | ) l 32 | 33 | let root = 34 | let cwd = Rresult.R.get_ok @@ Bos.OS.Dir.current () in 35 | match Fpath.(basename cwd) with 36 | | "tests" -> Fpath.v "app" 37 | | _ -> Fpath.(v "tests" / "app") 38 | 39 | let get_ok = function 40 | | Ok x -> x 41 | | Error (`Msg e) -> Alcotest.fail e 42 | 43 | let read_file file = get_ok @@ Bos.OS.File.read Fpath.(v file) 44 | 45 | let clean_app () = 46 | let dir = Fpath.(v "_build" / "default" // root) in 47 | get_ok @@ Bos.OS.Dir.delete ~recurse:true dir; 48 | let files = list_files root in 49 | List.iter (fun f -> 50 | match Filename.basename f with 51 | | "app.ml" | "config.ml" -> () 52 | | _ -> 53 | if Rresult.R.get_ok @@ Bos.OS.Dir.exists Fpath.(root / f) then () 54 | else get_ok @@ Bos.OS.File.delete Fpath.(root / f) 55 | ) files 56 | 57 | let clean_build () = 58 | let dir = Fpath.(v "custom_build_") in 59 | get_ok @@ Bos.OS.Dir.delete ~recurse:true dir 60 | 61 | let test ?err_ppf ?help_ppf fmt = 62 | Fmt.kstr (fun l -> 63 | let l = String.cuts ~sep:" " l in 64 | Test_app.run_with_argv ?err_ppf ?help_ppf (Array.of_list ("" :: l)) 65 | ) fmt 66 | 67 | (* cut a man page into sections *) 68 | let by_sections s = 69 | let lines = String.cuts ~sep:"\n" s in 70 | let return l = match List.rev l with 71 | | [] -> assert false 72 | | h::t -> h, t 73 | in 74 | let rec aux current sections = function 75 | | [] -> List.rev (return current :: sections) 76 | | h :: t -> 77 | if String.length h > 1 78 | && String.for_all (fun x -> Char.Ascii.(is_upper x || is_white x)) h 79 | then 80 | aux [h] (return current :: sections) t 81 | else 82 | aux (h :: current) sections t 83 | in 84 | aux ["INIT"] [] lines 85 | 86 | let files = Alcotest.(slist string String.compare) 87 | 88 | let test_configure () = 89 | clean_app (); 90 | (* check that configure generates the file in the right dir when 91 | --file is passed. *) 92 | Alcotest.(check files) "the usual files should be present before configure" 93 | ["app.ml"; "config.ml"] (list_files root); 94 | test "configure -vv --file tests/app/config.ml"; 95 | Alcotest.(check files) "new files should be created in the source dir" 96 | ["app.ml"; "config.ml"; 97 | "key_gen.ml"; "main.ml"; ".mirage.config"; 98 | "dune"; "dune.config"; "dune.build"] 99 | (list_files root); 100 | clean_app (); 101 | 102 | (* check that configure generates the file in the right dir when 103 | --build-dir is passed. *) 104 | let files = Alcotest.(slist string String.compare) in 105 | Alcotest.(check files) "the usual files should be present before configure" 106 | ["app.ml"; "config.ml"] (list_files root); 107 | test "configure -vv --file tests/app/config.ml --build-dir custom_build_"; 108 | Alcotest.(check files) "nothing should be created in the source dir" 109 | ["app.ml"; "config.ml"] 110 | (list_files root); 111 | Alcotest.(check files) "other files should be created in custom_build_" 112 | ["main.ml"; "key_gen.ml"; 113 | ".mirage.config"; 114 | "dune"; "dune.config"; "dune.build"; 115 | (* FIXME: add a .mirage-ignore file to avoid this *) ] 116 | (list_files Fpath.(v "custom_build_")); 117 | clean_build (); 118 | 119 | (* check that configure is writting the correct .mirage.config 120 | file *) 121 | let test_config root cfg = 122 | Test_app.run_with_argv (Array.of_list cfg); 123 | let expected = 124 | String.concat ~sep:"\n" 125 | @@ List.map String.Ascii.escape (List.tl cfg) in 126 | let got = get_ok @@ Bos.OS.File.read Fpath.(v root / ".mirage.config") in 127 | Alcotest.(check string) ("config should persist in " ^ root) 128 | (String.Ascii.escape_string expected ) 129 | (String.Ascii.escape_string got) 130 | in 131 | 132 | test_config "custom_build_" 133 | [""; "configure"; "-vv"; "--file=tests/app/config.ml"; 134 | "--build-dir=custom_build_"]; 135 | clean_build (); 136 | 137 | test_config "tests/app" 138 | [""; "configure"; "-vv"; "--file=tests/app/config.ml"]; 139 | clean_app (); 140 | 141 | (* check that `test help configure` and `test configure --help` have 142 | the same output. *) 143 | let b1 = Buffer.create 128 and b2 = Buffer.create 128 in 144 | test ~help_ppf:(Format.formatter_of_buffer b1) 145 | "help configure --file=tests/app/config.ml --help=plain"; 146 | test ~help_ppf:(Format.formatter_of_buffer b2) 147 | "configure --file=tests/app/config.ml --help=plain"; 148 | let s1 = Buffer.contents b1 and s2 = Buffer.contents b2 in 149 | 150 | let s1 = by_sections s1 and s2 = by_sections s2 in 151 | Alcotest.(check (list string)) 152 | "help messages have the same configure options" 153 | (List.assoc "CONFIGURE OPTIONS" s1) 154 | (List.assoc "CONFIGURE OPTIONS" s2); 155 | Alcotest.(check (list string)) 156 | "help messages have the same application parameters" 157 | (List.assoc "APPLICATION OPTIONS" s1) 158 | (List.assoc "APPLICATION OPTIONS" s2); 159 | Alcotest.(check (list string)) 160 | "help messages have the same common options" 161 | (List.assoc "COMMON OPTIONS" s1) 162 | (List.assoc "COMMON OPTIONS" s2); 163 | 164 | (* check that `test help configure` works when no config.ml file 165 | is present. *) 166 | let b3 = Buffer.create 128 in 167 | let b4 = Buffer.create 128 in 168 | test "help configure --help=plain" 169 | ~err_ppf:(Format.formatter_of_buffer b3) 170 | ~help_ppf:(Format.formatter_of_buffer b4); 171 | let s3 = Buffer.contents b3 in 172 | let s4 = by_sections (Buffer.contents b4) in 173 | Alcotest.(check string) "no errors" s3 ""; 174 | Alcotest.(check bool) "name should be present" 175 | true (List.mem_assoc "NAME" s4); 176 | Alcotest.(check bool) "synopsis should be present" 177 | true (List.mem_assoc "SYNOPSIS" s4) 178 | 179 | let test_describe () = 180 | Test_app.run_with_argv 181 | [| ""; "describe"; "-vv"; 182 | "--file"; "tests/app/config.ml"|] 183 | 184 | let test_build () = 185 | (* default build *) 186 | test "configure --file tests/app/config.ml"; 187 | test "build -vv --file tests/app/config.ml"; 188 | Alcotest.(check bool) "main.exe should be built" true 189 | (Sys.file_exists "tests/app/main.exe"); 190 | clean_app (); 191 | 192 | (* test --output *) 193 | test "configure --file tests/app/config.ml -o toto"; 194 | test "build -vv --file tests/app/config.ml"; 195 | Alcotest.(check bool) "toto.exe should be built" true 196 | (Sys.file_exists "tests/app/toto.exe"); 197 | clean_app (); 198 | 199 | (* test --build-dir *) 200 | test "configure -vv --file tests/app/config.ml --build-dir custom_build_"; 201 | test "build -vv --file tests/app/config.ml --build-dir custom_build_"; 202 | Alcotest.(check bool) "main.exe should be built in custom_build_" true 203 | (Sys.file_exists "custom_build_/main.exe"); 204 | clean_build (); 205 | 206 | (* test --output + --build-dir *) 207 | test "configure --file tests/app/config.ml --build-dir custom_build_ -o toto"; 208 | test "build -vv --build-dir custom_build_ --file tests/app/config.ml"; 209 | Alcotest.(check bool) "toto.exe should be built in custom_build_" true 210 | (Sys.file_exists "custom_build_/toto.exe"); 211 | clean_build () 212 | 213 | let test_keys () = 214 | test "configure -vv --file tests/app/config.ml"; 215 | test "build -vv --file tests/app/config.ml"; 216 | Alcotest.(check string) "vote contains the default value: cat" "cat" 217 | (read_file "tests/app/vote"); 218 | clean_app (); 219 | 220 | test "configure --file tests/app/config.ml --build-dir custom_build_"; 221 | test "build --file tests/app/config.ml --build-dir custom_build_"; 222 | Alcotest.(check string) "vote contains the default value: cat" "cat" 223 | (read_file "custom_build_/vote"); 224 | clean_build (); 225 | 226 | test "configure --file tests/app/config.ml --vote=dog"; 227 | test "build --file tests/app/config.ml"; 228 | Alcotest.(check string) "vote contains dog" 229 | "dog" (read_file "tests/app/vote"); 230 | clean_app () 231 | 232 | let test_clean () = 233 | test "configure -vv --file tests/app/config.ml"; 234 | test "clean -vv --file tests/app/config.ml"; 235 | Alcotest.(check files) "clean should remove all the files" 236 | ["app.ml"; "config.ml"] 237 | (list_files root); 238 | 239 | test "configure -vv --file tests/app/config.ml --build-dir=custom_build_"; 240 | test "clean -vv --file tests/app/config.ml --build-dir custom_build_"; 241 | Alcotest.(check files) "clean should remove all the files" 242 | [] 243 | (list_files (Fpath.v "custom_build_")) 244 | 245 | let test_cache () = 246 | let str = "foo;;bar;;;\n\nllll;;;sdaads;;\n\t\\0" in 247 | test "configure --file tests/app/config.ml --vote=%s" str; 248 | test "build --file tests/app/config.ml"; 249 | Alcotest.(check string) "cache is valid" str (read_file "tests/app/vote"); 250 | clean_app () 251 | 252 | let test_help () = 253 | test "help -vv --help=plain" 254 | 255 | let test_default () = 256 | test "-vv" 257 | 258 | let suite = [ 259 | "configure" , `Quick, test_configure; 260 | "describe" , `Quick, test_describe; 261 | "build" , `Quick, test_build; 262 | "keys" , `Quick, test_keys; 263 | "clean" , `Quick, test_clean; 264 | "help" , `Quick, test_help; 265 | "default" , `Quick, test_default; 266 | "cache" , `Quick, test_cache; 267 | ] 268 | 269 | let () = Alcotest.run "functoria-runtime" ["full", suite] 270 | -------------------------------------------------------------------------------- /tests/test_full.mli: -------------------------------------------------------------------------------- 1 | (* empty *) 2 | --------------------------------------------------------------------------------