exception Unreachable and Unimplemented

fun $ (x, y) = x y
infixr 0 $

fun assert truth = if not truth then raise Unreachable else ()

(* All global values which computations may raise an exception must be
 * wrapped in lazy, so that no exception is thrown before custom
 * top-level handler is set.
 *)
fun lazy thunk =
let
  datatype 'a value =
    Unevaluated of unit -> 'a |
    Evaluated of 'a |
    Exn of exn

  val value = ref $ Unevaluated thunk 
in
  fn () =>
    case !value of
      Unevaluated th =>
        let
          val x = th () handle e => (value := Exn e; raise e)
        in
          value := Evaluated x;
          x
        end
    | Evaluated v => v
    | Exn e => raise e
end

structure Fold = struct
  fun fold (a, f) g = g (a, f)
  fun step0 h (a, f) = fold (h a, f)
  fun step1 h (a, f) b = fold (h (b, a), f)
  fun step2 h (a, f) b c = fold (h (b, c, a), f)
end

structure FRU = struct
  fun next g (f, z) x = g (f x, z)
  fun f1 (f, z) x = f (z x)
  fun f2 z = next f1 z
  fun f3 z = next f2 z
  fun f4 z = next f3 z
  fun f5 z = next f4 z
  fun f6 z = next f5 z
  fun f7 z = next f6 z
  fun f8 z = next f7 z
  fun f9 z = next f8 z

  fun c0 from = from
  fun c1 from = c0 from f1
  fun c2 from = c1 from f2
  fun c3 from = c2 from f3
  fun c4 from = c3 from f4
  fun c5 from = c4 from f5
  fun c6 from = c5 from f6
  fun c7 from = c6 from f7
  fun c8 from = c7 from f8
  fun c9 from = c8 from f9

  fun makeUpdate cX (from, from', to) record =
    let
       fun ops () = cX from'
       fun vars f = to f record
    in
       Fold.fold ((vars, ops), fn (vars, _) => vars from)
    end
  fun makeUpdate0 z = makeUpdate c0 z
  fun makeUpdate1 z = makeUpdate c1 z
  fun makeUpdate2 z = makeUpdate c2 z
  fun makeUpdate3 z = makeUpdate c3 z
  fun makeUpdate4 z = makeUpdate c4 z
  fun makeUpdate5 z = makeUpdate c5 z
  fun makeUpdate6 z = makeUpdate c6 z
  fun makeUpdate7 z = makeUpdate c7 z
  fun makeUpdate8 z = makeUpdate c8 z
  fun makeUpdate9 z = makeUpdate c9 z

  fun upd z = Fold.step2
    (fn (s, f, (vars, ops)) =>
      (fn out => vars (s (ops ()) (out, f)), ops)) z
  fun set z = Fold.step2
    (fn (s, v, (vars, ops)) =>
      (fn out => vars (s (ops ()) (out, fn _ => v)), ops)) z

 fun set2 s v = Fold.step0
   (fn (vars, ops) => (fn out => vars (s (ops ()) (out, fn _ => v)), ops))
 fun upd2 s f = Fold.step0
   (fn (vars, ops) => (fn out => vars (s (ops ()) (out, f)), ops))
end

fun % (a, f) = f a
val s = FRU.set
val u = FRU.upd

fun output s = TextIO.output (TextIO.stdOut, s)
local
  fun printBuffer _ [] = ()
    | printBuffer stream (s :: acc) =
      (TextIO.output (stream, s); printBuffer stream acc)
in
  fun fprintf stream f = Fold.fold
    ((stream, []), fn (stream, acc) => printBuffer stream (rev acc)) f
  fun printf f = fprintf TextIO.stdOut f

  fun ` z = Fold.step1 (fn (str, (s, acc)) => (s, str :: acc)) z
  fun A0 z = Fold.step1 (fn (f, (s, a)) => (s, f () :: a)) z
  fun A1 z = Fold.step2 (fn (f, v, (s, a)) => (s, f v :: a)) z
  fun bind A f = fn z => Fold.fold z A f

  val C = fn z => bind A1 str z
  val I = fn z => bind A1 Int.toString z
end