[MLton] printf via fold

Vesa Karvonen vesa.karvonen@cs.helsinki.fi
Wed, 31 Aug 2005 19:04:32 +0300


Quoting Stephen Weeks <sweeks@sweeks.com>:
[...]
> One can also use the techniques in this note to build a nicer version
> of functional record update and optional arguments requiring only a
> single global "setter" instead of the per-function or
> per-optional-argument approaches we discussed earlier.  I'll save that
> for a separate note.

Interesting. I also did some experiments on FRU/OA (last changes seem to
be dated the 25th), but forgot about it. Here are snippets of the code I
came up with:

  (* 3-tuple update *)
  datatype ('v1, 'v2, 'v3) t = V1 of 'v1 | V2 of 'v2 | V3 of 'v3
  fun set3 f v (v1, v2, v3) =
      let fun g h v =
              (case h v of V1 v1 => v1 | _ => v1,
               case h v of V2 v2 => v2 | _ => v2,
               case h v of V3 v3 => v3 | _ => v3)
      in f (g V1, g V2, g V3) v end

  (* FRU/OA stuff *)
  fun pass x f = f x
  fun $> x = x
  fun <$ k = k $>
  fun wrapArg (set, t2r, t2r', r2t) t f v = pass (t o t2r o set (f o t2r') v o r2t)

  (* updater for {a, b, c} *)
  local
     fun t2r (v1, v2, v3) = {a = v1, b = v2, c = v3}
     fun r2t {a = v1, b = v2, c = v3} = (v1, v2, v3)
  in
     fun arg t f = wrapArg (set3, t2r, t2r, r2t) t f
  end

  (* testing *)
  val r = <$arg#a 1 arg#b 2.0 arg#c "3"$> {a=0, b=0.0, c="0"}

[...]
> I defined "$" at the top level because it will be useful as the
> end-of-arguments terminator in all situations, not just fold left.
[...]
> Nicely, the same end-of-argument terminator ($) that we used before
> still works. This will be true throughout this note. It's probably worth
> exposing $ at the top-level in the basis that exports all this stuff.

Yes, I can't see how it would cause harm. I would probably make it so.
OTOH, it doesn't seem imperative to expose $ at the top level, because it
isn't an infix operator and it could just as well be bound in each module
that uses the technique. Of course, exposing $ at the top level saves some
work. In other words, instead of

   Library code:
     fun $ (*...*)
     structure DSL = struct (* no $ *) ... end

   User code:
     let open DSL in ... $ ... end

you could have

   Library code:
     structure DSL = struct fun $ (*...*) ... end

   User code:
     let open DSL in ... $ ... end

and the user code stays the same.

