Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2013,2017 Matthew Fluet. |
2 | * Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh | |
3 | * Jagannathan, and Stephen Weeks. | |
4 | * | |
5 | * MLton is released under a BSD-style license. | |
6 | * See the file MLton-LICENSE for details. | |
7 | *) | |
8 | ||
9 | functor Tree (S: TREE_STRUCTS): TREE = | |
10 | struct | |
11 | ||
12 | open S | |
13 | ||
14 | datatype 'a t = T of 'a * 'a t Seq.t | |
15 | ||
16 | fun children (T (_, v)) = v | |
17 | ||
18 | fun foldPre (T (a, v), b, f) = | |
19 | Seq.fold (v, f (a, b), fn (t, b) => foldPre (t, b, f)) | |
20 | ||
21 | fun foldPost (T (a, v), b, f) = | |
22 | f (a, Seq.fold (v, b, fn (t, b) => foldPost (t, b, f))) | |
23 | ||
24 | fun traverse (t, f) = | |
25 | let | |
26 | fun loop (T (a, v)) = | |
27 | let | |
28 | val g = f a | |
29 | val _ = Seq.foreach (v, loop) | |
30 | val _ = g () | |
31 | in | |
32 | () | |
33 | end | |
34 | in | |
35 | loop t | |
36 | end | |
37 | ||
38 | fun foreachPre (t, f: 'a -> unit) = traverse (t, fn a => (f a; fn () => ())) | |
39 | fun foreachPost (t, f) = traverse (t, fn a => fn () => f a) | |
40 | ||
41 | local | |
42 | fun mkLayoutDot {nodeOptions: 'a -> Dot.NodeOption.t list, | |
43 | options, | |
44 | title} = | |
45 | let | |
46 | fun loopTree (next, nodes, T (x, ts)) = | |
47 | let | |
48 | val name = next () | |
49 | val () = | |
50 | List.push | |
51 | (nodes, {name = name, | |
52 | options = nodeOptions x, | |
53 | successors = loopForest (next, nodes, ts)}) | |
54 | in | |
55 | name | |
56 | end | |
57 | and loopForest (next, nodes, ts) = | |
58 | rev (Seq.fold (ts, [], fn (t, ac) => | |
59 | {name = loopTree (next, nodes, t), | |
60 | options = []} :: ac)) | |
61 | fun wrap (loop, arg) = | |
62 | let | |
63 | val c = Counter.new 0 | |
64 | fun next () = concat ["n", Int.toString (Counter.next c)] | |
65 | val nodes = ref [] | |
66 | val _ = loop (next, nodes, arg) | |
67 | in | |
68 | Dot.layout {nodes = !nodes, | |
69 | options = options, | |
70 | title = title} | |
71 | end | |
72 | in | |
73 | {layoutDotTree = fn t => wrap (loopTree, t), | |
74 | layoutDotForest = fn ts => wrap (loopForest, ts)} | |
75 | end | |
76 | in | |
77 | fun layoutDotTree (t, opts) = (#layoutDotTree (mkLayoutDot opts)) t | |
78 | fun layoutDotForest (ts, opts) = (#layoutDotForest (mkLayoutDot opts)) ts | |
79 | end | |
80 | val layoutDot = layoutDotTree | |
81 | ||
82 | local | |
83 | fun mkLayout lay = | |
84 | let | |
85 | open Layout | |
86 | fun layoutTree (T (x, ts)) = | |
87 | paren (seq [lay x, str ", ", layoutForest ts]) | |
88 | and layoutForest ts = | |
89 | Seq.layout (ts, layoutTree) | |
90 | in | |
91 | {layoutTree = layoutTree, layoutForest = layoutForest} | |
92 | end | |
93 | in | |
94 | fun layoutTree (t, lay) = (#layoutTree (mkLayout lay)) t | |
95 | fun layoutForest (ts, lay) = (#layoutForest (mkLayout lay)) ts | |
96 | end | |
97 | val layout = layoutTree | |
98 | ||
99 | fun map (T (a, ts), f) = T (f a, Seq.map (ts, fn t => map (t, f))) | |
100 | ||
101 | structure Forest = | |
102 | struct | |
103 | type 'a t = 'a t Seq.t | |
104 | val layoutDot = layoutDotForest | |
105 | val layout = layoutForest | |
106 | end | |
107 | ||
108 | end | |
109 | ||
110 | structure Tree = Tree (structure Seq = | |
111 | struct | |
112 | open Vector | |
113 | ||
114 | fun layout (v, l) = Vector.layout l v | |
115 | end) |