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

Merge pull request #1170 from rgrinberg/invert-sexp-stdune 

Invert sexp stdune
This commit is contained in:
Rudi Grinberg 2018-08-23 16:37:13 +03:00 committed by GitHub
parent df2ee53a8b fa33c061aa
commit 64755f8826
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
231 changed files with 2803 additions and 2517 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
bin/main.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open Dune
open Import
open Cmdliner
@ -985,11 +986,11 @@ let rules =
in
Build_system.build_rules setup.build_system ~request ~recursive >>= fun rules ->
let sexp_of_action action =
Action.for_shell action |> Action.For_shell.sexp_of_t
Action.for_shell action |> Action.For_shell.dgen
in
let print oc =
let ppf = Format.formatter_of_out_channel oc in
Sexp.prepare_formatter ppf;
Dsexp.prepare_formatter ppf;
Format.pp_open_vbox ppf 0;
if makefile_syntax then begin
List.iter rules ~f:(fun (rule : Build_system.Rule.t) ->
@ -1000,25 +1001,25 @@ let rules =
(fun ppf ->
Path.Set.iter rule.deps ~f:(fun dep ->
Format.fprintf ppf "@ %s" (Path.to_string dep)))
Sexp.pp_split_strings (sexp_of_action rule.action))
Dsexp.pp_split_strings (sexp_of_action rule.action))
end else begin
List.iter rules ~f:(fun (rule : Build_system.Rule.t) ->
let sexp =
let paths ps =
Sexp.To_sexp.list Path.sexp_of_t (Path.Set.to_list ps)
Dsexp.To_sexp.list Path_dsexp.dgen (Path.Set.to_list ps)
in
Sexp.To_sexp.record (
Dsexp.To_sexp.record (
List.concat
[ [ "deps" , paths rule.deps
; "targets", paths rule.targets ]
; (match rule.context with
| None -> []
| Some c -> ["context",
Sexp.atom_or_quoted_string c.name])
Dsexp.atom_or_quoted_string c.name])
; [ "action" , sexp_of_action rule.action ]
])
in
Format.fprintf ppf "%a@," Sexp.pp_split_strings sexp)
Format.fprintf ppf "%a@," Dsexp.pp_split_strings sexp)
end;
Format.pp_print_flush ppf ();
Fiber.return ()
@ -1472,7 +1473,7 @@ let printenv =
Build_system.do_build setup.build_system ~request
>>| fun l ->
let pp ppf = Format.fprintf ppf "@[<v1>(@,@[<v>%a@]@]@,)"
(Format.pp_print_list (Sexp.pp Dune)) in
(Format.pp_print_list (Dsexp.pp Dune)) in
match l with
| [(_, env)] ->
Format.printf "%a@." pp env

2
bootstrap.ml
View File

@ -36,7 +36,7 @@ let dirs =
; "src/xdg" , Some "Xdg"
; "src/ocaml-config" , Some "Ocaml_config"
; "vendor/boot" , None
; "src/usexp" , Some "Usexp"
; "src/dsexp" , Some "Dsexp"
; "src" , None
]

120
src/action.ml
View File

