Import Upstream version 20180207

[hcoop/debian/mlton.git] / regression / same-fringe.sml

structure Z =
struct

structure Thread = MLton.Thread

fun generate(f: ('a -> unit) -> unit): unit -> 'a option =
   let
      val paused: 'a option Thread.t option ref = ref NONE
      val gen: unit Thread.t option ref = ref NONE
      fun return(a: 'a option): unit =
         Thread.switch(fn t' =>
                       let val _ = gen := SOME t'
                          val t = valOf(!paused)
                          val _ = paused := NONE
                       in Thread.prepare (t, a)
                       end)
      val _ =
         gen := SOME(Thread.new(fn () => (f (return o SOME)
                                          ; return NONE)))
   in fn () => Thread.switch(fn t => (paused := SOME t
                                      ; Thread.prepare (valOf(!gen), ())))
   end
   
datatype 'a tree =
    L of 'a
  | N of 'a tree * 'a tree

fun foreach(t: 'a tree, f: 'a -> unit): unit =
   let
      val rec loop =
         fn L a => f a
          | N(l, r) => (loop l; loop r)
   in loop t
   end

fun same(f: unit -> 'a option,
         g: unit -> 'a option,
         eq: 'a * 'a -> bool): bool =
   let
      fun loop() =
         case (f(), g()) of
            (NONE, NONE) => true
          | (SOME x, SOME y) => eq(x, y) andalso loop()
          | _ => false
   in loop()
   end

fun fringe(t: 'a tree): unit -> 'a option =
   generate(fn f => foreach(t, f))

fun sameFringe(t1: 'a tree, t2: 'a tree, eq: 'a * 'a -> bool): bool =
   same(fringe t1, fringe t2, eq)

val t1 = N(N(L 1, L 2), N(N(L 3, L 4), L 5))
val t2 = N(L 1, N(N(L 2, L 3), N(L 4, L 5)))

val _ =
   if sameFringe(t1, t2, op =)
      then print "success\n"
   else print "failure\n"
         
end