[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