[MLton] sequences of products

[Stephen Weeks]

This note describes a new approach to arbitrary list products, along
with a new approach to products, different from infix & as a datatype
constructor.

The idea is to representat a product as its destructor function.  That
is, represent the product of types t1, t2, ..., tn as the type

  (t1 -> t2 -> ... -> tn -> 'a) -> 'a

We'd like to use 

  forall a'. (t1 -> t2 -> ... -> tn -> 'a) -> 'a

but since SML doesn't have first class polymorphism, we'll often have
to use an instantiation with 'a as some fixed type.  Fortunately, for
many cases, a single fixed type suffices.

This representation of products has a couple of advantages over &.
First, it supports products of length 1.  Second, there is a simple
associative operator for appending two products.  If f represents t1,
t2, ..., tn and g represents u1, u2, ..., um, then g o f represents t1,
t2, ..., tn, u1, u2, ..., um.  Furthermore, append has a natural unit,
namely, the identity function.  

One drawback of this approach vs & is that destructuring requires a
curried function.  That is, if p is a product of types t1, t2, ...,
tn, then the following expression destructures p.

  p (fn x1 => fn x2 => ... fn xn => e)

The currying is not so concise in SML.  One could use a function
declaration instead of an anonymous function, but for many situations
anonymous functions are handy.  So, I think it's useful to have a
family of curry functions C<n> so that one can do

  p (Cn (fn (x1, x2, ..., xn) => e))

In any case, once we have a representation of products, we can
represent a product of sequences as stream where each element is a
product of the corresponding element of each of the sequences.  Then,
all the usual fold/forall/map functions work over streams, passing the
product for each element to the supplied function.

The code below implements this idea, with the added bonus that it
supports all kinds of sequences (arrays, lists, strings, vectors), not
just lists.  The varargs stuff is used for constructing arbitrary
products, with directives for embedding each kind of sequence as a
stream.

--------------------------------------------------------------------------------
fun C2 z a b = z (a, b)
fun C3 z a b c = z (a, b, c)
fun C4 z a b c d = z (a, b, c, d)
fun C5 z a b c d e = z (a, b, c, d, e)
fun C6 z a b c d e f = z (a, b, c, d, e, f)
fun C7 z a b c d e f g = z (a, b, c, d, e, f, g)
fun C8 z a b c d e f g h = z (a, b, c, d, e, f, g, h)
fun C9 z a b c d e f g h i = z (a, b, c, d, e, f, g, h, i)
fun const c _ = c
val curry = C2
fun pass x f = f x
fun id x = x
fun $ (a, f) = f a

structure Fold =
   struct
      val fold = pass
      fun step0 h (a1, f) = fold (h a1, f)
      fun step1 h $ x = step0 (curry h x) $
      fun step2 h $ a1 a2 = step0 (fn x => h (a1, a2, x)) $
   end

structure Foldr =
   struct
      fun foldr (c, f) = Fold.fold (f, pass c)
      fun step0 h = Fold.step0 (fn g => g o h)
      fun step1 h = Fold.step1 (fn (z, g) => g o curry h z)
   end

structure Prod =
   struct
      type ('a, 'b) t = 'a -> 'b

      fun dest (f, g) = f g
      val none = id
      val one = pass
      fun append (f, g) = g o f
   end

structure Option =
   struct
      fun map (opt, f) =
         case opt of
            NONE => NONE
          | SOME x => SOME (f x)
   end

