diff --git a/src/context.ml b/src/context.ml index bd82e7a3..d2ab23ee 100644 --- a/src/context.ml +++ b/src/context.ml @@ -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 = diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 9dd8f95d..80a1adfe 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -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 diff --git a/src/install.mli b/src/install.mli index c6feb624..9a89569e 100644 --- a/src/install.mli +++ b/src/install.mli @@ -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 diff --git a/src/jbuild_load.ml b/src/jbuild_load.ml index 40b0b290..e5fd6db4 100644 --- a/src/jbuild_load.ml +++ b/src/jbuild_load.ml @@ -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 () = diff --git a/src/jbuild_types.ml b/src/jbuild_types.ml index c2e5d7d1..2157e73d 100644 --- a/src/jbuild_types.ml +++ b/src/jbuild_types.ml @@ -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 ) - (chdir ) - (setenv ) - (with-stdout-to ) -" + 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>... -> ) 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 "( ) 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, or ( 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 diff --git a/src/loc.ml b/src/loc.ml index cf93bc9c..09112c81 100644 --- a/src/loc.ml +++ b/src/loc.ml @@ -30,3 +30,4 @@ let in_file fn = ; stop = pos } +let none = in_file "" diff --git a/src/loc.mli b/src/loc.mli index 5abfcc54..2d9b0ef4 100644 --- a/src/loc.mli +++ b/src/loc.mli @@ -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 diff --git a/src/mode.mli b/src/mode.mli index 5f5b27d3..0fda04e3 100644 --- a/src/mode.mli +++ b/src/mode.mli @@ -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 diff --git a/src/ordered_set_lang.ml b/src/ordered_set_lang.ml index c6e2fa41..d2b8ed45 100644 --- a/src/ordered_set_lang.ml +++ b/src/ordered_set_lang.ml @@ -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 _ -> "") - | List l -> List (List.map l ~f:(expand ~files_contents)) + | List (loc, l) -> List (loc, List.map l ~f:(expand ~files_contents)) end diff --git a/src/ordered_set_lang.mli b/src/ordered_set_lang.mli index facf3215..e4af1556 100644 --- a/src/ordered_set_lang.mli +++ b/src/ordered_set_lang.mli @@ -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 diff --git a/src/sexp.ml b/src/sexp.ml index 9a831b00..e2fa43d8 100644 --- a/src/sexp.ml +++ b/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 *) diff --git a/src/sexp.mli b/src/sexp.mli index 446410fe..576b5b9d 100644 --- a/src/sexp.mli +++ b/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 diff --git a/src/sexp_lexer.mli b/src/sexp_lexer.mli index 1f94487d..6319a93a 100644 --- a/src/sexp_lexer.mli +++ b/src/sexp_lexer.mli @@ -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 diff --git a/src/sexp_lexer.mll b/src/sexp_lexer.mll index 32e3e219..82b2d4d2 100644 --- a/src/sexp_lexer.mll +++ b/src/sexp_lexer.mll @@ -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 } diff --git a/src/sexp_load.ml b/src/sexp_load.ml index 7cb8ea3a..50dc93e7 100644 --- a/src/sexp_load.ml +++ b/src/sexp_load.ml @@ -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 diff --git a/src/sexp_load.mli b/src/sexp_load.mli index 05f134df..c688f2b3 100644 --- a/src/sexp_load.mli +++ b/src/sexp_load.mli @@ -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 diff --git a/src/string_with_vars.ml b/src/string_with_vars.ml index 6fbe26e9..c27f4e61 100644 --- a/src/string_with_vars.ml +++ b/src/string_with_vars.ml @@ -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 diff --git a/src/string_with_vars.mli b/src/string_with_vars.mli index a317679d..bff93f67 100644 --- a/src/string_with_vars.mli +++ b/src/string_with_vars.mli @@ -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 diff --git a/src/vfile_kind.ml b/src/vfile_kind.ml index 3f7bd472..1d66557a 100644 --- a/src/vfile_kind.ml +++ b/src/vfile_kind.ml @@ -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 diff --git a/src/vfile_kind.mli b/src/vfile_kind.mli index 5fcac6ec..b097d9dd 100644 --- a/src/vfile_kind.mli +++ b/src/vfile_kind.mli @@ -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 diff --git a/src/workspace.ml b/src/workspace.ml index a0744580..a59196f9 100644 --- a/src/workspace.ml +++ b/src/workspace.ml @@ -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) diff --git a/src/workspace.mli b/src/workspace.mli new file mode 100644 index 00000000..316b68f3 --- /dev/null +++ b/src/workspace.mli @@ -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