lib/mlton/basic/tree.sml

   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)