This is an automated email from the git hooks/post-receive script. glondu pushed a commit to branch master in repository ocaml-atd.
commit ac30ec7047ebc564b1dac09841f0458196f657fb Author: Stephane Glondu <st...@glondu.net> Date: Wed Aug 6 11:00:31 2014 +0200 Imported Upstream version 1.1.2 --- .gitignore | 3 + .ocp-indent | 22 ++++ Makefile | 31 ++++- atd_ast.mli | 2 - atd_parser.mly | 6 +- atd_sort.ml | 403 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ atd_sort.mli | 73 +++++++++++ atd_tsort.ml | 103 --------------- atd_tsort.mli | 23 ---- atd_util.ml | 17 ++- unit_tests.ml | 4 + 11 files changed, 545 insertions(+), 142 deletions(-) diff --git a/.gitignore b/.gitignore index ed20a65..93ad1f5 100644 --- a/.gitignore +++ b/.gitignore @@ -4,6 +4,7 @@ *.cmx *.cma *.cmxa +*.cmxs *.a *.o *.annot @@ -18,4 +19,6 @@ atd_parser.ml atd_parser.mli atd_version.ml atdcat +unit-tests dep +*.out diff --git a/.ocp-indent b/.ocp-indent new file mode 100644 index 0000000..fb580a5 --- /dev/null +++ b/.ocp-indent @@ -0,0 +1,22 @@ +# See https://github.com/OCamlPro/ocp-indent/blob/master/.ocp-indent for more + +# Indent for clauses inside a pattern-match (after the arrow): +# match foo with +# | _ -> +# ^^^^bar +# the default is 2, which aligns the pattern and the expression +match_clause = 4 + +# When nesting expressions on the same line, their indentation are in +# some cases stacked, so that it remains correct if you close them one +# at a line. This may lead to large indents in complex code though, so +# this parameter can be used to set a maximum value. Note that it only +# affects indentation after function arrows and opening parens at end +# of line. +# +# for example (left: `none`; right: `4`) +# let f = g (h (i (fun x -> # let f = g (h (i (fun x -> +# x) # x) +# ) # ) +# ) # ) +max_indent = 2 diff --git a/Makefile b/Makefile index 9046f02..2a587d8 100644 --- a/Makefile +++ b/Makefile @@ -1,10 +1,20 @@ -VERSION = 1.1.1 +VERSION = 1.1.2 ifeq "$(shell ocamlc -config |grep os_type)" "os_type: Win32" EXE=.exe else EXE= endif +NATDYNLINK := $(shell if [ -f `ocamlc -where`/dynlink.cmxa ]; then \ + echo YES; \ + else \ + echo NO; \ + fi) + +ifeq "${NATDYNLINK}" "YES" +CMXS=atd.cmxs +endif + SOURCES = \ atd_version.ml \ atd_ast.mli atd_ast.ml \ @@ -17,7 +27,7 @@ SOURCES = \ atd_check.ml \ atd_expand.mli atd_expand.ml \ atd_inherit.mli atd_inherit.ml \ - atd_tsort.mli atd_tsort.ml \ + atd_sort.ml \ atd_util.mli atd_util.ml \ atd_reflect.mli atd_reflect.ml \ atd_indent.mli atd_indent.ml @@ -67,13 +77,13 @@ default: all opt all: VERSION META atd.cma -opt: VERSION META atd.cmxa atdcat$(EXE) +opt: VERSION META atd.cmxa $(CMXS) atdcat$(EXE) install: META test ! -f atdcat || cp atdcat $(BINDIR)/ test ! -f atdcat.exe || cp atdcat.exe $(BINDIR)/ ocamlfind install atd META \ - $(MLI) $(CMI) $(CMO) $(CMX) $(O) atd.cma atd.a atd.cmxa \ + $(MLI) $(CMI) $(CMO) $(CMX) $(CMXS) $(O) atd.cma atd.a atd.cmxa \ $(INSTALL_EXTRAS) uninstall: @@ -132,11 +142,20 @@ atd.cma: dep $(CMI) $(CMO) atd.cmxa: dep $(CMI) $(CMX) ocamlfind ocamlopt $(OCAMLFLAGS) -o atd.cmxa -a $(CMX) +atd.cmxs: dep $(CMI) $(CMX) + ocamlfind ocamlopt $(OCAMLFLAGS) -shared -o $(CMXS) $(CMX) + atdcat$(EXE): dep $(CMI) $(CMX) atdcat.ml ocamlfind ocamlopt $(OCAMLFLAGS) -o atdcat$(EXE) \ -package "$(OCAMLPACKS)" -linkpkg \ $(CMX) atdcat.ml +unit-tests$(EXE): dep $(CMI) $(CMX) unit_tests.ml + ocamlfind ocamlopt $(OCAMLFLAGS) -o unit-tests$(EXE) \ + -package "$(OCAMLPACKS)" -linkpkg \ + $(CMX) unit_tests.ml + + .PHONY: doc doc: odoc/index.html atdcat$(EXE) cd manual; $(MAKE) @@ -148,7 +167,8 @@ odoc/index.html: $(CMI) -package "$(OCAMLPACKS)" $(DOCSOURCES) .PHONY: test -test: atdcat$(EXE) test.atd test2.atd +test: atdcat$(EXE) unit-tests$(EXE) test.atd test2.atd + ./unit-tests$(EXE) ./atdcat test.atd > test.out ./atdcat test.out > test.out.out cmp test.out test.out.out @@ -186,6 +206,7 @@ clean: rm -f $(patsubst %.mly,%.ml, $(MLY)) rm -f $(patsubst %.mll,%.ml, $(MLL)) rm -f atdcat.cm[ioxa] atdcat.o atdcat.cma atdcat.cmxa atdcat$(EXE) + rm -f unit-tests$(EXE) rm -rf odoc cd manual; $(MAKE) clean diff --git a/atd_ast.mli b/atd_ast.mli index d5f9003..9508599 100644 --- a/atd_ast.mli +++ b/atd_ast.mli @@ -1,5 +1,3 @@ - - (** Abstract syntax tree (AST) representing ATD data *) type loc = Lexing.position * Lexing.position diff --git a/atd_parser.mly b/atd_parser.mly index e099d85..891b5d4 100644 --- a/atd_parser.mly +++ b/atd_parser.mly @@ -93,6 +93,9 @@ type_expr: | OP_CURL CL_CURL a = annot { `Record (($startpos, $endpos), [], a) } +| OP_PAREN x = annot_expr CL_PAREN a = annot + { `Tuple (($startpos, $endpos), [x], a) } + | OP_PAREN l = cartesian_product CL_PAREN a = annot { `Tuple (($startpos, $endpos), l, a) } @@ -135,7 +138,6 @@ type_expr: cartesian_product: | x = annot_expr STAR l = cartesian_product { x :: l } | x = annot_expr STAR y = annot_expr { [ x; y ] } -| x = annot_expr { [ x ] } | { [] } ; @@ -158,7 +160,7 @@ type_args: type_arg_list: | type_expr COMMA type_arg_list { $1 :: $3 } -| type_expr { [ $1 ] } +| type_expr COMMA type_expr { [ $1; $3 ] } ; variant_list: diff --git a/atd_sort.ml b/atd_sort.ml new file mode 100644 index 0000000..f3c9c97 --- /dev/null +++ b/atd_sort.ml @@ -0,0 +1,403 @@ +(* + Topological sort that doesn't give up on cycles: + + A --> B + C --> D gives: [A] [B C] [D] + B --> C + C --> B +*) + +open Printf + +module type Param = +sig + type t + type id + val id : t -> id + + (* for error messages and debugging *) + val to_string : id -> string +end + +module Make (P : Param) = +struct + type id = P.id + + type node_state = Visited | Unvisited + + (* graph node with mutable labels *) + type node = { + id: P.id; + value: P.t; + mutable state: node_state; + } + + (* all edges of the original graph *) + type graph = { + forward: (id, node list) Hashtbl.t; + backward: (id, node list) Hashtbl.t; + } + + (* subset of nodes on which iteration and set operations are possible + (intersection, union, etc.) *) + module S = Set.Make ( + struct + type t = node + let compare a b = Pervasives.compare a.id b.id + end + ) + + let debug = ref false + + let print msg = + if !debug then + printf "%s\n%!" msg + + let print_nodes msg nodes = + if !debug then + printf "%s: %s\n%!" + msg (String.concat " " + (List.map (fun v -> P.to_string v.id) + (S.elements nodes) + ) + ) + + (* + Algorithm outline: + + Input: directed graph + Output: a list of node groups sorted topologically, i.e. + for any group A coming after group B and any node n_a in A + and any node n_b in B, there is no edge + going from n_b to n_a. + ... such that the number of groups is maximum. + + Initialization: + Build graph structure such that allows following edges both forward + and backward. + + 1. root and leaf elimination: a leaf is a node without outgoing edges, + a root is a node without incoming edges. + 2. partitioning into strict ancestors (left), cycle (middle), + and strict descendants (right), and other (independent): + pick an processed node V (our pivot), determine the set of + descendant nodes and the set of ancestor nodes by following edges + from V respectively forward and backward. + Nodes that belong both to the descendant set + and to the ancestor set form a cycle with V and are removed + from the graph. + Strict ancestors are sorted starting from step 1, strict descendants + are sorted starting from step 1. + *) + + let get_neighbors v edges = + try Hashtbl.find edges v.id + with Not_found -> [] + + let filtered_neighbors v edges graph_nodes = + let all = get_neighbors v edges in + List.filter + (fun neighbor -> S.mem neighbor graph_nodes) + all + + let pick_one nodes = + try + let v = S.choose nodes in + Some (v, S.remove v nodes) + with Not_found -> + None + + let remove_list set l = + List.fold_left (fun set v -> S.remove v set) set l + + let add_list set l = + List.fold_left (fun set v -> S.add v set) set l + + let is_root back_edges graph_nodes v = + filtered_neighbors v back_edges graph_nodes = [] + + let eliminate_roots_recursively edges back_edges nodes = + let rec aux sorted graph_nodes input_nodes = + match pick_one input_nodes with + | None -> + List.rev_map (fun v -> false, S.singleton v) sorted, graph_nodes + | Some (v, input_nodes) -> + if is_root back_edges graph_nodes v then + let sorted = v :: sorted in + let children = filtered_neighbors v edges graph_nodes in + let graph_nodes = S.remove v graph_nodes in + let input_nodes = add_list input_nodes children in + assert (not (S.mem v input_nodes)); + aux sorted graph_nodes input_nodes + else + aux sorted graph_nodes input_nodes + in + aux [] nodes nodes + + let eliminate_roots graph nodes = + eliminate_roots_recursively graph.forward graph.backward nodes + + let eliminate_leaves graph nodes = + let sorted_leaves, remaining_nodes = + eliminate_roots_recursively graph.backward graph.forward nodes + in + remaining_nodes, List.rev sorted_leaves + + (* + Collect all nodes reachable from the root. + Exclude the root unless it can be reached by some cycle. + *) + let visit edges start_node nodes = + assert (S.for_all (fun v -> v.state = Unvisited) nodes); + let visited = ref [] in + let mark_visited v = + v.state <- Visited; + visited := v :: !visited + in + let clear_visited () = + List.iter (fun v -> v.state <- Unvisited) !visited + in + let rec color acc v = + match v.state with + | Visited -> acc + | Unvisited -> + mark_visited v; + List.fold_left (fun acc neighbor -> + if S.mem neighbor nodes then + let acc = S.add neighbor acc in + color acc neighbor + else + acc + ) acc (get_neighbors v edges) + in + let visited_excluding_root = color S.empty start_node in + clear_visited (); + visited_excluding_root + + let find_descendants graph pivot nodes = + print_nodes "find_descendants" nodes; + visit graph.forward pivot nodes + + let find_ancestors graph pivot nodes = + print_nodes "find_ancestors" nodes; + visit graph.backward pivot nodes + + let rec sort_subgraph graph nodes = + print_nodes "sort_subgraph" nodes; + let sorted_left, nodes = eliminate_roots graph nodes in + let nodes, sorted_right = eliminate_leaves graph nodes in + let sorted_middle = + match pick_one nodes with + | None -> [] + | Some (pivot, _) -> partition graph pivot nodes + in + sorted_left @ sorted_middle @ sorted_right + + and partition graph pivot nodes = + print_nodes "partition" nodes; + let ( - ) = S.diff in + let ancestors = find_ancestors graph pivot nodes in + let descendants = find_descendants graph pivot nodes in + let strict_ancestors = ancestors - descendants in + let strict_descendants = descendants - ancestors in + let cycle = S.inter descendants ancestors in + let is_cyclic, pivot_group = + if S.is_empty cycle then ( + assert (not (S.mem pivot ancestors)); + assert (not (S.mem pivot descendants)); + false, S.singleton pivot + ) + else ( + assert (S.mem pivot cycle); + true, cycle + ) + in + let other = nodes - pivot_group - strict_ancestors - strict_descendants in + print_nodes "ancestors" ancestors; + print_nodes "descendants" descendants; + print_nodes "cycle" cycle; + print_nodes "other" other; + sort_subgraph graph strict_ancestors + @ [ is_cyclic, pivot_group ] + @ sort_subgraph graph strict_descendants + @ sort_subgraph graph other (* could as well be inserted anywhere *) + + (* Data preparation and cleanup *) + let sort l = + let node_tbl = Hashtbl.create (2 * List.length l) in + let make_node x = + let id = P.id x in + if not (Hashtbl.mem node_tbl id) then + let v = { + id; + state = Unvisited; + value = x; + } in + Hashtbl.add node_tbl id v + in + let get_node id = + try Some (Hashtbl.find node_tbl id) + with Not_found -> None + in + let make_edge edges v1 v2 = + let l = + try Hashtbl.find edges v1.id + with Not_found -> [] + in + Hashtbl.replace edges v1.id (v2 :: l) + in + List.iter (fun (x, _) -> make_node x) l; + let forward = Hashtbl.create (2 * List.length l) in + let backward = Hashtbl.create (2 * List.length l) in + List.iter (fun (x1, l) -> + let v1 = + match get_node (P.id x1) with + | Some v -> v + | None -> assert false + in + List.iter (fun id2 -> + match get_node id2 with + | None -> () + | Some v2 -> + make_edge forward v1 v2; + make_edge backward v2 v1; + ) l + ) l; + let graph = { forward; backward } in + let nodes = Hashtbl.fold (fun k v set -> S.add v set) node_tbl S.empty in + + let sorted_groups = sort_subgraph graph nodes in + + (* Export as lists *) + List.map (fun (is_cyclic, set) -> + is_cyclic, List.map (fun node -> node.value) (S.elements set) + ) sorted_groups +end + + +(* Testing *) + +module Sorter = Make ( +struct + type t = int + type id = int + let id x = x + let to_string x = string_of_int x +end +) + +let rec in_order result a b = + match result with + | [] -> false + | (cyclic, l) :: ll -> + if List.mem b l then + false + else if List.mem a l then + List.exists (fun (_, l) -> List.mem b l) ll + else + in_order ll a b + +let rec in_same_cycle result a b = + match result with + | [] -> false + | (cyclic, l) :: ll -> + cyclic && List.mem a l && List.mem b l + || in_same_cycle ll a b + +let not_in_cycle result x = + List.exists (function + | (false, [y]) when y = x -> true + | _ -> false + ) result + + +let seq result a b = + in_order result a b + && not (in_order result b a) + && not (in_same_cycle result a b) + +let cyc result a b = + in_same_cycle result a b + && not (in_order result a b) + && not (in_order result b a) + +let sng result x = + not_in_cycle result x + +let run_test1 () = + Sorter.sort [ + 1, [ 2 ]; + 2, [ 3 ]; + 3, [ 1 ]; + ] + +let test1 () = + let r = run_test1 () in + assert (cyc r 1 2); + assert (cyc r 2 3); + assert (cyc r 1 3) + +let run_test2 () = + Sorter.sort [ + 1, [ 2 ]; + 2, [ 3 ]; + 3, []; + 5, [ 6 ]; + 4, [ 5 ]; + 6, []; + ] + +let test2 () = + let r = run_test2 () in + assert (seq r 1 2); + assert (seq r 2 3); + assert (seq r 4 5); + assert (seq r 5 6); + assert (sng r 3); + assert (sng r 6) + +let run_test3 () = + Sorter.sort [ + 1, [ 2; 3 ]; + 2, [ 3 ]; + 3, [ 3; 4 ]; + 4, [ 3; ]; + 5, [ 6 ]; + 6, [ 6; 1 ]; + 5, [ 7 ]; + 7, [ 8 ]; + 8, [ 9 ]; + 9, [ 0 ]; + 10, [ 10 ]; + 11, [ 12 ]; + 12, [ 13 ]; + 13, [ 11 ]; + ] + +let test3 () = + let r = run_test3 () in + assert (not (sng r 0)); + assert (not (seq r 0 1)); + assert (not (seq r 1 0)); + assert (not (cyc r 0 0)); + assert (sng r 1); + assert (seq r 1 2); + assert (seq r 1 4); + assert (seq r 1 3); + assert (seq r 2 3); + assert (cyc r 3 4); + assert (sng r 5); + assert (seq r 6 1); + assert (sng r 7); + assert (sng r 8); + assert (sng r 9); + assert (seq r 5 9); + assert (cyc r 10 10); + assert (cyc r 11 12); + assert (cyc r 12 13); + assert (cyc r 11 13) + +let test () = + test1 (); + test2 (); + test3 () diff --git a/atd_sort.mli b/atd_sort.mli new file mode 100644 index 0000000..a8148fc --- /dev/null +++ b/atd_sort.mli @@ -0,0 +1,73 @@ +(** + Topological sort that doesn't give up on cycles. + +{v + A --> B + C --> D + B --> C + C --> B + D --> E + E --> E +v} + + gives the following ordering: + +{v + [A] [B C]* [D] [E]* +v} + + where a group marked with a star is cyclic, i.e any member of the group + can be reached from any other member of that group. + + This is used by atdgen to sort type definitions by dependency order, + creating recursive groups only when needed. This makes ocamlopt + significantly faster in certain pathological situations. + Also it improves the clarity of the generated code and can be used to + report cycles in a context where they are not allowed. + + Feel free to reuse outside of atdgen. The algorithm is outlined in + the ml file. The interface of this module may change without notice. +*) + +module type Param = +sig + type t + (** Type of the nodes as specified by the user *) + + type id + (** Node identifier that can be compared and hashed using + the generic comparison and hashing functions of the standard library. + Typically an int or a string. + *) + + val id : t -> id + (** User function to extract a node's unique identifier *) + + val to_string : id -> string + (** User function to make a node identifier printable, + used for debugging only. *) +end + +module Make (P : Param) : +sig + val sort : (P.t * P.id list) list -> (bool * P.t list) list + (** + Partition the nodes of a directed graph into groups and sort these + groups such that all edges going from one group to another + point to the right, and such that each group + has a single element or is a cycle. A cyclic group is marked + as [true] while non-cyclic singletons are marked as [false]. + + A cycle is a set of nodes such that any node of the set + can be reached from any other node of that set. + + All groups of more than one node are cyclic. + Groups of one node may or may not be cyclic. + *) + + (**/**) + val debug : bool ref +end + +(**/**) +val test : unit -> unit diff --git a/atd_tsort.ml b/atd_tsort.ml deleted file mode 100644 index cc04653..0000000 --- a/atd_tsort.ml +++ /dev/null @@ -1,103 +0,0 @@ - - -open Printf - -type ('a, 'b) node = ('a * 'a list * 'b) - -module type Ordered = -sig - type t - val compare : t -> t -> int - val to_string : t -> string -end - -module Make (Param : Ordered) : -sig - val sort : (Param.t, 'a) node list -> (bool * 'a list) list -end = -struct - - module S = Set.Make (Param) - module M = Map.Make (Param) - - type state = White | Grey | Black - - let fst3 (x, _, _) = x - - let init_states l = - List.fold_left (fun m x -> M.add (fst3 x) (ref White) m) M.empty l - - let get_state key states = - try !(M.find key states) - with Not_found -> - invalid_arg (sprintf "Atd_tsort: undefined child node %s" - (Param.to_string key)) - - let set_state key state states = - try M.find key states := state - with Not_found -> - invalid_arg (sprintf "Atd_tsort: undefined child node %s" - (Param.to_string key)) - - let merge (s1, l1, ll1) (s2, l2, ll2) = - (S.union s1 s2, l1 @ l2, ll1 @ ll2) - - let map_of_list l = - List.fold_left (fun m x -> M.add (fst3 x) x m) M.empty l - - let get_node key graph = - try M.find key graph - with Not_found -> - invalid_arg - (sprintf "Atd_tsort: undefined child node %s" (Param.to_string key)) - - let rec sort_root graph states (x : (_, _) node) = - let key, children, value = x in - match get_state key states with - Black -> (S.empty, [], []) - | Grey -> (S.singleton key, [], []) - | White -> - set_state key Grey states; - let closing_nodes, cycle_nodes, sorted = - sort_list graph states children in - set_state key Black states; - if S.is_empty closing_nodes then - (closing_nodes, [], (false, [value]) :: sorted) - else - let closing_nodes = S.remove key closing_nodes in - let cycle_nodes = value :: cycle_nodes in - if S.is_empty closing_nodes then - (closing_nodes, [], (true, cycle_nodes) :: sorted) - else - (closing_nodes, cycle_nodes, sorted) - - and sort_list graph states l = - List.fold_left ( - fun accu key -> - merge (sort_root graph states (get_node key graph)) accu - ) (S.empty, [], []) l - - and sort (l : (Param.t, 'a) node list) = - let graph = map_of_list l in - let states = init_states l in - let _, _, sorted = - sort_list graph states (List.map fst3 l) in - sorted - -end - -(* Testing *) -(* -module Test = Make (String) - - -let test_result = - Test.sort [ - "1", [ "2"; "3" ], "1"; - "2", [ "3" ], "2"; - "3", [ "3"; "4" ], "3"; - "4", [ "3"; ], "4"; - "5", [ "6" ], "5"; - "6", [ "6"; "1" ], "6"; - ] -*) diff --git a/atd_tsort.mli b/atd_tsort.mli deleted file mode 100644 index 72ff509..0000000 --- a/atd_tsort.mli +++ /dev/null @@ -1,23 +0,0 @@ - - -(* - Generic topological sorting and cycle detection. - - This is useful for detecting which definitions are truly recursive, - if allowed at all. -*) - -type ('a, 'b) node = ('a * 'a list * 'b) - -module type Ordered = -sig - type t - val compare : t -> t -> int - val to_string : t -> string (* for error messages *) -end - -module Make (Param : Ordered) : -sig - val sort : (Param.t, 'a) node list -> (bool * 'a list) list - (* bool indicates whether definitions are mutually recursive. *) -end diff --git a/atd_util.ml b/atd_util.ml index 9b7261a..c95ecd1 100644 --- a/atd_util.ml +++ b/atd_util.ml @@ -1,5 +1,3 @@ - - let read_lexbuf ?(expand = false) ?keep_poly ?(xdebug = false) ?(inherit_fields = false) @@ -67,11 +65,16 @@ let load_string read_lexbuf ?expand ?keep_poly ?xdebug ?inherit_fields ?inherit_variants ?pos_fname ?pos_lnum lexbuf -module Tsort = Atd_tsort.Make ( +module Tsort = Atd_sort.Make ( struct - type t = string - let compare = String.compare - let to_string s = s + type t = Atd_ast.module_item + type id = string (* type name *) + + let id def = + let `Type (loc, (name, _, _), x) = def in + name + + let to_string name = name end ) @@ -82,7 +85,7 @@ let tsort l0 = fun def -> let `Type (loc, (name, _, _), x) = def in let deps = Atd_ast.extract_type_names ~ignorable x in - (name, deps, def) + (def, deps) ) l0 in List.rev (Tsort.sort l) diff --git a/unit_tests.ml b/unit_tests.ml new file mode 100644 index 0000000..88d8411 --- /dev/null +++ b/unit_tests.ml @@ -0,0 +1,4 @@ +let main () = + Atd_sort.test () + +let () = main () -- Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-ocaml-maint/packages/ocaml-atd.git _______________________________________________ Pkg-ocaml-maint-commits mailing list Pkg-ocaml-maint-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-ocaml-maint-commits