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

Refactor S-expression parsing

This commit is contained in:
Jérémie Dimino 2017-02-25 17:53:39 +00:00
parent af82f587e4
commit c6b2169037
22 changed files with 213 additions and 259 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
src/context.ml
View File

@ -273,7 +273,6 @@ let create_for_opam ?root ~switch ~name () =
>>= fun s ->
let vars =
Sexp_lexer.single (Lexing.from_string s)
|> fst
|> Sexp.Of_sexp.(string_map string)
in
let path =

4
src/gen_rules.ml
View File

@ -735,7 +735,7 @@ module Gen(P : Params) = struct
Build.arr (fun () ->
let files_contents =
List.map2 files paths ~f:(fun fn path ->
(fn, Sexp_load.single (Path.to_string path) (fun x -> x)))
(fn, Sexp_load.single (Path.to_string path)))
|> String_map.of_alist_exn
in
let set = Ordered_set_lang.Unexpanded.expand set ~files_contents in
@ -1360,7 +1360,7 @@ module Gen(P : Params) = struct
Sexp.To_sexp.list Dep_conf_interpret.sexp_of_t alias_conf.deps in
let action =
match alias_conf.action with
| None -> Atom "none"
| None -> Sexp.Atom "none"
| Some a -> List [Atom "some" ; User_action.Unexpanded.sexp_of_t a] in
Sexp.List [deps ; action]
|> Sexp.to_string

2
src/install.mli
View File

@ -15,7 +15,7 @@ module Section : sig
| Man
| Misc
val t : Sexp.t -> t
val t : t Sexp.Of_sexp.t
end
module Entry : sig

35
src/jbuild_load.ml
View File

@ -9,25 +9,24 @@ type conf =
}
let load ~dir ~visible_packages ~version =
let version, stanzas =
Sexp_load.many (Path.relative dir "jbuild" |> Path.to_string)
(fun sexps ->
let versions, sexps =
List.partition_map sexps ~f:(function
| List [Atom ("jbuilder_version" | "Jbuilder_version"); ver] as sexp ->
Inl (Jbuilder_version.t ver, sexp)
| sexp -> Inr sexp)
in
let version =
match versions with
| [] -> version
| [(v, _)] -> v
| _ :: (_, sexp) :: _ ->
of_sexp_error sexp "jbuilder_version specified too many times"
in
(version, List.filter_map sexps ~f:(Stanza.select version)))
let sexps = Sexp_load.many (Path.relative dir "jbuild" |> Path.to_string) in
let versions, sexps =
List.partition_map sexps ~f:(function
| List (loc, [Atom (_, ("jbuilder_version" | "Jbuilder_version")); ver]) ->
Inl (Jbuilder_version.t ver, loc)
| sexp -> Inr sexp)
in
let version =
match versions with
| [] -> version
| [(v, _)] -> v
| _ :: (_, loc) :: _ ->
Loc.fail loc "jbuilder_version specified too many times"
in
let stanzas =
List.filter_map sexps ~f:(Stanza.select version)
|> Stanza.resolve_packages ~dir ~visible_packages
in
let stanzas = Stanza.resolve_packages stanzas ~dir ~visible_packages in
(version, stanzas)
let load () =

96
src/jbuild_types.ml
View File

