[MLton-commit] r6419

Vesa Karvonen vesak at mlton.org
Tue Feb 26 09:18:36 PST 2008


Initial implementation of basic Uniplate-style generics.  Tested briefly
interactively, but not very thoroughly.

----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm
U   mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
A   mltonlib/trunk/com/ssh/generic/unstable/detail/value/uniplate.sml
U   mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
U   mltonlib/trunk/com/ssh/generic/unstable/lib.use
U   mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
A   mltonlib/trunk/com/ssh/generic/unstable/public/value/uniplate.sig
A   mltonlib/trunk/com/ssh/generic/unstable/with/uniplate.sml

----------------------------------------------------------------------

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm	2008-02-26 17:01:39 UTC (rev 6418)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm	2008-02-26 17:18:35 UTC (rev 6419)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+(* Copyright (C) 2007-2008 SSH Communications Security, Helsinki, Finland
  *
  * This code is released under the MLton license, a BSD-style license.
  * See the LICENSE file or http://mlton.org/License for details.
@@ -42,6 +42,7 @@
    ../../../public/value/type-exp.sig
    ../../../public/value/type-hash.sig
    ../../../public/value/type-info.sig
+   ../../../public/value/uniplate.sig
    ../../framework/generics.sml
    ../../framework/ty.sml
    ../../util/sml-syntax.sml

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm	2008-02-26 17:01:39 UTC (rev 6418)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm	2008-02-26 17:18:35 UTC (rev 6419)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+(* Copyright (C) 2007-2008 SSH Communications Security, Helsinki, Finland
  *
  * This code is released under the MLton license, a BSD-style license.
  * See the LICENSE file or http://mlton.org/License for details.
@@ -44,5 +44,6 @@
    ../../value/type-exp.sml
    ../../value/type-hash.sml
    ../../value/type-info.sml
+   ../../value/uniplate.sml
    extensions.cm
    sigs.cm

Added: mltonlib/trunk/com/ssh/generic/unstable/detail/value/uniplate.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/uniplate.sml	2008-02-26 17:01:39 UTC (rev 6418)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/uniplate.sml	2008-02-26 17:18:35 UTC (rev 6419)
@@ -0,0 +1,233 @@
+(* Copyright (C) 2008 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(* TBD: Avoid redundantly querying/transforming substructures *)
+
+functor WithUniplate (Arg : WITH_UNIPLATE_DOM) : UNIPLATE_CASES = struct
+   (* <-- SML/NJ workaround *)
+   open TopLevel
+   infix 7 >> << *`
+   infix 6 +`
+   infix 4 orb
+   infix 0 &
+   (* SML/NJ workaround --> *)
+
+   type r = Unit.t Ref.t Option.t
+   type 'a i = r * 'a Univ.Iso.t
+
+   val dummy = (NONE, (undefined, undefined))
+
+   type e = (HashUniv.t, Unit.t) HashMap.t
+   type c = Univ.t List.t
+   datatype 'a t =
+      IN of 'a i * ((r * e) * c * 'a -> c) * ((r * e) * c * 'a -> 'a * c)
+
+   val none = IN (dummy, fn (_, c, _) => c, fn (_, c, x) => (x, c))
+
+   fun cyclic aT (IN (_, aKi, aKo)) = let
+      val (to, _) = HashUniv.new {eq = op =, hash = Arg.hash aT}
+   in
+      IN (dummy,
+          fn args as ((_, e), c, x) => let
+                val xD = to x
+             in
+                if isSome (HashMap.find e xD) then c
+                else (HashMap.insert e (xD, ()) ; aKi args)
+             end,
+          fn args as ((_, e), c, x) => let
+                val xD = to x
+             in
+                if isSome (HashMap.find e xD) then (x, c)
+                else (HashMap.insert e (xD, ()) ; aKo args)
+             end)
+   end
+
+   fun op `*` (IN (_, aKi, aKo), IN (_, bKi, bKo)) =
+       IN (dummy,
+           fn (r, c, a & b) => aKi (r, bKi (r, c, b), a),
+           fn (r, c, a & b) =>
+              case aKo (r, c, a)
+               of (a, c) =>
+                  case bKo (r, c, b)
+                   of (b, c) => (a & b, c))
+   fun op `+` (IN (_, aKi, aKo), IN (_, bKi, bKo)) =
+       IN (dummy,
+           fn (r, c, INL a) => aKi (r, c, a)
+            | (r, c, INR b) => bKi (r, c, b),
+           fn (r, c, INL a) => Pair.map (INL, id) (aKo (r, c, a))
+            | (r, c, INR b) => Pair.map (INR, id) (bKo (r, c, b)))
+   fun iso' (IN (_, ki, ko)) (a2b, b2a) =
+       IN (dummy,
+           fn (r, c, a) => ki (r, c, a2b a),
+           fn (r, c, a) => Pair.map (b2a, id) (ko (r, c, a2b a)))
+
+   structure UniplateRep = LayerRep
+     (open Arg
+      structure Rep = MkClosedRep (type 'a t = 'a t))
+
+   open UniplateRep.This
+
+   fun newMap () = HashMap.new {eq = HashUniv.eq, hash = HashUniv.hash}
+
+   fun uniplate' aT =
+       case getT aT
+        of IN ((NONE, _), _, _) =>
+           (fn x => ([], fn _ => x))
+         | IN ((r, (to, from)), ki, ko) =>
+           (fn x => (map from (ki ((r, newMap ()), [], x)),
+                     fn xs => #1 (ko ((r, newMap ()), map to xs, x))))
+
+   fun children t = #1 o uniplate' t
+   fun holes t =
+       (fn (k, c) => let
+              fun lp hs ys =
+               fn []    => hs
+                | x::xs =>
+                  lp ((x, fn x => c (List.revAppend (ys, x::xs)))::hs) (x::ys) xs
+           in
+              lp [] [] k
+           end) o
+       uniplate' t
+   fun contexts t x = let
+      fun lp (x, f, ys) =
+          foldl (fn ((x, c), ys) => lp (x, f o c, ys))
+                ((x, f)::ys)
+                (holes t x)
+   in
+      rev (lp (x, id, []))
+   end
+   fun para t f x = f x (map (para t f) (children t x))
+   fun descend t f = (fn (k, c) => c (map f k)) o uniplate' t
+   fun transform t f x = f (descend t (transform t f) x)
+   fun rewrite t f =
+       transform t (fn x => case f x of NONE => x | SOME x => rewrite t f x)
+   fun universe t x = let
+      fun lp (x, ys) = foldl lp (x::ys) (children t x)
+   in
+      rev (lp (x, []))
+   end
+
+   fun uniplate t =
+       (fn (children, context) =>
+           (children,
+            context o (case length children
+                        of n => fn children =>
+                                   if n <> length children
+                                   then fail "wrong number of children"
+                                   else children))) o
+       uniplate' t
+
+   structure Open = LayerDepCases
+     (fun iso        bT = iso' (getT bT)
+      fun isoProduct bP = iso' (getP bP)
+      fun isoSum     bS = iso' (getS bS)
+
+      fun op *` (aP, bP) = op `*` (getP aP, getP bP)
+      val T      = getT
+      fun R _    = getT
+      val tuple  = getP
+      val record = getP
+
+      fun op +` (aS, bS) = op `+` (getS aS, getS bS)
+      val unit = none
+      fun C0 _ = unit
+      fun C1 _ = getT
+      val data = getS
+
+      fun Y ? = Tie.pure (fn () => let
+         val r = SOME (ref ())
+         val iso as (to, from) = Univ.Iso.new ()
+         val rKi = ref (raising Fix.Fix)
+         fun ki' ? = !rKi ?
+         val rKo = ref (raising Fix.Fix)
+         fun ko' ? = !rKo ?
+         val i = (r, iso)
+      in
+         (IN (i,
+              fn args as ((r', _), c, x) =>
+                 if r = r' then to x::c else ki' args,
+              fn args as ((r', _), c, _) =>
+                 if r = r'
+                 then case c
+                       of []   => fail "bug"
+                        | x::c => (from x, c)
+                 else ko' args),
+          fn IN (_, ki, ko) => (rKi := ki ; rKo := ko ; IN (i, ki, ko)))
+      end) ?
+
+      fun op --> _ = none
+
+      val exn = none
+      fun regExn0 _ _ = ()
+      fun regExn1 _ _ _ = ()
+
+      fun array aT =
+          case getT aT
+           of IN (_, aKi, aKo) =>
+              cyclic (Arg.Open.array ignore aT)
+                     (IN (dummy,
+                          fn (r, c, s) =>
+                             Array.foldr (fn (a, c) => aKi (r, c, a)) c s,
+                          fn (r, c, s) => let
+                                fun lp i c =
+                                    if i = Array.length s
+                                    then (s, c)
+                                    else case aKo (r, c, Array.sub (s, i))
+                                          of (x, c) =>
+                                             (Array.update (s, i, x)
+                                            ; lp (i+1) c)
+                             in
+                                lp 0 c
+                             end))
+      fun list aT =
+          (Tie.fix Y)
+             (fn aListT =>
+                 iso' (op `+` (unit, op `*` (getT aT, aListT)))
+                      (fn [] => INL () | x::xs => INR (x & xs),
+                       fn INL () => [] | INR (x & xs) => x::xs))
+      fun vector aT =
+          case getT aT
+           of (IN (_, aKi, aKo)) =>
+              IN (dummy,
+                  fn (r, c, s) =>
+                     Vector.foldr (fn (a, c) => aKi (r, c, a)) c s,
+                  fn (r, c, s) =>
+                     Vector.unfoldi
+                        (fn (i, c) => aKo (r, c, Vector.sub (s, i)))
+                        (Vector.length s, c))
+
+      fun refc aT =
+          case getT aT
+           of IN (_, aKi, aKo) =>
+              cyclic (Arg.Open.refc ignore aT)
+                     (IN (dummy,
+                          fn (r, c, s) => aKi (r, c, !s),
+                          fn (r, c, s) => case aKo (r, c, !s)
+                                           of (x, c) => (s := x ; (s, c))))
+
+      val fixedInt  = none
+      val largeInt  = none
+
+      val largeReal = none
+      val largeWord = none
+
+      val bool   = none
+      val char   = none
+      val int    = none
+      val real   = none
+      val string = none
+      val word   = none
+
+      val word8  = none
+      val word32 = none
+(*
+      val word64 = none
+*)
+
+      fun hole () = IN (dummy, undefined, undefined)
+
+      open Arg UniplateRep)
+end


Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/value/uniplate.sml
___________________________________________________________________
Name: svn:eol-style
   + native

Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb	2008-02-26 17:01:39 UTC (rev 6418)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb	2008-02-26 17:18:35 UTC (rev 6419)
@@ -92,6 +92,9 @@
          public/value/fmap.sig
          detail/value/fmap.sml
 
+         public/value/uniplate.sig
+         detail/value/uniplate.sml
+
          public/value/ord.sig
          detail/value/ord.sml
 

Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.use
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.use	2008-02-26 17:01:39 UTC (rev 6418)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.use	2008-02-26 17:18:35 UTC (rev 6419)
@@ -55,6 +55,8 @@
      "detail/value/eq.sml",
      "public/value/fmap.sig",
      "detail/value/fmap.sml",
+     "public/value/uniplate.sig",
+     "detail/value/uniplate.sml",
      "public/value/ord.sig",
      "detail/value/ord.sml",
      "public/value/pickle.sig",

Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml	2008-02-26 17:01:39 UTC (rev 6418)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml	2008-02-26 17:18:35 UTC (rev 6419)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+(* Copyright (C) 2007-2008 SSH Communications Security, Helsinki, Finland
  *
  * This code is released under the MLton license, a BSD-style license.
  * See the LICENSE file or http://mlton.org/License for details.
@@ -203,3 +203,8 @@
       and WITH_TYPE_HASH_DOM = WITH_TYPE_HASH_DOM
 functor WithTypeHash (Arg : WITH_TYPE_HASH_DOM) : TYPE_HASH_CASES =
    WithTypeHash (Arg)
+
+signature UNIPLATE = UNIPLATE and UNIPLATE_CASES = UNIPLATE_CASES
+      and WITH_UNIPLATE_DOM = WITH_UNIPLATE_DOM
+functor WithUniplate (Arg : WITH_UNIPLATE_DOM) : UNIPLATE_CASES =
+   WithUniplate (Arg)

Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/uniplate.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/uniplate.sig	2008-02-26 17:01:39 UTC (rev 6418)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/uniplate.sig	2008-02-26 17:18:35 UTC (rev 6419)
@@ -0,0 +1,103 @@
+(* Copyright (C) 2008 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(**
+ * Signature for a generic function for processing recursive datatypes.
+ * Unlike the {Reduce}, {Transform}, and {Fmap} generics, this generic
+ * allows recursive datatypes to be processed in various ways without
+ * requiring the recursive datatype to be encoded as a fixed point of a
+ * functor.
+ *
+ * Much of this generic is inspired by the following article:
+ *
+ *   Uniform Boilerplate and List Processing
+ *   Neil Mitchell and Colin Runciman
+ *   ICFP 2007
+ *)
+signature UNIPLATE = sig
+   structure UniplateRep : OPEN_REP
+
+   val children : ('a, 'x) UniplateRep.t -> 'a -> 'a List.t
+   (**
+    * Returns all maximal proper substructures of the same type contained
+    * in the given value.  This is non-recursive.
+    *)
+
+   val universe : ('a, 'x) UniplateRep.t -> 'a -> 'a List.t
+   (**
+    * Returns a list of all substructures of the same type contained in
+    * the given value (including it).  This is recursive.
+    *)
+
+   val holes : ('a, 'x) UniplateRep.t -> 'a -> ('a * 'a UnOp.t) List.t
+   (**
+    * Returns a list of all maximal proper substructures of the given
+    * value and functions to replace the corresponding substructure in the
+    * given value.
+    *
+    *> map op </ (holes t x) = children t x
+    *)
+
+   val contexts : ('a, 'x) UniplateRep.t -> 'a -> ('a * 'a UnOp.t) List.t
+   (**
+    * Returns a list of all substructures of the given value and functions
+    * to replace the corresponding substructure in the given value.
+    *
+    *> map op </ (contexts t x) = universe t x
+    *)
+
+   val descend : ('a, 'x) UniplateRep.t -> 'a UnOp.t UnOp.t
+   (**
+    * Replaces each maximal proper substructure {x} by {f x} in the given
+    * value.  This is non-recursive.
+    *)
+
+   val para : ('a, 'x) UniplateRep.t -> ('a -> 'b List.t -> 'b) -> 'a -> 'b
+   (**
+    * A kind of fold.  {para} can be defined as follows:
+    *
+    *> fun para t f x = f x (map (para t f) (children t x))
+    *)
+
+   val rewrite : ('a, 'x) UniplateRep.t -> ('a -> 'a Option.t) -> 'a UnOp.t
+   (**
+    * Exhaustive recursive bottom-up transformation.  The idea is to keep
+    * rewriting as long as some new value is returned.  {rewrite} can be
+    * defined as follows:
+    *
+    *> fun rewrite t f =
+    *>     transform t (fn x => case f x
+    *>                           of NONE   => x
+    *>                            | SOME x => rewrite t f x)
+    *)
+
+   val transform : ('a, 'x) UniplateRep.t -> 'a UnOp.t UnOp.t
+   (**
+    * Recursive bottom-up transformation.  {transform} can be defined as
+    * follows:
+    *
+    *> fun transform t f x = f (descend t (transform t f) x)
+    *)
+
+   val uniplate : ('a, 'x) UniplateRep.t -> 'a -> 'a List.t * ('a List.t -> 'a)
+   (**
+    * Returns a list of all maximal proper substructures (children) of the
+    * same type contained in the given value and a function, dubbed
+    * context, to replace the substructures.  At immutable contexts, a new
+    * value is built.  At mutable contexts, the objects are mutated.  The
+    * number of elements in the list given to context must be equal to the
+    * number of maximal proper substructure returned.  All functions
+    * specified in the {UNIPLATE} signature can be defined in terms of
+    * {uniplate}.
+    *)
+end
+
+signature UNIPLATE_CASES = sig
+   include CASES UNIPLATE
+   sharing Open.Rep = UniplateRep
+end
+
+signature WITH_UNIPLATE_DOM = HASH_CASES


Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/uniplate.sig
___________________________________________________________________
Name: svn:eol-style
   + native

Added: mltonlib/trunk/com/ssh/generic/unstable/with/uniplate.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/with/uniplate.sml	2008-02-26 17:01:39 UTC (rev 6418)
+++ mltonlib/trunk/com/ssh/generic/unstable/with/uniplate.sml	2008-02-26 17:18:35 UTC (rev 6419)
@@ -0,0 +1,19 @@
+(* Copyright (C) 2008 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+signature Generic = sig
+   include Generic UNIPLATE
+end
+
+functor MkGeneric (Arg : Generic) = struct
+   structure Open = MkGeneric (Arg)
+   open Arg Open
+   structure UniplateRep = Open.Rep
+end
+
+structure Generic =
+   MkGeneric (structure Open = WithUniplate (Generic)
+              open Generic Open)


Property changes on: mltonlib/trunk/com/ssh/generic/unstable/with/uniplate.sml
___________________________________________________________________
Name: svn:eol-style
   + native




More information about the MLton-commit mailing list