structure Stream =
   struct
      datatype 'a t = T of unit -> ('a * 'a t) option

      val empty = T (fn () => NONE)

      fun cons (x, s) = T (fn () => SOME (x, s))

      fun dest (T f) = f ()

      fun unfold (b, f) =
         let
            fun loop b = T (fn () => Option.map (f b, fn (a, b) => (a, loop b)))
         in
            loop b
         end
                        
      fun forever x = unfold ((), fn () => SOME (x, ()))

      fun fold (s, b, f) =
         let
            fun loop (s, b) =
               case dest s of
                  NONE => b
                | SOME (a, s) => loop (s, f (a, b))
         in
            loop (s, b)
         end

      fun toList s = List.rev (fold (s, [], op ::))

      fun map (s, f) =
         let
            fun loop s =
               T (fn () => Option.map (dest s, fn (a, s) => (f a, loop s)))
         in
            loop s
         end
   end

structure Prods =
   struct
      datatype ('a, 'b) t = T of {isNone: bool} * ('a, 'b) Prod.t Stream.t

      fun none () = T ({isNone = true}, Stream.forever Prod.none)

      fun stream s = T ({isNone = false}, Stream.map (s, Prod.one))

      fun toStream (T (_, s)) = Stream.map (s, fn p => Prod.dest (p, id))

      local
         fun make (size, sub) s =
            stream
            (Stream.unfold
             (0, fn i => if i = size s then NONE else SOME (sub (s, i), i + 1)))
      in
         fun array a = make (Array.length, Array.sub) a
         fun string s = make (String.size, String.sub) s
         fun vector v = make (Vector.length, Vector.sub) v
      end

      fun list l =
         stream (Stream.unfold (l, fn [] => NONE | a :: l => SOME (a, l)))
                  
      fun toList ps = Stream.toList (toStream ps)

      fun append (T ({isNone = i}, s), T ({isNone = i'}, s')) =
         T ({isNone = i andalso i'},
            Stream.unfold
            ((s, s'), fn (s, s') =>
             let
                fun empty i = if i then NONE else raise Fail "length mismatch"
             in
                case (Stream.dest s, Stream.dest s') of
                   (NONE, NONE) => NONE
                 | (NONE, SOME _) => empty i'
                 | (SOME (p, s), SOME (p', s')) =>
                      SOME (Prod.append (p, p'), (s, s'))
                 | (SOME _, NONE) => empty i
             end))

      fun P $ = Foldr.foldr (none (), fn p => p) $
         
      local
         fun make c = Foldr.step1 (fn (x, p) => append (c x, p))
      in
         val ` = fn $ => make id $
         val A = fn $ => make array $
         val L = fn $ => make list $
         val S = fn $ => make string $
         val V = fn $ => make vector $
      end
         
      local
         fun make (T (is, s), b, f, step, done) =
            let
               fun loop (s, b) =
                  case Stream.dest s of
                     NONE => done b
                   | SOME (p, ls) => step (Prod.dest (p, f),
                                           b, fn b => loop (ls, b))
            in
               loop (s, b)
            end
      in
         fun fold (p, b, f) = make (p, b, f, fn (h, b, k) => k (h b), id)
         fun forall (p, f) =
            make (p, (), f, fn (h, _, k) => h andalso k (), const true)
         fun foreach (p, f) =
            make (p, (), f, fn (h, (), k) => k (), ignore)
         fun map (p, f) =
            make (p, (), f, fn (x, (), k) => Stream.cons (x, k ()),
                  const Stream.empty)
      end
   end

open Prods

val a = Array.fromList [1.0, 2.0, 3.0]
val l = [1, 2, 3]
val s = "abc"
val v = Vector.fromList ["foo", "bar", "baz"]

local
   fun make ts x = (print (ts x); print "\n")
in
   val pb = make Bool.toString
   val pc = make Char.toString
   val pi = make Int.toString
   val pr = make Real.toString
end

val () = foreach (P L l $, pi)

val () =
   foreach (P L l A a $,
            C2 (fn (i, r) => (pi i; pr r)))

val _ : (real * int * char * string) Stream.t =
   map (P A a L l S s V v $, C4 id)

val () =
   print
   (concat
    (rev
     ("\n" :: (fold (P S s V v $,
                     [], C3 (fn (c, s, ac) => str c :: s :: ac))))))