@ -8,10 +8,6 @@ open Sexp.Of_sexp
[jane_street] version. When they are all the same, sexp parsers are just named [t].
*)
type sexp = Sexp.t = Atom of string | List of sexp list
let of_sexp_error = Sexp.of_sexp_error
let of_sexp_errorf = Sexp.of_sexp_errorf
module Jbuilder_version = struct
type t =
| V1
@ -73,7 +69,7 @@ module Raw_string () : sig
type t = private string
val to_string : t -> string
val of_string : string -> t
val t : Sexp.t -> t
val t : t Sexp.Of_sexp.t
end = struct
type t = string
let to_string t = t
@ -130,20 +126,13 @@ module User_action = struct
| With_stdout_to of 'a * 'a t
let rec t a sexp =
match sexp with
| List (Atom "run" :: prog :: args) -> Run (a prog, List.map args ~f:a)
| List [ Atom "chdir"; dir; arg ] -> Chdir (a dir, t a arg)
| List [ Atom "setenv"; var; value; arg ] -> Setenv (a var, a value, t a arg)
| List [ Atom "with-stdout-to"; file; arg ] -> With_stdout_to (a file, t a arg)
| _ ->
of_sexp_error sexp "\
invalid action, expected one of:
(run <prog> <args>)
(chdir <dir> <action>)
(setenv <var> <value> <action>)
(with-stdout-to <file> <action>)
"
sum
[ cstr_rest "run" [a] a (fun prog args -> Run (prog, args))
; cstr "chdir" [a; t a] (fun dn t -> Chdir (dn, t))
; cstr "setenv" [a; a; t a] (fun k v t -> Setenv (k, v, t))
; cstr "with-stdout-to" [a; t a] (fun fn t -> With_stdout_to (fn, t))
]
sexp
let rec map t ~f =
match t with
@ -184,7 +173,7 @@ invalid action, expected one of:
in
loop String_map.empty dir [] t
let rec sexp_of_t f = function
let rec sexp_of_t f : _ -> Sexp.t = function
| Run (a, xs) -> List (Atom "run" :: f a :: List.map xs ~f)
| Chdir (a, r) -> List [Atom "chdir" ; f a ; sexp_of_t f r]
| Setenv (k, v, r) -> List [Atom "setenv" ; f k ; f v ; sexp_of_t f r]
@ -211,7 +200,7 @@ invalid action, expected one of:
| Bash x -> f init x
| Shexp x -> Mini_shexp.fold x ~init ~f
let sexp_of_t f = function
let sexp_of_t f : _ -> Sexp.t = function
| Bash a -> List [Atom "bash" ; f a]
| Shexp a -> List [Atom "shexp" ; Mini_shexp.sexp_of_t f a]
end
@ -296,11 +285,12 @@ module Preprocess_map = struct
| For_all pp -> pp
| Per_file map -> String_map.find_default module_name map ~default:No_preprocessing
let default = For_all (Pps { pps = Pp_set.singleton (Pp.of_string "ppx_jane"); flags = [] })
let default_v1 = For_all No_preprocessing
let default_vjs = For_all (Pps { pps = Pp_set.singleton (Pp.of_string "ppx_jane"); flags = [] })
let t sexp =
match sexp with
| List (Atom "per_file" :: rest) -> begin
| List (_, Atom (_, "per_file") :: rest) -> begin
List.concat_map rest ~f:(fun sexp ->
let pp, names = pair Preprocess.t module_names sexp in
List.map (String_set.elements names) ~f:(fun name -> (name, pp)))
@ -352,15 +342,15 @@ module Lib_dep = struct
| Select of { result_fn : string; choices : choice list }
let choice = function
| List l as sexp ->
| List (_, l) as sexp ->
let rec loop acc = function
| [Atom "->"; sexp] ->
| [Atom (_, "->"); sexp] ->
{ lits = List.rev acc
; file = file sexp
}
| Atom "->" :: _ | List _ :: _ | [] ->
| Atom (_, "->") :: _ | List _ :: _ | [] ->
of_sexp_error sexp "(<[!]libraries>... -> <file>) expected"
| Atom s :: l ->
| Atom (_, s) :: l ->
let len = String.length s in
if len > 0 && s.[0] = '!' then
let s = String.sub s ~pos:1 ~len:(len - 1) in
@ -371,16 +361,17 @@ module Lib_dep = struct
loop [] l
| sexp -> of_sexp_error sexp "(<library-name> <code>) expected"
let sexp_of_choice { lits; file } =
List (List.fold_right lits ~init:[Atom "->"; Atom file] ~f:(fun lit acc ->
match lit with
| Pos s -> Atom s :: acc
| Neg s -> Atom ("!" ^ s) :: acc))
let sexp_of_choice { lits; file } : Sexp.t =
List (List.fold_right lits ~init:[Atom "->"; Atom file]
~f:(fun lit acc : Sexp.t list ->
match lit with
| Pos s -> Atom s :: acc
| Neg s -> Atom ("!" ^ s) :: acc))
let t = function
| Atom s ->
| Atom (_, s) ->
Direct s
| List (Atom "select" :: m :: Atom "from" :: libs) ->
| List (_, Atom (_, "select") :: m :: Atom (_, "from") :: libs) ->
Select { result_fn = file m
; choices = List.map libs ~f:choice
}
@ -409,8 +400,8 @@ module Buildable = struct
; ocamlopt_flags : Ordered_set_lang.t
}
let common =
field "preprocess" Preprocess_map.t ~default:Preprocess_map.default
let common ~pp_default =
field "preprocess" Preprocess_map.t ~default:pp_default
>>= fun preprocess ->
field "preprocessor_deps" (list Dep_conf.t) ~default:[]
>>= fun preprocessor_deps ->
@ -432,10 +423,10 @@ module Buildable = struct
; ocamlopt_flags
}
let v1 = common
let v1 = common ~pp_default:Preprocess_map.default_v1
let vjs =
common >>= fun t ->
common ~pp_default:Preprocess_map.default_vjs >>= fun t ->
field "extra_disabled_warnings" (list int) ~default:[]
>>= fun extra_disabled_warnings ->
let t =
@ -443,11 +434,13 @@ module Buildable = struct
let flags =
Ordered_set_lang.append t.flags
(Ordered_set_lang.t
(List [ Atom "-w"
; Atom
(String.concat ~sep:""
(List.map extra_disabled_warnings ~f:(sprintf "-%d")))
]))
(List (Loc.none,
[ Atom (Loc.none, "-w")
; Atom
(Loc.none,
String.concat ~sep:""
(List.map extra_disabled_warnings ~f:(sprintf "-%d")))
])))
in
{ t with flags }
else
@ -578,7 +571,9 @@ module Library = struct
; c_library_flags =
Ordered_set_lang.Unexpanded.append
(Ordered_set_lang.Unexpanded.t
(Sexp.To_sexp.(list string (List.map c_libraries ~f:((^) "-l")))))
(List (Loc.none,
List.map c_libraries ~f:(fun lib ->
Atom (Loc.none, "-l" ^ lib)))))
c_library_flags
; self_build_stubs_archive
; js_of_ocaml
@ -691,14 +686,14 @@ module Provides = struct
let v1 sexp =
match sexp with
| Atom s ->
| Atom (_, s) ->
{ name = s
; file =
match String.lsplit2 s ~on:':' with
| None -> s
| Some (_, s) -> s
}
| List [Atom s; List [Atom "file"; Atom file]] ->
| List (_, [Atom (_, s); List (_, [Atom (_, "file"); Atom (_, file)])]) ->
{ name = s
; file
}
@ -714,10 +709,11 @@ module Install_conf = struct
; dst : string option
}
let file (sexp : Sexp.t) =
let file sexp =
match sexp with
| Atom src -> { src; dst = None }
| List [Atom src; Atom "as"; Atom dst] -> { src; dst = Some dst }
| Atom (_, src) -> { src; dst = None }
| List (_, [Atom (_, src); Atom (_, "as"); Atom (_, dst)]) ->
{ src; dst = Some dst }
| _ ->
of_sexp_error sexp
"invalid format, <name> or (<name> as <install-as>) expected"
@ -814,7 +810,7 @@ module Stanza = struct
; cstr "jbuilder_version" [Jbuilder_version.t] (fun _ -> None)
]
let select : Jbuilder_version.t -> Sexp.t -> t option = function
let select : Jbuilder_version.t -> t option Sexp.Of_sexp.t = function
| V1 -> v1
| Vjs -> vjs

