[Pkg-ocaml-maint-commits] [ocaml-atd] 01/05: Imported Upstream version 1.1.2
Stéphane Glondu
glondu at moszumanska.debian.org
Wed Aug 6 10:00:50 UTC 2014
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 <steph at 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
More information about the Pkg-ocaml-maint-commits
mailing list