path: root/common.sml

exception Unreachable and Unimplemented

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

val compare = fn a => fn b => Int.compare (a, b)

fun sort _ [] = []
  | sort _ [x] = [x]
  | sort le l =
  let
    fun divide [] accp = accp
      | divide [x] (acc1, acc2) = (x :: acc1, acc2)
      | divide (x :: y :: tail) (acc1, acc2) =
        divide tail (x :: acc1, y :: acc2)
    val (part1, part2) = divide l ([], [])
    val part1 = sort le part1
    val part2 = sort le part2

    fun merge [] [] acc = acc
      | merge [] ys acc = rev $ List.revAppend (ys, acc)
      | merge xs [] acc = rev $ List.revAppend (xs, acc)
      | merge (x :: xs) (y :: ys) acc =
          if le (x, y) then
            merge xs (y :: ys) (x :: acc)
          else
            merge (x :: xs) ys (y :: acc)
  in
    merge part1 part2 []
  end

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

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)
  fun step3 h (a, f) b c d = fold (h (b, c, d, a), f)
  fun step4 h (a, f) b c d e = fold (h (b, c, d, e, 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 f10 z = next f9 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 c10 from = c9 from f10

  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 makeUpdate10 z = makeUpdate c10 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 sysExit code = Posix.Process.exit $ Word8.fromInt code

fun exit code = (
  TextIO.closeOut TextIO.stdOut;
  TextIO.closeOut TextIO.stdErr;
  sysExit code
)

fun output stream s = TextIO.output (stream, s)

fun makePrintfBase output =
let
  val firstOnLine = ref true
  fun endsWithNL "" = raise Unreachable
    | endsWithNL s = String.sub (s, size s - 1) = #"\n"

  fun output' "" = ()
    | output' s = (
    output s;
    firstOnLine := endsWithNL s
  )
  fun mf () =
    if not $ !firstOnLine then
      (output "\n"; firstOnLine := true)
    else
      ()
in
  (output', mf)
end

type 'a acc = (string -> unit) * 'a

local
  val ctx = ((false, makePrintfBase $ output TextIO.stdOut),
    fn (_: bool * ((string -> unit) * (unit -> unit))) => ())
in
  fun printf g = Fold.fold ctx g
end

fun sprintf g =
let
  val buf = ref []
  fun output s = buf := s :: !buf
  fun finish _ = String.concat $ rev $ !buf
in
  Fold.fold ((false, makePrintfBase output), finish)
end g

fun printfp n g =
let
  val buf = ref []
  fun output s = buf := s :: !buf
  fun finish _ =
  let
    val s = String.concat $ rev $ !buf
    val s =
      if size s < n then
        implode (List.tabulate (n - size s, fn _ => #" ")) ^ s
      else
        s
  in
    TextIO.output (TextIO.stdOut, s)
  end
in
  Fold.fold ((false, makePrintfBase output), finish)
end g

fun Printf out g = Fold.fold ((false, out), fn _ => ()) g

local
  fun ifF flag cl = if not flag then cl () else ()
in
  fun ` z = Fold.step1 (fn (s, (ign, out as (output, _))) =>
    (ifF ign (fn () => output s); (ign, out))) z

  fun A0 z = Fold.step1 (fn (f, (ign, out)) =>
    (ifF ign (fn () => f out); (ign, out))) z
  fun A1 z = Fold.step2 (fn (f, v, (ign, out)) =>
    (ifF ign (fn () => f v out); (ign, out))) z
  fun A2 z = Fold.step3 (fn (f, v1, v2, (ign, out)) =>
    (ifF ign (fn () => f v1 v2 out); (ign, out))) z
  fun A3 z = Fold.step4 (fn (f, v1, v2, v3, (ign, out)) =>
    (ifF ign (fn () => f v1 v2 v3 out); (ign, out))) z
end

fun Ign z = Fold.step0 (fn (_, out) => (true, out)) z

fun bind A f = fn z => Fold.fold z A f
fun bindWith2str to = bind A1 (fn v => fn (output, _) => output $ to v)

fun F z = bind A0 (fn (_, mf) => mf ()) z

val I = fn z =>
let
  fun f v out =
    if v >= 0 then
      Printf out `(Int.toString v) %
    else
      Printf out `"-" `(Int.toString $ ~v) %
in
  bind A1 f
end z

fun i v out = Printf out I v %

val Ip = fn z =>
let
  fun f w i out =
  let
    val s = Int.toString i
    val len = size s
    val s =
      if len < w then
        implode (List.tabulate (w - len, fn _ => #" ")) ^ s
      else
        s
  in
    Printf out `s %
  end
in
  bind A2 f
end z

val C = fn z => bindWith2str str z
val B = fn z => bindWith2str Bool.toString z
val W = fn z => bindWith2str (Word.fmt StringCvt.DEC) z
val R = fn z => bind A1 (fn n => fn (output, _) => app (fn f => f ())
        (List.tabulate (n, fn _ => fn () => output "    "))) z

type ('t, 'a, 'b, 'c) a1printer = (bool * ((string -> unit) * 'a)) * 'b
        -> 't -> ((bool * ((string -> unit) * 'a)) * 'b -> 'c) -> 'c

type ('t1, 't2, 'a, 'b, 'c) a2printer =
    (bool * ((string -> unit) * 'a)) * 'b -> 't1 -> 't2 ->
        ((bool * ((string -> unit) * 'a)) * 'b -> 'c) -> 'c

fun poptInternal addSpace none p v out =
  case v of
    NONE => Printf out `none %
  | SOME v => Printf out A1 p v `(if addSpace then " " else "") %

fun poptN z = poptInternal false z
val Popt = fn z => bind A2 (poptInternal false "") z
val PoptS = fn z => bind A2 (poptInternal true "") z

fun plist p l (s, parens, from) out =
let
  fun f [] _ = ()
    | f [e] out = Printf out A1 p e %
    | f (e1 :: e2 :: tail) out =
      (Printf out A1 p e1 %; Printf out `s A1 f (e2 :: tail) %)
in
  if parens andalso length l >= from then
    Printf out `"(" A1 f l `")" %
  else
    Printf out A1 f l %
end

val Plist = fn z => bind A3 plist z

fun die code g =
let
  fun finish (true, _) = raise Unreachable
    | finish (false, (output, _)) = (
        output "\n";
        exit code
    )
in
  printf `"error: " (fn (a, _) => g (a, finish))
end

fun printfn g =
let
  fun finish (true, _) = ()
    | finish (false, (output, _)) = output "\n"
in
  printf (fn (a, _) => g (a, finish))
end