1
src/loc.ml
View File

@ -30,3 +30,4 @@ let in_file fn =
; stop = pos
}
let none = in_file "<none>"

2
src/loc.mli
View File

@ -11,3 +11,5 @@ val fail : t -> ('a, unit, string, _) format4 -> 'a
val fail_lex : Lexing.lexbuf -> ('a, unit, string, _) format4 -> 'a
val in_file : string -> t
val none : t

2
src/mode.mli
View File

@ -2,7 +2,7 @@ open! Import
type t = Byte | Native
val t : Sexp.t -> t
val t : t Sexp.Of_sexp.t
val all : t list

36
src/ordered_set_lang.ml
View File

@ -1,30 +1,30 @@
open! Import
type t = Sexp.t
type t = Sexp.Ast.t
let t t = t
let eval t ~special_values =
let rec of_sexp : Sexp.t -> _ = function
| Atom "\\" -> failwith "unexpected \\"
| Atom s ->
let rec of_sexp : Sexp.Ast.t -> _ = function
| Atom (loc, "\\") -> Loc.fail loc "unexpected \\"
| Atom (loc, s) ->
let len = String.length s in
if len > 0 && s.[0] = ':' then
let name = String.sub s ~pos:1 ~len:(len - 1) in
match List.assoc name special_values with
| l -> l
| exception Not_found -> Printf.ksprintf failwith "undefined symbol %s" s;
| exception Not_found -> Loc.fail loc "undefined symbol %s" s;
else
[s]
| List sexps -> of_sexps [] sexps
| List (_, sexps) -> of_sexps [] sexps
and of_sexps acc = function
| Atom "\\" :: sexps -> of_sexps_negative acc sexps
| Atom (_, "\\") :: sexps -> of_sexps_negative acc sexps
| elt :: sexps ->
let elts = of_sexp elt in
of_sexps (List.rev_append elts acc) sexps
| [] -> List.rev acc
and of_sexps_negative acc = function
| Atom "\\" :: sexps -> of_sexps_negative acc sexps
| Atom (_, "\\") :: sexps -> of_sexps_negative acc sexps
| elt :: sexps ->
let elts = of_sexp elt in
let acc = List.filter acc ~f:(fun acc_elt -> not (List.mem acc_elt ~set:elts)) in
@ -34,7 +34,7 @@ let eval t ~special_values =
of_sexp t
let is_standard : t -> bool = function
| Atom ":standard" -> true
| Atom (_, ":standard") -> true
| _ -> false
let eval_with_standard t ~standard =
@ -45,17 +45,17 @@ let eval_with_standard t ~standard =
let rec map (t : t) ~f =
match t with
| Atom s ->
| Atom (loc, s) ->
let len = String.length s in
if len > 0 && s.[0] = ':' then
t
else
Atom (f s)
| List l -> List (List.map l ~f:(map ~f))
Atom (loc, f s)
| List (loc, l) -> List (loc, List.map l ~f:(map ~f))
let standard : t = Atom ":standard"
let standard : t = Atom (Loc.none, ":standard")
let append a b = Sexp.List [a; b]
let append a b : t = List (Loc.none, [a; b])
module Unexpanded = struct
type nonrec t = t
@ -67,16 +67,16 @@ module Unexpanded = struct
let files t =
let rec loop acc : t -> _ = function
| Atom _ -> acc
| List [Atom ":include"; Atom fn] -> String_set.add fn acc
| List l -> List.fold_left l ~init:acc ~f:loop
| List (_, [Atom (_, ":include"); Atom (_, fn)]) -> String_set.add fn acc
| List (_, l) -> List.fold_left l ~init:acc ~f:loop
in
loop String_set.empty t
let rec expand (t : t) ~files_contents =
match t with
| Atom _ -> t
| List [Atom ":include"; Atom fn] ->
| List (_, [Atom (_, ":include"); Atom (_, fn)]) ->
String_map.find_exn fn files_contents ~string_of_key:(sprintf "%S")
~desc:(fun _ -> "<filename to s-expression>")
| List l -> List (List.map l ~f:(expand ~files_contents))
| List (loc, l) -> List (loc, List.map l ~f:(expand ~files_contents))
end

6
src/ordered_set_lang.mli
View File

@ -4,7 +4,7 @@
open Import
type t
val t : Sexp.t -> t
val t : t Sexp.Of_sexp.t
val eval_with_standard : t -> standard:string list -> string list
val standard : t
@ -17,7 +17,7 @@ val map : t -> f:(string -> string) -> t
module Unexpanded : sig
type expanded = t
type t
val t : Sexp.t -> t
val t : t Sexp.Of_sexp.t
val standard : t
val append : t -> t -> t
@ -28,5 +28,5 @@ module Unexpanded : sig
(** Expand [t] using with the given file contents. [file_contents] is a map from
filenames to their parsed contents. Every [(:include fn)] in [t] is replaced by
[Map.find files_contents fn]. *)
val expand : t -> files_contents:Sexp.t String_map.t -> expanded
val expand : t -> files_contents:Sexp.Ast.t String_map.t -> expanded
end with type expanded := t

147
src/sexp.ml
View File

@ -4,46 +4,16 @@ type t =
| Atom of string
| List of t list
type sexp = t
module Locs = struct
module Ast = struct
type t =
| Atom of Loc.t
| Atom of Loc.t * string
| List of Loc.t * t list
let loc = function
| Atom loc -> loc
| Atom (loc, _) -> loc
| List (loc, _) -> loc
end
let locate_in_list ts ~sub ~locs =
let rec loop ts locs =
match ts, locs with
| [], _ -> None
| _, [] -> assert false
| t::ts, loc::locs ->
if t == sub then
Some (Locs.loc loc)
else
match t, loc with
| Atom _, _ -> loop ts locs
| List inner_ts, List (_, inner_locs) -> begin
match loop inner_ts inner_locs with
| None -> loop ts locs
| Some _ as res -> res
end
| _ -> assert false
in
loop ts locs
let locate t ~sub ~locs =
locate_in_list [t] ~sub ~locs:[locs]
exception Of_sexp_error of t * string
let of_sexp_error t msg = raise (Of_sexp_error (t, msg))
let of_sexp_errorf t fmt = Printf.ksprintf (of_sexp_error t) fmt
let must_escape str =
let len = String.length str in
len = 0 ||
@ -97,14 +67,21 @@ module To_sexp = struct
end
module Of_sexp = struct
type nonrec 'a t = t -> 'a
type ast = Ast.t =
| Atom of Loc.t * string
| List of Loc.t * ast list
type 'a t = ast -> 'a
let of_sexp_error sexp str = raise (Loc.Error (Ast.loc sexp, str))
let of_sexp_errorf sexp fmt = ksprintf (of_sexp_error sexp) fmt
let unit = function
| List [] -> ()
| List (_, []) -> ()
| sexp -> of_sexp_error sexp "() expected"
let string = function
| Atom s -> s
| Atom (_, s) -> s
| List _ as sexp -> of_sexp_error sexp "Atom expected"
let int sexp =
@ -121,16 +98,16 @@ module Of_sexp = struct
| _ -> of_sexp_error sexp "'true' or 'false' expected"
let pair fa fb = function
| List [a; b] -> (fa a, fb b)
| List (_, [a; b]) -> (fa a, fb b)
| sexp -> of_sexp_error sexp "S-expression of the form (_ _) expected"
let list f = function
| Atom _ as sexp -> of_sexp_error sexp "List expected"
| List l -> List.map l ~f
| List (_, l) -> List.map l ~f
let option f = function
| List [] -> None
| List [x] -> Some (f x)
| List (_, []) -> None
| List (_, [x]) -> Some (f x)
| sexp -> of_sexp_error sexp "S-expression of the form () or (_) expected"
let string_set sexp = String_set.of_list (list string sexp)
@ -141,8 +118,8 @@ module Of_sexp = struct
of_sexp_error sexp (sprintf "key %S present multiple times" key)
type unparsed_field =
{ value : sexp option
; entry : sexp
{ value : Ast.t option
; entry : Ast.t
}
module Name_map = Map.Make(struct
@ -158,7 +135,7 @@ module Of_sexp = struct
end)
type record_parser_state =
{ record : sexp
{ loc : Loc.t
; unparsed : unparsed_field Name_map.t
; known : string list
}
@ -195,19 +172,19 @@ module Of_sexp = struct
| Some { value = Some value; _ } ->
(value_of_sexp value, consume name state)
| Some { value = None; _ } ->
of_sexp_error state.record (Printf.sprintf "field %s needs a value" name)
Loc.fail state.loc "field %s needs a value" name
| None ->
match default with
| Some v -> (v, add_known name state)
| None ->
of_sexp_error state.record (Printf.sprintf "field %s missing" name)
Loc.fail state.loc "field %s missing" name
let field_o name value_of_sexp state =
match Name_map.find name state.unparsed with
| Some { value = Some value; _ } ->
(Some (value_of_sexp value), consume name state)
| Some { value = None; _ } ->
of_sexp_error state.record (Printf.sprintf "field %s needs a value" name)
Loc.fail state.loc "field %s needs a value" name
| None -> (None, add_known name state)
let field_b name state =
@ -222,15 +199,15 @@ module Of_sexp = struct
let make_record_parser_state sexp =
match sexp with
| Atom _ -> of_sexp_error sexp "List expected"
| List sexps ->
| List (loc, sexps) ->
let unparsed =
List.fold_left sexps ~init:Name_map.empty ~f:(fun acc sexp ->
match sexp with
| List [Atom name] ->
| List (_, [Atom (_, name)]) ->
Name_map.add acc ~key:name ~data:{ value = None; entry = sexp }
| List [name_sexp; value] -> begin
| List (_, [name_sexp; value]) -> begin
match name_sexp with
| Atom name ->
| Atom (_, name) ->
Name_map.add acc ~key:name ~data:{ value = Some value; entry = sexp }
| List _ ->
of_sexp_error name_sexp "Atom expected"
@ -238,7 +215,7 @@ module Of_sexp = struct
| _ ->
of_sexp_error sexp "S-expression of the form (_ _) expected")
in
{ record = sexp
{ loc = loc
; known = []
; unparsed
}
@ -252,38 +229,48 @@ module Of_sexp = struct
let name, { entry; _ } = Name_map.choose state.unparsed in
let name_sexp =
match entry with
| List (s :: _) -> s
| List (_, s :: _) -> s
| _ -> assert false
in
of_sexp_errorf name_sexp
"Unknown field %s%s" name (hint name state.known)
type ('a, 'b) rest =
| No_rest : ('a, 'a) rest
| Many : 'a t -> ('a list -> 'b, 'b) rest
module Constructor_args_spec = struct
type 'a conv = 'a t
type ('a, 'b) t =
| [] : ('a, 'a) t
| ( :: ) : 'a conv * ('b, 'c) t -> ('a -> 'b, 'c) t
let rec convert : type a b. (a, b) t -> sexp -> sexp list -> a -> b
= fun t sexp sexps f ->
match t, sexps with
| [], [] -> f
| _ :: _, [] -> of_sexp_error sexp "not enough arguments"
| [], _ :: _ -> of_sexp_error sexp "too many arguments"
| conv :: t, s :: sexps ->
convert t sexp sexps (f (conv s))
let rec convert : type a b c. (a, b) t -> (b, c) rest -> Ast.t -> Ast.t list -> a -> c
= fun t rest sexp sexps f ->
match t, rest, sexps with
| [], No_rest, [] -> f
| [], Many _ , [] -> f []
| _ :: _, _, [] -> of_sexp_error sexp "not enough arguments"
| [], No_rest, _ :: _ -> of_sexp_error sexp "too many arguments"
| [], Many conv, l -> f (List.map l ~f:conv)
| conv :: t, _, s :: sexps ->
convert t rest sexp sexps (f (conv s))
end
module Constructor_spec = struct
type 'a t =
T : { name : string
; args : ('a, 'b) Constructor_args_spec.t
; rest : ('b, 'c) rest
; make : 'a
} -> 'b t
} -> 'c t
end
let cstr_rest name args rest make =
Constructor_spec.T { name; args; make; rest = Many rest }
let cstr name args make =
Constructor_spec.T { name; args; make }
Constructor_spec.T { name; args; make; rest = No_rest }
let equal_cstr_name a b =
let alen = String.length a and blen = String.length b in
@ -321,22 +308,22 @@ module Of_sexp = struct
let sum cstrs sexp =
match sexp with
| Atom s -> begin
| Atom (_, s) -> begin
let (Constructor_spec.T c) = find_cstr cstrs sexp s in
Constructor_args_spec.convert c.args sexp [] c.make
Constructor_args_spec.convert c.args c.rest sexp [] c.make
end
| List [] -> of_sexp_error sexp "non-empty list expected"
| List (name_sexp :: args) ->
| List (_, []) -> of_sexp_error sexp "non-empty list expected"
| List (_, name_sexp :: args) ->
match name_sexp with
| List _ -> of_sexp_error name_sexp "Atom expected"
| Atom s ->
| Atom (_, s) ->
let (Constructor_spec.T c) = find_cstr cstrs sexp s in
Constructor_args_spec.convert c.args sexp args c.make
Constructor_args_spec.convert c.args c.rest sexp args c.make
let enum cstrs sexp =
match sexp with
| List _ -> of_sexp_error sexp "Atom expected"
| Atom s ->
| Atom (_, s) ->
match
List.find cstrs ~f:(fun (name, _) ->
equal_cstr_name name s)
@ -350,25 +337,3 @@ module Of_sexp = struct
(List.map cstrs ~f:(fun (name, _) ->
String.uncapitalize_ascii name)))
end
(*
module Both = struct
type sexp = t
type 'a t =
{ of_sexp : sexp -> 'a
; to_sexp : 'a -> sexp
}
module A = Of_sexp
module B = To_Sexp
let string = { of_sexp = A.string; to_sexp = B.string }
let int = { of_sexp = A.int; to_sexp = B.int }
let pair a b = { of_sexp = A.pair a.of_sexp b.of_sexp
; to_sexp =
let list f l = List (List.map l ~f)
let string_set set = list string (String_set.elements set)
let string_map f map = list (pair string f) (String_map.bindings map)
end
functor (C : Sexp.Combinators) -> struct
open C
let t = string int int *)

29
src/sexp.mli
View File

@ -4,23 +4,15 @@ type t =
| Atom of string
| List of t list
exception Of_sexp_error of t * string
val of_sexp_error : t -> string -> _
val of_sexp_errorf : t -> ('a, unit, string, 'b) format4 -> 'a
val code_error : string -> (string * t) list -> _
module Locs : sig
module Ast : sig
type t =
| Atom of Loc.t
| Atom of Loc.t * string
| List of Loc.t * t list
val loc : t -> Loc.t
end
val locate : t -> sub:t -> locs:Locs.t -> Loc.t option
val locate_in_list : t list -> sub:t -> locs:Locs.t list -> Loc.t option
val code_error : string -> (string * t) list -> _
val to_string : t -> string
@ -40,7 +32,14 @@ end
module To_sexp : Combinators with type 'a t = 'a -> t
module Of_sexp : sig
include Combinators with type 'a t = t -> 'a
type ast = Ast.t =
| Atom of Loc.t * string
| List of Loc.t * ast list
include Combinators with type 'a t = Ast.t -> 'a
val of_sexp_error : Ast.t -> string -> _
val of_sexp_errorf : Ast.t -> ('a, unit, string, 'b) format4 -> 'a
(* Record parsing monad *)
type 'a record_parser
@ -67,6 +66,12 @@ module Of_sexp : sig
end with type 'a conv := 'a t
val cstr : string -> ('a, 'b) Constructor_args_spec.t -> 'a -> 'b Constructor_spec.t
val cstr_rest
: string
-> ('a, 'b list -> 'c) Constructor_args_spec.t
-> 'b t
-> 'a
-> 'c Constructor_spec.t
val sum
: 'a Constructor_spec.t list

4
src/sexp_lexer.mli
View File

@ -1,2 +1,2 @@
val single : Lexing.lexbuf -> Sexp.t * Sexp.Locs.t
val many : Lexing.lexbuf -> (Sexp.t * Sexp.Locs.t) list
val single : Lexing.lexbuf -> Sexp.Ast.t
val many : Lexing.lexbuf -> Sexp.Ast.t list

28
src/sexp_lexer.mll
View File

@ -2,32 +2,30 @@
type stack =
| Empty
| Open of Lexing.position * stack
| Sexp of Sexp.t * Sexp.Locs.t * stack
| Sexp of Sexp.Ast.t * stack
let error = Loc.fail_lex
let make_list =
let rec loop lexbuf acc acc_locs = function
let rec loop lexbuf acc = function
| Empty ->
error lexbuf "right parenthesis without matching left parenthesis"
| Open (start, stack) ->
Sexp (List acc,
List ({ start; stop = Lexing.lexeme_end_p lexbuf }, acc_locs),
Sexp (List ({ start; stop = Lexing.lexeme_end_p lexbuf }, acc),
stack)
| Sexp (sexp, locs, stack) -> loop lexbuf (sexp :: acc) (locs :: acc_locs) stack
| Sexp (sexp, stack) -> loop lexbuf (sexp :: acc) stack
in
fun lexbuf stack -> loop lexbuf [] [] stack
fun lexbuf stack -> loop lexbuf [] stack
let new_sexp loop stack lexbuf =
match stack with
| Sexp (sexp, locs, Empty) -> Some (sexp, locs)
| Sexp (sexp, Empty) -> Some sexp
| _ -> loop stack lexbuf
let atom_loc lexbuf : Sexp.Locs.t =
Atom
{ start = Lexing.lexeme_start_p lexbuf
; stop = Lexing.lexeme_end_p lexbuf
}
let atom_loc lexbuf : Loc.t =
{ start = Lexing.lexeme_start_p lexbuf
; stop = Lexing.lexeme_end_p lexbuf
}
let char_for_backslash = function
| 'n' -> '\010'
@ -81,7 +79,7 @@ rule main stack = parse
| "#|"
{ block_comment 0 stack lexbuf }
| unquoted* as s
{ new_sexp main (Sexp (Atom s, atom_loc lexbuf, stack)) lexbuf }
{ new_sexp main (Sexp (Atom (atom_loc lexbuf, s), stack)) lexbuf }
| eof
{ match stack with
| Empty -> None
@ -105,8 +103,8 @@ and block_comment depth stack = parse
and scan_string buf start stack = parse
| '"'
{ new_sexp main
(Sexp (Atom (Buffer.contents buf),
Atom { start; stop = Lexing.lexeme_end_p lexbuf },
(Sexp (Atom ({ start; stop = Lexing.lexeme_end_p lexbuf },
Buffer.contents buf),
stack))
lexbuf
}

31
src/sexp_load.ml
View File

@ -1,30 +1,7 @@
open Import
let single fn f =
let sexp, locs =
with_lexbuf_from_file fn ~f:Sexp_lexer.single
in
try
f sexp
with Sexp.Of_sexp_error (sub, msg) ->
let loc =
match Sexp.locate sexp ~sub ~locs with
| None -> Loc.in_file fn
| Some loc -> loc
in
Loc.fail loc "%s" msg
let single fn =
with_lexbuf_from_file fn ~f:Sexp_lexer.single
let many fn f =
let sexps, locs =
with_lexbuf_from_file fn ~f:Sexp_lexer.many
|> List.split
in
try
f sexps
with Sexp.Of_sexp_error (sub, msg) ->
let loc =
match Sexp.locate_in_list sexps ~sub ~locs with
| None -> Loc.in_file fn
| Some loc -> loc
in
Loc.fail loc "%s" msg
let many fn =
with_lexbuf_from_file fn ~f:Sexp_lexer.many

4
src/sexp_load.mli
View File

@ -1,4 +1,4 @@
open! Import
val single : string -> (Sexp.t -> 'a) -> 'a
val many : string -> (Sexp.t list -> 'a) -> 'a
val single : string -> Sexp.Ast.t
val many : string -> Sexp.Ast.t list

2
src/string_with_vars.ml
View File

@ -91,7 +91,7 @@ let expand t ~f =
module type Container = sig
type 'a t
val t : (Sexp.t -> 'a) -> Sexp.t -> 'a t
val t : 'a Sexp.Of_sexp.t -> 'a t Sexp.Of_sexp.t
val sexp_of_t : ('a -> Sexp.t) -> 'a t -> Sexp.t
val map : 'a t -> f:('a -> 'b) -> 'b t

6
src/string_with_vars.mli
View File

@ -6,7 +6,7 @@
open Import
type t
val t : Sexp.t -> t
val t : t Sexp.Of_sexp.t
val sexp_of_t : t -> Sexp.t
val of_string : string -> t
@ -19,7 +19,7 @@ val expand : t -> f:(string -> string option) -> string
module type Container = sig
type 'a t
val t : (Sexp.t -> 'a) -> Sexp.t -> 'a t
val t : 'a Sexp.Of_sexp.t -> 'a t Sexp.Of_sexp.t
val sexp_of_t : ('a -> Sexp.t) -> 'a t -> Sexp.t
val map : 'a t -> f:('a -> 'b) -> 'b t
@ -28,7 +28,7 @@ end
module Lift(M : Container) : sig
type nonrec t = t M.t
val t : Sexp.t -> t
val t : t Sexp.Of_sexp.t
val sexp_of_t : t -> Sexp.t

7
src/vfile_kind.ml
View File

@ -45,7 +45,7 @@ let eq (type a) (type b)
module Make_full
(T : sig type t end)
(To_sexp : sig val t : T.t -> Sexp.t end)
(Of_sexp : sig val t : Sexp.t -> T.t end)
(Of_sexp : sig val t : Sexp.Ast.t -> T.t end)
: S with type t = T.t =
struct
type t = T.t
@ -59,10 +59,7 @@ struct
close_out oc
let load ~filename =
let sexp, _locs =
with_lexbuf_from_file filename ~f:Sexp_lexer.single
in
Of_sexp.t sexp
Of_sexp.t (Sexp_load.single filename)
end

2
src/vfile_kind.mli
View File

@ -27,5 +27,5 @@ module Make
module Make_full
(T : sig type t end)
(To_sexp : sig val t : T.t -> Sexp.t end)
(Of_sexp : sig val t : Sexp.t -> T.t end)
(Of_sexp : sig val t : Sexp.Ast.t -> T.t end)
: S with type t = T.t

8
src/workspace.ml
View File

@ -1,10 +1,6 @@
open Import
open Sexp.Of_sexp
type sexp = Sexp.t = Atom of string | List of sexp list
let of_sexp_error = Sexp.of_sexp_error
let of_sexp_errorf = Sexp.of_sexp_errorf
module Context = struct
module Opam = struct
type t =
@ -27,7 +23,7 @@ module Context = struct
type t = Default | Opam of Opam.t
let t = function
| Atom "default" -> Default
| Atom (_, "default") -> Default
| sexp -> Opam (Opam.t sexp)
let name = function
@ -55,4 +51,4 @@ let t sexps =
ctx :: acc)
|> List.rev
let load fn = Sexp_load.many fn t
let load fn = t (Sexp_load.many fn)

19
src/workspace.mli Normal file
View File

@ -0,0 +1,19 @@
(** Workspaces definitions *)
open! Import
module Context : sig
module Opam : sig
type t =
{ name : string
; switch : string
; root : string option
}
end
type t = Default | Opam of Opam.t
end
type t = Context.t list
val load : string -> t