@ -1,5 +1,6 @@
open! Stdune
open Import
open Sexp.Of_sexp
open Dsexp.Of_sexp
let ignore_loc k ~loc:_ = k
@ -15,9 +16,9 @@ end
module Diff_mode = Action_intf.Diff_mode
module Make_ast
(Program : Sexp.Sexpable)
(Path : Sexp.Sexpable)
(String : Sexp.Sexpable)
(Program : Dsexp.Sexpable)
(Path : Dsexp.Sexpable)
(String : Dsexp.Sexpable)
(Ast : Action_intf.Ast
with type program := Program.t
with type path := Path.t
@ -25,13 +26,13 @@ module Make_ast
struct
include Ast
let t =
let path = Path.t and string = String.t in
Sexp.Of_sexp.fix (fun t ->
let dparse =
let path = Path.dparse and string = String.dparse in
Dsexp.Of_sexp.fix (fun t ->
sum
[ "run",
(let%map prog = Program.t
and args = repeat string
(let%map prog = Program.dparse
and args = repeat String.dparse
in
Run (prog, args))
; "chdir",
@ -129,55 +130,53 @@ struct
Diff { optional = false; file1; file2; mode = Binary })
])
let rec sexp_of_t : _ -> Sexp.t =
let path = Path.sexp_of_t and string = String.sexp_of_t in
let rec dgen =
let open Dsexp in
let program = Program.dgen in
let string = String.dgen in
let path = Path.dgen in
function
| Run (a, xs) -> List (Sexp.unsafe_atom_of_string "run"
:: Program.sexp_of_t a :: List.map xs ~f:string)
| Chdir (a, r) -> List [Sexp.unsafe_atom_of_string "chdir" ;
path a ; sexp_of_t r]
| Setenv (k, v, r) -> List [Sexp.unsafe_atom_of_string "setenv" ;
string k ; string v ; sexp_of_t r]
| Run (a, xs) ->
List (atom "run" :: program a :: List.map xs ~f:string)
| Chdir (a, r) -> List [atom "chdir" ; path a ; dgen r]
| Setenv (k, v, r) -> List [atom "setenv" ; string k ; string v ; dgen r]
| Redirect (outputs, fn, r) ->
List [ Sexp.atom (sprintf "with-%s-to" (Outputs.to_string outputs))
List [ atom (sprintf "with-%s-to" (Outputs.to_string outputs))
; path fn
; sexp_of_t r
; dgen r
]
| Ignore (outputs, r) ->
List [ Sexp.atom (sprintf "ignore-%s" (Outputs.to_string outputs))
; sexp_of_t r
List [ atom (sprintf "ignore-%s" (Outputs.to_string outputs))
; dgen r
]
| Progn l -> List (Sexp.unsafe_atom_of_string "progn"
:: List.map l ~f:sexp_of_t)
| Progn l -> List (atom "progn" :: List.map l ~f:dgen)
| Echo xs ->
List (Sexp.unsafe_atom_of_string "echo" :: List.map xs ~f:string)
| Cat x -> List [Sexp.unsafe_atom_of_string "cat"; path x]
List (atom "echo" :: List.map xs ~f:string)
| Cat x -> List [atom "cat"; path x]
| Copy (x, y) ->
List [Sexp.unsafe_atom_of_string "copy"; path x; path y]
List [atom "copy"; path x; path y]
| Symlink (x, y) ->
List [Sexp.unsafe_atom_of_string "symlink"; path x; path y]
List [atom "symlink"; path x; path y]
| Copy_and_add_line_directive (x, y) ->
List [Sexp.unsafe_atom_of_string "copy#"; path x; path y]
| System x -> List [Sexp.unsafe_atom_of_string "system"; string x]
| Bash x -> List [Sexp.unsafe_atom_of_string "bash"; string x]
| Write_file (x, y) -> List [Sexp.unsafe_atom_of_string "write-file";
path x; string y]
| Rename (x, y) -> List [Sexp.unsafe_atom_of_string "rename";
path x; path y]
| Remove_tree x -> List [Sexp.unsafe_atom_of_string "remove-tree"; path x]
| Mkdir x -> List [Sexp.unsafe_atom_of_string "mkdir"; path x]
| Digest_files paths -> List [Sexp.unsafe_atom_of_string "digest-files";
List [atom "copy#"; path x; path y]
| System x -> List [atom "system"; string x]
| Bash x -> List [atom "bash"; string x]
| Write_file (x, y) -> List [atom "write-file"; path x; string y]
| Rename (x, y) -> List [atom "rename"; path x; path y]
| Remove_tree x -> List [atom "remove-tree"; path x]
| Mkdir x -> List [atom "mkdir"; path x]
| Digest_files paths -> List [atom "digest-files";
List (List.map paths ~f:path)]
| Diff { optional; file1; file2; mode = Binary} ->
assert (not optional);
List [Sexp.unsafe_atom_of_string "cmp"; path file1; path file2]
List [atom "cmp"; path file1; path file2]
| Diff { optional = false; file1; file2; mode = _ } ->
List [Sexp.unsafe_atom_of_string "diff"; path file1; path file2]
List [atom "diff"; path file1; path file2]
| Diff { optional = true; file1; file2; mode = _ } ->
List [Sexp.unsafe_atom_of_string "diff?"; path file1; path file2]
List [atom "diff?"; path file1; path file2]
| Merge_files_into (srcs, extras, target) ->
List
[ Sexp.unsafe_atom_of_string "merge-files-into"
[ atom "merge-files-into"
; List (List.map ~f:path srcs)
; List (List.map ~f:string extras)
; path target
@ -268,11 +267,12 @@ module Prog = struct
type t = (Path.t, Not_found.t) result
let t : t Sexp.Of_sexp.t = Sexp.Of_sexp.map Path.t ~f:Result.ok
let dparse : t Dsexp.Of_sexp.t =
Dsexp.Of_sexp.map Path_dsexp.dparse ~f:Result.ok
let sexp_of_t = function
| Ok s -> Path.sexp_of_t s
| Error (e : Not_found.t) -> Sexp.To_sexp.string e.program
let dgen = function
| Ok s -> Path_dsexp.dgen s
| Error (e : Not_found.t) -> Dsexp.To_sexp.string e.program
end
module type Ast = Action_intf.Ast
@ -283,13 +283,13 @@ module rec Ast : Ast = Ast
module String_with_sexp = struct
type t = string
let t = Sexp.Of_sexp.string
let sexp_of_t = Sexp.To_sexp.string
let dparse = Dsexp.Of_sexp.string
let dgen = Dsexp.To_sexp.string
end
include Make_ast
(Prog)
(Path)
(Path_dsexp)
(String_with_sexp)
(Ast)
@ -372,9 +372,19 @@ module Unexpanded = struct
include Make_ast(String_with_vars)(String_with_vars)(String_with_vars)(Uast)
let t =
module Mapper = Make_mapper(Uast)(Uast)
let remove_locs =
let no_loc_template = String_with_vars.make_text Loc.none "" in
fun t ->
Mapper.map t ~dir:no_loc_template
~f_program:(fun ~dir:_ -> String_with_vars.remove_locs)
~f_path:(fun ~dir:_ -> String_with_vars.remove_locs)
~f_string:(fun ~dir:_ -> String_with_vars.remove_locs)
let dparse =
if_list
~then_:t
~then_:dparse
~else_:
(loc >>| fun loc ->
of_sexp_errorf
@ -383,11 +393,11 @@ module Unexpanded = struct
let check_mkdir loc path =
if not (Path.is_managed path) then
Loc.fail loc
Errors.fail loc
"(mkdir ...) is not supported for paths outside of the workspace:\n\
\ %a\n"
(Sexp.pp Dune)
(List [Sexp.unsafe_atom_of_string "mkdir"; Path.sexp_of_t path])
(Dsexp.pp Dune)
(List [Dsexp.unsafe_atom_of_string "mkdir"; Path_dsexp.dgen path])
module Partial = struct
module Program = Unresolved.Program
@ -538,7 +548,7 @@ module Unexpanded = struct
Chdir (res, partial_expand t ~dir ~map_exe ~f)
| Right fn ->
let loc = String_with_vars.loc fn in
Loc.fail loc
Errors.fail loc
"This directory cannot be evaluated statically.\n\
This is not allowed by dune"
end
@ -733,7 +743,7 @@ module Infer = struct
match fn with
| Left fn -> { acc with targets = Path.Set.add acc.targets fn }
| Right sw ->
Loc.fail (String_with_vars.loc sw)
Errors.fail (String_with_vars.loc sw)
"Cannot determine this target statically."
let ( +< ) acc fn =
match fn with

9
src/action.mli
View File

@ -1,3 +1,4 @@
open! Stdune
open! Import
module Outputs : module type of struct include Action_intf.Outputs end
@ -31,7 +32,7 @@ include Action_intf.Helpers
with type string := string
with type t := t
val t : t Sexp.Of_sexp.t
val dparse : t Dsexp.Of_sexp.t
module For_shell : sig
include Action_intf.Ast
@ -39,7 +40,7 @@ module For_shell : sig
with type path := string
with type string := string
val sexp_of_t : t Sexp.To_sexp.t
val dgen : t Dsexp.To_sexp.t
end
(** Convert the action to a format suitable for printing *)
@ -72,7 +73,7 @@ module Unexpanded : sig
with type path := String_with_vars.t
with type string := String_with_vars.t
include Sexp.Sexpable with type t := t
include Dsexp.Sexpable with type t := t
module Partial : sig
include Action_intf.Ast
@ -94,6 +95,8 @@ module Unexpanded : sig
-> map_exe:(Path.t -> Path.t)
-> f:(Value.t list option String_with_vars.expander)
-> Partial.t
val remove_locs : t -> t
end
(** Infer dependencies and targets.

1
src/action_exec.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open Import
open Fiber.O

2
src/action_exec.mli
View File

@ -1,4 +1,4 @@
open Stdune
open! Stdune
val exec
: targets:Path.Set.t

2
src/action_intf.ml
View File

@ -1,4 +1,4 @@
open Stdune
open! Stdune
module Outputs = struct
type t =

1
src/arg_spec.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open Import
type 'a t =

1
src/arg_spec.mli
View File

@ -1,3 +1,4 @@
open! Stdune
(** Command line arguments specification *)
(** This module implements a small DSL to specify the command line

1
src/artifacts.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open Import
open Dune_file

1
src/artifacts.mli
View File

@ -1,3 +1,4 @@
open! Stdune
open! Import
type t

2
src/bin.ml
View File

@ -1,4 +1,4 @@
open Import
open! Stdune
let path_sep =
if Sys.win32 then

2
src/bin.mli
View File

@ -1,6 +1,6 @@
(** OCaml binaries *)
open Stdune
open! Stdune
(** Character used to separate entries in [PATH] and similar
environment variables *)

10
src/binary_kind.ml
View File

@ -1,12 +1,12 @@
open Stdune
open! Stdune
type t =
| Exe
| Object
| Shared_object
let t =
let open Sexp.Of_sexp in
let dparse =
let open Dsexp.Of_sexp in
enum
[ "exe" , Exe
; "object" , Object
@ -21,7 +21,7 @@ let to_string = function
let pp fmt t =
Format.pp_print_string fmt (to_string t)
let sexp_of_t t =
Sexp.unsafe_atom_of_string (to_string t)
let dgen t =
Dsexp.unsafe_atom_of_string (to_string t)
let all = [Exe; Object; Shared_object]

6
src/binary_kind.mli
View File

@ -1,15 +1,13 @@
(** Linking modes for binaries *)
open Stdune
open! Stdune
type t =
| Exe
| Object
| Shared_object
val t : t Sexp.Of_sexp.t
val sexp_of_t : t Sexp.To_sexp.t
include Dsexp.Sexpable with type t := t
val all : t list

2
src/blang.ml
View File

@ -35,7 +35,7 @@ let rec eval_bool t ~dir ~(f : 'a expander) =
begin match f.f ~mode:Single a with
| _, String "true" -> true
| _, String "false" -> false
| loc, _ -> Loc.fail loc "This value must be either true or false"
| loc, _ -> Errors.fail loc "This value must be either true or false"
end
| And xs -> List.for_all ~f:(eval_bool ~f ~dir) xs
| Or xs -> List.exists ~f:(eval_bool ~f ~dir) xs

2
src/blang.mli
View File

@ -1,4 +1,4 @@
open Stdune
open! Stdune
module Op : sig
type t =

7
src/build.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open Import
module Vspec = struct
@ -59,8 +60,8 @@ module Repr = struct
| G_evaluated l -> l
| G_unevaluated (loc, path, _) ->
Exn.code_error "Build.get_glob_result_exn: got unevaluated"
[ "loc", Loc.sexp_of_t loc
; "path", Path.sexp_of_t path ]
[ "loc", Loc.to_sexp loc
; "path", Path.to_sexp path ]
end
include Repr
let repr t = t
@ -130,7 +131,7 @@ let strings p =
let read_sexp p syntax =
contents p
>>^ fun s ->
Usexp.parse_string s
Dsexp.parse_string s
~lexer:(File_tree.Dune_file.Kind.lexer syntax)
~fname:(Path.to_string p) ~mode:Single

3
src/build.mli
View File

@ -1,5 +1,6 @@
(** The build arrow *)
open! Stdune
open! Import
type ('a, 'b) t
@ -95,7 +96,7 @@ val lines_of : Path.t -> ('a, string list) t
val strings : Path.t -> ('a, string list) t
(** Load an S-expression from a file *)
val read_sexp : Path.t -> Usexp.syntax -> (unit, Sexp.Ast.t) t
val read_sexp : Path.t -> Dsexp.syntax -> (unit, Dsexp.Ast.t) t
(** Evaluates to [true] if the file is present on the file system or is the target of a
rule. *)

13
src/build_interpret.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open Import
open Build.Repr
@ -82,11 +83,11 @@ let static_deps t ~all_targets ~file_tree =
if Path.Set.is_empty result then begin
match inspect_path file_tree dir with
| None ->
Loc.warn loc "Directory %s doesn't exist."
Errors.warn loc "Directory %s doesn't exist."
(Path.to_string_maybe_quoted
(Path.drop_optional_build_context dir))
| Some Reg ->
Loc.warn loc "%s is not a directory."
Errors.warn loc "%s is not a directory."
(Path.to_string_maybe_quoted
(Path.drop_optional_build_context dir))
| Some Dir ->
@ -187,7 +188,7 @@ let targets =
match loop a [], loop b [] with
| [], [] -> acc
| a, b ->
let targets x = Path.Set.sexp_of_t (Target.paths x) in
let targets x = Path.Set.to_sexp (Target.paths x) in
Exn.code_error "Build_interpret.targets: cannot have targets \
under a [if_file_exists]"
[ "targets-a", targets a
@ -219,7 +220,7 @@ module Rule = struct
match targets with
| [] ->
begin match loc with
| Some loc -> Loc.fail loc "Rule has no targets specified"
| Some loc -> Errors.fail loc "Rule has no targets specified"
| None -> Exn.code_error "Build_interpret.Rule.make: no targets" []
end
| x :: l ->
@ -230,11 +231,11 @@ module Rule = struct
match loc with
| None ->
Exn.code_error "rule has targets in different directories"
[ "targets", Sexp.To_sexp.list Path.sexp_of_t
[ "targets", Sexp.To_sexp.list Path.to_sexp
(List.map targets ~f:Target.path)
]
| Some loc ->
Loc.fail loc
Errors.fail loc
"Rule has targets in different directories.\nTargets:\n%s"
(String.concat ~sep:"\n"
(List.map targets ~f:(fun t ->

1
src/build_interpret.mli
View File

@ -1,3 +1,4 @@
open! Stdune
open! Import
module Target : sig

31
src/build_system.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open Import
open Fiber.O
@ -233,13 +234,13 @@ module Alias0 = struct
if not (Path.is_in_build_dir dir) || String.contains name '/' then
Exn.code_error "Alias0.make: Invalid alias"
[ "name", Sexp.To_sexp.string name
; "dir", Path.sexp_of_t dir
; "dir", Path.to_sexp dir
];
{ dir; name }
let of_user_written_path ~loc path =
if not (Path.is_in_build_dir path) then
Loc.fail loc "Invalid alias!\n\
Errors.fail loc "Invalid alias!\n\
Tried to reference path outside build dir: %S"
(Path.to_string_maybe_quoted path);
{ dir = Path.parent_exn path
@ -304,13 +305,13 @@ module Alias0 = struct
match File_tree.find_dir file_tree src_dir with
| None ->
Build.fail { fail = fun () ->
Loc.fail loc "Don't know about directory %s!"
Errors.fail loc "Don't know about directory %s!"
(Path.to_string_maybe_quoted src_dir) }
| Some dir ->
dep_rec_internal ~name:t.name ~dir ~ctx_dir
>>^ fun is_empty ->
if is_empty && not (is_standard t.name) then
Loc.fail loc
Errors.fail loc
"This alias is empty.\n\
Alias %S is not defined in %s or any of its descendants."
t.name (Path.to_string_maybe_quoted src_dir)
@ -461,7 +462,7 @@ let entry_point t ~f =
| stack ->
Exn.code_error
"Build_system.entry_point: called inside the rule generator callback"
["stack", Sexp.To_sexp.list Path.sexp_of_t stack]
["stack", Sexp.To_sexp.list Path.to_sexp stack]
);
f ()
@ -564,7 +565,7 @@ let add_spec t fn spec ~copy_source =
| Some (File_spec.T { rule; _ }) ->
match copy_source, rule.mode with
| true, (Standard | Not_a_rule_stanza) ->
Loc.warn (Internal_rule.loc rule ~dir:(Path.parent_exn fn)
Errors.warn (Internal_rule.loc rule ~dir:(Path.parent_exn fn)
~file_tree:t.file_tree)
"File %s is both generated by a rule and present in the source tree.\n\
As a result, the rule is currently ignored, however this will become an error \
@ -686,7 +687,7 @@ let remove_old_artifacts t ~dir ~subdirs_to_keep =
let no_rule_found =
let fail fn ~loc =
Loc.fail_opt loc "No rule found for %s" (Utils.describe_target fn)
Errors.fail_opt loc "No rule found for %s" (Utils.describe_target fn)
in
fun t ~loc fn ->
match Utils.analyse_target fn with
@ -1067,7 +1068,7 @@ and load_dir_step2_exn t ~dir ~collector ~lazy_generators =
let present_targets =
Path.Set.diff source_files_for_targtes absent_targets
in
Loc.fail
Errors.fail
(rule_loc
~file_tree:t.file_tree
~loc:rule.loc
@ -1275,13 +1276,13 @@ let update_universe t =
Utils.Cached_digest.remove universe_file;
let n =
if Path.exists universe_file then
Sexp.Of_sexp.(parse int) Univ_map.empty
(Io.Sexp.load ~mode:Single universe_file) + 1
Dsexp.Of_sexp.(parse int) Univ_map.empty
(Dsexp.Io.load ~mode:Single universe_file) + 1
else
0
in
make_local_dirs t (Path.Set.singleton Path.build_dir);
Io.write_file universe_file (Sexp.to_string ~syntax:Dune (Sexp.To_sexp.int n))
Io.write_file universe_file (Dsexp.to_string ~syntax:Dune (Dsexp.To_sexp.int n))
let do_build t ~request =
entry_point t ~f:(fun () ->
@ -1535,8 +1536,8 @@ let get_collector t ~dir =
"Build_system.get_collector called on external directory"
else
"Build_system.get_collector called on closed directory")
[ "dir", Path.sexp_of_t dir
; "load_dir_stack", Sexp.To_sexp.list Path.sexp_of_t t.load_dir_stack
[ "dir", Path.to_sexp dir
; "load_dir_stack", Sexp.To_sexp.list Path.to_sexp t.load_dir_stack
]
let add_rule t (rule : Build_interpret.Rule.t) =
@ -1557,7 +1558,7 @@ let prefix_rules t prefix ~f =
| [] -> ()
| targets ->
Exn.code_error "Build_system.prefix_rules' prefix contains targets"
["targets", Path.Set.sexp_of_t (Build_interpret.Target.paths targets)]
["targets", Path.Set.to_sexp (Build_interpret.Target.paths targets)]
end;
let prefix =
match t.prefix with
@ -1620,7 +1621,7 @@ module Alias = struct
let add_action build_system t ~context ~loc ?(locks=[]) ~stamp action =
let def = get_alias_def build_system t in
def.actions <- { stamp = Digest.string (Sexp.to_string ~syntax:Dune stamp)
def.actions <- { stamp = Digest.string (Marshal.to_string stamp [])
; action
; locks
; context

3
src/build_system.mli
View File

@ -1,5 +1,6 @@
(** Build rules *)
open! Stdune
open! Import
type t
@ -173,7 +174,7 @@ module Alias : sig
-> context:Context.t
-> loc:Loc.t option
-> ?locks:Path.t list
-> stamp:Sexp.t
-> stamp:_
-> (unit, Action.t) Build.t
-> unit
end with type build_system := t

1
src/colors.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open Import
type styles = Ansi_color.Style.t list

2
src/colors.mli
View File

@ -1,4 +1,4 @@
open Stdune
open! Stdune
val colorize : key:string -> string -> string

1
src/compilation_context.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open Import
module SC = Super_context

1
src/compilation_context.mli
View File

@ -1,5 +1,6 @@
(** High-level API for compiling OCaml files *)
open! Stdune
open Import
(** Represent a compilation context.

21
src/config.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open! Import
let local_install_dir =
@ -49,7 +50,7 @@ module Display = struct
; "quiet" , Quiet
]
let t = enum all
let dparse = enum all
end
module Concurrency = struct
@ -71,7 +72,7 @@ module Concurrency = struct
else
error
let t =
let dparse =
plain_string (fun ~loc s ->
match of_string s with
| Error m -> of_sexp_errorf loc "%s" m
@ -109,15 +110,15 @@ let default =
; concurrency = if inside_dune then Fixed 1 else Auto
}
let t =
let%map display = field "display" Display.t ~default:default.display
and concurrency = field "jobs" Concurrency.t ~default:default.concurrency
let dparse =
let%map display = field "display" Display.dparse ~default:default.display
and concurrency = field "jobs" Concurrency.dparse ~default:default.concurrency
in
{ display
; concurrency
}
let t = fields t
let dparse = fields dparse
let user_config_file =
Path.relative (Path.of_filename_relative_to_initial_cwd Xdg.config_dir)
@ -128,16 +129,16 @@ let () = Lang.register syntax ()
let load_config_file p =
match Which_program.t with
| Dune -> load p ~f:(fun _lang -> t)
| Dune -> load p ~f:(fun _lang -> dparse)
| Jbuilder ->
Io.with_lexbuf_from_file p ~f:(fun lb ->
match Dune_lexer.maybe_first_line lb with
| None ->
parse (enter t)
parse (enter dparse)
(Univ_map.singleton (Syntax.key syntax) (0, 0))
(Io.Sexp.load p ~mode:Many_as_one ~lexer:Sexp.Lexer.jbuild_token)
(Dsexp.Io.load p ~mode:Many_as_one ~lexer:Dsexp.Lexer.jbuild_token)
| Some first_line ->
parse_contents lb first_line ~f:(fun _lang -> t))
parse_contents lb first_line ~f:(fun _lang -> dparse))
let load_user_config_file () =
if Path.exists user_config_file then

4
src/config.mli
View File

@ -32,7 +32,7 @@ module Display : sig
| Verbose (** Display all commands fully *)
| Quiet (** Only display errors *)
val t : t Sexp.Of_sexp.t
val dparse : t Dsexp.Of_sexp.t
val all : (string * t) list
end
@ -58,7 +58,7 @@ include S with type 'a field = 'a
module Partial : S with type 'a field := 'a option
val t : t Sexp.Of_sexp.t
val dparse : t Dsexp.Of_sexp.t
val merge : t -> Partial.t -> t

2
src/configurator/dune
View File

@ -3,6 +3,6 @@
(library
(name configurator)
(public_name dune.configurator)
(libraries stdune ocaml_config)
(libraries stdune ocaml_config dsexp)
(flags (:standard -safe-string (:include flags/flags.sexp)))
(preprocess no_preprocessing))

6
src/configurator/v1.ml
View File

@ -1,4 +1,4 @@
open Stdune
open! Stdune
let sprintf = Printf.sprintf
let eprintf = Printf.eprintf
@ -75,8 +75,8 @@ module Flags = struct
let write_sexp fname s =
let path = Path.in_source fname in
let sexp = Usexp.List (List.map s ~f:(fun s -> Usexp.Quoted_string s)) in
Io.write_file path (Usexp.to_string sexp ~syntax:Dune)
let sexp = Dsexp.List (List.map s ~f:(fun s -> Dsexp.Quoted_string s)) in
Io.write_file path (Dsexp.to_string sexp ~syntax:Dune)
end
module Find_in_path = struct

25
src/context.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open Import
open Fiber.O
@ -10,8 +11,8 @@ module Kind = struct
end
type t = Default | Opam of Opam.t
let sexp_of_t : t -> Sexp.t = function
| Default -> Sexp.unsafe_atom_of_string "default"
let to_sexp : t -> Sexp.t = function
| Default -> Sexp.To_sexp.string "default"
| Opam o ->
Sexp.To_sexp.(record [ "root" , string o.root
; "switch", string o.switch
@ -85,12 +86,12 @@ type t =
; which_cache : (string, Path.t option) Hashtbl.t
}
let sexp_of_t t =
let to_sexp t =
let open Sexp.To_sexp in
let path = Path.sexp_of_t in
let path = Path.to_sexp in
record
[ "name", string t.name
; "kind", Kind.sexp_of_t t.kind
; "kind", Kind.to_sexp t.kind
; "profile", string t.profile
; "merlin", bool t.merlin
; "for_host", option string (Option.map t.for_host ~f:(fun t -> t.name))
@ -102,16 +103,16 @@ let sexp_of_t t =
; "ocamlopt", option path t.ocamlopt
; "ocamldep", path t.ocamldep
; "ocamlmklib", path t.ocamlmklib
; "env", Env.sexp_of_t (Env.diff t.env Env.initial)
; "env", Env.to_sexp (Env.diff t.env Env.initial)
; "findlib_path", list path (Findlib.path t.findlib)
; "arch_sixtyfour", bool t.arch_sixtyfour
; "natdynlink_supported",
bool (Dynlink_supported.By_the_os.get t.natdynlink_supported)
; "supports_shared_libraries",
bool (Dynlink_supported.By_the_os.get t.supports_shared_libraries)
; "opam_vars", string_hashtbl string t.opam_var_cache
; "ocaml_config", Ocaml_config.sexp_of_t t.ocaml_config
; "which", string_hashtbl (option path) t.which_cache
; "opam_vars", Hashtbl.to_sexp string string t.opam_var_cache
; "ocaml_config", Ocaml_config.to_sexp t.ocaml_config
; "which", Hashtbl.to_sexp string (option path) t.which_cache
]
let compare a b = compare a.name b.name
@ -269,7 +270,7 @@ let create ~(kind : Kind.t) ~path ~env ~env_nodes ~name ~merlin ~targets
%s"
(Path.to_string ocamlc) msg
| Error (Makefile_config file, msg) ->
Loc.fail (Loc.in_file (Path.to_string file)) "%s" msg
Errors.fail (Loc.in_file (Path.to_string file)) "%s" msg
in
Fiber.fork_and_join
findlib_path
@ -451,8 +452,8 @@ let create_for_opam ?root ~env ~env_nodes ~targets ~profile ~switch ~name
["config"; "env"; "--root"; root; "--switch"; switch; "--sexp"]
>>= fun s ->
let vars =
Usexp.parse_string ~fname:"<opam output>" ~mode:Single s
|> Sexp.Of_sexp.(parse (list (pair string string)) Univ_map.empty)
Dsexp.parse_string ~fname:"<opam output>" ~mode:Single s
|> Dsexp.Of_sexp.(parse (list (pair string string)) Univ_map.empty)
|> Env.Map.of_list_multi
|> Env.Map.mapi ~f:(fun var values ->
match List.rev values with

3
src/context.mli
View File

@ -18,6 +18,7 @@
it is obtained by looking in another context.
*)
open! Stdune
open! Import
module Kind : sig
@ -127,7 +128,7 @@ type t =
; which_cache : (string, Path.t option) Hashtbl.t
}
val sexp_of_t : t -> Sexp.t
val to_sexp : t -> Sexp.t
(** Compare the context names *)
val compare : t -> t -> Ordering.t

6
src/dep_path.ml
View File

@ -1,4 +1,4 @@
open Import
open! Stdune
module Entry = struct
type t =
@ -14,8 +14,8 @@ module Entry = struct
| Library (path, lib_name) ->
sprintf "library %S in %s" lib_name (Path.to_string_maybe_quoted path)
| Preprocess l ->
Sexp.to_string ~syntax:Dune
(List [ Sexp.unsafe_atom_of_string "pps"
Sexp.to_string
(List [ Atom "pps"
; Sexp.To_sexp.(list string) l])
| Loc loc ->
Loc.to_file_colon_line loc

2
src/dep_path.mli
View File

@ -1,6 +1,6 @@
(** Dependency path *)
open Stdune
open! Stdune
module Entry : sig
type t =

37
src/dir_contents.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open Import
module Menhir_rules = Menhir
open Dune_file
@ -39,7 +40,7 @@ end = struct
match m with
| Ok m -> Some m
| Error s ->
Loc.fail loc "Module %a doesn't exist." Module.Name.pp s)
Errors.fail loc "Module %a doesn't exist." Module.Name.pp s)
, modules
)
@ -100,28 +101,28 @@ end = struct
if missing_intf_only <> [] then begin
match Ordered_set_lang.loc buildable.modules_without_implementation with
| None ->
Loc.warn buildable.loc
Errors.warn buildable.loc
"Some modules don't have an implementation.\
\nYou need to add the following field to this stanza:\
\n\
\n %s\
\n\
\nThis will become an error in the future."
(let tag = Sexp.unsafe_atom_of_string
(let tag = Dsexp.unsafe_atom_of_string
"modules_without_implementation" in
let modules =
missing_intf_only
|> uncapitalized
|> List.map ~f:Sexp.To_sexp.string
|> List.map ~f:Dsexp.To_sexp.string
in
Sexp.to_string ~syntax:Dune (List (tag :: modules)))
Dsexp.to_string ~syntax:Dune (List (tag :: modules)))
| Some loc ->
let list_modules l =
uncapitalized l
|> List.map ~f:(sprintf "- %s")
|> String.concat ~sep:"\n"
in
Loc.warn loc
Errors.warn loc
"The following modules must be listed here as they don't \
have an implementation:\n\
%s\n\
@ -135,7 +136,7 @@ end = struct
|> Option.value_exn
in
(* CR-soon jdimino for jdimino: report all errors *)
Loc.fail loc
Errors.fail loc
"Module %a has an implementation, it cannot be listed here"
Module.Name.pp module_name
end
@ -154,7 +155,7 @@ end = struct
)
in
Module.Name.Map.iteri fake_modules ~f:(fun m loc ->
Loc.warn loc "Module %a is excluded but it doesn't exist."
Errors.warn loc "Module %a is excluded but it doesn't exist."
Module.Name.pp m
);
check_invalid_module_listing ~buildable:conf ~intf_only ~modules
@ -280,8 +281,8 @@ let mlds t (doc : Documentation.t) =
| Some x -> x
| None ->
Exn.code_error "Dir_contents.mlds"
[ "doc", Loc.sexp_of_t doc.loc
; "available", Sexp.To_sexp.(list Loc.sexp_of_t)
[ "doc", Loc.to_sexp doc.loc
; "available", Sexp.To_sexp.(list Loc.to_sexp)
(List.map map ~f:(fun (d, _) -> d.Documentation.loc))
]
@ -378,7 +379,7 @@ let build_modules_map (d : Super_context.Dir_with_jbuild.t) ~modules =
with
| Ok x -> x
| Error (name, _, (lib2, _)) ->
Loc.fail lib2.buildable.loc
Errors.fail lib2.buildable.loc
"Library %S appears for the second time \
in this directory"
name
@ -390,7 +391,7 @@ let build_modules_map (d : Super_context.Dir_with_jbuild.t) ~modules =
with
| Ok x -> x
| Error (name, _, (exes2, _)) ->
Loc.fail exes2.buildable.loc
Errors.fail exes2.buildable.loc
"Executable %S appears for the second time \
in this directory"
name
@ -416,7 +417,7 @@ let build_modules_map (d : Super_context.Dir_with_jbuild.t) ~modules =
Option.some_if (n = name) b.loc)
|> List.sort ~compare
in
Loc.fail (Loc.in_file (List.hd locs).start.pos_fname)
Errors.fail (Loc.in_file (List.hd locs).start.pos_fname)
"Module %a is used in several stanzas:@\n\
@[<v>%a@]@\n\
@[%a@]"
@ -441,7 +442,7 @@ let build_modules_map (d : Super_context.Dir_with_jbuild.t) ~modules =
List.sort ~compare
(b.Buildable.loc :: List.map rest ~f:(fun b -> b.Buildable.loc))
in
Loc.warn (Loc.in_file b.loc.start.pos_fname)
Errors.warn (Loc.in_file b.loc.start.pos_fname)
"Module %a is used in several stanzas:@\n\
@[<v>%a@]@\n\
@[%a@]@\n\
@ -477,7 +478,7 @@ let build_mlds_map (d : Super_context.Dir_with_jbuild.t) ~files =
| Some s ->
s
| None ->
Loc.fail loc "%s.mld doesn't exist in %s" s
Errors.fail loc "%s.mld doesn't exist in %s" s
(Path.to_string_maybe_quoted
(Path.drop_optional_build_context dir))
)
@ -513,7 +514,7 @@ module Dir_status = struct
match stanza with
| Include_subdirs (loc, x) ->
if Option.is_some acc then
Loc.fail loc "The 'include_subdirs' stanza cannot appear \
Errors.fail loc "The 'include_subdirs' stanza cannot appear \
more than once";
Some x
| _ -> acc)
@ -523,7 +524,7 @@ module Dir_status = struct
match stanza with
| Library { buildable; _} | Executables { buildable; _ }
| Tests { exes = { buildable; _ }; _ } ->
Loc.fail buildable.loc
Errors.fail buildable.loc
"This stanza is not allowed in a sub-directory of directory with \
(include_subdirs unqualified).\n\
Hint: add (include_subdirs no) to this file."
@ -663,7 +664,7 @@ let rec get sctx ~dir =
~f:(fun acc (dir, files) ->
let modules = modules_of_files ~dir ~files in
Module.Name.Map.union acc modules ~f:(fun name x y ->
Loc.fail (Loc.in_file
Errors.fail (Loc.in_file
(Path.to_string
(match File_tree.Dir.dune_file ft_dir with
| None ->

1
src/dir_contents.mli
View File

@ -4,6 +4,7 @@
in the source tree or generated by user rules to library,
executables, tests and documentation stanzas. *)
open! Stdune
open Import
type t

0
src/usexp/atom.ml → src/dsexp/atom.ml
View File

0
src/usexp/atom.mli → src/dsexp/atom.mli
View File

869
src/dsexp/dsexp.ml Normal file
View File

@ -0,0 +1,869 @@
open! Stdune
module Atom = Atom
module Template = Template
type syntax = Atom.syntax = Jbuild | Dune
type t =
| Atom of Atom.t
| Quoted_string of string
| List of t list
| Template of Template.t
let atom_or_quoted_string s =
if Atom.is_valid_dune s then
Atom (Atom.of_string s)
else
Quoted_string s
let atom s = Atom (Atom.of_string s)
let unsafe_atom_of_string s = atom s
let rec to_string t ~syntax =
match t with
| Atom a -> Atom.print a syntax
| Quoted_string s -> Escape.quoted s ~syntax
| List l ->
Printf.sprintf "(%s)" (List.map l ~f:(to_string ~syntax)
|> String.concat ~sep:" ")
| Template t -> Template.to_string t ~syntax
let rec pp syntax ppf = function
| Atom s ->
Format.pp_print_string ppf (Atom.print s syntax)
| Quoted_string s ->
Format.pp_print_string ppf (Escape.quoted ~syntax s)
| List [] ->
Format.pp_print_string ppf "()"
| List (first :: rest) ->
Format.pp_open_box ppf 1;
Format.pp_print_string ppf "(";
Format.pp_open_hvbox ppf 0;
pp syntax ppf first;
List.iter rest ~f:(fun sexp ->
Format.pp_print_space ppf ();
pp syntax ppf sexp);
Format.pp_close_box ppf ();
Format.pp_print_string ppf ")";
Format.pp_close_box ppf ()
| Template t -> Template.pp syntax ppf t
let pp_quoted =
let rec loop = function
| Atom (A s) as t ->
if Atom.is_valid_dune s then
t
else
Quoted_string s
| List xs -> List (List.map ~f:loop xs)
| (Quoted_string _ | Template _) as t -> t
in
fun ppf t -> pp Dune ppf (loop t)
let pp_print_quoted_string ppf s =
let syntax = Dune in
if String.contains s '\n' then begin
match String.split s ~on:'\n' with
| [] -> Format.pp_print_string ppf (Escape.quoted ~syntax s)
| first :: rest ->
Format.fprintf ppf "@[<hv 1>\"@{<atom>%s"
(Escape.escaped ~syntax first);
List.iter rest ~f:(fun s ->
Format.fprintf ppf "@,\\n%s" (Escape.escaped ~syntax s));
Format.fprintf ppf "@}\"@]"
end else
Format.pp_print_string ppf (Escape.quoted ~syntax s)
let rec pp_split_strings ppf = function
| Atom s -> Format.pp_print_string ppf (Atom.print s Atom.Dune)
| Quoted_string s -> pp_print_quoted_string ppf s
| List [] ->
Format.pp_print_string ppf "()"
| List (first :: rest) ->
Format.pp_open_box ppf 1;
Format.pp_print_string ppf "(";
Format.pp_open_hvbox ppf 0;
pp_split_strings ppf first;
List.iter rest ~f:(fun sexp ->
Format.pp_print_space ppf ();
pp_split_strings ppf sexp);
Format.pp_close_box ppf ();
Format.pp_print_string ppf ")";
Format.pp_close_box ppf ()
| Template t -> Template.pp_split_strings ppf t
type formatter_state =
| In_atom
| In_makefile_action
| In_makefile_stuff
let prepare_formatter ppf =
let state = ref [] in
Format.pp_set_mark_tags ppf true;
let ofuncs = Format.pp_get_formatter_out_functions ppf () in
let tfuncs = Format.pp_get_formatter_tag_functions ppf () in
Format.pp_set_formatter_tag_functions ppf
{ tfuncs with
mark_open_tag = (function
| "atom" -> state := In_atom :: !state; ""
| "makefile-action" -> state := In_makefile_action :: !state; ""
| "makefile-stuff" -> state := In_makefile_stuff :: !state; ""
| s -> tfuncs.mark_open_tag s)
; mark_close_tag = (function
| "atom" | "makefile-action" | "makefile-stuff" -> state := List.tl !state; ""
| s -> tfuncs.mark_close_tag s)
};
Format.pp_set_formatter_out_functions ppf
{ ofuncs with
out_newline = (fun () ->
match !state with
| [In_atom; In_makefile_action] ->
ofuncs.out_string "\\\n\t" 0 3
| [In_atom] ->
ofuncs.out_string "\\\n" 0 2
| [In_makefile_action] ->
ofuncs.out_string " \\\n\t" 0 4
| [In_makefile_stuff] ->
ofuncs.out_string " \\\n" 0 3
| [] ->
ofuncs.out_string "\n" 0 1
| _ -> assert false)
; out_spaces = (fun n ->
ofuncs.out_spaces
(match !state with
| In_atom :: _ -> max 0 (n - 2)
| _ -> n))
}
module Ast = struct
type dsexp = t
type t =
| Atom of Loc.t * Atom.t
| Quoted_string of Loc.t * string
| Template of Template.t
| List of Loc.t * t list
let atom_or_quoted_string loc s =
match atom_or_quoted_string s with
| Atom a -> Atom (loc, a)
| Quoted_string s -> Quoted_string (loc, s)
| Template _
| List _ -> assert false
let loc (Atom (loc, _) | Quoted_string (loc, _) | List (loc, _)
| Template { loc ; _ }) = loc
let rec remove_locs t : dsexp =
match t with
| Template t -> Template (Template.remove_locs t)
| Atom (_, s) -> Atom s
| Quoted_string (_, s) -> Quoted_string s
| List (_, l) -> List (List.map l ~f:remove_locs)
end
let rec add_loc t ~loc : Ast.t =
match t with
| Atom s -> Atom (loc, s)
| Quoted_string s -> Quoted_string (loc, s)
| List l -> List (loc, List.map l ~f:(add_loc ~loc))
| Template t -> Template { t with loc }
module Parse_error = struct
include Lexer.Error
let loc t : Loc.t = { start = t.start; stop = t.stop }
let message t = t.message
end
exception Parse_error = Lexer.Error
module Lexer = Lexer
module Parser = struct
let error (loc : Loc.t) message =
raise (Parse_error
{ start = loc.start
; stop = loc.stop
; message
})
module Mode = struct
type 'a t =
| Single : Ast.t t
| Many : Ast.t list t
| Many_as_one : Ast.t t
let make_result : type a. a t -> Lexing.lexbuf -> Ast.t list -> a
= fun t lexbuf sexps ->
match t with
| Single -> begin
match sexps with
| [sexp] -> sexp
| [] -> error (Loc.of_lexbuf lexbuf) "no s-expression found in input"
| _ :: sexp :: _ ->
error (Ast.loc sexp) "too many s-expressions found in input"
end
| Many -> sexps
| Many_as_one ->
match sexps with
| [] -> List (Loc.in_file lexbuf.lex_curr_p.pos_fname, [])
| x :: l ->
let last = List.fold_left l ~init:x ~f:(fun _ x -> x) in
let loc = { (Ast.loc x) with stop = (Ast.loc last).stop } in
List (loc, x :: l)
end
let rec loop depth lexer lexbuf acc =
match (lexer lexbuf : Lexer.Token.t) with
| Atom a ->
let loc = Loc.of_lexbuf lexbuf in
loop depth lexer lexbuf (Ast.Atom (loc, a) :: acc)
| Quoted_string s ->
let loc = Loc.of_lexbuf lexbuf in
loop depth lexer lexbuf (Quoted_string (loc, s) :: acc)
| Template t ->
let loc = Loc.of_lexbuf lexbuf in
loop depth lexer lexbuf (Template { t with loc } :: acc)
| Lparen ->
let start = Lexing.lexeme_start_p lexbuf in
let sexps = loop (depth + 1) lexer lexbuf [] in
let stop = Lexing.lexeme_end_p lexbuf in
loop depth lexer lexbuf (List ({ start; stop }, sexps) :: acc)
| Rparen ->
if depth = 0 then
error (Loc.of_lexbuf lexbuf)
"right parenthesis without matching left parenthesis";
List.rev acc
| Sexp_comment ->
let sexps =
let loc = Loc.of_lexbuf lexbuf in
match loop depth lexer lexbuf [] with
| _ :: sexps -> sexps
| [] -> error loc "s-expression missing after #;"
in
List.rev_append acc sexps
| Eof ->
if depth > 0 then
error (Loc.of_lexbuf lexbuf)
"unclosed parenthesis at end of input";
List.rev acc
let parse ~mode ?(lexer=Lexer.token) lexbuf =
loop 0 lexer lexbuf []
|> Mode.make_result mode lexbuf
end
let parse_string ~fname ~mode ?lexer str =
let lb = Lexing.from_string str in
lb.lex_curr_p <-
{ pos_fname = fname
; pos_lnum = 1
; pos_bol = 0
; pos_cnum = 0
};
Parser.parse ~mode ?lexer lb
type dsexp = t
module To_sexp = struct
type nonrec 'a t = 'a -> t
let unit () = List []
let string = atom_or_quoted_string
let int n = Atom (Atom.of_int n)
let float f = Atom (Atom.of_float f)
let bool b = Atom (Atom.of_bool b)
let pair fa fb (a, b) = List [fa a; fb b]
let triple fa fb fc (a, b, c) = List [fa a; fb b; fc c]
let list f l = List (List.map l ~f)
let array f a = list f (Array.to_list a)
let option f = function
| None -> List []
| Some x -> List [f x]
let record l =
List (List.map l ~f:(fun (n, v) -> List [Atom(Atom.of_string n); v]))
type field = string * dsexp option
let field name f ?(equal=(=)) ?default v =
match default with
| None -> (name, Some (f v))
| Some d ->
if equal d v then
(name, None)
else
(name, Some (f v))
let field_o name f v = (name, Option.map ~f v)
let record_fields (l : field list) =
List (List.filter_map l ~f:(fun (k, v) ->
Option.map v ~f:(fun v -> List[Atom (Atom.of_string k); v])))
let unknown _ = unsafe_atom_of_string "<unknown>"
end
module Of_sexp = struct
type ast = Ast.t =
| Atom of Loc.t * Atom.t
| Quoted_string of Loc.t * string
| Template of Template.t
| List of Loc.t * ast list
type hint =
{ on: string
; candidates: string list
}
exception Of_sexp of Loc.t * string * hint option
let of_sexp_error ?hint loc msg =
raise (Of_sexp (loc, msg, hint))
let of_sexp_errorf ?hint loc fmt =
Printf.ksprintf (fun msg -> of_sexp_error loc ?hint msg) fmt
let no_templates ?hint loc fmt =
Printf.ksprintf (fun msg ->
of_sexp_error loc ?hint ("No variables allowed " ^ msg)) fmt
type unparsed_field =
{ values : Ast.t list
; entry : Ast.t
; prev : unparsed_field option (* Previous occurrence of this field *)
}
module Name = struct
type t = string
let compare a b =
let alen = String.length a and blen = String.length b in
match Int.compare alen blen with
| Eq -> String.compare a b
| ne -> ne
end
module Name_map = Map.Make(Name)
type values = Ast.t list
type fields =
{ unparsed : unparsed_field Name_map.t
; known : string list
}
(* Arguments are:
- the location of the whole list
- the first atom when parsing a constructor or a field
- the universal map holding the user context
*)
type 'kind context =
| Values : Loc.t * string option * Univ_map.t -> values context
| Fields : Loc.t * string option * Univ_map.t -> fields context
type ('a, 'kind) parser = 'kind context -> 'kind -> 'a * 'kind
type 'a t = ('a, values) parser
type 'a fields_parser = ('a, fields) parser
let return x _ctx state = (x, state)
let (>>=) t f ctx state =
let x, state = t ctx state in
f x ctx state
let (>>|) t f ctx state =
let x, state = t ctx state in
(f x, state)
let (>>>) a b ctx state =
let (), state = a ctx state in
b ctx state
let map t ~f = t >>| f
let try_ t f ctx state =
try
t ctx state
with exn ->
f exn ctx state
let get_user_context : type k. k context -> Univ_map.t = function
| Values (_, _, uc) -> uc
| Fields (_, _, uc) -> uc
let get key ctx state = (Univ_map.find (get_user_context ctx) key, state)
let get_all ctx state = (get_user_context ctx, state)
let set : type a b k. a Univ_map.Key.t -> a -> (b, k) parser -> (b, k) parser
= fun key v t ctx state ->
match ctx with
| Values (loc, cstr, uc) ->
t (Values (loc, cstr, Univ_map.add uc key v)) state
| Fields (loc, cstr, uc) ->
t (Fields (loc, cstr, Univ_map.add uc key v)) state
let set_many : type a k. Univ_map.t -> (a, k) parser -> (a, k) parser
= fun map t ctx state ->
match ctx with
| Values (loc, cstr, uc) ->
t (Values (loc, cstr, Univ_map.superpose uc map)) state
| Fields (loc, cstr, uc) ->
t (Fields (loc, cstr, Univ_map.superpose uc map)) state
let loc : type k. k context -> k -> Loc.t * k = fun ctx state ->
match ctx with
| Values (loc, _, _) -> (loc, state)
| Fields (loc, _, _) -> (loc, state)
let at_eos : type k. k context -> k -> bool = fun ctx state ->
match ctx with
| Values _ -> state = []
| Fields _ -> Name_map.is_empty state.unparsed
let eos ctx state = (at_eos ctx state, state)
let if_eos ~then_ ~else_ ctx state =
if at_eos ctx state then
then_ ctx state
else
else_ ctx state
let repeat : 'a t -> 'a list t =
let rec loop t acc ctx l =
match l with
| [] -> (List.rev acc, [])
| _ ->
let x, l = t ctx l in
loop t (x :: acc) ctx l
in
fun t ctx state -> loop t [] ctx state
let result : type a k. k context -> a * k -> a =
fun ctx (v, state) ->
match ctx with
| Values (_, cstr, _) -> begin
match state with
| [] -> v
| sexp :: _ ->
match cstr with
| None ->
of_sexp_errorf (Ast.loc sexp) "This value is unused"
| Some s ->
of_sexp_errorf (Ast.loc sexp) "Too many argument for %s" s
end
| Fields _ -> begin
match Name_map.choose state.unparsed with
| None -> v
| Some (name, { entry; _ }) ->
let name_loc =
match entry with
| List (_, s :: _) -> Ast.loc s
| _ -> assert false
in
of_sexp_errorf ~hint:{ on = name; candidates = state.known }
name_loc "Unknown field %s" name
end
let parse t context sexp =
let ctx = Values (Ast.loc sexp, None, context) in
result ctx (t ctx [sexp])
let capture ctx state =
let f t =
result ctx (t ctx state)
in
(f, [])
let end_of_list (Values (loc, cstr, _)) =
match cstr with
| None ->
let loc = { loc with start = loc.stop } in
of_sexp_errorf loc "Premature end of list"
| Some s ->
of_sexp_errorf loc "Not enough arguments for %s" s
[@@inline never]
let next f ctx sexps =
match sexps with
| [] -> end_of_list ctx
| sexp :: sexps -> (f sexp, sexps)
[@@inline always]
let next_with_user_context f ctx sexps =
match sexps with
| [] -> end_of_list ctx
| sexp :: sexps -> (f (get_user_context ctx) sexp, sexps)
[@@inline always]
let peek _ctx sexps =
match sexps with
| [] -> (None, sexps)
| sexp :: _ -> (Some sexp, sexps)
[@@inline always]
let peek_exn ctx sexps =
match sexps with
| [] -> end_of_list ctx
| sexp :: _ -> (sexp, sexps)
[@@inline always]
let junk = next ignore
let junk_everything : type k. (unit, k) parser = fun ctx state ->
match ctx with
| Values _ -> ((), [])
| Fields _ -> ((), { state with unparsed = Name_map.empty })
let keyword kwd =
next (function
| Atom (_, s) when Atom.to_string s = kwd -> ()
| sexp -> of_sexp_errorf (Ast.loc sexp) "'%s' expected" kwd)
let match_keyword l ~fallback =
peek >>= function
| Some (Atom (_, A s)) -> begin
match List.assoc l s with
| Some t -> junk >>> t
| None -> fallback
end
| _ -> fallback
let until_keyword kwd ~before ~after =
let rec loop acc =
peek >>= function
| None -> return (List.rev acc, None)
| Some (Atom (_, A s)) when s = kwd ->
junk >>> after >>= fun x ->
return (List.rev acc, Some x)
| _ ->
before >>= fun x ->
loop (x :: acc)
in
loop []
let plain_string f =
next (function
| Atom (loc, A s) | Quoted_string (loc, s) -> f ~loc s
| Template { loc ; _ } | List (loc, _) ->
of_sexp_error loc "Atom or quoted string expected")
let enter t =
next_with_user_context (fun uc sexp ->
match sexp with
| List (loc, l) ->
let ctx = Values (loc, None, uc) in
result ctx (t ctx l)
| sexp ->
of_sexp_error (Ast.loc sexp) "List expected")
let if_list ~then_ ~else_ =
peek_exn >>= function
| List _ -> then_
| _ -> else_
let if_paren_colon_form ~then_ ~else_ =
peek_exn >>= function
| List (_, Atom (loc, A s) :: _) when String.is_prefix s ~prefix:":" ->
let name = String.sub s ~pos:1 ~len:(String.length s - 1) in
enter
(junk >>= fun () ->
then_ >>| fun f ->
f (loc, name))
| _ ->
else_
let fix f =
let rec p = lazy (f r)
and r ast = (Lazy.force p) ast in
r
let loc_between_states : type k. k context -> k -> k -> Loc.t
= fun ctx state1 state2 ->
match ctx with
| Values _ -> begin
match state1 with
| sexp :: rest when rest == state2 -> (* common case *)
Ast.loc sexp
| [] ->
let (Values (loc, _, _)) = ctx in
{ loc with start = loc.stop }
| sexp :: rest ->
let loc = Ast.loc sexp in
let rec search last l =
if l == state2 then
{ loc with stop = (Ast.loc last).stop }
else
match l with
| [] ->
let (Values (loc, _, _)) = ctx in
{ (Ast.loc sexp) with stop = loc.stop }
| sexp :: rest ->
search sexp rest
in
search sexp rest
end
| Fields _ ->
let parsed =
Name_map.merge state1.unparsed state2.unparsed
~f:(fun _key before after ->
match before, after with
| Some _, None -> before
| _ -> None)
in
match
Name_map.values parsed
|> List.map ~f:(fun f -> Ast.loc f.entry)
|> List.sort ~compare:(fun a b ->
Int.compare a.Loc.start.pos_cnum b.start.pos_cnum)
with
| [] ->
let (Fields (loc, _, _)) = ctx in
loc
| first :: l ->
let last = List.fold_left l ~init:first ~f:(fun _ x -> x) in
{ first with stop = last.stop }
let located t ctx state1 =
let x, state2 = t ctx state1 in
((loc_between_states ctx state1 state2, x), state2)
let raw = next (fun x -> x)
let unit =
next
(function
| List (_, []) -> ()
| sexp -> of_sexp_error (Ast.loc sexp) "() expected")
let basic desc f =
next (function
| Template { loc; _ } | List (loc, _) | Quoted_string (loc, _) ->
of_sexp_errorf loc "%s expected" desc
| Atom (loc, s) ->
match f (Atom.to_string s) with
| Result.Error () ->
of_sexp_errorf loc "%s expected" desc
| Ok x -> x)
let string = plain_string (fun ~loc:_ x -> x)
let int =
basic "Integer" (fun s ->
match int_of_string s with
| x -> Ok x
| exception _ -> Result.Error ())
let float =
basic "Float" (fun s ->
match float_of_string s with
| x -> Ok x
| exception _ -> Result.Error ())
let pair a b =
enter
(a >>= fun a ->
b >>= fun b ->
return (a, b))
let triple a b c =
enter
(a >>= fun a ->
b >>= fun b ->
c >>= fun c ->
return (a, b, c))
let list t = enter (repeat t)
let array t = list t >>| Array.of_list
let option t =
enter
(eos >>= function
| true -> return None
| false -> t >>| Option.some)
let find_cstr cstrs loc name ctx values =
match List.assoc cstrs name with
| Some t ->
result ctx (t ctx values)
| None ->
of_sexp_errorf loc
~hint:{ on = name
; candidates = List.map cstrs ~f:fst
}
"Unknown constructor %s" name
let sum cstrs =
next_with_user_context (fun uc sexp ->
match sexp with
| Atom (loc, A s) ->
find_cstr cstrs loc s (Values (loc, Some s, uc)) []
| Template { loc; _ }
| Quoted_string (loc, _) ->
of_sexp_error loc "Atom expected"
| List (loc, []) ->
of_sexp_error loc "Non-empty list expected"
| List (loc, name :: args) ->
match name with
| Quoted_string (loc, _) | List (loc, _) | Template { loc; _ } ->
of_sexp_error loc "Atom expected"
| Atom (s_loc, A s) ->
find_cstr cstrs s_loc s (Values (loc, Some s, uc)) args)
let enum cstrs =
next (function
| Quoted_string (loc, _)
| Template { loc; _ }
| List (loc, _) -> of_sexp_error loc "Atom expected"
| Atom (loc, A s) ->
match List.assoc cstrs s with
| Some value -> value
| None ->
of_sexp_errorf loc
~hint:{ on = s
; candidates = List.map cstrs ~f:fst
}
"Unknown value %s" s)
let bool = enum [ ("true", true); ("false", false) ]
let consume name state =
{ unparsed = Name_map.remove state.unparsed name
; known = name :: state.known
}
let add_known name state =
{ state with known = name :: state.known }
let map_validate t ~f ctx state1 =
let x, state2 = t ctx state1 in
match f x with
| Result.Ok x -> (x, state2)
| Error msg ->
let loc = loc_between_states ctx state1 state2 in
of_sexp_errorf loc "%s" msg
let field_missing loc name =
of_sexp_errorf loc "field %s missing" name
[@@inline never]
let field_present_too_many_times _ name entries =
match entries with
| _ :: second :: _ ->
of_sexp_errorf (Ast.loc second) "Field %S is present too many times"
name
| _ -> assert false
let multiple_occurrences ?(on_dup=field_present_too_many_times) uc name last =
let rec collect acc x =
let acc = x.entry :: acc in
match x.prev with
| None -> acc
| Some prev -> collect acc prev
in
on_dup uc name (collect [] last)
[@@inline never]
let find_single ?on_dup uc state name =
let res = Name_map.find state.unparsed name in
(match res with
| Some ({ prev = Some _; _ } as last) ->
multiple_occurrences uc name last ?on_dup
| _ -> ());
res
let field name ?default ?on_dup t (Fields (loc, _, uc)) state =
match find_single uc state name ?on_dup with
| Some { values; entry; _ } ->
let ctx = Values (Ast.loc entry, Some name, uc) in
let x = result ctx (t ctx values) in
(x, consume name state)
| None ->
match default with
| Some v -> (v, add_known name state)
| None -> field_missing loc name
let field_o name ?on_dup t (Fields (_, _, uc)) state =
match find_single uc state name ?on_dup with
| Some { values; entry; _ } ->
let ctx = Values (Ast.loc entry, Some name, uc) in
let x = result ctx (t ctx values) in
(Some x, consume name state)
| None ->
(None, add_known name state)
let field_b ?check ?on_dup name =
field name ~default:false ?on_dup
(Option.value check ~default:(return ()) >>= fun () ->
eos >>= function
| true -> return true
| _ -> bool)
let multi_field name t (Fields (_, _, uc)) state =
let rec loop acc field =
match field with
| None -> acc
| Some { values; prev; entry } ->
let ctx = Values (Ast.loc entry, Some name, uc) in
let x = result ctx (t ctx values) in
loop (x :: acc) prev
in
let res = loop [] (Name_map.find state.unparsed name) in
(res, consume name state)
let fields t (Values (loc, cstr, uc)) sexps =
let unparsed =
List.fold_left sexps ~init:Name_map.empty ~f:(fun acc sexp ->
match sexp with
| List (_, name_sexp :: values) -> begin
match name_sexp with
| Atom (_, A name) ->
Name_map.add acc name
{ values
; entry = sexp
; prev = Name_map.find acc name
}
| List (loc, _) | Quoted_string (loc, _) | Template { loc; _ } ->
of_sexp_error loc "Atom expected"
end
| _ ->
of_sexp_error (Ast.loc sexp)
"S-expression of the form (<name> <values>...) expected")
in
let ctx = Fields (loc, cstr, uc) in
let x = result ctx (t ctx { unparsed; known = [] }) in
(x, [])
let record t = enter (fields t)
type kind =
| Values of Loc.t * string option
| Fields of Loc.t * string option
let kind : type k. k context -> k -> kind * k
= fun ctx state ->
match ctx with
| Values (loc, cstr, _) -> (Values (loc, cstr), state)
| Fields (loc, cstr, _) -> (Fields (loc, cstr), state)
module Let_syntax = struct
let ( $ ) f t =
f >>= fun f ->
t >>| fun t ->
f t
let const = return
end
end
module type Sexpable = sig
type t
val dparse : t Of_sexp.t
val dgen : t To_sexp.t
end
let rec to_sexp = function
| Atom (A a) -> Sexp.Atom a
| List s -> List (List.map s ~f:to_sexp)
| Quoted_string s -> Sexp.Atom s
| Template t ->
List
[ Atom "template"
; Atom (Template.to_string ~syntax:Dune t)
]
module Io = struct
let load ?lexer path ~mode =
Io.with_lexbuf_from_file path ~f:(Parser.parse ~mode ?lexer)
end

410
src/dsexp/dsexp.mli Normal file
View File

@ -0,0 +1,410 @@
open! Stdune
(** Parsing of s-expressions.
This library is internal to jbuilder and guarantees no API stability.*)
type syntax = Jbuild | Dune
module Atom : sig
type t = private A of string [@@unboxed]
val is_valid : t -> syntax -> bool
val of_string : string -> t
val to_string : t -> string
val of_int : int -> t
val of_float : float -> t
val of_bool : bool -> t
val of_int64 : Int64.t -> t
val of_digest : Digest.t -> t
end
module Template : sig
type var_syntax = Dollar_brace | Dollar_paren | Percent
type var =
{ loc: Loc.t
; name: string
; payload: string option
; syntax: var_syntax
}
type part =
| Text of string
| Var of var
type t =
{ quoted: bool
; parts: part list
; loc: Loc.t
}
val string_of_var : var -> string
val to_string : t -> syntax:syntax -> string
val remove_locs : t -> t
end
(** The S-expression type *)
type t =
| Atom of Atom.t
| Quoted_string of string
| List of t list
| Template of Template.t
val atom : string -> t
(** [atom s] convert the string [s] to an Atom.
@raise Invalid_argument if [s] does not satisfy [Atom.is_valid s]. *)
val atom_or_quoted_string : string -> t
val unsafe_atom_of_string : string -> t
(** Serialize a S-expression *)
val to_string : t -> syntax:syntax -> string
(** Serialize a S-expression using indentation to improve readability *)
val pp : syntax -> Format.formatter -> t -> unit
(** Serialization that never fails because it quotes atoms when necessary
TODO remove this once we have a proper sexp type *)
val pp_quoted : Format.formatter -> t -> unit
(** Same as [pp ~syntax:Dune], but split long strings. The formatter
must have been prepared with [prepare_formatter]. *)
val pp_split_strings : Format.formatter -> t -> unit
(** Prepare a formatter for [pp_split_strings]. Additionaly the
formatter escape newlines when the tags "makefile-action" or
"makefile-stuff" are active. *)
val prepare_formatter : Format.formatter -> unit
(** Abstract syntax tree *)
module Ast : sig
type sexp = t
type t =
| Atom of Loc.t * Atom.t
| Quoted_string of Loc.t * string
| Template of Template.t
| List of Loc.t * t list
val atom_or_quoted_string : Loc.t -> string -> t
val loc : t -> Loc.t
val remove_locs : t -> sexp
end with type sexp := t
val add_loc : t -> loc:Loc.t -> Ast.t
module Parse_error : sig
type t
val loc : t -> Loc.t
val message : t -> string
end
(** Exception raised in case of a parsing error *)
exception Parse_error of Parse_error.t
module Lexer : sig
module Token : sig
type t =
| Atom of Atom.t
| Quoted_string of string
| Lparen
| Rparen
| Sexp_comment
| Eof
| Template of Template.t
end
type t = Lexing.lexbuf -> Token.t
val token : t
val jbuild_token : t
end
module Parser : sig
module Mode : sig
type 'a t =
| Single : Ast.t t
| Many : Ast.t list t
| Many_as_one : Ast.t t
end
val parse
: mode:'a Mode.t
-> ?lexer:Lexer.t
-> Lexing.lexbuf
-> 'a
end
val parse_string
: fname:string
-> mode:'a Parser.Mode.t
-> ?lexer:Lexer.t
-> string
-> 'a
module To_sexp : sig
type sexp = t
include Sexp_intf.Combinators with type 'a t = 'a -> t
val record : (string * sexp) list -> sexp
type field
val field
: string
-> 'a t
-> ?equal:('a -> 'a -> bool)
-> ?default:'a
-> 'a
-> field
val field_o : string -> 'a t-> 'a option -> field
val record_fields : field list t
val unknown : _ t
end with type sexp := t
module Of_sexp : sig
type ast = Ast.t =
| Atom of Loc.t * Atom.t
| Quoted_string of Loc.t * string
| Template of Template.t
| List of Loc.t * ast list
type hint =
{ on: string
; candidates: string list
}
exception Of_sexp of Loc.t * string * hint option
(** Monad producing a value of type ['a] by parsing an input
composed of a sequence of S-expressions.
The input can be seen either as a plain sequence of
S-expressions or a list of fields. The ['kind] parameter
indicates how the input is seen:
- with {['kind = [values]]}, the input is seen as an ordered
sequence of S-expressions
- with {['kind = [fields]]}, the input is seen as an unordered
sequence of fields
A field is a S-expression of the form: [(<atom> <values>...)]
where [atom] is a plain atom, i.e. not a quoted string and not
containing variables. [values] is a sequence of zero, one or more
S-expressions.
It is possible to switch between the two mode at any time using
the appropriate combinator. Some primitives can be used in both
mode while some are specific to one mode. *)
type ('a, 'kind) parser
type values
type fields
type 'a t = ('a, values) parser
type 'a fields_parser = ('a, fields) parser
(** [parse parser context sexp] parse a S-expression using the
following parser. The input consist of a single
S-expression. [context] allows to pass extra information such as
versions to individual parsers. *)
val parse : 'a t -> Univ_map.t -> ast -> 'a
val return : 'a -> ('a, _) parser
val (>>=) : ('a, 'k) parser -> ('a -> ('b, 'k) parser) -> ('b, 'k) parser
val (>>|) : ('a, 'k) parser -> ('a -> 'b) -> ('b, 'k) parser
val (>>>) : (unit, 'k) parser -> ('a, 'k) parser -> ('a, 'k) parser
val map : ('a, 'k) parser -> f:('a -> 'b) -> ('b, 'k) parser
val try_ : ('a, 'k) parser -> (exn -> ('a, 'k) parser) -> ('a, 'k) parser
(** Access to the context *)
val get : 'a Univ_map.Key.t -> ('a option, _) parser
val set : 'a Univ_map.Key.t -> 'a -> ('b, 'k) parser -> ('b, 'k) parser
val get_all : (Univ_map.t, _) parser
val set_many : Univ_map.t -> ('a, 'k) parser -> ('a, 'k) parser
(** Return the location of the list currently being parsed. *)
val loc : (Loc.t, _) parser
(** End of sequence condition. Uses [then_] if there are no more
S-expressions to parse, [else_] otherwise. *)
val if_eos : then_:('a, 'b) parser -> else_:('a, 'b) parser -> ('a, 'b) parser
(** If the next element of the sequence is a list, parse it with
[then_], otherwise parse it with [else_]. *)
val if_list
: then_:'a t
-> else_:'a t
-> 'a t
(** If the next element of the sequence is of the form [(:<name>
...)], use [then_] to parse [...]. Otherwise use [else_]. *)
val if_paren_colon_form
: then_:(Loc.t * string -> 'a) t
-> else_:'a t
-> 'a t
(** Expect the next element to be the following atom. *)
val keyword : string -> unit t
(** {[match_keyword [(k1, t1); (k2, t2); ...] ~fallback]} inspects
the next element of the input sequence. If it is an atom equal to
one of [k1], [k2], ... then the corresponding parser is used to
parse the rest of the sequence. Other [fallback] is used. *)
val match_keyword
: (string * 'a t) list
-> fallback:'a t
-> 'a t
(** Use [before] to parse elements until the keyword is
reached. Then use [after] to parse the rest. *)
val until_keyword
: string
-> before:'a t
-> after:'b t
-> ('a list * 'b option) t
(** What is currently being parsed. The second argument is the atom
at the beginnig of the list when inside a [sum ...] or [field
...]. *)
type kind =
| Values of Loc.t * string option
| Fields of Loc.t * string option
val kind : (kind, _) parser
(** [repeat t] use [t] to consume all remaning elements of the input
until the end of sequence is reached. *)
val repeat : 'a t -> 'a list t
(** Capture the rest of the input for later parsing *)
val capture : ('a t -> 'a) t
(** [enter t] expect the next element of the input to be a list and
parse its contents with [t]. *)
val enter : 'a t -> 'a t
(** [fields fp] converts the rest of the current input to a list of
fields and parse them with [fp]. This operation fails if one the
S-expression in the input is not of the form [(<atom>
<values>...)] *)
val fields : 'a fields_parser -> 'a t
(** [record fp = enter (fields fp)] *)
val record : 'a fields_parser -> 'a t
(** Consume the next element of the input as a string, int, char, ... *)
include Sexp_intf.Combinators with type 'a t := 'a t
(** Unparsed next element of the input *)
val raw : ast t
(** Inspect the next element of the input without consuming it *)
val peek : ast option t
(** Same as [peek] but fail if the end of input is reached *)
val peek_exn : ast t
(** Consume and ignore the next element of the input *)
val junk : unit t
(** Ignore all the rest of the input *)
val junk_everything : (unit, _) parser
(** [plain_string f] expects the next element of the input to be a
plain string, i.e. either an atom or a quoted string, but not a
template nor a list. *)
val plain_string : (loc:Loc.t -> string -> 'a) -> 'a t
val fix : ('a t -> 'a t) -> 'a t
val of_sexp_error
: ?hint:hint
-> Loc.t
-> string
-> _
val of_sexp_errorf
: ?hint:hint
-> Loc.t
-> ('a, unit, string, 'b) format4
-> 'a
val no_templates
: ?hint:hint
-> Loc.t
-> ('a, unit, string, 'b) format4
-> 'a
val located : ('a, 'k) parser -> (Loc.t * 'a, 'k) parser
val enum : (string * 'a) list -> 'a t
(** Parser that parse a S-expression of the form [(<atom> <s-exp1>
<s-exp2> ...)] or [<atom>]. [<atom>] is looked up in the list and
the remaining s-expressions are parsed using the corresponding
list parser. *)
val sum : (string * 'a t) list -> 'a t
(** Check the result of a list parser, and raise a properly located
error in case of failure. *)
val map_validate
: 'a fields_parser
-> f:('a -> ('b, string) Result.t)
-> 'b fields_parser
(** {3 Parsing record fields} *)
val field
: string
-> ?default:'a
-> ?on_dup:(Univ_map.t -> string -> Ast.t list -> unit)
-> 'a t
-> 'a fields_parser
val field_o
: string
-> ?on_dup:(Univ_map.t -> string -> Ast.t list -> unit)
-> 'a t
-> 'a option fields_parser
val field_b
: ?check:(unit t)
-> ?on_dup:(Univ_map.t -> string -> Ast.t list -> unit)
-> string
-> bool fields_parser
(** A field that can appear multiple times *)
val multi_field
: string
-> 'a t
-> 'a list fields_parser
(** Default value for [on_dup]. It fails with an appropriate error
message. *)
val field_present_too_many_times : Univ_map.t -> string -> Ast.t list -> _
module Let_syntax : sig
val ( $ ) : ('a -> 'b, 'k) parser -> ('a, 'k) parser -> ('b, 'k) parser
val const : 'a -> ('a, _) parser
end
end
module type Sexpable = sig
type t
val dparse : t Of_sexp.t
val dgen : t To_sexp.t
end
val to_sexp : t Sexp.To_sexp.t
module Io : sig
val load : ?lexer:Lexer.t -> Path.t -> mode:'a Parser.Mode.t -> 'a
end

5
src/usexp/dune → src/dsexp/dune
View File

@ -1,6 +1,7 @@
(library
(name usexp)
(name dsexp)
(synopsis "[Internal] S-expression library")
(public_name dune._usexp))
(libraries stdune)
(public_name dune._dsexp))
(ocamllex dune_lexer jbuild_lexer)

0
src/usexp/dune_lexer.mli → src/dsexp/dune_lexer.mli
View File

1
src/usexp/dune_lexer.mll → src/dsexp/dune_lexer.mll
View File

@ -1,4 +1,5 @@
{
open! Stdune
open Lexer_shared
type block_string_line_kind =

2
src/usexp/escape.ml → src/dsexp/escape.ml
View File

@ -1,4 +1,4 @@
open Import
open! Stdune
let quote_length s ~syntax =
let n = ref 0 in

0
src/usexp/escape.mli → src/dsexp/escape.mli
View File

0
src/usexp/jbuild_lexer.boot.ml → src/dsexp/jbuild_lexer.boot.ml
View File

0
src/usexp/jbuild_lexer.mli → src/dsexp/jbuild_lexer.mli
View File

0
src/usexp/jbuild_lexer.mll → src/dsexp/jbuild_lexer.mll
View File

0
src/usexp/lexer.ml → src/dsexp/lexer.ml
View File

0
src/usexp/lexer.mli → src/dsexp/lexer.mli
View File

0
src/usexp/lexer_shared.ml → src/dsexp/lexer_shared.ml
View File

0
src/usexp/lexer_shared.mli → src/dsexp/lexer_shared.mli
View File

4
src/usexp/template.ml → src/dsexp/template.ml
View File

@ -1,4 +1,4 @@
open Import
open! Stdune
include Types.Template
@ -76,7 +76,7 @@ let pp_split_strings ppf (t : t) =
| Var s ->
Format.pp_print_string ppf (string_of_var s)
| Text s ->
begin match String.split_on_char s ~on:'\n' with
begin match String.split s ~on:'\n' with
| [] -> assert false
| [s] -> Format.pp_print_string ppf (Escape.escaped ~syntax s)
| split ->

2
src/usexp/template.mli → src/dsexp/template.mli
View File

@ -1,3 +1,5 @@
open! Stdune
type var_syntax = Types.Template.var_syntax =
| Dollar_brace
| Dollar_paren

10
src/usexp/types.ml → src/dsexp/types.ml
View File

@ -1,3 +1,5 @@
open! Stdune
module Template = struct
type var_syntax = Dollar_brace | Dollar_paren | Percent
@ -18,11 +20,3 @@ module Template = struct
; loc: Loc.t
}
end
module Sexp = struct
type t =
| Atom of Atom.t
| Quoted_string of string
| List of t list
| Template of Template.t
end

2
src/dune
View File

@ -6,7 +6,7 @@
xdg
re
opam_file_format
usexp
dsexp
ocaml_config
which_program)
(synopsis "Internal Dune library, do not use!")

3
src/dune_env.ml
View File

@ -1,3 +1,4 @@
open! Stdune
type stanza = Stanza.t = ..
module Stanza = struct
@ -36,7 +37,7 @@ module Stanza = struct
in
(pat, configs))
let t =
let dparse =
let%map () = Syntax.since Stanza.syntax (1, 0)
and loc = loc
and rules = repeat rule

4
src/dune_env.mli
View File

@ -1,4 +1,4 @@
open Import
open! Stdune
type stanza = Stanza.t = ..
@ -18,7 +18,7 @@ module Stanza : sig
; rules : (pattern * config) list
}
val t : t Sexp.Of_sexp.t
val dparse : t Dsexp.Of_sexp.t
end
type stanza +=

305
src/dune_file.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open Import
open Stanza.Of_sexp
@ -10,7 +11,7 @@ module Jbuild_version = struct
type t =
| V1
let t =
let dparse =
enum
[ "1", V1
]
@ -53,7 +54,7 @@ module Lib_name : sig
val validate : (Loc.t * result) -> wrapped:bool -> t
val t : (Loc.t * result) Sexp.Of_sexp.t
val dparse : (Loc.t * result) Dsexp.Of_sexp.t
end = struct
type t = string
@ -78,9 +79,9 @@ end = struct
let validate (loc, res) ~wrapped =
match res, wrapped with
| Ok s, _ -> s
| Warn _, true -> Loc.fail loc "%s" wrapped_message
| Warn s, false -> Loc.warn loc "%s" wrapped_message; s
| Invalid, _ -> Loc.fail loc "%s" invalid_message
| Warn _, true -> Errors.fail loc "%s" wrapped_message
| Warn s, false -> Errors.warn loc "%s" wrapped_message; s
| Invalid, _ -> Errors.fail loc "%s" invalid_message
let valid_char = function
| 'A'..'Z' | 'a'..'z' | '_' | '0'..'9' -> true
@ -110,7 +111,7 @@ end = struct
in
loop false 0
let t = plain_string (fun ~loc s -> (loc, of_string s))
let dparse = plain_string (fun ~loc s -> (loc, of_string s))
end
let file =
@ -210,12 +211,12 @@ module Pkg = struct
(hint name_s (Package.Name.Map.keys packages
|> List.map ~f:Package.Name.to_string)))
let t =
let dparse =
let%map p = Dune_project.get_exn ()
and (loc, name) = located Package.Name.t in
and (loc, name) = located Package.Name.dparse in
match resolve p name with
| Ok x -> x
| Error e -> Loc.fail loc "%s" e
| Error e -> Errors.fail loc "%s" e
let field stanza =
map_validate
@ -266,11 +267,11 @@ module Pps_and_flags = struct
in
(pps, List.concat flags)
let t = list item >>| split
let dparse = list item >>| split
end
module Dune_syntax = struct
let t =
let dparse =
let%map l, flags =
until_keyword "--"
~before:(plain_string (fun ~loc s -> (loc, s)))
@ -286,10 +287,10 @@ module Pps_and_flags = struct
(pps, more_flags @ Option.value flags ~default:[])
end
let t =
let dparse =
switch_file_kind
~jbuild:Jbuild_syntax.t
~dune:Dune_syntax.t
~jbuild:Jbuild_syntax.dparse
~dune:Dune_syntax.dparse
end
module Bindings = struct
@ -301,6 +302,11 @@ module Bindings = struct
let fold t ~f ~init = List.fold_left ~f:(fun acc x -> f x acc) ~init t
let map t ~f =
List.map t ~f:(function
| Unnamed a -> Unnamed (f a)
| Named (s, xs) -> Named (s, List.map ~f xs))
let to_list =
List.concat_map ~f:(function
| Unnamed x -> [x]
@ -344,17 +350,25 @@ module Bindings = struct
in
loop String.Set.empty [] l)
let t elem =
let dparse elem =
switch_file_kind
~jbuild:(jbuild elem)
~dune:(dune elem)
let sexp_of_t sexp_of_a bindings =
let dgen dgen bindings =
Dsexp.List (
List.map bindings ~f:(function
| Unnamed a -> dgen a
| Named (name, bindings) ->
Dsexp.List (Dsexp.atom (":" ^ name) :: List.map ~f:dgen bindings))
)
let to_sexp sexp_of_a bindings =
Sexp.List (
List.map bindings ~f:(function
| Unnamed a -> sexp_of_a a
| Named (name, bindings) ->
Sexp.List (Sexp.atom (":" ^ name) :: List.map ~f:sexp_of_a bindings))
Sexp.List (Sexp.To_sexp.string (":" ^ name) :: List.map ~f:sexp_of_a bindings))
)
end
@ -368,9 +382,18 @@ module Dep_conf = struct
| Package of String_with_vars.t
| Universe
let t =
let t =
let sw = String_with_vars.t in
let remove_locs = function
| File sw -> File (String_with_vars.remove_locs sw)
| Alias sw -> Alias (String_with_vars.remove_locs sw)
| Alias_rec sw -> Alias_rec (String_with_vars.remove_locs sw)
| Glob_files sw -> Glob_files (String_with_vars.remove_locs sw)
| Source_tree sw -> Source_tree (String_with_vars.remove_locs sw)
| Package sw -> Package (String_with_vars.remove_locs sw)
| Universe -> Universe
let dparse =
let dparse =
let sw = String_with_vars.dparse in
sum
[ "file" , (sw >>| fun x -> File x)
; "alias" , (sw >>| fun x -> Alias x)
@ -390,31 +413,33 @@ module Dep_conf = struct
]
in
if_list
~then_:t
~else_:(String_with_vars.t >>| fun x -> File x)
~then_:dparse
~else_:(String_with_vars.dparse >>| fun x -> File x)
open Sexp
let sexp_of_t = function
open Dsexp
let dgen = function
| File t ->
List [ Sexp.unsafe_atom_of_string "file"
; String_with_vars.sexp_of_t t ]
List [ Dsexp.unsafe_atom_of_string "file"
; String_with_vars.dgen t ]
| Alias t ->
List [ Sexp.unsafe_atom_of_string "alias"
; String_with_vars.sexp_of_t t ]
List [ Dsexp.unsafe_atom_of_string "alias"
; String_with_vars.dgen t ]
| Alias_rec t ->
List [ Sexp.unsafe_atom_of_string "alias_rec"
; String_with_vars.sexp_of_t t ]
List [ Dsexp.unsafe_atom_of_string "alias_rec"
; String_with_vars.dgen t ]
| Glob_files t ->
List [ Sexp.unsafe_atom_of_string "glob_files"
; String_with_vars.sexp_of_t t ]
List [ Dsexp.unsafe_atom_of_string "glob_files"
; String_with_vars.dgen t ]
| Source_tree t ->
List [ Sexp.unsafe_atom_of_string "files_recursively_in"
; String_with_vars.sexp_of_t t ]
List [ Dsexp.unsafe_atom_of_string "files_recursively_in"
; String_with_vars.dgen t ]
| Package t ->
List [ Sexp.unsafe_atom_of_string "package"
; String_with_vars.sexp_of_t t]
List [ Dsexp.unsafe_atom_of_string "package"
; String_with_vars.dgen t]
| Universe ->
Sexp.unsafe_atom_of_string "universe"
Dsexp.unsafe_atom_of_string "universe"
let to_sexp t = Dsexp.to_sexp (dgen t)
end
module Preprocess = struct
@ -429,20 +454,20 @@ module Preprocess = struct
| Action of Loc.t * Action.Unexpanded.t
| Pps of pps
let t =
let dparse =
sum
[ "no_preprocessing", return No_preprocessing
; "action",
(located Action.Unexpanded.t >>| fun (loc, x) ->
(located Action.Unexpanded.dparse >>| fun (loc, x) ->
Action (loc, x))
; "pps",
(let%map loc = loc
and pps, flags = Pps_and_flags.t in
and pps, flags = Pps_and_flags.dparse in
Pps { loc; pps; flags; staged = false })
; "staged_pps",
(let%map () = Syntax.since Stanza.syntax (1, 1)
and loc = loc
and pps, flags = Pps_and_flags.t in
and pps, flags = Pps_and_flags.dparse in
Pps { loc; pps; flags; staged = true })
]
@ -464,36 +489,36 @@ module Blang = struct
; "<>", Neq
]
let t =
let dparse =
let ops =
List.map ops ~f:(fun (name, op) ->
( name
, (let%map x = String_with_vars.t
and y = String_with_vars.t
, (let%map x = String_with_vars.dparse
and y = String_with_vars.dparse
in
Compare (op, x, y))))
in
let t =
fix begin fun (t : String_with_vars.t Blang.t Sexp.Of_sexp.t) ->
let dparse =
fix begin fun (t : String_with_vars.t Blang.t Dsexp.Of_sexp.t) ->
if_list
~then_:(
[ "or", repeat t >>| (fun x -> Or x)
; "and", repeat t >>| (fun x -> And x)
] @ ops
|> sum)
~else_:(String_with_vars.t >>| fun v -> Expr v)
~else_:(String_with_vars.dparse >>| fun v -> Expr v)
end
in
let%map () = Syntax.since Stanza.syntax (1, 1)
and t = t
and dparse = dparse
in
t
dparse
end
module Per_module = struct
include Per_item.Make(Module.Name)
let t ~default a =
let dparse ~default a =
peek_exn >>= function
| List (loc, Atom (_, A "per_module") :: _) ->
sum [ "per_module",
@ -517,7 +542,7 @@ end
module Preprocess_map = struct
type t = Preprocess.t Per_module.t
let t = Per_module.t Preprocess.t ~default:Preprocess.No_preprocessing
let dparse = Per_module.dparse Preprocess.dparse ~default:Preprocess.No_preprocessing
let no_preprocessing = Per_module.for_all Preprocess.No_preprocessing
@ -537,7 +562,7 @@ end
module Lint = struct
type t = Preprocess_map.t
let t = Preprocess_map.t
let dparse = Preprocess_map.dparse
let default = Preprocess_map.default
let no_lint = default
@ -552,7 +577,7 @@ module Js_of_ocaml = struct
; javascript_files : string list
}
let t =
let dparse =
record
(let%map flags = field_oslu "flags"
and javascript_files = field "javascript_files" (list string) ~default:[]
@ -617,7 +642,7 @@ module Lib_dep = struct
in
loop String.Set.empty String.Set.empty preds)
let t =
let dparse =
if_list
~then_:(
enter
@ -649,9 +674,9 @@ module Lib_deps = struct
| Optional
| Forbidden
let t =
let dparse =
let%map loc = loc
and t = repeat Lib_dep.t
and t = repeat Lib_dep.dparse
in
let add kind name acc =
match String.Map.find acc name with
@ -686,7 +711,7 @@ module Lib_deps = struct
: kind String.Map.t);
t
let t = parens_removed_in_dune t
let dparse = parens_removed_in_dune dparse
let of_pps pps =
List.map pps ~f:(fun pp -> Lib_dep.of_pp (Loc.none, pp))
@ -720,22 +745,22 @@ module Buildable = struct
let modules_field name = Ordered_set_lang.field name
let t =
let dparse =
let%map loc = loc
and preprocess =
field "preprocess" Preprocess_map.t ~default:Preprocess_map.default
field "preprocess" Preprocess_map.dparse ~default:Preprocess_map.default
and preprocessor_deps =
field "preprocessor_deps" (list Dep_conf.t) ~default:[]
and lint = field "lint" Lint.t ~default:Lint.default
field "preprocessor_deps" (list Dep_conf.dparse) ~default:[]
and lint = field "lint" Lint.dparse ~default:Lint.default
and modules = modules_field "modules"
and modules_without_implementation =
modules_field "modules_without_implementation"
and libraries = field "libraries" Lib_deps.t ~default:[]
and libraries = field "libraries" Lib_deps.dparse ~default:[]
and flags = field_oslu "flags"
and ocamlc_flags = field_oslu "ocamlc_flags"
and ocamlopt_flags = field_oslu "ocamlopt_flags"
and js_of_ocaml =
field "js_of_ocaml" Js_of_ocaml.t ~default:Js_of_ocaml.default
field "js_of_ocaml" Js_of_ocaml.dparse ~default:Js_of_ocaml.default
and allow_overlapping_dependencies =
field_b "allow_overlapping_dependencies"
in
@ -803,7 +828,7 @@ module Sub_system_info = struct
val name : Sub_system_name.t
val loc : t -> Loc.t
val syntax : Syntax.t
val parse : t Sexp.Of_sexp.t
val parse : t Dsexp.Of_sexp.t
end
let all = Sub_system_name.Table.create ~default_value:None
@ -846,7 +871,7 @@ module Mode_conf = struct
end
include T
let t =
let dparse =
enum
[ "byte" , Byte
; "native", Native
@ -861,13 +886,13 @@ module Mode_conf = struct
let pp fmt t =
Format.pp_print_string fmt (to_string t)
let sexp_of_t t =
Sexp.unsafe_atom_of_string (to_string t)
let dgen t =
Dsexp.unsafe_atom_of_string (to_string t)
module Set = struct
include Set.Make(T)
let t = list t >>| of_list
let dparse = list dparse >>| of_list
let default = of_list [Byte; Best]
@ -886,7 +911,7 @@ module Library = struct
| Ppx_deriver
| Ppx_rewriter
let t =
let dparse =
enum
[ "normal" , Normal
; "ppx_deriver" , Ppx_deriver
@ -920,11 +945,11 @@ module Library = struct
; dune_version : Syntax.Version.t
}
let t =
let dparse =
record
(let%map buildable = Buildable.t
(let%map buildable = Buildable.dparse
and loc = loc
and name = field_o "name" Lib_name.t
and name = field_o "name" Lib_name.dparse
and public = Public_lib.public_name_field
and synopsis = field_o "synopsis" string
and install_c_headers =
@ -939,8 +964,8 @@ module Library = struct
and c_library_flags = field_oslu "c_library_flags"
and virtual_deps =
field "virtual_deps" (list (located string)) ~default:[]
and modes = field "modes" Mode_conf.Set.t ~default:Mode_conf.Set.default
and kind = field "kind" Kind.t ~default:Kind.Normal
and modes = field "modes" Mode_conf.Set.dparse ~default:Mode_conf.Set.default
and kind = field "kind" Kind.dparse ~default:Kind.Normal
and wrapped = field "wrapped" bool ~default:true
and optional = field_b "optional"
and self_build_stubs_archive =
@ -1038,7 +1063,7 @@ module Install_conf = struct
| List (_, [Atom (_, A src); Atom (_, A "as"); Atom (_, A dst)]) ->
junk >>> return { src; dst = Some dst }
| sexp ->
of_sexp_error (Sexp.Ast.loc sexp)
of_sexp_error (Dsexp.Ast.loc sexp)
"invalid format, <name> or (<name> as <install-as>) expected"
type t =
@ -1047,9 +1072,9 @@ module Install_conf = struct
; package : Package.t
}
let t =
let dparse =
record
(let%map section = field "section" Install.Section.t
(let%map section = field "section" Install.Section.dparse
and files = field "files" (list file)
and package = Pkg.field "install"
in
@ -1105,37 +1130,37 @@ module Executables = struct
]
let simple =
Sexp.Of_sexp.enum simple_representations
Dsexp.Of_sexp.enum simple_representations
let t =
let dparse =
if_list
~then_:
(enter
(let%map mode = Mode_conf.t
and kind = Binary_kind.t in
(let%map mode = Mode_conf.dparse
and kind = Binary_kind.dparse in
{ mode; kind }))
~else_:simple
let simple_sexp_of_t link_mode =
let simple_dgen link_mode =
let is_ok (_, candidate) =
compare candidate link_mode = Eq
in
match List.find ~f:is_ok simple_representations with
| Some (s, _) -> Some (Sexp.unsafe_atom_of_string s)
| Some (s, _) -> Some (Dsexp.unsafe_atom_of_string s)
| None -> None
let sexp_of_t link_mode =
match simple_sexp_of_t link_mode with
let dgen link_mode =
match simple_dgen link_mode with
| Some s -> s
| None ->
let { mode; kind } = link_mode in
Sexp.To_sexp.pair Mode_conf.sexp_of_t Binary_kind.sexp_of_t (mode, kind)
Dsexp.To_sexp.pair Mode_conf.dgen Binary_kind.dgen (mode, kind)
module Set = struct
include Set.Make(T)
let t =
located (list t) >>| fun (loc, l) ->
let dparse =
located (list dparse) >>| fun (loc, l) ->
match l with
| [] -> of_sexp_errorf loc "No linking mode defined"
| l ->
@ -1175,12 +1200,12 @@ module Executables = struct
s
let common =
let%map buildable = Buildable.t
let%map buildable = Buildable.dparse
and (_ : bool) = field "link_executables" ~default:true
(Syntax.deleted_in Stanza.syntax (1, 0) >>> bool)
and link_deps = field "link_deps" (list Dep_conf.t) ~default:[]
and link_deps = field "link_deps" (list Dep_conf.dparse) ~default:[]
and link_flags = field_oslu "link_flags"
and modes = field "modes" Link_mode.Set.t ~default:Link_mode.Set.default
and modes = field "modes" Link_mode.Set.dparse ~default:Link_mode.Set.default
and () = map_validate
(field "inline_tests" (repeat junk >>| fun _ -> true) ~default:false)
~f:(function
@ -1240,9 +1265,9 @@ module Executables = struct
match Link_mode.Set.best_install_mode t.modes with
| None when has_public_name ->
let mode_to_string mode =
" - " ^ Sexp.to_string ~syntax:Dune (Link_mode.sexp_of_t mode) in
" - " ^ Dsexp.to_string ~syntax:Dune (Link_mode.dgen mode) in
let mode_strings = List.map ~f:mode_to_string Link_mode.installable_modes in
Loc.fail
Errors.fail
buildable.loc
"No installable mode found for %s.\n\
One of the following modes is required:\n\
@ -1278,8 +1303,8 @@ module Executables = struct
| Some (loc, _) ->
let func =
match file_kind with
| Jbuild -> Loc.warn
| Dune -> Loc.fail
| Jbuild -> Errors.warn
| Dune -> Errors.fail
in
func loc
"This field is useless without a (public_name%s ...) field."
@ -1358,7 +1383,7 @@ module Rule = struct
| Not_a_rule_stanza
| Ignore_source_files
let t =
let dparse =
enum
[ "standard" , Standard
; "fallback" , Fallback
@ -1366,7 +1391,7 @@ module Rule = struct
; "promote-until-clean", Promote_but_delete_on_clean
]
let field = field "mode" t ~default:Standard
let field = field "mode" dparse ~default:Standard
end
type t =
@ -1411,7 +1436,7 @@ module Rule = struct
]
let short_form =
located Action.Unexpanded.t >>| fun (loc, action) ->
located Action.Unexpanded.dparse >>| fun (loc, action) ->
{ targets = Infer
; deps = Bindings.empty
; action = (loc, action)
@ -1422,10 +1447,11 @@ module Rule = struct
let long_form =
let%map loc = loc
and action = field "action" (located Action.Unexpanded.t)
and action = field "action" (located Action.Unexpanded.dparse)
and targets = field "targets" (list file_in_current_dir)
and deps = field "deps" (Bindings.t Dep_conf.t) ~default:Bindings.empty
and locks = field "locks" (list String_with_vars.t) ~default:[]
and deps =
field "deps" (Bindings.dparse Dep_conf.dparse) ~default:Bindings.empty
and locks = field "locks" (list String_with_vars.dparse) ~default:[]
and mode =
map_validate
(let%map fallback =
@ -1433,7 +1459,7 @@ module Rule = struct
~check:(Syntax.renamed_in Stanza.syntax (1, 0)
~to_:"(mode fallback)")
"fallback"
and mode = field_o "mode" Mode.t
and mode = field_o "mode" Mode.dparse
in
(fallback, mode))
~f:(function
@ -1472,10 +1498,10 @@ module Rule = struct
| Some Action -> short_form
end
| sexp ->
of_sexp_errorf (Sexp.Ast.loc sexp)
of_sexp_errorf (Dsexp.Ast.loc sexp)
"S-expression of the form (<atom> ...) expected"
let t =
let dparse =
switch_file_kind
~jbuild:jbuild_syntax
~dune:dune_syntax
@ -1582,7 +1608,7 @@ module Menhir = struct
~desc:"the menhir extension"
[ (1, 0) ]
let t =
let dparse =
record
(let%map merge_into = field_o "merge_into" string
and flags = field_oslu "flags"
@ -1599,7 +1625,7 @@ module Menhir = struct
let () =
Dune_project.Extension.register syntax
(return [ "menhir", t >>| fun x -> [T x] ])
(return [ "menhir", dparse >>| fun x -> [T x] ])
(* Syntax for jbuild files *)
let jbuild_syntax =
@ -1634,15 +1660,15 @@ module Alias_conf = struct
else
s)
let t =
let dparse =
record
(let%map name = field "name" alias_name
and loc = loc
and package = field_o "package" Pkg.t
and action = field_o "action" (located Action.Unexpanded.t)
and locks = field "locks" (list String_with_vars.t) ~default:[]
and deps = field "deps" (Bindings.t Dep_conf.t) ~default:Bindings.empty
and enabled_if = field_o "enabled_if" Blang.t
and package = field_o "package" Pkg.dparse
and action = field_o "action" (located Action.Unexpanded.dparse)
and locks = field "locks" (list String_with_vars.dparse) ~default:[]
and deps = field "deps" (Bindings.dparse Dep_conf.dparse) ~default:Bindings.empty
and enabled_if = field_o "enabled_if" Blang.dparse
in
{ name
; deps
@ -1665,15 +1691,16 @@ module Tests = struct
let gen_parse names =
record
(let%map buildable = Buildable.t
(let%map buildable = Buildable.dparse
and link_flags = field_oslu "link_flags"
and names = names
and package = field_o "package" Pkg.t
and locks = field "locks" (list String_with_vars.t) ~default:[]
and modes = field "modes" Executables.Link_mode.Set.t
and package = field_o "package" Pkg.dparse
and locks = field "locks" (list String_with_vars.dparse) ~default:[]
and modes = field "modes" Executables.Link_mode.Set.dparse
~default:Executables.Link_mode.Set.default
and deps = field "deps" (Bindings.t Dep_conf.t) ~default:Bindings.empty
and enabled_if = field_o "enabled_if" Blang.t
and deps =
field "deps" (Bindings.dparse Dep_conf.dparse) ~default:Bindings.empty
and enabled_if = field_o "enabled_if" Blang.dparse
in
{ exes =
{ Executables.
@ -1699,7 +1726,7 @@ module Copy_files = struct
; glob : String_with_vars.t
}
let t = String_with_vars.t
let dparse = String_with_vars.dparse
end
module Documentation = struct
@ -1709,7 +1736,7 @@ module Documentation = struct
; mld_files : Ordered_set_lang.t
}
let t =
let dparse =
record
(let%map package = Pkg.field "documentation"
and mld_files = Ordered_set_lang.field "mld_files"
@ -1724,7 +1751,7 @@ end
module Include_subdirs = struct
type t = No | Unqualified
let t =
let dparse =
enum
[ "no", No
; "unqualified", Unqualified
@ -1756,17 +1783,17 @@ module Stanzas = struct
type Stanza.t += Include of Loc.t * string
type constructors = (string * Stanza.t list Sexp.Of_sexp.t) list
type constructors = (string * Stanza.t list Dsexp.Of_sexp.t) list
let stanzas : constructors =
[ "library",
(let%map x = Library.t in
(let%map x = Library.dparse in
[Library x])
; "executable" , Executables.single >>| execs
; "executables", Executables.multi >>| execs
; "rule",
(let%map loc = loc
and x = Rule.t in
and x = Rule.dparse in
[Rule { x with loc }])
; "ocamllex",
(let%map loc = loc
@ -1777,27 +1804,27 @@ module Stanzas = struct
and x = Rule.ocamlyacc in
rules (Rule.ocamlyacc_to_rule loc x))
; "install",
(let%map x = Install_conf.t in
(let%map x = Install_conf.dparse in
[Install x])
; "alias",
(let%map x = Alias_conf.t in
(let%map x = Alias_conf.dparse in
[Alias x])
; "copy_files",
(let%map glob = Copy_files.t in
(let%map glob = Copy_files.dparse in
[Copy_files {add_line_directive = false; glob}])
; "copy_files#",
(let%map glob = Copy_files.t in
(let%map glob = Copy_files.dparse in
[Copy_files {add_line_directive = true; glob}])
; "include",
(let%map loc = loc
and fn = relative_file in
[Include (loc, fn)])
; "documentation",
(let%map d = Documentation.t in
(let%map d = Documentation.dparse in
[Documentation d])
; "jbuild_version",
(let%map () = Syntax.deleted_in Stanza.syntax (1, 0)
and _ = Jbuild_version.t in
and _ = Jbuild_version.dparse in
[])
; "tests",
(let%map () = Syntax.since Stanza.syntax (1, 0)
@ -1808,11 +1835,11 @@ module Stanzas = struct
and t = Tests.single in
[Tests t])
; "env",
(let%map x = Dune_env.Stanza.t in
(let%map x = Dune_env.Stanza.dparse in
[Dune_env.T x])
; "include_subdirs",
(let%map () = Syntax.since Stanza.syntax (1, 1)
and t = Include_subdirs.t
and t = Include_subdirs.dparse
and loc = loc in
[Include_subdirs (loc, t)])
]
@ -1837,18 +1864,18 @@ module Stanzas = struct
exception Include_loop of Path.t * (Loc.t * Path.t) list
let rec parse stanza_parser ~lexer ~current_file ~include_stack sexps =
List.concat_map sexps ~f:(Sexp.Of_sexp.parse stanza_parser Univ_map.empty)
List.concat_map sexps ~f:(Dsexp.Of_sexp.parse stanza_parser Univ_map.empty)
|> List.concat_map ~f:(function
| Include (loc, fn) ->
let include_stack = (loc, current_file) :: include_stack in
let dir = Path.parent_exn current_file in
let current_file = Path.relative dir fn in
if not (Path.exists current_file) then
Loc.fail loc "File %s doesn't exist."
Errors.fail loc "File %s doesn't exist."
(Path.to_string_maybe_quoted current_file);
if List.exists include_stack ~f:(fun (_, f) -> Path.equal f current_file) then
raise (Include_loop (current_file, include_stack));
let sexps = Io.Sexp.load ~lexer current_file ~mode:Many in
let sexps = Dsexp.Io.load ~lexer current_file ~mode:Many in
parse stanza_parser sexps ~lexer ~current_file ~include_stack
| stanza -> [stanza])
@ -1856,8 +1883,8 @@ module Stanzas = struct
let (stanza_parser, lexer) =
let (parser, lexer) =
match (kind : File_tree.Dune_file.Kind.t) with
| Jbuild -> (jbuild_parser, Usexp.Lexer.jbuild_token)
| Dune -> (Dune_project.stanza_parser project, Usexp.Lexer.token)
| Jbuild -> (jbuild_parser, Dsexp.Lexer.jbuild_token)
| Dune -> (Dune_project.stanza_parser project, Dsexp.Lexer.token)
in
(Dune_project.set project parser, lexer)
in
@ -1873,7 +1900,7 @@ module Stanzas = struct
(Path.to_string_maybe_quoted file)
loc.Loc.start.pos_lnum
in
Loc.fail loc
Errors.fail loc
"Recursive inclusion of jbuild files detected:\n\
File %s is included from %s%s"
(Path.to_string_maybe_quoted file)
@ -1889,6 +1916,6 @@ module Stanzas = struct
~f:(function Dune_env.T e -> Some e | _ -> None)
with
| _ :: e :: _ ->
Loc.fail e.loc "The 'env' stanza cannot appear more than once"
Errors.fail e.loc "The 'env' stanza cannot appear more than once"
| _ -> stanzas
end

24
src/dune_file.mli
View File

@ -1,5 +1,6 @@
(** Representation and parsing of jbuild files *)
open! Stdune
open Import
(** Ppx preprocessors *)
@ -90,6 +91,8 @@ module Bindings : sig
type 'a t = 'a one list
val map : 'a t -> f:('a -> 'b) -> 'b t
val find : 'a t -> string -> 'a list option
val fold : 'a t -> f:('a one -> 'acc -> 'acc) -> init:'acc -> 'acc
@ -100,7 +103,9 @@ module Bindings : sig
val singleton : 'a -> 'a t
val sexp_of_t : ('a -> Usexp.t) -> 'a t -> Usexp.t
val dgen : 'a Dsexp.To_sexp.t -> 'a t Dsexp.To_sexp.t
val to_sexp : 'a Sexp.To_sexp.t -> 'a t Sexp.To_sexp.t
end
module Dep_conf : sig
@ -113,8 +118,10 @@ module Dep_conf : sig
| Package of String_with_vars.t
| Universe
val t : t Sexp.Of_sexp.t
val sexp_of_t : t -> Sexp.t
val remove_locs : t -> t
include Dsexp.Sexpable with type t := t
val to_sexp : t Sexp.To_sexp.t
end
module Buildable : sig
@ -170,7 +177,7 @@ module Sub_system_info : sig
val syntax : Syntax.t
(** Parse parameters written by the user in jbuid/dune files *)
val parse : t Sexp.Of_sexp.t
val parse : t Dsexp.Of_sexp.t
end
module Register(M : S) : sig end
@ -184,13 +191,13 @@ module Mode_conf : sig
| Native
| Best (** [Native] if available and [Byte] if not *)
val t : t Sexp.Of_sexp.t
val dparse : t Dsexp.Of_sexp.t
val compare : t -> t -> Ordering.t
val pp : Format.formatter -> t -> unit
module Set : sig
include Set.S with type elt = t
val t : t Sexp.Of_sexp.t
val dparse : t Dsexp.Of_sexp.t
(** Both Byte and Native *)
val default : t
@ -260,8 +267,7 @@ module Executables : sig
; kind : Binary_kind.t
}
val t : t Sexp.Of_sexp.t
val sexp_of_t : t Sexp.To_sexp.t
include Dsexp.Sexpable with type t := t
val exe : t
val object_ : t
@ -391,6 +397,6 @@ module Stanzas : sig
: file:Path.t
-> kind:File_tree.Dune_file.Kind.t
-> Dune_project.t
-> Sexp.Ast.t list
-> Dsexp.Ast.t list
-> t
end

33
src/dune_fmt.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open! Import
let parse_file path_opt =
@ -13,20 +14,20 @@ let parse_file path_opt =
let contents = String.concat ~sep:"\n" lines in
("<stdin>", contents)
in
Sexp.parse_string
Dsexp.parse_string
~fname
~mode:Usexp.Parser.Mode.Many
~mode:Dsexp.Parser.Mode.Many
contents
let can_be_displayed_inline =
List.for_all ~f:(function
| Usexp.Atom _
| Usexp.Quoted_string _
| Usexp.Template _
| Usexp.List [_]
| Dsexp.Atom _
| Dsexp.Quoted_string _
| Dsexp.Template _
| Dsexp.List [_]
->
true
| Usexp.List _
| Dsexp.List _
->
false
)
@ -42,21 +43,21 @@ let print_inline_list fmt indent sexps =
first := false
else
Format.pp_print_string fmt " ";
Usexp.pp Usexp.Dune fmt sexp
Dsexp.pp Dsexp.Dune fmt sexp
);
Format.pp_print_string fmt ")"
let rec pp_sexp indent fmt =
function
( Usexp.Atom _
| Usexp.Quoted_string _
| Usexp.Template _
( Dsexp.Atom _
| Dsexp.Quoted_string _
| Dsexp.Template _
) as sexp
->
Format.fprintf fmt "%a%a"
pp_indent indent
(Usexp.pp Usexp.Dune) sexp
| Usexp.List sexps
(Dsexp.pp Dsexp.Dune) sexp
| Dsexp.List sexps
->
if can_be_displayed_inline sexps then
print_inline_list fmt indent sexps
@ -96,7 +97,7 @@ let pp_top_sexps fmt sexps =
first := false
else
Format.pp_print_string fmt "\n";
pp_top_sexp fmt (Sexp.Ast.remove_locs sexp);
pp_top_sexp fmt (Dsexp.Ast.remove_locs sexp);
)
let with_output path_opt k =
@ -110,10 +111,10 @@ let with_output path_opt k =
let format_file ~input ~output =
match parse_file input with
| exception Usexp.Parse_error e ->
| exception Dsexp.Parse_error e ->
Printf.printf
"Parse error: %s\n"
(Usexp.Parse_error.message e)
(Dsexp.Parse_error.message e)
| sexps ->
with_output output (fun fmt ->
pp_top_sexps fmt sexps;

2
src/dune_lexer.mli
View File

@ -1,3 +1,5 @@
open! Stdune
(** Returns [true] if the input starts with "(* -*- tuareg -*- *)" *)
val is_script : Lexing.lexbuf -> bool

3
src/dune_lexer.mll
View File

@ -1,4 +1,5 @@
{
open! Stdune
type first_line =
{ lang : Loc.t * string
; version : Loc.t * string
@ -11,7 +12,7 @@ let make_loc lexbuf : Loc.t =
let invalid_lang_line start lexbuf =
lexbuf.Lexing.lex_start_p <- start;
Loc.fail_lex lexbuf
Errors.fail_lex lexbuf
"Invalid first line, expected: (lang <lang> <version>)"
}

73
src/dune_project.ml
View File

@ -1,13 +1,14 @@
open! Stdune
open Import
open Sexp.Of_sexp
open Dsexp.Of_sexp
module Kind = struct
type t =
| Dune
| Jbuilder
let sexp_of_t t =
Sexp.atom_or_quoted_string
let to_sexp t =
Sexp.Atom
(match t with
| Dune -> "dune"
| Jbuilder -> "jbuilder")
@ -22,8 +23,8 @@ module Name : sig
val to_string_hum : t -> string
val named_of_sexp : t Sexp.Of_sexp.t
val sexp_of_t : t Sexp.To_sexp.t
val dparse : t Dsexp.Of_sexp.t
val to_sexp : t Sexp.To_sexp.t
val encode : t -> string
val decode : string -> t
@ -58,11 +59,11 @@ end = struct
| Named s -> s
| Anonymous p -> sprintf "<anonymous %s>" (Path.to_string_maybe_quoted p)
let sexp_of_t = function
let to_sexp = function
| Named s -> Sexp.To_sexp.string s
| Anonymous p ->
List [ Sexp.unsafe_atom_of_string "anonymous"
; Path.sexp_of_t p
List [ Atom "anonymous"
; Path.to_sexp p
]
let validate name =
@ -84,12 +85,12 @@ end = struct
else
None
let named_of_sexp =
Sexp.Of_sexp.plain_string (fun ~loc s ->
let dparse =
Dsexp.Of_sexp.plain_string (fun ~loc s ->
if validate s then
Named s
else
Sexp.Of_sexp.of_sexp_errorf loc "invalid project name")
Dsexp.Of_sexp.of_sexp_errorf loc "invalid project name")
let encode = function
| Named s -> s
@ -131,10 +132,10 @@ module Project_file = struct
; mutable exists : bool
}
let sexp_of_t { file; exists } =
let to_sexp { file; exists } =
Sexp.To_sexp.(
record
[ "file", Path.sexp_of_t file
[ "file", Path.to_sexp file
; "exists", bool exists
])
end
@ -145,7 +146,7 @@ type t =
; root : Path.Local.t
; version : string option
; packages : Package.t Package.Name.Map.t
; stanza_parser : Stanza.t list Sexp.Of_sexp.t
; stanza_parser : Stanza.t list Dsexp.Of_sexp.t
; project_file : Project_file.t
}
@ -202,14 +203,14 @@ let append_to_project_file t str =
module Extension = struct
type t =
{ syntax : Syntax.t
; stanzas : Stanza.Parser.t list Sexp.Of_sexp.t
; stanzas : Stanza.Parser.t list Dsexp.Of_sexp.t
}
type instance =
{ extension : t
; version : Syntax.Version.t
; loc : Loc.t
; parse_args : Stanza.Parser.t list Sexp.Of_sexp.t -> Stanza.Parser.t list
; parse_args : Stanza.Parser.t list Dsexp.Of_sexp.t -> Stanza.Parser.t list
}
let extensions = Hashtbl.create 32
@ -224,7 +225,7 @@ module Extension = struct
let instantiate ~loc ~parse_args (name_loc, name) (ver_loc, ver) =
match Hashtbl.find extensions name with
| None ->
Loc.fail name_loc "Unknown extension %S.%s" name
Errors.fail name_loc "Unknown extension %S.%s" name
(hint name (Hashtbl.keys extensions))
| Some t ->
Syntax.check_supported t.syntax (ver_loc, ver);
@ -242,7 +243,7 @@ module Extension = struct
if f name then
let version = Syntax.greatest_supported_version ext.syntax in
let parse_args p =
let open Sexp.Of_sexp in
let open Dsexp.Of_sexp in
let dune_project_edited = ref false in
parse (enter p) Univ_map.empty (List (Loc.of_pos __POS__, []))
|> List.map ~f:(fun (name, p) ->
@ -251,10 +252,10 @@ module Extension = struct
if not !dune_project_edited then begin
dune_project_edited := true;
Project_file_edit.append project_file
(Sexp.to_string ~syntax:Dune
(List [ Sexp.atom "using"
; Sexp.atom name
; Sexp.atom (Syntax.Version.to_string version)
(Dsexp.to_string ~syntax:Dune
(List [ Dsexp.atom "using"
; Dsexp.atom name
; Dsexp.atom (Syntax.Version.to_string version)
]))
end;
p))
@ -279,16 +280,16 @@ let key =
(fun { name; root; version; project_file; kind
; stanza_parser = _; packages = _ } ->
Sexp.To_sexp.record
[ "name", Name.sexp_of_t name
; "root", Path.Local.sexp_of_t root
[ "name", Name.to_sexp name
; "root", Path.Local.to_sexp root
; "version", Sexp.To_sexp.(option string) version
; "project_file", Project_file.sexp_of_t project_file
; "kind", Kind.sexp_of_t kind
; "project_file", Project_file.to_sexp project_file
; "kind", Kind.to_sexp kind
])
let set t = Sexp.Of_sexp.set key t
let set t = Dsexp.Of_sexp.set key t
let get_exn () =
let open Sexp.Of_sexp in
let open Dsexp.Of_sexp in
get key >>| function
| Some t -> t
| None ->
@ -310,7 +311,7 @@ let anonymous = lazy (
; root = get_local_path Path.root
; version = None
; stanza_parser =
Sexp.Of_sexp.(set_many parsing_context (sum lang.data))
Dsexp.Of_sexp.(set_many parsing_context (sum lang.data))
; project_file = { file = Path.relative Path.root filename; exists = false }
})
@ -330,12 +331,12 @@ let default_name ~dir ~packages =
match Name.named name with
| Some x -> x
| None ->
Loc.fail (Loc.in_file (Path.to_string (Package.opam_file pkg)))
Errors.fail (Loc.in_file (Path.to_string (Package.opam_file pkg)))
"%S is not a valid opam package name."
name
let name_field ~dir ~packages =
let%map name = field_o "name" Name.named_of_sexp in
let%map name = field_o "name" Name.dparse in
match name with
| Some x -> x
| None -> default_name ~dir ~packages
@ -348,7 +349,7 @@ let parse ~dir ~lang ~packages ~file =
multi_field "using"
(let%map loc = loc
and name = located string
and ver = located Syntax.Version.t
and ver = located Syntax.Version.dparse
and parse_args = capture
in
(* We don't parse the arguments quite yet as we want to set
@ -361,7 +362,7 @@ let parse ~dir ~lang ~packages ~file =
(Syntax.name e.extension.syntax, e.loc)))
with
| Error (name, _, loc) ->
Loc.fail loc "Extension %S specified for the second time." name
Errors.fail loc "Extension %S specified for the second time." name
| Ok map ->
let project_file : Project_file.t = { file; exists = true } in
let extensions =
@ -375,14 +376,14 @@ let parse ~dir ~lang ~packages ~file =
(lang.data ::
List.map extensions ~f:(fun (ext : Extension.instance) ->
ext.parse_args
(Sexp.Of_sexp.set_many parsing_context ext.extension.stanzas)))
(Dsexp.Of_sexp.set_many parsing_context ext.extension.stanzas)))
in
{ kind = Dune
; name
; root = get_local_path dir
; version
; packages
; stanza_parser = Sexp.Of_sexp.(set_many parsing_context (sum stanzas))
; stanza_parser = Dsexp.Of_sexp.(set_many parsing_context (sum stanzas))
; project_file
})
@ -399,7 +400,7 @@ let make_jbuilder_project ~dir packages =
; version = None
; packages
; stanza_parser =
Sexp.Of_sexp.(set_many parsing_context (sum lang.data))
Dsexp.Of_sexp.(set_many parsing_context (sum lang.data))
; project_file = { file = Path.relative dir filename; exists = false }
}

11
src/dune_project.mli
View File

@ -1,3 +1,4 @@
open! Stdune
(** dune-project files *)
open Import
@ -22,7 +23,7 @@ module Name : sig
(** Convert to a string that is suitable for human readable messages *)
val to_string_hum : t -> string
val sexp_of_t : t -> Sexp.t
val to_sexp : t Sexp.To_sexp.t
(** Convert to/from an encoded string that is suitable to use in filenames *)
val encode : t -> string
@ -41,7 +42,7 @@ val packages : t -> Package.t Package.Name.Map.t
val version : t -> string option
val name : t -> Name.t
val root : t -> Path.Local.t
val stanza_parser : t -> Stanza.t list Sexp.Of_sexp.t
val stanza_parser : t -> Stanza.t list Dsexp.Of_sexp.t
module Lang : sig
(** [register id stanzas_parser] register a new language. Users will
@ -62,7 +63,7 @@ module Extension : sig
in their [dune-project] file. [parser] is used to describe
what [<args>] might be. *)
val register : Syntax.t -> Stanza.Parser.t list Sexp.Of_sexp.t -> unit
val register : Syntax.t -> Stanza.Parser.t list Dsexp.Of_sexp.t -> unit
end
(** Load a project description from the following directory. [files]
@ -86,5 +87,5 @@ val ensure_project_file_exists : t -> unit
val append_to_project_file : t -> string -> unit
(** Set the project we are currently parsing dune files for *)
val set : t -> ('a, 'k) Sexp.Of_sexp.parser -> ('a, 'k) Sexp.Of_sexp.parser
val get_exn : unit -> (t, 'k) Sexp.Of_sexp.parser
val set : t -> ('a, 'k) Dsexp.Of_sexp.parser -> ('a, 'k) Dsexp.Of_sexp.parser
val get_exn : unit -> (t, 'k) Dsexp.Of_sexp.parser

3
src/env.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open Import
module Var = struct
@ -62,7 +63,7 @@ let extend t ~vars =
let extend_env x y =
extend x ~vars:y.vars
let sexp_of_t t =
let to_sexp t =
let open Sexp.To_sexp in
(list (pair string string)) (Map.to_list t.vars)

4
src/env.mli
View File

@ -1,4 +1,4 @@
open Import
open! Stdune
module Var : sig
type t = string
@ -28,6 +28,6 @@ val diff : t -> t -> t
val update : t -> var:string -> f:(string option -> string option) -> t
val sexp_of_t : t -> Sexp.t
val to_sexp : t -> Sexp.t
val of_string_map : string String.Map.t -> t

83
src/errors.ml
View File

@ -1,4 +1,4 @@
open Stdune
open! Stdune
exception Already_reported
@ -15,3 +15,84 @@ let kerrf fmt ~f =
let die fmt =
kerrf fmt ~f:(fun s -> raise (Exn.Fatal_error s))
let exnf t fmt =
Format.pp_open_box err_ppf 0;
Format.pp_print_as err_ppf 7 ""; (* "Error: " *)
kerrf (fmt^^ "@]") ~f:(fun s -> Exn.Loc_error (t, s))
let fail t fmt =
Format.pp_print_as err_ppf 7 ""; (* "Error: " *)
kerrf fmt ~f:(fun s ->
raise (Exn.Loc_error (t, s)))
let fail_lex lb fmt =
fail (Loc.of_lexbuf lb) fmt
let fail_opt t fmt =
match t with
| None -> die fmt
| Some t -> fail t fmt
let file_line path n =
Io.with_file_in ~binary:false path
~f:(fun ic ->
for _ = 1 to n - 1 do
ignore (input_line ic)
done;
input_line ic
)
let file_lines path ~start ~stop =
Io.with_file_in ~binary:true path
~f:(fun ic ->
let rec aux acc lnum =
if lnum > stop then
List.rev acc
else if lnum < start then
(ignore (input_line ic);
aux acc (lnum + 1))
else
let line = input_line ic in
aux ((string_of_int lnum, line) :: acc) (lnum + 1)
in
aux [] 1
)
let print ppf loc =
let { Loc.start; stop } = loc in
let start_c = start.pos_cnum - start.pos_bol in
let stop_c = stop.pos_cnum - start.pos_bol in
let num_lines = stop.pos_lnum - start.pos_lnum in
let pp_file_excerpt pp () =
let whole_file = start_c = 0 && stop_c = 0 in
if not whole_file then
let path = Path.of_string start.pos_fname in
if Path.exists path then
let line = file_line path start.pos_lnum in
if stop_c <= String.length line then
let len = stop_c - start_c in
Format.fprintf pp "%s\n%*s\n" line
stop_c
(String.make len '^')
else if num_lines <= 10 then
let lines = file_lines path ~start:start.pos_lnum ~stop:stop.pos_lnum in
let last_lnum = Option.map ~f:fst (List.last lines) in
let padding_width = Option.value_exn
(Option.map ~f:String.length last_lnum) in
List.iter ~f:(fun (lnum, l) ->
Format.fprintf pp "%*s: %s\n" padding_width lnum l)
lines
in
Format.fprintf ppf
"@{<loc>File \"%s\", line %d, characters %d-%d:@}@\n%a"
start.pos_fname start.pos_lnum start_c stop_c
pp_file_excerpt ()
(* This is ugly *)
let printer = ref (Printf.eprintf "%s%!")
let print_to_console s = !printer s
let warn t fmt =
kerrf ~f:print_to_console
("%a@{<warning>Warning@}: " ^^ fmt ^^ "@.") print t

16
src/errors.mli
View File

@ -1,3 +1,4 @@
open Stdune
(** Dealing with errors *)
(* CR-soon diml: stop including this in [Import] *)
@ -21,3 +22,18 @@ val kerrf
: ('a, Format.formatter, unit, 'b) format4
-> f:(string -> 'b)
-> 'a
val exnf : Loc.t -> ('a, Format.formatter, unit, exn) format4 -> 'a
val fail : Loc.t -> ('a, Format.formatter, unit, 'b ) format4 -> 'a
val fail_lex : Lexing.lexbuf -> ('a, Format.formatter, unit, 'b ) format4 -> 'a
val fail_opt : Loc.t option -> ('a, Format.formatter, unit, 'b ) format4 -> 'a
(** Prints "File ..., line ..., characters ...:\n" *)
val print : Format.formatter -> Loc.t -> unit
(** Prints a warning *)
val warn : Loc.t -> ('a, Format.formatter, unit) format -> 'a
val print_to_console : string -> unit
val printer : (string -> unit) ref

1
src/exe.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open Import
open Build.O

4
src/fiber/fiber.ml
View File

@ -1,4 +1,4 @@
open Stdune
open! Stdune
module Execution_context : sig
type t
@ -234,7 +234,7 @@ module Var = struct
fiber ctx k
let create () =
create ~name:"var" (fun _ -> Sexp.atom_or_quoted_string "var")
create ~name:"var" (fun _ -> Sexp.To_sexp.string "var")
end
let with_error_handler f ~on_error ctx k =

2
src/fiber/fiber.mli
View File

@ -1,6 +1,6 @@
(** Concurrency library *)
open Stdune
open! Stdune
(** {1 Generals} *)

28
src/file_tree.ml
View File

@ -1,8 +1,9 @@
open! Stdune
open! Import
module Dune_file = struct
module Kind = struct
type t = Usexp.syntax = Jbuild | Dune
type t = Dsexp.syntax = Jbuild | Dune
let of_basename = function
| "dune" -> Dune
@ -10,14 +11,14 @@ module Dune_file = struct
| _ -> assert false
let lexer = function
| Dune -> Sexp.Lexer.token
| Jbuild -> Sexp.Lexer.jbuild_token
| Dune -> Dsexp.Lexer.token
| Jbuild -> Dsexp.Lexer.jbuild_token
end
module Plain = struct
type t =
{ path : Path.t
; mutable sexps : Sexp.Ast.t list
; mutable sexps : Dsexp.Ast.t list
}
end
@ -39,7 +40,7 @@ module Dune_file = struct
let extract_ignored_subdirs =
let stanza =
let open Sexp.Of_sexp in
let open Dsexp.Of_sexp in
let sub_dir =
plain_string (fun ~loc dn ->
if Filename.dirname dn <> Filename.current_dir_name ||
@ -58,9 +59,9 @@ module Dune_file = struct
fun sexps ->
let ignored_subdirs, sexps =
List.partition_map sexps ~f:(fun sexp ->
match (sexp : Sexp.Ast.t) with
match (sexp : Dsexp.Ast.t) with
| List (_, (Atom (_, A "ignored_subdirs") :: _)) ->
Left (Sexp.Of_sexp.parse stanza Univ_map.empty sexp)
Left (Dsexp.Of_sexp.parse stanza Univ_map.empty sexp)
| _ -> Right sexp)
in
let ignored_subdirs =
@ -75,7 +76,7 @@ module Dune_file = struct
(Contents.Ocaml_script file, String.Set.empty)
else
let sexps =
Usexp.Parser.parse lb ~lexer:(Kind.lexer kind) ~mode:Many
Dsexp.Parser.parse lb ~lexer:(Kind.lexer kind) ~mode:Many
in
let ignored_subdirs, sexps = extract_ignored_subdirs sexps in
(Plain { path = file; sexps }, ignored_subdirs)
@ -88,11 +89,12 @@ let load_jbuild_ignore path =
if Filename.dirname fn = Filename.current_dir_name then
true
else begin
Loc.(warn (of_pos ( Path.to_string path
, i + 1, 0
, String.length fn
))
"subdirectory expression %s ignored" fn);
Errors.(warn (Loc.of_pos
( Path.to_string path
, i + 1, 0
, String.length fn
))
"subdirectory expression %s ignored" fn);
false
end)
|> String.Set.of_list

7
src/file_tree.mli
View File

@ -1,12 +1,13 @@
open! Stdune
(** Dune representation of the source tree *)
open! Import
module Dune_file : sig
module Kind : sig
type t = Usexp.syntax = Jbuild | Dune
type t = Dsexp.syntax = Jbuild | Dune
val lexer : t -> Sexp.Lexer.t
val lexer : t -> Dsexp.Lexer.t
end
module Plain : sig
@ -15,7 +16,7 @@ module Dune_file : sig
as we don't need them. *)
type t =
{ path : Path.t
; mutable sexps : Sexp.Ast.t list
; mutable sexps : Dsexp.Ast.t list
}
end

1
src/findlib.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open Import
module P = Variant

1
src/findlib.mli
View File

@ -1,5 +1,6 @@
(** Findlib database *)
open! Stdune
open Import
(** Findlib database *)

1
src/gen_meta.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open Import
open Meta

7
src/gen_rules.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open Import
module Menhir_rules = Menhir
open Dune_file
@ -61,11 +62,11 @@ module Gen(P : Install_rules.Params) = struct
match Module.Name.Map.find modules mod_name with
| Some m ->
if not (Module.has_impl m) then
Loc.fail loc "Module %a has no implementation."
Errors.fail loc "Module %a has no implementation."
Module.Name.pp mod_name
else
{ Exe.Program.name; main_module_name = mod_name }
| None -> Loc.fail loc "Module %a doesn't exist."
| None -> Errors.fail loc "Module %a doesn't exist."
Module.Name.pp mod_name)
in
@ -295,7 +296,7 @@ module Gen(P : Install_rules.Params) = struct
SC.add_rule sctx
(Build.fail ~targets
{ fail = fun () ->
Loc.fail m.loc
Errors.fail m.loc
"I can't determine what library/executable the files \
produced by this stanza are part of."
})

1
src/gen_rules.mli
View File

@ -1,3 +1,4 @@
open! Stdune
open! Import
(* Generate rules. Returns evaluated jbuilds per context names. *)

4
src/glob_lexer.mli
View File

@ -1,3 +1,3 @@
open Import
open Stdune
val parse_string : string -> (Re.t, int * string) result
val parse_string : string -> (Re.t, int * string) Result.result

5
src/glob_lexer.mll
View File

@ -1,4 +1,5 @@
{
open! Stdune
open Re
let no_slash = diff any (char '/')
@ -59,8 +60,8 @@ and char_set st = parse
let parse_string s =
let lb = Lexing.from_string s in
match initial lb with
| re -> Import.Ok re
| re -> Result.Ok re
| exception Failure msg ->
Import.Error (Lexing.lexeme_start lb, msg)
Error (Lexing.lexeme_start lb, msg)
}

6
src/import.ml
View File

@ -1,3 +1,5 @@
open! Stdune
include Stdune
include Errors
@ -87,6 +89,4 @@ module No_io = struct
module Io = struct end
end
(* This is ugly *)
let printer = ref (Printf.eprintf "%s%!")
let print_to_console s = !printer s
let print_to_console = Errors.print_to_console

19
src/inline_tests.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open Import
open Dune_file
open Build.O
@ -37,7 +38,7 @@ module Backend = struct
(let%map loc = loc
and runner_libraries = field "runner_libraries" (list (located string)) ~default:[]
and flags = Ordered_set_lang.Unexpanded.field "flags"
and generate_runner = field_o "generate_runner" (located Action.Unexpanded.t)
and generate_runner = field_o "generate_runner" (located Action.Unexpanded.dparse)
and extends = field "extends" (list (located string)) ~default:[]
in
{ loc
@ -74,21 +75,21 @@ module Backend = struct
resolve x >>= fun lib ->
match get ~loc lib with
| None ->
Error (Loc.exnf loc "%S is not an %s" name
Error (Errors.exnf loc "%S is not an %s" name
(desc ~plural:false))
| Some t -> Ok t))
}
let to_sexp t =
let open Sexp.To_sexp in
let dgen t =
let open Dsexp.To_sexp in
let lib x = string (Lib.name x) in
let f x = string (Lib.name x.lib) in
((1, 0),
record_fields
[ field "runner_libraries" (list lib)
(Result.ok_exn t.runner_libraries)
; field "flags" Ordered_set_lang.Unexpanded.sexp_of_t t.info.flags
; field_o "generate_runner" Action.Unexpanded.sexp_of_t
; field "flags" Ordered_set_lang.Unexpanded.dgen t.info.flags
; field_o "generate_runner" Action.Unexpanded.dgen
(Option.map t.info.generate_runner ~f:snd)
; field "extends" (list f) (Result.ok_exn t.extends) ~default:[]
])
@ -135,7 +136,7 @@ include Sub_system.Register_end_point(
~else_:
(record
(let%map loc = loc
and deps = field "deps" (list Dep_conf.t) ~default:[]
and deps = field "deps" (list Dep_conf.dparse) ~default:[]
and flags = Ordered_set_lang.Unexpanded.field "flags"
and backend = field_o "backend" (located string)
and libraries = field "libraries" (list (located string)) ~default:[]
@ -260,9 +261,7 @@ include Sub_system.Register_end_point(
SC.add_alias_action sctx
~loc:(Some info.loc)
(Build_system.Alias.runtest ~dir)
~stamp:(List [ Sexp.unsafe_atom_of_string "ppx-runner"
; Quoted_string name
])
~stamp:("ppx-runner", name)
(let module A = Action in
let exe = Path.relative inline_test_dir (name ^ ".exe") in
Build.path exe >>>

7
src/install.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open Import
module Section = struct
@ -58,8 +59,8 @@ module Section = struct
|"misc" -> Some Misc
| _ -> None
let t =
let open Sexp.Of_sexp in
let dparse =
let open Dsexp.Of_sexp in
enum
[ "lib" , Lib
; "lib_root" , Lib_root
@ -271,7 +272,7 @@ let load_install_file path =
; pos_cnum = col
}
in
Loc.fail { start = pos; stop = pos } fmt
Errors.fail { start = pos; stop = pos } fmt
in
List.concat_map file.file_contents ~f:(function
| Variable (pos, section, files) -> begin

4
src/install.mli
View File

@ -1,6 +1,6 @@
(** Opam install file *)
open Stdune
open! Stdune
module Section : sig
type t =
@ -19,7 +19,7 @@ module Section : sig
| Man
| Misc
val t : t Sexp.Of_sexp.t
val dparse : t Dsexp.Of_sexp.t
(** [true] iff the executable bit should be set for files installed
in this location. *)

3
src/install_rules.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open Import
open Dune_file
open Build.O
@ -22,7 +23,7 @@ module Gen(P : Params) = struct
(Build.arr (fun () ->
let dune_version = Option.value_exn (Lib.dune_version lib) in
Format.asprintf "%a@."
(Sexp.pp (Stanza.File_kind.of_syntax dune_version))
(Dsexp.pp (Stanza.File_kind.of_syntax dune_version))
(Lib.Sub_system.dump_config lib
|> Installed_dune_file.gen ~dune_version))
>>> Build.write_file_dyn

40
src/installed_dune_file.ml
View File

@ -1,9 +1,9 @@
open Import
open! Stdune
let parse_sub_systems ~parsing_context sexps =
List.filter_map sexps ~f:(fun sexp ->
let name, ver, data =
Sexp.Of_sexp.(parse (triple string (located Syntax.Version.t) raw)
Dsexp.Of_sexp.(parse (triple string (located Syntax.Version.dparse) raw)
parsing_context) sexp
in
match Sub_system_name.get name with
@ -12,12 +12,12 @@ let parse_sub_systems ~parsing_context sexps =
correspond to plugins that are not in use in the current
workspace. *)
None
| Some name -> Some (name, (Sexp.Ast.loc sexp, ver, data)))
| Some name -> Some (name, (Dsexp.Ast.loc sexp, ver, data)))
|> Sub_system_name.Map.of_list
|> (function
| Ok x -> x
| Error (name, _, (loc, _, _)) ->
Loc.fail loc "%S present twice" (Sub_system_name.to_string name))
Errors.fail loc "%S present twice" (Sub_system_name.to_string name))
|> Sub_system_name.Map.mapi ~f:(fun name (_, version, data) ->
let (module M) = Dune_file.Sub_system_info.get name in
Syntax.check_supported M.syntax version;
@ -32,10 +32,10 @@ let parse_sub_systems ~parsing_context sexps =
| (_, _) ->
Univ_map.add parsing_context (Syntax.key M.syntax) (snd version)
in
M.T (Sexp.Of_sexp.parse M.parse parsing_context data))
M.T (Dsexp.Of_sexp.parse M.parse parsing_context data))
let of_sexp =
let open Sexp.Of_sexp in
let open Dsexp.Of_sexp in
let version =
plain_string (fun ~loc -> function
| "1" -> (0, 0)
@ -64,45 +64,45 @@ let load fname =
which point we can decide what lexer to use for the reset of
the file. *)
let state = ref 0 in
let lexer = ref Sexp.Lexer.token in
let lexer = ref Dsexp.Lexer.token in
let lexer lb =
let token : Sexp.Lexer.Token.t = !lexer lb in
let token : Dsexp.Lexer.Token.t = !lexer lb in
(match !state, token with
| 0, Lparen -> state := 1
| 1, Atom (A "dune") -> state := 2
| 2, Atom (A "1") -> state := 3; lexer := Sexp.Lexer.jbuild_token
| 2, Atom (A "2") -> state := 3; lexer := Sexp.Lexer.token
| 2, Atom (A "1") -> state := 3; lexer := Dsexp.Lexer.jbuild_token
| 2, Atom (A "2") -> state := 3; lexer := Dsexp.Lexer.token
| 2, Atom (A version) ->
Loc.fail (Sexp.Loc.of_lexbuf lexbuf) "Unsupported version %S" version
Errors.fail (Loc.of_lexbuf lexbuf) "Unsupported version %S" version
| 3, _ -> ()
| _ ->
Loc.fail (Sexp.Loc.of_lexbuf lexbuf)
Errors.fail (Loc.of_lexbuf lexbuf)
"This <lib>.dune file looks invalid, it should \
contain a S-expression of the form (dune x.y ..)"
);
token
in
Sexp.Of_sexp.parse of_sexp Univ_map.empty
(Sexp.Parser.parse ~lexer ~mode:Single lexbuf))
Dsexp.Of_sexp.parse of_sexp Univ_map.empty
(Dsexp.Parser.parse ~lexer ~mode:Single lexbuf))
let gen ~(dune_version : Syntax.Version.t) confs =
let sexps =
Sub_system_name.Map.to_list confs
|> List.map ~f:(fun (name, (ver, conf)) ->
let (module M) = Dune_file.Sub_system_info.get name in
Sexp.List [ Sexp.atom (Sub_system_name.to_string name)
; Syntax.Version.sexp_of_t ver
Dsexp.List [ Dsexp.atom (Sub_system_name.to_string name)
; Syntax.Version.dgen ver
; conf
])
in
Sexp.List
[ Sexp.unsafe_atom_of_string "dune"
; Sexp.unsafe_atom_of_string
Dsexp.List
[ Dsexp.unsafe_atom_of_string "dune"
; Dsexp.unsafe_atom_of_string
(match dune_version with
| (0, 0) -> "1"
| (x, _) when x >= 1 -> "2"
| (_, _) ->
Exn.code_error "Cannot generate dune with unknown version"
["dune_version", Syntax.Version.sexp_of_t dune_version])
["dune_version", Syntax.Version.to_sexp dune_version])
; List sexps
]

6
src/installed_dune_file.mli
View File

@ -1,9 +1,9 @@
(** Dune files that are installed on the system *)
open Stdune
open! Stdune
val load : Path.t -> Dune_file.Sub_system_info.t Sub_system_name.Map.t
val gen
: dune_version:Syntax.Version.t
-> (Syntax.Version.t * Sexp.t) Sub_system_name.Map.t
-> Sexp.t
-> (Syntax.Version.t * Dsexp.t) Sub_system_name.Map.t
-> Dsexp.t

7
src/jbuild_load.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open Import
open Dune_file
@ -73,7 +74,7 @@ module Jbuilds = struct
(match (kind : File_tree.Dune_file.Kind.t) with
| Jbuild -> ()
| Dune ->
Loc.fail loc
Errors.fail loc
"#require is no longer supported in dune files.\n\
You can use the following function instead of \
Unix.open_process_in:\n\
@ -84,7 +85,7 @@ module Jbuilds = struct
| [] -> acc
| ["unix"] -> Unix
| _ ->
Loc.fail loc
Errors.fail loc
"Using libraries other that \"unix\" is not supported.\n\
See the manual for details.";
in
@ -207,7 +208,7 @@ end
Did you forgot to call [Jbuild_plugin.V*.send]?"
(Path.to_string file);
Fiber.return
(Io.Sexp.load generated_jbuild ~mode:Many
(Dsexp.Io.load generated_jbuild ~mode:Many
~lexer:(File_tree.Dune_file.Kind.lexer kind)
|> Jbuild.parse ~dir ~file ~project ~kind ~ignore_promoted_rules))
>>| fun dynamic ->

2
src/jbuild_load.mli
View File

@ -1,4 +1,4 @@
open Stdune
open! Stdune
module Jbuild : sig
type t =

1
src/js_of_ocaml_rules.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open Import
open! No_io
open Build.O

1
src/js_of_ocaml_rules.mli
View File

@ -1,5 +1,6 @@
(** Generate rules for js_of_ocaml *)
open! Stdune
open Import
open Dune_file

33
src/lib.ml
View File

@ -1,4 +1,5 @@
open Import
open! Stdune
open Result.O
(* +-----------------------------------------------------------------+
@ -202,7 +203,7 @@ module Sub_system0 = struct
module type S = sig
type t
type sub_system += T of t
val to_sexp : (t -> Syntax.Version.t * Sexp.t) option
val dgen : (t -> Syntax.Version.t * Dsexp.t) option
end
type 'a s = (module S with type t = 'a)
@ -319,7 +320,7 @@ exception Error of Error.t
let not_available ~loc reason fmt =
Errors.kerrf fmt ~f:(fun s ->
Loc.fail loc "%s %a" s
Errors.fail loc "%s %a" s
Error.Library_not_available.Reason.pp reason)
(* +-----------------------------------------------------------------+
@ -455,7 +456,7 @@ module Sub_system = struct
-> lib
-> Info.t
-> t
val to_sexp : (t -> Syntax.Version.t * Sexp.t) option
val dgen : (t -> Syntax.Version.t * Dsexp.t) option
end
module type S' = sig
@ -491,7 +492,7 @@ module Sub_system = struct
| M.Info.T info ->
let get ~loc lib' =
if lib.unique_id = lib'.unique_id then
Loc.fail loc "Library %S depends on itself" lib.name
Errors.fail loc "Library %S depends on itself" lib.name
else
M.get lib'
in
@ -502,7 +503,7 @@ module Sub_system = struct
let dump_config lib =
Sub_system_name.Map.filter_map lib.sub_systems ~f:(fun (lazy inst) ->
let (Sub_system0.Instance.T ((module M), t)) = inst in
Option.map ~f:(fun f -> f t) M.to_sexp)
Option.map ~f:(fun f -> f t) M.dgen)
end
(* +-----------------------------------------------------------------+
@ -582,25 +583,25 @@ let check_private_deps lib ~loc ~allow_private_deps =
Ok lib
let already_in_table (info : Info.t) name x =
let to_sexp = Sexp.To_sexp.(pair Path.sexp_of_t string) in
let dgen = Sexp.To_sexp.(pair Path.to_sexp string) in
let sexp =
match x with
| St_initializing x ->
Sexp.List [Sexp.unsafe_atom_of_string "Initializing";
Path.sexp_of_t x.path]
Sexp.List [Sexp.Atom "Initializing";
Path.to_sexp x.path]
| St_found t ->
List [Sexp.unsafe_atom_of_string "Found";
Path.sexp_of_t t.info.src_dir]
List [Sexp.Atom "Found";
Path.to_sexp t.info.src_dir]
| St_not_found ->
Sexp.unsafe_atom_of_string "Not_found"
Sexp.Atom "Not_found"
| St_hidden (_, { path; reason; _ }) ->
List [Sexp.unsafe_atom_of_string "Hidden";
Path.sexp_of_t path; Sexp.atom reason]
List [Sexp.Atom "Hidden";
Path.to_sexp path; Sexp.Atom reason]
in
Exn.code_error
"Lib_db.DB: resolver returned name that's already in the table"
[ "name" , Sexp.atom name
; "returned_lib" , to_sexp (info.src_dir, name)
[ "name" , Sexp.To_sexp.string name
; "returned_lib" , dgen (info.src_dir, name)
; "conflicting_with", sexp
]
@ -1137,7 +1138,7 @@ let report_lib_error ppf (e : Error.t) =
| No_solution_found_for_select { loc } ->
Format.fprintf ppf
"%a@{<error>Error@}: No solution found for this select form.\n"
Loc.print loc
Errors.print loc
| Dependency_cycle cycle ->
Format.fprintf ppf
"@{<error>Error@}: Dependency cycle detected between the \

5
src/lib.mli
View File

@ -1,3 +1,4 @@
open! Stdune
open Import
(** {1 Generals} *)
@ -331,7 +332,7 @@ module Sub_system : sig
-> lib
-> Info.t
-> t
val to_sexp : (t -> Syntax.Version.t * Sexp.t) option
val dgen : (t -> Syntax.Version.t * Dsexp.t) option
end
module Register(M : S) : sig
@ -339,7 +340,7 @@ module Sub_system : sig
val get : lib -> M.t option
end
val dump_config : lib -> (Syntax.Version.t * Sexp.t) Sub_system_name.Map.t
val dump_config : lib -> (Syntax.Version.t * Dsexp.t) Sub_system_name.Map.t
end with type lib := t
(** {1 Dependencies for META files} *)

2
src/lib_deps_info.ml
View File

@ -1,4 +1,4 @@
open Import
open! Stdune
module Kind = struct
type t =

2
src/lib_deps_info.mli
View File

@ -3,7 +3,7 @@
(** This module implements tracking of external library dependencies,
for [dune external-lib-deps] *)
open Import
open! Stdune
module Kind : sig
type t =

3
src/lib_rules.ml
View File

@ -1,3 +1,4 @@
open! Stdune
open Import
open Build.O
open Dune_file
@ -226,7 +227,7 @@ module Gen (P : Install_rules.Params) = struct
if not (match Path.parent p with
| None -> false
| Some p -> Path.Set.mem all_dirs p) then
Loc.fail loc
Errors.fail loc
"File %a is not part of the current directory group. \
This is not allowed."
Path.pp (Path.drop_optional_build_context p)

4
src/lib_rules.mli
View File

@ -1,4 +1,4 @@
open Stdune
open! Stdune
open Dune_file
module Gen (S : sig val sctx : Super_context.t end) : sig
@ -13,6 +13,6 @@ module Gen (S : sig val sctx : Super_context.t end) : sig
-> dir_contents:Dir_contents.t
-> dir:Path.t
-> scope:Scope.t
-> dir_kind:Usexp.syntax
-> dir_kind:Dsexp.syntax
-> Compilation_context.t * Merlin.t
end

146
src/loc.ml
View File

@ -1,146 +0,0 @@
open Import
include Usexp.Loc
(* TODO get rid of all this stuff once this parsing code moves to Usexp and
there will be no circular dependency *)
let int n = Usexp.Atom (Usexp.Atom.of_int n)
let string = Usexp.atom_or_quoted_string
let record l =
let open Usexp in
List (List.map l ~f:(fun (n, v) -> List [Atom(Atom.of_string n); v]))
let sexp_of_position_no_file (p : Lexing.position) =
record
[ "pos_lnum", int p.pos_lnum
; "pos_bol", int p.pos_bol
; "pos_cnum", int p.pos_cnum
]
let sexp_of_t t =
record (* TODO handle when pos_fname differs *)
[ "pos_fname", string t.start.pos_fname
; "start", sexp_of_position_no_file t.start
; "stop", sexp_of_position_no_file t.stop
]
let of_lexbuf lb =
{ start = Lexing.lexeme_start_p lb
; stop = Lexing.lexeme_end_p lb
}
let exnf t fmt =
Format.pp_open_box err_ppf 0;
Format.pp_print_as err_ppf 7 ""; (* "Error: " *)
kerrf (fmt^^ "@]") ~f:(fun s -> Exn.Loc_error (t, s))
let fail t fmt =
Format.pp_print_as err_ppf 7 ""; (* "Error: " *)
kerrf fmt ~f:(fun s ->
raise (Exn.Loc_error (t, s)))
let fail_lex lb fmt =
fail (of_lexbuf lb) fmt
let fail_opt t fmt =
match t with
| None -> die fmt
| Some t -> fail t fmt
let in_file = Usexp.Loc.in_file
let of_pos (fname, lnum, cnum, enum) =
let pos : Lexing.position =
{ pos_fname = fname
; pos_lnum = lnum
; pos_cnum = cnum
; pos_bol = 0
}
in
{ start = pos
; stop = { pos with pos_cnum = enum }
}
let file_line path n =
Io.with_file_in ~binary:false path
~f:(fun ic ->
for _ = 1 to n - 1 do
ignore (input_line ic)
done;
input_line ic
)
let file_lines path ~start ~stop =
Io.with_file_in ~binary:true path
~f:(fun ic ->
let rec aux acc lnum =
if lnum > stop then
List.rev acc
else if lnum < start then
(ignore (input_line ic);
aux acc (lnum + 1))
else
let line = input_line ic in
aux ((string_of_int lnum, line) :: acc) (lnum + 1)
in
aux [] 1
)
let print ppf loc =
let { start; stop } = loc in
let start_c = start.pos_cnum - start.pos_bol in
let stop_c = stop.pos_cnum - start.pos_bol in
let num_lines = stop.pos_lnum - start.pos_lnum in
let pp_file_excerpt pp () =
let whole_file = start_c = 0 && stop_c = 0 in
if not whole_file then
let path = Path.of_string start.pos_fname in
if Path.exists path then
let line = file_line path start.pos_lnum in
if stop_c <= String.length line then
let len = stop_c - start_c in
Format.fprintf pp "%s\n%*s\n" line
stop_c
(String.make len '^')
else if num_lines <= 10 then
let lines = file_lines path ~start:start.pos_lnum ~stop:stop.pos_lnum in
let last_lnum = Option.map ~f:fst (List.last lines) in
let padding_width = Option.value_exn
(Option.map ~f:String.length last_lnum) in
List.iter ~f:(fun (lnum, l) ->
Format.fprintf pp "%*s: %s\n" padding_width lnum l)
lines
in
Format.fprintf ppf
"@{<loc>File \"%s\", line %d, characters %d-%d:@}@\n%a"
start.pos_fname start.pos_lnum start_c stop_c
pp_file_excerpt ()
let warn t fmt =
Errors.kerrf ~f:print_to_console
("%a@{<warning>Warning@}: " ^^ fmt ^^ "@.") print t
let to_file_colon_line t =
sprintf "%s:%d" t.start.pos_fname t.start.pos_lnum
let pp_file_colon_line ppf t =
Format.pp_print_string ppf (to_file_colon_line t)
let equal_position
{ Lexing.pos_fname = f_a; pos_lnum = l_a
; pos_bol = b_a; pos_cnum = c_a }
{ Lexing.pos_fname = f_b; pos_lnum = l_b
; pos_bol = b_b; pos_cnum = c_b }
=
let open Int.Infix in
String.equal f_a f_b
&& l_a = l_b
&& b_a = b_b
&& c_a = c_b
let equal
{ start = start_a ; stop = stop_a }
{ start = start_b ; stop = stop_b }
=
equal_position start_a start_b
&& equal_position stop_a stop_b

Some files were not shown because too many files have changed in this diff Show More