| 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) |