Refactor S-expression parsing
This commit is contained in:
parent
af82f587e4
commit
c6b2169037
|
@ -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 =
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 sexps = Sexp_load.many (Path.relative dir "jbuild" |> Path.to_string) in
|
||||
let versions, sexps =
|
||||
List.partition_map sexps ~f:(function
|
||||
| List [Atom ("jbuilder_version" | "Jbuilder_version"); ver] as sexp ->
|
||||
Inl (Jbuilder_version.t ver, sexp)
|
||||
| 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
|
||||
| _ :: (_, sexp) :: _ ->
|
||||
of_sexp_error sexp "jbuilder_version specified too many times"
|
||||
| _ :: (_, loc) :: _ ->
|
||||
Loc.fail loc "jbuilder_version specified too many times"
|
||||
in
|
||||
(version, List.filter_map sexps ~f:(Stanza.select version)))
|
||||
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 () =
|
||||
|
|
|
@ -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 ->
|
||||
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"
|
||||
(List (Loc.none,
|
||||
[ Atom (Loc.none, "-w")
|
||||
; Atom
|
||||
(String.concat ~sep:""
|
||||
(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
|
||||
|
||||
|
|
|
@ -30,3 +30,4 @@ let in_file fn =
|
|||
; stop = pos
|
||||
}
|
||||
|
||||
let none = in_file "<none>"
|
||||
|
|
|
@ -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,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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
147
src/sexp.ml
|
@ -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
29
src/sexp.mli
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -2,29 +2,27 @@
|
|||
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
|
||||
let atom_loc lexbuf : Loc.t =
|
||||
{ start = Lexing.lexeme_start_p lexbuf
|
||||
; stop = Lexing.lexeme_end_p lexbuf
|
||||
}
|
||||
|
@ -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
|
||||
}
|
||||
|
|
|
@ -1,30 +1,7 @@
|
|||
open Import
|
||||
|
||||
let single fn f =
|
||||
let sexp, locs =
|
||||
let single fn =
|
||||
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 many fn f =
|
||||
let sexps, locs =
|
||||
let many fn =
|
||||
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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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,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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
Loading…
Reference in New Issue