Refactor dune-project parsing
This commit is contained in:
parent
2e47052bb2
commit
8d4e1904a2
|
@ -11,59 +11,30 @@ type lang =
|
|||
| Dune_0_1
|
||||
|
||||
let lang =
|
||||
let name =
|
||||
enum
|
||||
[ ("dune", ()) ]
|
||||
in
|
||||
let version ver =
|
||||
match string ver with
|
||||
| "0.1" -> Dune_0_1
|
||||
| _ ->
|
||||
of_sexp_error ver "unsupported version of the dune language"
|
||||
in
|
||||
let name =
|
||||
enum
|
||||
[ ("dune", ()) ]
|
||||
in
|
||||
sum
|
||||
[ cstr "lang" (name @> version @> nil) (fun () v -> v) ]
|
||||
field_multi "lang" (name @> version @> nil) (fun () v -> v)
|
||||
|
||||
module Acc = struct
|
||||
type t =
|
||||
{ name : string option
|
||||
}
|
||||
let name ~dir =
|
||||
field_o "name" string >>= function
|
||||
| Some s -> return s
|
||||
| None -> return ("_" ^ String.concat ~sep:"_" (Path.explode_exn dir))
|
||||
|
||||
let init =
|
||||
{ name = None }
|
||||
end
|
||||
let parse ~dir =
|
||||
record
|
||||
(lang >>= fun Dune_0_1 ->
|
||||
name ~dir >>= fun name ->
|
||||
return { name })
|
||||
|
||||
let load ~dir =
|
||||
let fname = Path.relative dir filename in
|
||||
let sexps = Io.Sexp.load fname ~mode:Many in
|
||||
let langs, sexps =
|
||||
List.partition_map sexps ~f:(function
|
||||
| List (loc, Atom (_, A "lang") :: _) as sexp ->
|
||||
Left (lang sexp, loc)
|
||||
| sexp -> Right sexp)
|
||||
in
|
||||
let _lang =
|
||||
match langs with
|
||||
| [] ->
|
||||
Loc.fail (Loc.in_file (Path.to_string fname))
|
||||
"language not specified, you need to add (lang dune 0.1)"
|
||||
| [(v, _)] -> v
|
||||
| _ :: (_, loc) :: _ ->
|
||||
Loc.fail loc "language specified too many times"
|
||||
in
|
||||
let acc =
|
||||
List.fold_left sexps ~init:Acc.init ~f:(fun (acc : Acc.t) sexp ->
|
||||
sum
|
||||
[ cstr "lang" nil acc
|
||||
; cstr_loc "name" (string @> nil) (fun loc name ->
|
||||
match acc.name with
|
||||
| None -> { Acc.name = Some name }
|
||||
| Some _ -> Loc.fail loc "name specified too many times")
|
||||
]
|
||||
sexp)
|
||||
in
|
||||
{ name =
|
||||
match acc.name with
|
||||
| Some s -> s
|
||||
| None -> "_" ^ String.concat ~sep:"_" (Path.explode_exn dir)
|
||||
}
|
||||
let sexp = Io.Sexp.load_many_as_one fname in
|
||||
parse ~dir sexp
|
||||
|
|
|
@ -140,8 +140,8 @@ module Of_sexp = struct
|
|||
tbl
|
||||
|
||||
type unparsed_field =
|
||||
{ value : Ast.t option
|
||||
; entry : Ast.t
|
||||
{ values : Ast.t list
|
||||
; entry : Ast.t
|
||||
}
|
||||
|
||||
module Name = struct
|
||||
|
@ -229,27 +229,36 @@ module Of_sexp = struct
|
|||
| Located f -> f (Ast.loc entry)
|
||||
end
|
||||
|
||||
let too_many_values name field =
|
||||
of_sexp_errorf_loc (Ast.loc field.entry) "too many values for field %s" name
|
||||
|
||||
let field_missing state name =
|
||||
of_sexp_errorf_loc state.loc "field %s missing" name
|
||||
|
||||
let field name ?(short=Short_syntax.Not_allowed)
|
||||
?default value_of_sexp state =
|
||||
match Name_map.find state.unparsed name with
|
||||
| Some { value = Some value; _ } ->
|
||||
| Some { values = [value]; _ } ->
|
||||
(value_of_sexp value, consume name state)
|
||||
| Some { value = None; entry } ->
|
||||
| Some { values = []; entry } ->
|
||||
(Short_syntax.parse short entry name,
|
||||
consume name state)
|
||||
| Some f ->
|
||||
too_many_values name f
|
||||
| None ->
|
||||
match default with
|
||||
| Some v -> (v, add_known name state)
|
||||
| None ->
|
||||
of_sexp_errorf_loc state.loc "field %s missing" name
|
||||
| None -> field_missing state name
|
||||
|
||||
let field_o name ?(short=Short_syntax.Not_allowed) value_of_sexp state =
|
||||
match Name_map.find state.unparsed name with
|
||||
| Some { value = Some value; _ } ->
|
||||
| Some { values = [value]; _ } ->
|
||||
(Some (value_of_sexp value), consume name state)
|
||||
| Some { value = None; entry } ->
|
||||
| Some { values = []; entry } ->
|
||||
(Some (Short_syntax.parse short entry name),
|
||||
consume name state)
|
||||
| Some f ->
|
||||
too_many_values name f
|
||||
| None -> (None, add_known name state)
|
||||
|
||||
let field_b name = field name bool ~default:false ~short:(This true)
|
||||
|
@ -261,17 +270,16 @@ module Of_sexp = struct
|
|||
let unparsed =
|
||||
List.fold_left sexps ~init:Name_map.empty ~f:(fun acc sexp ->
|
||||
match sexp with
|
||||
| List (_, [Atom (_, A name)]) ->
|
||||
Name_map.add acc name { value = None; entry = sexp }
|
||||
| List (_, [name_sexp; value]) -> begin
|
||||
| List (_, name_sexp :: values) -> begin
|
||||
match name_sexp with
|
||||
| Atom (_, A name) ->
|
||||
Name_map.add acc name { value = Some value; entry = sexp }
|
||||
Name_map.add acc name { values; entry = sexp }
|
||||
| List _ | Quoted_string _ ->
|
||||
of_sexp_error name_sexp "Atom expected"
|
||||
end
|
||||
| _ ->
|
||||
of_sexp_error sexp "S-expression of the form (_ _) expected")
|
||||
of_sexp_error sexp
|
||||
"S-expression of the form (<name> <values>...) expected")
|
||||
in
|
||||
{ loc = loc
|
||||
; known = []
|
||||
|
@ -317,6 +325,16 @@ module Of_sexp = struct
|
|||
let nil = Constructor_args_spec.Nil
|
||||
let ( @> ) a b = Constructor_args_spec.Cons (a, b)
|
||||
|
||||
let field_multi name ?default args_spec f state =
|
||||
match Name_map.find state.unparsed name with
|
||||
| Some { values; entry } ->
|
||||
(Constructor_args_spec.convert args_spec No_rest entry values f,
|
||||
consume name state)
|
||||
| None ->
|
||||
match default with
|
||||
| Some v -> (v, add_known name state)
|
||||
| None -> field_missing state name
|
||||
|
||||
module Constructor_spec = struct
|
||||
type ('a, 'b, 'c) tuple =
|
||||
{ name : string
|
||||
|
|
|
@ -123,6 +123,14 @@ module Of_sexp : sig
|
|||
-> ('b, 'c) Constructor_args_spec.t
|
||||
-> ('a -> 'b, 'c) Constructor_args_spec.t
|
||||
|
||||
(** Field that takes multiple values *)
|
||||
val field_multi
|
||||
: string
|
||||
-> ?default:'b
|
||||
-> ('a, 'b) Constructor_args_spec.t
|
||||
-> 'a
|
||||
-> 'b record_parser
|
||||
|
||||
val cstr : string -> ('a, 'b) Constructor_args_spec.t -> 'a -> 'b Constructor_spec.t
|
||||
val cstr_rest
|
||||
: string
|
||||
|
|
Loading…
Reference in New Issue