2016-12-02 13:54:32 +00:00
|
|
|
open! Import
|
|
|
|
|
2017-07-05 17:12:44 +00:00
|
|
|
module Ast = struct
|
|
|
|
[@@@warning "-37"]
|
|
|
|
type expanded = Expanded
|
|
|
|
type unexpanded = Unexpanded
|
|
|
|
type ('a, _) t =
|
|
|
|
| Element : 'a -> ('a, _) t
|
|
|
|
| Special : Loc.t * string -> ('a, _) t
|
|
|
|
| Union : ('a, 'b) t list -> ('a, 'b) t
|
|
|
|
| Diff : ('a, 'b) t * ('a, 'b) t -> ('a, 'b) t
|
2017-08-23 20:56:32 +00:00
|
|
|
| Include : String_with_vars.t -> ('a, unexpanded) t
|
2017-07-05 17:12:44 +00:00
|
|
|
end
|
2016-12-02 13:54:32 +00:00
|
|
|
|
2018-02-08 10:12:46 +00:00
|
|
|
type 'ast generic =
|
|
|
|
{ ast : 'ast
|
|
|
|
; loc : Loc.t option
|
|
|
|
}
|
2016-12-02 13:54:32 +00:00
|
|
|
|
2018-02-08 10:12:46 +00:00
|
|
|
type ast_expanded = (Loc.t * string, Ast.expanded) Ast.t
|
|
|
|
type t = ast_expanded generic
|
|
|
|
|
|
|
|
let loc t = t.loc
|
|
|
|
|
|
|
|
let parse_general sexp ~f =
|
2017-02-25 17:53:39 +00:00
|
|
|
let rec of_sexp : Sexp.Ast.t -> _ = function
|
2018-02-24 23:33:26 +00:00
|
|
|
| Atom (loc, A "\\") -> Loc.fail loc "unexpected \\"
|
|
|
|
| (Atom (_, A "") | Quoted_string (_, _)) as t -> Ast.Element (f t)
|
|
|
|
| Atom (loc, A s) as t ->
|
2017-07-05 17:12:44 +00:00
|
|
|
if s.[0] = ':' then
|
|
|
|
Special (loc, String.sub s ~pos:1 ~len:(String.length s - 1))
|
2016-12-02 13:54:32 +00:00
|
|
|
else
|
2017-07-05 19:55:17 +00:00
|
|
|
Element (f t)
|
2017-02-25 17:53:39 +00:00
|
|
|
| List (_, sexps) -> of_sexps [] sexps
|
2016-12-02 13:54:32 +00:00
|
|
|
and of_sexps acc = function
|
2018-02-24 23:33:26 +00:00
|
|
|
| Atom (_, A "\\") :: sexps ->
|
|
|
|
Diff (Union (List.rev acc), of_sexps [] sexps)
|
2016-12-02 13:54:32 +00:00
|
|
|
| elt :: sexps ->
|
2017-07-05 17:12:44 +00:00
|
|
|
of_sexps (of_sexp elt :: acc) sexps
|
|
|
|
| [] -> Union (List.rev acc)
|
2016-12-02 13:54:32 +00:00
|
|
|
in
|
2018-02-08 10:12:46 +00:00
|
|
|
of_sexp sexp
|
|
|
|
|
|
|
|
let t sexp : t =
|
|
|
|
let ast =
|
|
|
|
parse_general sexp ~f:(function
|
2018-02-24 23:33:26 +00:00
|
|
|
| Atom (loc, A s) | Quoted_string (loc, s) -> (loc, s)
|
2018-02-08 10:12:46 +00:00
|
|
|
| List _ -> assert false)
|
2017-07-05 17:12:44 +00:00
|
|
|
in
|
2018-02-08 10:12:46 +00:00
|
|
|
{ ast
|
|
|
|
; loc = Some (Sexp.Ast.loc sexp)
|
|
|
|
}
|
2017-07-05 17:12:44 +00:00
|
|
|
|
2018-02-08 10:12:46 +00:00
|
|
|
let is_standard t =
|
|
|
|
match (t.ast : ast_expanded) with
|
2017-07-05 17:12:44 +00:00
|
|
|
| Ast.Special (_, "standard") -> true
|
2016-12-02 13:54:32 +00:00
|
|
|
| _ -> false
|
|
|
|
|
2018-02-08 10:12:46 +00:00
|
|
|
module type Value = sig
|
|
|
|
type t
|
|
|
|
val name : t -> string
|
|
|
|
end
|
|
|
|
|
|
|
|
module Make(Value : Value) = struct
|
|
|
|
module type Named_values = sig
|
|
|
|
type t
|
|
|
|
|
|
|
|
val singleton : Value.t -> t
|
|
|
|
val union : t list -> t
|
|
|
|
val diff : t -> t -> t
|
|
|
|
end
|
|
|
|
|
|
|
|
module Make(M : Named_values) = struct
|
|
|
|
let eval t ~parse ~special_values =
|
|
|
|
let rec of_ast (t : ast_expanded) =
|
|
|
|
let open Ast in
|
|
|
|
match t with
|
|
|
|
| Element (loc, s) ->
|
|
|
|
let x = parse ~loc s in
|
|
|
|
M.singleton x
|
|
|
|
| Special (loc, name) -> begin
|
2018-02-25 16:35:25 +00:00
|
|
|
match String_map.find special_values name with
|
2018-02-08 10:12:46 +00:00
|
|
|
| Some x -> x
|
|
|
|
| None -> Loc.fail loc "undefined symbol %s" name
|
|
|
|
end
|
|
|
|
| Union elts -> M.union (List.map elts ~f:of_ast)
|
|
|
|
| Diff (left, right) ->
|
|
|
|
let left = of_ast left in
|
|
|
|
let right = of_ast right in
|
|
|
|
M.diff left right
|
|
|
|
in
|
|
|
|
of_ast t.ast
|
|
|
|
end
|
|
|
|
|
|
|
|
module Ordered = Make(struct
|
|
|
|
type t = Value.t list
|
|
|
|
|
|
|
|
let singleton x = [x]
|
|
|
|
let union = List.flatten
|
|
|
|
let diff a b =
|
|
|
|
List.filter a ~f:(fun x ->
|
|
|
|
List.for_all b ~f:(fun y -> Value.name x <> Value.name y))
|
|
|
|
end)
|
|
|
|
|
|
|
|
module Unordered = Make(struct
|
|
|
|
type t = Value.t String_map.t
|
|
|
|
|
|
|
|
let singleton x = String_map.singleton (Value.name x) x
|
2016-12-02 13:54:32 +00:00
|
|
|
|
2018-02-08 10:12:46 +00:00
|
|
|
let union l =
|
|
|
|
List.fold_left l ~init:String_map.empty ~f:(fun acc t ->
|
|
|
|
String_map.merge acc t ~f:(fun _name x y ->
|
|
|
|
match x, y with
|
|
|
|
| Some x, _ | _, Some x -> Some x
|
|
|
|
| _ -> None))
|
2016-12-02 13:54:32 +00:00
|
|
|
|
2018-02-08 10:12:46 +00:00
|
|
|
let diff a b =
|
|
|
|
String_map.merge a b ~f:(fun _name x y ->
|
|
|
|
match x, y with
|
|
|
|
| Some _, None -> x
|
|
|
|
| _ -> None)
|
|
|
|
end)
|
2016-12-02 13:54:32 +00:00
|
|
|
|
2018-02-08 10:12:46 +00:00
|
|
|
let eval t ~parse ~standard =
|
|
|
|
if is_standard t then
|
|
|
|
standard (* inline common case *)
|
|
|
|
else
|
|
|
|
Ordered.eval t ~parse
|
|
|
|
~special_values:(String_map.singleton "standard" standard)
|
|
|
|
|
|
|
|
let eval_unordered t ~parse ~standard =
|
|
|
|
if is_standard t then
|
|
|
|
standard (* inline common case *)
|
|
|
|
else
|
|
|
|
Unordered.eval t ~parse
|
|
|
|
~special_values:(String_map.singleton "standard" standard)
|
|
|
|
end
|
|
|
|
|
|
|
|
let standard =
|
|
|
|
{ ast = Ast.Special (Loc.none, "standard")
|
|
|
|
; loc = None
|
|
|
|
}
|
2017-02-23 10:43:51 +00:00
|
|
|
|
2016-12-02 13:54:32 +00:00
|
|
|
module Unexpanded = struct
|
2018-02-08 10:12:46 +00:00
|
|
|
type ast = (Sexp.Ast.t, Ast.unexpanded) Ast.t
|
|
|
|
type t = ast generic
|
|
|
|
let t sexp =
|
2017-07-05 19:55:17 +00:00
|
|
|
let rec map (t : (Sexp.Ast.t, Ast.expanded) Ast.t) =
|
2017-07-05 17:12:44 +00:00
|
|
|
let open Ast in
|
|
|
|
match t with
|
2018-02-08 10:12:46 +00:00
|
|
|
| Element x -> Element x
|
2017-07-05 17:12:44 +00:00
|
|
|
| Union [Special (_, "include"); Element fn] ->
|
2017-08-23 20:56:32 +00:00
|
|
|
Include (String_with_vars.t fn)
|
2017-08-25 10:12:15 +00:00
|
|
|
| Union [Special (loc, "include"); _]
|
|
|
|
| Special (loc, "include") ->
|
2017-08-23 20:56:32 +00:00
|
|
|
Loc.fail loc "(:include expects a single element (do you need to quote the filename?)"
|
2017-08-25 10:12:15 +00:00
|
|
|
| Special (l, s) -> Special (l, s)
|
2017-07-05 17:12:44 +00:00
|
|
|
| Union l ->
|
2017-08-23 20:56:32 +00:00
|
|
|
Union (List.map l ~f:map)
|
2017-07-05 17:12:44 +00:00
|
|
|
| Diff (l, r) ->
|
2017-08-23 20:56:32 +00:00
|
|
|
Diff (map l, map r)
|
2017-07-05 17:12:44 +00:00
|
|
|
in
|
2018-02-08 10:12:46 +00:00
|
|
|
{ ast = map (parse_general sexp ~f:(fun x -> x))
|
|
|
|
; loc = Some (Sexp.Ast.loc sexp)
|
|
|
|
}
|
2017-07-05 17:12:44 +00:00
|
|
|
|
2018-02-27 19:06:12 +00:00
|
|
|
let sexp_of_t t =
|
|
|
|
let open Ast in
|
|
|
|
let rec loop : ast -> Sexp.t = function
|
|
|
|
| Element sexp -> Usexp.Ast.remove_locs sexp
|
|
|
|
| Special (_, s) -> Sexp.atom (":" ^ s)
|
|
|
|
| Union l -> List (List.map l ~f:loop)
|
|
|
|
| Diff (a, b) -> List [loop a; Sexp.unsafe_atom_of_string "\\"; loop b]
|
|
|
|
| Include fn -> List [ Sexp.unsafe_atom_of_string ":include"
|
|
|
|
; String_with_vars.sexp_of_t fn
|
|
|
|
]
|
|
|
|
in
|
|
|
|
loop t.ast
|
|
|
|
|
2016-12-02 13:54:32 +00:00
|
|
|
let standard = standard
|
|
|
|
|
2018-02-27 19:06:12 +00:00
|
|
|
let field ?(default=standard) name = Sexp.Of_sexp.field name t ~default
|
|
|
|
|
2017-08-23 20:56:32 +00:00
|
|
|
let files t ~f =
|
2018-02-08 10:12:46 +00:00
|
|
|
let rec loop acc (t : ast) =
|
2017-07-05 17:12:44 +00:00
|
|
|
let open Ast in
|
|
|
|
match t with
|
|
|
|
| Element _
|
|
|
|
| Special _ -> acc
|
|
|
|
| Include fn ->
|
2018-02-25 16:35:25 +00:00
|
|
|
String_set.add acc (f fn)
|
2017-07-05 17:12:44 +00:00
|
|
|
| Union l ->
|
2017-08-23 20:56:32 +00:00
|
|
|
List.fold_left l ~init:acc ~f:loop
|
2017-07-05 17:12:44 +00:00
|
|
|
| Diff (l, r) ->
|
2017-08-23 20:56:32 +00:00
|
|
|
loop (loop acc l) r
|
2016-12-02 13:54:32 +00:00
|
|
|
in
|
2018-02-08 10:12:46 +00:00
|
|
|
loop String_set.empty t.ast
|
|
|
|
|
|
|
|
let expand t ~files_contents ~f =
|
|
|
|
let rec expand (t : ast) : ast_expanded =
|
|
|
|
let open Ast in
|
|
|
|
match t with
|
|
|
|
| Element s -> Element (Sexp.Ast.loc s, f (String_with_vars.t s))
|
|
|
|
| Special (l, s) -> Special (l, s)
|
|
|
|
| Include fn ->
|
|
|
|
let sexp =
|
|
|
|
let fn = f fn in
|
2018-02-25 16:35:25 +00:00
|
|
|
match String_map.find files_contents fn with
|
2018-02-08 10:12:46 +00:00
|
|
|
| Some x -> x
|
|
|
|
| None ->
|
|
|
|
Sexp.code_error
|
|
|
|
"Ordered_set_lang.Unexpanded.expand"
|
2018-02-24 23:33:26 +00:00
|
|
|
[ "included-file", Quoted_string fn
|
2018-02-25 16:35:25 +00:00
|
|
|
; "files", Sexp.To_sexp.(list string)
|
|
|
|
(String_map.keys files_contents)
|
2018-02-08 10:12:46 +00:00
|
|
|
]
|
|
|
|
in
|
|
|
|
parse_general sexp ~f:(fun sexp ->
|
|
|
|
(Sexp.Ast.loc sexp, f (String_with_vars.t sexp)))
|
|
|
|
| Union l -> Union (List.map l ~f:expand)
|
|
|
|
| Diff (l, r) ->
|
|
|
|
Diff (expand l, expand r)
|
|
|
|
in
|
|
|
|
{ t with ast = expand t.ast }
|
2016-12-02 13:54:32 +00:00
|
|
|
end
|