> ----------------------------------------------------------------------
> structure MakeFold =
>    struct
>       fun makeFold (a, g, f) = Foldr.foldr ((g, f), fn (_, f) => f a)
>       fun step_0_1 h =
>          Foldr.step0 (fn (g, r) => (g, fn a => fn d1 => r (g (h d1, a))))
>       fun step_1_0 z =
>          Foldr.step1 (fn (b, (g, r)) => (g, fn a => r (g (b, a)))) z
>       fun step_1_1 h =
>          Foldr.step1 (fn (z, (g, r)) =>
>                       (g, fn a => fn d1 => r (g (h (z, d1), a))))
>    end
> ----------------------------------------------------------------------
> 
> By plugging in the definitions and using the Foldr equations, one can
> see that the MakeFold library satisfies the following equations.
> 
>   makeFold (a, g, f) 
>            (step_1_0 h1) b1 (step_1_0 h2) b2 ... (step_1_0 hn) bn $ 
>   === g (hn bn, ... g (h2 b2, g (h1 b1, a))
> 
>   makeFold (a, g, f) 
>            (step_0_1 h1) (step_0_1 h2) ... (step_0_1 hn) $ 
>            b1 b2 ... bn
>   === g (hn bn, ... g (h2 b2, g (h1 b1, a))
> 
>   makeFold (a, g, f) 
>            (step_1_1 h1) b1 (step_1_1 h2) b2 ... (step_1_1 hn) bn $ 
>            c1 c2 ... cn
>   === g (hn (bn, cn), ... g (h2 (b2, c2), g (h1 (b1, c1), a)))

The above definition of step_1_0 seems to be wrong. Shouldn't it be:

        fun step_1_0 h =
           Foldr.step1 (fn (b, (g, r)) => (g, fn a => r (g (h b, a))))

Also, I wonder if it would make sense to use curried functions and to make
it so that the "inline argument" (to step1, step_1_0, and step_1_1) is
used "inline" (immediately) rather than after applying $. This would allow
you to use partial application (evaluation) to avoid repeated computation
(similar to e.g. the Char.contains function of the SML Basis library:
http://www.standardml.org/Basis/char.html#SIG:CHAR.contains:VAL). The
syntax may be slightly more verbose, but the ability to take advantage of
partial application might be useful in some circumstances. The end of this
message contains an implementation of this idea and a simple Scanf
implementation that uses the (curried) Fold library.

> One could define fprintf in the following simpler way.
> 
>       fun fprintf out =
>          MakeFold.makeFold ((),
>                             fn (s, f) => (f (); TextIO.output (out, s)),
>                             fn () => ())
> 
> However, I think the first way I gave is better because none of the
> printing happens until fprintf is fully applied.  Thus partial
> applications will work as expected and it will be easier to avoid
> errors where fprintf isn't fully applied (since nothing displays until
> it is).

Looking at the Ocaml Printf documentation, it seems that the simpler thing
is the wrong thing to do:

  http://caml.inria.fr/pub/docs/manual-ocaml/libref/Printf.html

In other words, the warning would disappear from the documentation (and
the gotcha, of course) if printing was delayed.

> In any case, MLton should still do the right thing.

Is there a simple way to verify this?

> That's it.  Less than forty lines of code to define printf along with
> a few useful libraries for handling variable-number of arguments,
> optional arguments, and other generic folders.

Very nice work!

> All that remains is the signatures.  Sadly, these are not so nice
> because of the large number of type variables involved.  I'd love to
> hear suggestions for improvements, but I'm not optimistic.

The type abbreviations seem about as concise as they can be. It might be
possible to make them more readable by using more descriptive (mnemonic)
names for the type variables, but that's about it.

-Vesa Karvonen

(************************************************************************)

infix <\ fun x <\f = fn y => f (x, y)
infix /> fun f/> y = fn x => f (x, y)
fun pass x f = f x
fun id x = x
fun const x _ = x
fun curry f x y = f (x, y)
fun uncurry f (x, y) = f x y

datatype ('a, 'b) product = & of 'a * 'b
infix &

(************************************************************************)

fun $ (a, f) = f a

structure Fold =
   struct
      val fold = pass
      fun step0 h (a1, f) = fold (h a1, f)
      fun step1 h u x = step0 (h x) u
   end

(************************************************************************)

fun pi' i = print (Int.toString i)
fun pi i = (pi' i; print "\n")
fun pis is = 
   (print "["
    ; (case is of 
          [] => () 
        | i :: is => (pi' i; List.app (fn i => (print ", "; pi' i)) is))
    ; print "]\n")

(************************************************************************)

fun C $ = Fold.step0 (1 <\op+) $
fun f $ = Fold.fold (0, pi) $
val () = f $
val () = f C C $
val () = f C C C C C $

(************************************************************************)

fun C $ = Fold.step1 (curry op::) $
fun f $ = Fold.fold ([], pis) $
val () = f C 1 $
val () = f C 1 C 2 C 3 $

(************************************************************************)

fun C $ = Fold.step0 const $
fun f $ = Fold.fold ((), id) $
val () = f C $ ()
val () = f C C C $ () () ()

(************************************************************************)

fun L $ = Fold.fold ([], rev) $
fun X $ = Fold.fold ([], Fold.step1 (curry op::) $ o rev)
fun Y $ = Fold.step1 (curry op::) $
val () = List.app pis (L X Y 1 Y 2 Y 3 $ 
                         X Y 4 Y 5 $ 
                         X Y 6 $ 
                       $)

(************************************************************************)

structure Foldr =
   struct
      fun foldr (c, f) = Fold.fold (f, pass c)
      fun step0 h = Fold.step0 (op o/> h)
      fun step1 h = Fold.step1 (fn x => op o/> h x)
   end

(************************************************************************)

fun C $ = Foldr.step1 (curry op::) $
fun f $ = Foldr.foldr ([], pis) $
val () = f C 1 $
val () = f C 1 C 2 C 3 $

(************************************************************************)

structure MakeFold =
   struct
      fun makeFold (a, g, f) = Foldr.foldr ((g, f), fn (_, f) => f a)
      fun step_0_0 b1 =
         Foldr.step0 (fn (g, r) => (g, fn a => r (g (b1, a))))
      fun step_0_1 h =
         Foldr.step0 (fn (g, r) => (g, fn a => fn c1 => r (g (h c1, a))))
      fun step_1_0 h $ b1 = step_0_0 (h b1) $
      fun step_1_1 h $ b1 = step_0_1 (h b1) $
   end

(************************************************************************)

structure Printf =
   struct
      fun format $ = MakeFold.makeFold ([], op ::, concat o rev) $
      fun fprintf out =
         MakeFold.makeFold
         (id,
          fn (s, f) => fn () => (f (); TextIO.output (out, s)),
          pass ())
      fun printf $ = fprintf TextIO.stdOut $
      fun ` $ = MakeFold.step_1_0 id $
      val newSpec = MakeFold.step_0_1
      fun D $ = newSpec Int.toString $
      fun G $ = newSpec Real.toString $
   end

(************************************************************************)

local
   open Printf
   val f = printf`"A real "G`" and a real "G`".\n"$ 13.1
   val g = fprintf TextIO.stdErr`"A string"
   val () = printf`"Hello.\n"$
   val () = printf`"An int "D`" and an int "D`".\n"$ 13 14
   val () = print (format`"An int "D`" and a real "G`".\n"$ 13 3.1415)
   val () = f 3.1415
   val () = g `" - followed by another.\n"$
   val () = printf $
   val () = printf G D`"\n"$ 1.0 13
