matthieu
/
dune
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Add support for a meta language in jbuild files

This commit is contained in:
Jérémie Dimino 2017-02-26 12:20:47 +00:00
parent 4227e756bd
commit 8d52cba130
11 changed files with 322 additions and 161 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
Makefile
View File

@ -17,7 +17,4 @@ reinstall: uninstall reinstall
clean:
rm -rf _build
cinaps:
cinaps -i doc/jbuild
.PHONY: default install uninstall reinstall clean cinaps
.PHONY: default install uninstall reinstall clean

92
doc/jbuild
View File

@ -1,93 +1,37 @@
;; When adding a command to jbuilder, add it to the [cmds] variable in
;; this file and run "make cinaps"
(use_meta_lang)
(install
((section doc)
(files (manual.org))))
#|(*$
open StdLabels
open Printf
(:let :commands
(build
build-package
external-lib-deps
install
installed-libraries
runtest
uninstall))
let cmds =
[ "build"
; "build-package"
; "external-lib-deps"
; "install"
; "installed-libraries"
; "runtest"
; "uninstall"
]
let cmds = ("", "") :: List.map cmds ~f:(fun x -> ("-" ^ x, x))
let () =
print_endline ("|"^"#");
List.iter cmds ~f:(fun (suffix, cmd) ->
printf {|
(rule
((targets (jbuilder%s.1))
(action (with-stdout-to ${@}
(run ${bin:jbuilder} %s --help=groff)))))
|}
suffix cmd);
print_string ";; "
*)|#
(:let-macro (:man-file :cmd)
(:concat "" (jbuilder- (:cmd) .1)))
(rule
((targets (jbuilder.1))
(action (with-stdout-to ${@}
(run ${bin:jbuilder} --help=groff)))))
(run ${bin:jbuilder} --help=groff)))))
(rule
((targets (jbuilder-build.1))
(action (with-stdout-to ${@}
(run ${bin:jbuilder} build --help=groff)))))
(rule
((targets (jbuilder-build-package.1))
(action (with-stdout-to ${@}
(run ${bin:jbuilder} build-package --help=groff)))))
(rule
((targets (jbuilder-external-lib-deps.1))
(action (with-stdout-to ${@}
(run ${bin:jbuilder} external-lib-deps --help=groff)))))
(rule
((targets (jbuilder-install.1))
(action (with-stdout-to ${@}
(run ${bin:jbuilder} install --help=groff)))))
(rule
((targets (jbuilder-installed-libraries.1))
(action (with-stdout-to ${@}
(run ${bin:jbuilder} installed-libraries --help=groff)))))
(rule
((targets (jbuilder-runtest.1))
(action (with-stdout-to ${@}
(run ${bin:jbuilder} runtest --help=groff)))))
(rule
((targets (jbuilder-uninstall.1))
(action (with-stdout-to ${@}
(run ${bin:jbuilder} uninstall --help=groff)))))
;; (*$*)
(:foreach :cmd (:commands)
(rule
((targets ((:man-file (:cmd))))
(action (with-stdout-to ${@}
(run ${bin:jbuilder} (:cmd) --help=groff))))))
(install
((section man)
(files (
;; (*$List.iter cmds ~f:(fun (suf, _) -> printf "\n jbuilder%s.1" suf); printf "\n;; "*)
jbuilder.1
jbuilder-build.1
jbuilder-build-package.1
jbuilder-external-lib-deps.1
jbuilder-install.1
jbuilder-installed-libraries.1
jbuilder-runtest.1
jbuilder-uninstall.1
;; (*$*)
(:foreach :cmd (:commands) (:man-file (:cmd)))
))))
(alias

11
src/gen_rules.ml
View File

@ -1783,16 +1783,7 @@ let gen ~contexts ?(filter_out_optional_stanzas_with_missing_deps=true) conf =
let alias_store = Alias.Store.create () in
let rules =
List.concat_map contexts ~f:(fun context ->
let stanzas =
List.map jbuilds ~f:(fun { Jbuild_load.Jbuild. path
; version
; sexps
; visible_packages
} ->
(path,
List.filter_map sexps ~f:(Stanza.select version)
|> Stanza.resolve_packages ~dir:path ~visible_packages))
in
let stanzas = List.map jbuilds ~f:(Jbuild_load.Jbuild.eval ~context) in
let module M =
Gen(struct
let context = context

53
src/jbuild_load.ml
View File

@ -3,11 +3,24 @@ open Jbuild_types
module Jbuild = struct
type t =
{ path : Path.t
; version : Jbuild_types.Jbuilder_version.t
; sexps : Sexp.Ast.t list
; visible_packages : Package.t String_map.t
}
| Constant of Path.t * Stanza.t list
| With_macros of
{ path : Path.t
; version : Jbuilder_version.t
; sexps : Sexp.Ast.t list
; visible_packages : Package.t String_map.t
}
let eval jbuild ~context =
match jbuild with
| Constant (path, stanzas) -> (path, stanzas)
| With_macros { path
; version
; sexps
; visible_packages
} ->
let sexps = Jbuild_meta_lang.expand ~context sexps in
(path, Stanzas.parse sexps ~dir:path ~visible_packages ~version)
end
type conf =
@ -21,7 +34,7 @@ let load ~dir ~visible_packages ~version =
let sexps = Sexp_load.many (Path.relative dir "jbuild" |> Path.to_string) in
let versions, sexps =
List.partition_map sexps ~f:(function
| List (loc, [Atom (_, ("jbuilder_version" | "Jbuilder_version")); ver]) ->
| List (loc, [Atom (_, "jbuilder_version"); ver]) ->
Inl (Jbuilder_version.t ver, loc)
| sexp -> Inr sexp)
in
@ -32,12 +45,24 @@ let load ~dir ~visible_packages ~version =
| _ :: (_, loc) :: _ ->
Loc.fail loc "jbuilder_version specified too many times"
in
{ Jbuild.
path = dir
; version
; sexps
; visible_packages
}
let use_meta_lang, sexps =
List.partition_map sexps ~f:(function
| List (_, [Atom (_, "use_meta_lang")]) -> Inl ()
| sexp -> Inr sexp)
in
let jbuild =
match use_meta_lang with
| [] ->
Jbuild.Constant (dir, Stanzas.parse sexps ~dir ~visible_packages ~version)
| _ ->
With_macros
{ path = dir
; version
; sexps
; visible_packages
}
in
(version, jbuild)
let load () =
let ftree = File_tree.load Path.root in
@ -90,8 +115,8 @@ let load () =
in
let version, jbuilds =
if String_set.mem "jbuild" files then
let jbuild = load ~dir:path ~visible_packages ~version in
(jbuild.version, jbuild :: jbuilds)
let version, jbuild = load ~dir:path ~visible_packages ~version in
(version, jbuild :: jbuilds)
else
(version, jbuilds)
in

9
src/jbuild_load.mli
View File

@ -1,12 +1,9 @@
open Import
module Jbuild : sig
type t =
{ path : Path.t
; version : Jbuild_types.Jbuilder_version.t
; sexps : Sexp.Ast.t list
; visible_packages : Package.t String_map.t
}
type t
val eval : t -> context:Context.t -> Path.t * Jbuild_types.Stanzas.t
end
type conf =

191
src/jbuild_meta_lang.ml Normal file
View File

@ -0,0 +1,191 @@
open Import
open Sexp.Of_sexp
module To = Sexp.To_sexp
module Prim = struct
module Spec = struct
[@@@warning "-37"]
type ('a, 'b) t =
| Ret : ('b -> Sexp.t) -> ('b, 'b) t
| Rest : (Sexp.Ast.t -> 'a) * ('b -> Sexp.t) -> ('a list -> 'b, 'b) t
| Abs : (Sexp.Ast.t -> 'a) * ('b, 'c) t -> ('a -> 'b, 'c) t
let ( @> ) a b = Abs (a, b)
let rec apply
: type a b. (a, b) t -> loc:Loc.t -> Sexp.Ast.t list -> a -> Sexp.Ast.t
= fun t ~loc l f ->
match t, l with
| Ret conv, [] -> Sexp.add_loc (conv f) ~loc
| Ret _, _ :: _ -> Loc.fail loc "too many arguments"
| Rest (conv, ret_conv), l ->
Sexp.add_loc (ret_conv (f (List.map l ~f:conv))) ~loc
| Abs _, [] -> Loc.fail loc "not enough arguments"
| Abs (conv, t), x :: l ->
apply t ~loc l (f (conv x))
end
type ('a, 'b) unpacked =
{ spec : ('a, 'b) Spec.t
; exec : 'a
}
type t = T : (_, _) unpacked -> t
let make spec exec = T { spec; exec }
let exec (T { spec; exec }) ~loc args =
Spec.apply spec ~loc args exec
end
type env =
{ context : Context.t
; macros : macro String_map.t
}
and macro =
| Value of Sexp.Ast.t list
| Closure of
{ env : env
; pattern : Sexp.Ast.t
; form : Sexp.Ast.t list
}
| Prim of Prim.t
let prims =
let open Prim.Spec in
let mk name spec exec = (name, Prim (Prim.make spec exec)) in
let cmp name f = mk name (string @> string @> Ret To.bool) f in
(* CR-someday jdimino: implement proper version comparison *)
[ cmp ":ver<" (<)
; cmp ":ver<=" (<=)
; cmp ":ver=" (=)
; cmp ":ver>=" (>=)
; cmp ":ver>" (>)
; mk ":concat" (string @> list string @> Ret To.string)
(fun sep l -> String.concat ~sep l)
] |> String_map.of_alist_exn
let make_env context =
{ context; macros = prims }
let bind env var macro =
{ env with macros = String_map.add env.macros ~key:var ~data:macro }
let rec match_pattern env ~pattern ~value =
match pattern, value with
| Atom (_, var), _ when String.is_prefix var ~prefix:":" ->
bind env var (Value [value])
| Atom (_, a), Atom (_, b) when a = b -> env
| List (_, a), List (_, b) when List.length a = List.length b ->
List.fold_left2 a b ~init:env ~f:(fun env pattern value ->
match_pattern env ~pattern ~value)
| _ ->
Loc.fail (Sexp.Ast.loc pattern)
"Failed to match value against pattern:\n\
- pattern: %s\n\
- value: %s"
(Sexp.Ast.to_string pattern)
(Sexp.Ast.to_string value)
let unexpected sexp values ~expected =
Loc.fail (Sexp.Ast.loc sexp)
"%s expected here, got:\n\
\ %s"
expected
(String.concat ~sep:", "
(List.map values ~f:Sexp.Ast.to_string))
let rec eval env t =
match t with
| Atom _ -> (env, [t])
| List (_, Atom (_, ":quote") :: args) -> (env, args)
| List (loc, Atom (_, ":if") :: args) -> begin
let cond, then_, else_ =
match args with
| [cond; then_] ->
let loc = Sexp.Ast.loc then_ in
(cond, then_, List ({ loc with start = loc.stop }, []))
| [cond; then_; else_] ->
(cond, then_, else_)
| _ ->
Loc.fail loc "invalid (:if ...) form"
in
match eval_bool env cond with
| true -> eval env else_
| false -> eval env then_
end
| List (loc, Atom (_, ":foreach") :: args) -> begin
match args with
| pattern :: vals :: form -> begin
let vals = eval_list env vals in
(env,
List.concat_map vals ~f:(fun value ->
let env = match_pattern env ~pattern ~value in
eval_seq env form))
end
| _ ->
Loc.fail loc "invalid (:foreach ...) form"
end
| List (loc, Atom (_, ":let") :: args) -> begin
match args with
| [pattern; value] ->
let value = eval_one env value in
(match_pattern env ~pattern ~value, [])
| _ ->
Loc.fail loc "invalid (:let ...) form"
end
| List (loc, Atom (_, ":let-macro") :: args) -> begin
match args with
| List (_, Atom (_, s) :: _) as pattern :: form when s <> "" && s.[0] = ':' ->
(bind env s (Closure { env; pattern; form }),
[])
| _ ->
Loc.fail loc "invalid (:let-macro ...) form"
end
| List (loc, (Atom (loc_s, s) :: args)) when s <> "" && s.[0] = ':' -> begin
match String_map.find s env.macros with
| None -> Loc.fail loc_s "Unknown macro %S" s
| Some (Value x) -> (env, x)
| Some (Closure { env = closure_env; pattern; form }) ->
let args = eval_seq env args in
let t = List (loc, Atom (loc_s, s) :: args) in
(env,
let env = match_pattern closure_env ~pattern ~value:t in
eval_seq env form)
| Some (Prim prim) ->
let args = eval_seq env args in
(env,
[Prim.exec prim args ~loc])
end
| List (loc, l) ->
(env, [List (loc, eval_seq env l)])
and eval_seq env l =
match l with
| [] -> []
| sexp :: rest ->
let env, res = eval env sexp in
res @ eval_seq env rest
and eval_one env sexp =
match snd (eval env sexp) with
| [sexp] -> sexp
| l -> unexpected sexp l ~expected:"single value"
and eval_list env sexp =
match eval_one env sexp with
| List (_, l) -> l
| l -> unexpected sexp [l] ~expected:"list"
and eval_bool env sexp : bool =
match eval_one env sexp with
| Atom (_, "true" ) -> true
| Atom (_, "false") -> false
| l -> unexpected sexp [l] ~expected:"true or false"
let expand sexps ~context =
let env = make_env context in
eval_seq env sexps

5
src/jbuild_meta_lang.mli Normal file
View File

@ -0,0 +1,5 @@
(** Meta Jbuild language *)
open! Import
val expand : Sexp.Ast.t list -> context:Context.t -> Sexp.Ast.t list

11
src/jbuild_types.ml
View File

@ -789,6 +789,7 @@ module Stanza = struct
; cstr' "alias" [Alias_conf.v1] (fun x -> Alias x)
(* Just for validation and error messages *)
; cstr "jbuilder_version" [Jbuilder_version.t] (fun _ -> None)
; cstr "use_meta_lang" [] None
]
let vjs =
@ -823,6 +824,10 @@ module Stanza = struct
| None -> acc
| Some n -> String_set.add n acc)
| _ -> acc))
end
module Stanzas = struct
type t = Stanza.t list
let resolve_packages ts ~dir ~(visible_packages : Package.t String_map.t) =
let error fmt =
@ -856,7 +861,7 @@ module Stanza = struct
You need to add a (package ...) field in your (install ...) stanzas"
(known_packages ())
in
List.map ts ~f:(fun stanza ->
List.map ts ~f:(fun (stanza : Stanza.t) ->
match stanza with
| Library { public_name = Some name; _ }
| Executables { object_public_name = Some name; _ } ->
@ -868,4 +873,8 @@ module Stanza = struct
| Install ({ package = None; _ } as install) ->
Install { install with package = Some (default ()) }
| _ -> stanza)
let parse sexps ~dir ~visible_packages ~version =
List.filter_map sexps ~f:(Stanza.select version)
|> resolve_packages ~dir ~visible_packages
end

22
src/main.ml
View File

@ -44,7 +44,7 @@ let setup ?filter_out_optional_stanzas_with_missing_deps ?workspace () =
let external_lib_deps ?log ~packages () =
Future.Scheduler.go ?log
(setup () ~filter_out_optional_stanzas_with_missing_deps:false
>>| fun ({ build_system = bs; jbuilds; _ } as setup) ->
>>| fun ({ build_system = bs; jbuilds; contexts; _ } as setup) ->
let install_files =
List.map packages ~f:(fun pkg ->
match package_install_file setup pkg with
@ -54,17 +54,15 @@ let external_lib_deps ?log ~packages () =
Path.Map.map
(Build_system.all_lib_deps bs install_files)
~f:(fun deps ->
let stanzas =
List.map jbuilds ~f:(fun { Jbuild_load.Jbuild. path
; version
; sexps
; _
} ->
(path,
List.filter_map sexps ~f:(Jbuild_types.Stanza.select version)))
in
let internals = Jbuild_types.Stanza.lib_names stanzas in
String_map.filter deps ~f:(fun name _ -> not (String_set.mem name internals))))
let context =
match List.find contexts ~f:(fun c -> c.name = "default") with
| None -> die "You need to set a default context to use external-lib-deps"
| Some context -> context
in
let stanzas = List.map jbuilds ~f:(Jbuild_load.Jbuild.eval ~context) in
let internals = Jbuild_types.Stanza.lib_names stanzas in
String_map.filter deps ~f:(fun name _ ->
not (String_set.mem name internals))))
let report_error ?(map_fname=fun x->x) ppf exn ~backtrace =
match exn with

76
src/sexp.ml
View File

@ -4,15 +4,7 @@ type t =
| Atom of string
| List of t list
module Ast = struct
type t =
| Atom of Loc.t * string
| List of Loc.t * t list
let loc = function
| Atom (loc, _) -> loc
| List (loc, _) -> loc
end
type sexp = t
let must_escape str =
let len = String.length str in
@ -38,6 +30,28 @@ let code_error message vars =
:: List.map vars ~f:(fun (name, value) ->
List [Atom name; value]))))
module Ast = struct
type t =
| Atom of Loc.t * string
| List of Loc.t * t list
let loc = function
| Atom (loc, _) -> loc
| List (loc, _) -> loc
let rec remove_locs : t -> sexp = function
| Atom (_, s) -> Atom s
| List (_, l) -> List (List.map l ~f:remove_locs)
let to_string t = to_string (remove_locs t)
end
let rec add_loc t ~loc : Ast.t =
match t with
| Atom s -> Atom (loc, s)
| List l -> List (loc, List.map l ~f:(add_loc ~loc))
module type Combinators = sig
type 'a t
val unit : unit t
@ -122,17 +136,19 @@ module Of_sexp = struct
; entry : Ast.t
}
module Name_map = Map.Make(struct
type t = string
let compare a b =
let alen = String.length a and blen = String.length b in
if alen < blen then
-1
else if alen > blen then
1
else
String.compare a b
end)
module Name = struct
type t = string
let compare a b =
let alen = String.length a and blen = String.length b in
if alen < blen then
-1
else if alen > blen then
1
else
String.compare a b
end
module Name_map = Map.Make(Name)
type record_parser_state =
{ loc : Loc.t
@ -272,25 +288,7 @@ module Of_sexp = struct
let cstr name args make =
Constructor_spec.T { name; args; make; rest = No_rest }
let equal_cstr_name a b =
let alen = String.length a and blen = String.length b in
if alen <> blen then
false
else if alen = 0 then
true
else
let is_cap s =
match s.[0] with
| 'A'..'Z' -> true
| _ -> false
in
match is_cap a, is_cap b with
| true, true | false, false ->
a = b
| true, false ->
a = String.capitalize_ascii b
| false, true ->
String.capitalize_ascii a = b
let equal_cstr_name a b = Name.compare a b = 0
let find_cstr cstrs sexp name =
match

8
src/sexp.mli
View File

@ -5,12 +5,18 @@ type t =
| List of t list
module Ast : sig
type sexp = t
type t =
| Atom of Loc.t * string
| List of Loc.t * t list
val loc : t -> Loc.t
end
val remove_locs : t -> sexp
val to_string : t -> string
end with type sexp := t
val add_loc : t -> loc:Loc.t -> Ast.t
val code_error : string -> (string * t) list -> _