in end

(************************************************************************)

structure Scanf =
   struct
      exception Scanf

      fun fromString s = (Substring.getc, Substring.full s)

      fun scanf (g, s) = Fold.fold ((g, s, id), fn (_, s, vs) => pass (vs s))
      fun sscanf $ = (scanf o fromString) $

      fun newScanner scan =
          Fold.step0 (fn (g, s, vs) =>
                         case scan (g, s) of
                            NONE => raise Scanf
                          | SOME (v, s) =>
                            (g, s, case vs v of vs_v => fn v => vs_v & v))

      fun newSkipper scan =
          Fold.step1 (fn a1 =>
                         case scan a1 of
                            scan_a1 =>
                            fn (g, s, vs) =>
                               case scan_a1 (g, s) of
                                  NONE => raise Scanf
                                | SOME s => (g, s, vs))

      fun ` $ =
          newSkipper
             (fn s' =>
                 fn (g, s) => let
                       fun loop (s, s') =
                           case g s & Substring.getc s' of
                              SOME (c, s) & SOME (c', s') =>
                              if c = c' then
                                 loop (s, s')
                              else
                                 NONE
                            | _ & NONE => SOME s
                            | _ & SOME _ => NONE
                    in loop (s, Substring.full s') end)
             $
      fun D $ = newScanner (uncurry (Int.scan StringCvt.DEC)) $
      fun G $ = newScanner (uncurry Real.scan) $
   end

(************************************************************************)

val () =
    let open Scanf in
       sscanf "An int 25 and a real 3.141\n"
              `"An int "D`" and a real "G`"\n"$ end
       let open Printf in
          fn i & r & _ =>
             printf `"Got an int "D`" and a real "G`".\n"$ i r end

(************************************************************************)