[MLton-commit] r6048
Vesa Karvonen
vesak at mlton.org
Sun Sep 23 06:19:25 PDT 2007
Tweaked functor signatures to make combining and defining generics
simpler. See the lib-with-default.mlb and test.mlb, in particular, for
how to define a combination of generics with the ML Basis system or in an
interactive implementation with the use-procedure.
Also implemented a na?\195?\175ve algorithm for searching smaller counterexamples
in the unit-test framework.
----------------------------------------------------------------------
A mltonlib/trunk/com/ssh/generic/unstable/Test-mlton.sh
U mltonlib/trunk/com/ssh/generic/unstable/Test-smlnj.sh
U mltonlib/trunk/com/ssh/generic/unstable/Test.bgb
D mltonlib/trunk/com/ssh/generic/unstable/Test.sh
A mltonlib/trunk/com/ssh/generic/unstable/detail/close-pretty-with-extra.fun
U mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/layer-generic.fun
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/data-rec-info.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-exp.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-hash.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml
U mltonlib/trunk/com/ssh/generic/unstable/lib-with-default.mlb
U mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
U mltonlib/trunk/com/ssh/generic/unstable/public/layer-cases-fun.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/layer-dep-cases-fun.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/layer-rep-fun.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/layered-rep.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/arbitrary.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/data-rec-info.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/dynamic.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/hash.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/reduce.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/seq.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/size.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/some.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/transform.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/type-exp.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/type-hash.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sig
U mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml
U mltonlib/trunk/com/ssh/generic/unstable/test/reduce.sml
U mltonlib/trunk/com/ssh/generic/unstable/test/transform.sml
A mltonlib/trunk/com/ssh/generic/unstable/test/utils.fun
D mltonlib/trunk/com/ssh/generic/unstable/test/utils.sml
U mltonlib/trunk/com/ssh/generic/unstable/test.cm
U mltonlib/trunk/com/ssh/generic/unstable/test.mlb
A mltonlib/trunk/com/ssh/generic/unstable/with/
A mltonlib/trunk/com/ssh/generic/unstable/with/arbitrary.sml
A mltonlib/trunk/com/ssh/generic/unstable/with/close-pretty-with-extra.sml
A mltonlib/trunk/com/ssh/generic/unstable/with/close.sml
A mltonlib/trunk/com/ssh/generic/unstable/with/data-rec-info.sml
A mltonlib/trunk/com/ssh/generic/unstable/with/eq.sml
A mltonlib/trunk/com/ssh/generic/unstable/with/extra.sml
A mltonlib/trunk/com/ssh/generic/unstable/with/generic.sml
A mltonlib/trunk/com/ssh/generic/unstable/with/hash.sml
A mltonlib/trunk/com/ssh/generic/unstable/with/infix-product.sml
A mltonlib/trunk/com/ssh/generic/unstable/with/ord.sml
A mltonlib/trunk/com/ssh/generic/unstable/with/pickle.sml
A mltonlib/trunk/com/ssh/generic/unstable/with/pretty.sml
A mltonlib/trunk/com/ssh/generic/unstable/with/reduce.sml
A mltonlib/trunk/com/ssh/generic/unstable/with/reg-basis-exns.sml
A mltonlib/trunk/com/ssh/generic/unstable/with/seq.sml
A mltonlib/trunk/com/ssh/generic/unstable/with/size.sml
A mltonlib/trunk/com/ssh/generic/unstable/with/some.sml
A mltonlib/trunk/com/ssh/generic/unstable/with/transform.sml
A mltonlib/trunk/com/ssh/generic/unstable/with/type-hash.sml
A mltonlib/trunk/com/ssh/generic/unstable/with/type-info.sml
A mltonlib/trunk/com/ssh/unit-test/unstable/detail/generic.sml
U mltonlib/trunk/com/ssh/unit-test/unstable/detail/mk-unit-test.fun
U mltonlib/trunk/com/ssh/unit-test/unstable/detail/unit-test.sml
U mltonlib/trunk/com/ssh/unit-test/unstable/lib-with-default.cm
U mltonlib/trunk/com/ssh/unit-test/unstable/lib-with-default.mlb
U mltonlib/trunk/com/ssh/unit-test/unstable/public/mk-unit-test-fun.sig
----------------------------------------------------------------------
Copied: mltonlib/trunk/com/ssh/generic/unstable/Test-mlton.sh (from rev 6035, mltonlib/trunk/com/ssh/generic/unstable/Test.sh)
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/Test.sh 2007-09-19 13:00:00 UTC (rev 6035)
+++ mltonlib/trunk/com/ssh/generic/unstable/Test-mlton.sh 2007-09-23 13:19:11 UTC (rev 6048)
@@ -0,0 +1,24 @@
+#!/bin/bash
+
+# Copyright (C) 2007 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.
+
+set -e
+set -x
+
+mkdir -p generated
+
+echo "SML_COMPILER mlton
+MLTON_LIB $(cd ../../../.. && pwd)" > generated/mlb-path-map
+
+time \
+mlton -mlb-path-map generated/mlb-path-map \
+ -prefer-abs-paths true \
+ -show-def-use generated/test.du \
+ -output generated/test \
+ test.mlb
+
+time \
+generated/test
Modified: mltonlib/trunk/com/ssh/generic/unstable/Test-smlnj.sh
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/Test-smlnj.sh 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/Test-smlnj.sh 2007-09-23 13:19:11 UTC (rev 6048)
@@ -14,5 +14,13 @@
echo '' | \
sml -m test.cm \
$eb/public/export/{open-top-level.sml,infixes.sml} \
- test/utils.sml \
- $(find test/ -name '*.sml' -a -not -name 'utils.sml')
+ test/utils.fun \
+ with/reg-basis-exns.sml \
+ with/data-rec-info.sml \
+ with/some.sml \
+ with/pickle.sml \
+ with/seq.sml \
+ with/reduce.sml \
+ with/transform.sml \
+ with/close-pretty-with-extra.sml \
+ $(find test/ -name '*.sml')
Modified: mltonlib/trunk/com/ssh/generic/unstable/Test.bgb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/Test.bgb 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/Test.bgb 2007-09-23 13:19:11 UTC (rev 6048)
@@ -5,4 +5,6 @@
(bg-build
:name "Generics Test"
- :shell "nice -n5 ./Test.sh")
+ :shell "export COLUMNS=80 &&
+ nice -n5 ./Test-mlton.sh &&
+ nice -n5 ./Test-smlnj.sh")
Deleted: mltonlib/trunk/com/ssh/generic/unstable/Test.sh
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/Test.sh 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/Test.sh 2007-09-23 13:19:11 UTC (rev 6048)
@@ -1,27 +0,0 @@
-#!/bin/bash
-
-# Copyright (C) 2007 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.
-
-set -e
-set -x
-
-mkdir -p generated
-
-echo "SML_COMPILER mlton
-MLTON_LIB $(cd ../../../.. && pwd)" > generated/mlb-path-map
-
-time \
-mlton -mlb-path-map generated/mlb-path-map \
- -prefer-abs-paths true \
- -show-def-use generated/test.du \
- -output generated/test \
- -const 'Exn.keepHistory true' \
- -type-check true \
- -verbose 2 \
- test.mlb
-
-time \
-generated/test
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/close-pretty-with-extra.fun
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/close-pretty-with-extra.fun 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/close-pretty-with-extra.fun 2007-09-23 13:19:11 UTC (rev 6048)
@@ -0,0 +1,22 @@
+(* Copyright (C) 2007 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.
+ *)
+
+functor ClosePrettyWithExtra (Arg : PRETTY_CASES) : GENERIC_EXTRA = struct
+ structure Rep = CloseCases (Arg.Open)
+ structure Rep = WithExtra (open Arg Rep)
+ open Arg Rep
+ local
+ (* <-- SML/NJ workaround *)
+ open TopLevel
+ (* SML/NJ workaround --> *)
+ val et = C "&"
+ in
+ fun op &` ab =
+ iso (data (Pretty.infixL 0 et ab
+ (C1 et (tuple2 ab))))
+ (fn op & ? => ?, op &)
+ end
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/close-pretty-with-extra.fun
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml 2007-09-23 13:19:11 UTC (rev 6048)
@@ -4,96 +4,54 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-structure Generic :> sig
- include GENERIC_EXTRA
- include ARBITRARY sharing Open.Rep = ArbitraryRep
- include DATA_REC_INFO sharing Open.Rep = DataRecInfoRep
- include EQ sharing Open.Rep = EqRep
- include HASH sharing Open.Rep = HashRep
- include ORD sharing Open.Rep = OrdRep
- include PICKLE sharing Open.Rep = PickleRep
- include PRETTY sharing Open.Rep = PrettyRep
- include SOME sharing Open.Rep = SomeRep
- include TYPE_HASH sharing Open.Rep = TypeHashRep
- include TYPE_INFO sharing Open.Rep = TypeInfoRep
-end = struct
- (* <-- SML/NJ workaround *)
- open TopLevel
- (* SML/NJ workaround --> *)
-
+signature Generic = sig structure Open : OPEN_CASES end
+structure Generic : Generic = struct
structure Open = RootGeneric
+end
- (* Add generics not depending on any other generic: *)
- structure Open = WithEq (Open) open Open structure Eq=Open
- structure Open = WithTypeHash (Open) open Open structure TypeHash=Open
- structure Open = WithTypeInfo (Open) open Open structure TypeInfo=Open
- structure Open = WithDataRecInfo (Open) open Open structure DataRecInfo=Open
+signature Generic = sig include Generic EQ end
+structure Generic : Generic = struct
+ structure Open = WithEq (Generic)
+ open Generic Open
+end
- (* Add generics depending on other generics: *)
+signature Generic = sig include Generic TYPE_HASH end
+structure Generic : Generic = struct
+ structure Open = WithTypeHash (Generic)
+ open Generic Open
+end
- structure Open = struct
- open TypeHash TypeInfo Open
- structure TypeHashRep = Rep and TypeInfoRep = Rep
- end
- structure Open = WithHash (Open) open Open structure Hash=Open
+signature Generic = sig include Generic TYPE_INFO end
+structure Generic : Generic = struct
+ structure Open = WithTypeInfo (Generic)
+ open Generic Open
+end
- structure Open = WithOrd (Open) open Open
+signature Generic = sig include Generic HASH end
+structure Generic : Generic = struct
+ structure Open = WithHash
+ (open Generic
+ structure TypeHashRep = Open.Rep and TypeInfoRep = Open.Rep)
+ open Generic Open
+end
- structure Open = struct
- open Hash Open
- structure HashRep = Rep
- end
- structure Open = WithPretty (Open) open Open
+signature Generic = sig include Generic ORD end
+structure Generic = struct
+ structure Open = WithOrd (Generic)
+ open Generic Open
+end
- structure Open = struct
- open Hash TypeInfo Open
- structure HashRep = Rep and TypeInfoRep = Rep
- structure RandomGen = RanQD1Gen
- end
- structure Open = WithArbitrary (Open) open Open
+signature Generic = sig include Generic PRETTY end
+structure Generic = struct
+ structure Open = WithPretty
+ (open Generic
+ structure HashRep = Open.Rep)
+ open Generic Open
+end
- structure Open = struct
- open TypeInfo Open
- structure TypeInfoRep = Rep
- end
- structure Open = WithSome (Open) open Open structure Some=Open
-
- structure Open = struct
- open DataRecInfo Eq Hash Some TypeHash TypeInfo Open
- structure DataRecInfoRep = Rep and EqRep = Rep and HashRep = Rep
- and SomeRep = Rep and TypeHashRep = Rep and TypeInfoRep = Rep
- end
- structure Open = WithPickle (Open) open Open
-
- (* Make type representations equal: *)
- structure ArbitraryRep = Rep
- structure DataRecInfoRep = Rep
- structure EqRep = Rep
- structure HashRep = Rep
- structure OrdRep = Rep
- structure PickleRep = Rep
- structure PrettyRep = Rep
- structure SomeRep = Rep
- structure TypeHashRep = Rep
- structure TypeInfoRep = Rep
-
- (* Close the combination for use: *)
- structure Generic = struct
- structure Open = Open
- structure Closed = CloseCases (Open)
- open Closed
- end
-
- (* Add extra type representation constructors: *)
- structure Extra = WithExtra (Generic) open Extra
-
- (* Pretty print products in infix: *)
- local
- val et = C "&"
- in
- fun op &` ab =
- iso (data (Pretty.infixL 0 et ab
- (C1 et (tuple2 ab))))
- (fn op & ? => ?, op &)
- end
+structure Generic = struct
+ structure Rep = ClosePrettyWithExtra
+ (open Generic
+ structure PrettyRep = Open.Rep)
+ open Generic Rep
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/layer-generic.fun
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/layer-generic.fun 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/layer-generic.fun 2007-09-23 13:19:11 UTC (rev 6048)
@@ -5,24 +5,21 @@
*)
functor LayerRep (Arg : LAYER_REP_DOM) :>
- LAYERED_REP
- where type 'a Closed.t = 'a Arg.Closed.t
- where type 'a Closed.s = 'a Arg.Closed.s
- where type ('a, 'k) Closed.p = ('a, 'k) Arg.Closed.p
+ LAYER_REP_COD
+ where type 'a This.t = 'a Arg.Rep.t
+ where type 'a This.s = 'a Arg.Rep.s
+ where type ('a, 'k) This.p = ('a, 'k) Arg.Rep.p
- where type ('a, 'x) Outer.t = ('a, 'x) Arg.Outer.t
- where type ('a, 'x) Outer.s = ('a, 'x) Arg.Outer.s
- where type ('a, 'k, 'x) Outer.p = ('a, 'k, 'x) Arg.Outer.p =
+ where type ('a, 'x) Outer.t = ('a, 'x) Arg.Open.Rep.t
+ where type ('a, 'x) Outer.s = ('a, 'x) Arg.Open.Rep.s
+ where type ('a, 'k, 'x) Outer.p = ('a, 'k, 'x) Arg.Open.Rep.p =
struct
- open Arg
+ structure Outer = Arg.Open.Rep
+ structure Rep = Arg.Rep
structure Inner = struct
- type ('a, 'x) t = 'a Closed.t * 'x
- type ('a, 'x) s = 'a Closed.s * 'x
- type ('a, 'k, 'x) p = ('a, 'k) Closed.p * 'x
- val mkT = Fn.id
- val mkS = Fn.id
- val mkP = Fn.id
- val mkY = Tie.tuple2
+ type ('a, 'x) t = 'a Rep.t * 'x
+ type ('a, 'x) s = 'a Rep.s * 'x
+ type ('a, 'k, 'x) p = ('a, 'k) Rep.p * 'x
val getT = Pair.snd
val getS = Pair.snd
val getP = Pair.snd
@@ -40,108 +37,115 @@
fun mapS ? = Outer.mapS (Inner.mapS ?)
fun mapP ? = Outer.mapP (Inner.mapP ?)
structure This = struct
+ open Rep
fun getT ? = Pair.fst (Outer.getT ?)
fun getS ? = Pair.fst (Outer.getS ?)
fun getP ? = Pair.fst (Outer.getP ?)
fun mapT ? = Outer.mapT (Pair.mapFst ?)
fun mapS ? = Outer.mapS (Pair.mapFst ?)
fun mapP ? = Outer.mapP (Pair.mapFst ?)
+ val mkT = Fn.id
+ val mkS = Fn.id
+ val mkP = Fn.id
+ val mkY = Tie.tuple2
end
end
functor LayerDepCases (Arg : LAYER_DEP_CASES_DOM) :>
OPEN_CASES
- where type ('a, 'x) Rep.t = ('a, 'x) Arg.Result.t
- where type ('a, 'x) Rep.s = ('a, 'x) Arg.Result.s
- where type ('a, 'k, 'x) Rep.p = ('a, 'k, 'x) Arg.Result.p =
+ where type ('a, 'x) Rep.t = ('a, 'x) Arg.t
+ where type ('a, 'x) Rep.s = ('a, 'x) Arg.s
+ where type ('a, 'k, 'x) Rep.p = ('a, 'k, 'x) Arg.p =
struct
- structure Rep = Arg.Result
+ open Arg
+ structure Rep = Arg
- structure Inner = Rep.Inner
- structure Outer = Arg.Outer
-
fun op1 mk get outer this x2y a = outer (fn x => mk (this a, x2y (get x))) a
fun op2 mk getx gety outer this xy2z ab =
outer (fn (x, y) => mk (this ab, xy2z (getx x, gety y))) ab
fun m mk get outer this f b =
outer (fn y => fn i => mk (this b i, f (get y) i)) b
- fun op0t outer this x = outer (Inner.mkT (this, x))
- fun op1t ? = op1 Inner.mkT Inner.getT ?
- fun t ? = op1 Inner.mkP Inner.getT ?
+ fun op0t outer this x = outer (This.mkT (this, x))
+ fun op1t ? = op1 This.mkT Inner.getT ?
+ fun t ? = op1 This.mkP Inner.getT ?
fun r outer this lx2y l a =
- outer (fn l => fn x => Inner.mkP (this l a, lx2y l (Inner.getT x))) l a
- fun p ? = op1 Inner.mkT Inner.getP ?
- fun s ? = op1 Inner.mkT Inner.getS ?
- fun c0 outer l2s l2x = outer (Inner.mkS o Pair.map (l2s, l2x) o Sq.mk)
+ outer (fn l => fn x => This.mkP (this l a, lx2y l (Inner.getT x))) l a
+ fun p ? = op1 This.mkT Inner.getP ?
+ fun s ? = op1 This.mkT Inner.getS ?
+ fun c0 outer l2s l2x = outer (This.mkS o Pair.map (l2s, l2x) o Sq.mk)
fun c1 outer this cx2y c a =
- outer (fn c => fn x => Inner.mkS (this c a, cx2y c (Inner.getT x))) c a
- fun y outer x y = outer (Inner.mkY (x, y))
+ outer (fn c => fn x => This.mkS (this c a, cx2y c (Inner.getT x))) c a
+ fun y outer x y = outer (This.mkY (x, y))
fun re0 outer this ex =
outer (fn c => fn e => (this c e : Unit.t ; ex c e : Unit.t))
fun re1 outer this ex c a =
outer (fn c => fn x => fn e =>
(this c a e : Unit.t ; ex c (Inner.getT x) e : Unit.t)) c a
- fun iso ? = m Inner.mkT Inner.getT Outer.iso Arg.iso ?
- fun isoProduct ? = m Inner.mkP Inner.getP Outer.isoProduct Arg.isoProduct ?
- fun isoSum ? = m Inner.mkS Inner.getS Outer.isoSum Arg.isoSum ?
- fun op *` ? = op2 Inner.mkP Inner.getP Inner.getP Outer.*` Arg.*` ?
- fun T ? = t Outer.T Arg.T ?
- fun R ? = r Outer.R Arg.R ?
- fun tuple ? = p Outer.tuple Arg.tuple ?
- fun record ? = p Outer.record Arg.record ?
- fun op +` ? = op2 Inner.mkS Inner.getS Inner.getS Outer.+` Arg.+` ?
- fun C0 ? = c0 Outer.C0 Arg.C0 ?
- fun C1 ? = c1 Outer.C1 Arg.C1 ?
- fun data ? = s Outer.data Arg.data ?
- fun unit ? = op0t Outer.unit Arg.unit ?
- fun Y ? = y Outer.Y Arg.Y ?
- fun op --> ? = op2 Inner.mkT Inner.getT Inner.getT Outer.--> Arg.--> ?
- fun exn ? = op0t Outer.exn Arg.exn ?
- fun regExn0 ? = re0 Outer.regExn0 Arg.regExn0 ?
- fun regExn1 ? = re1 Outer.regExn1 Arg.regExn1 ?
- fun array ? = op1t Outer.array Arg.array ?
- fun refc ? = op1t Outer.refc Arg.refc ?
- fun vector ? = op1t Outer.vector Arg.vector ?
- fun fixedInt ? = op0t Outer.fixedInt Arg.fixedInt ?
- fun largeInt ? = op0t Outer.largeInt Arg.largeInt ?
- fun largeReal ? = op0t Outer.largeReal Arg.largeReal ?
- fun largeWord ? = op0t Outer.largeWord Arg.largeWord ?
- fun word8 ? = op0t Outer.word8 Arg.word8 ?
- fun word32 ? = op0t Outer.word32 Arg.word32 ?
- fun word64 ? = op0t Outer.word64 Arg.word64 ?
- fun list ? = op1t Outer.list Arg.list ?
- fun bool ? = op0t Outer.bool Arg.bool ?
- fun char ? = op0t Outer.char Arg.char ?
- fun int ? = op0t Outer.int Arg.int ?
- fun real ? = op0t Outer.real Arg.real ?
- fun string ? = op0t Outer.string Arg.string ?
- fun word ? = op0t Outer.word Arg.word ?
+ fun iso ? = m This.mkT Inner.getT Open.iso Arg.iso ?
+ fun isoProduct ? = m This.mkP Inner.getP Open.isoProduct Arg.isoProduct ?
+ fun isoSum ? = m This.mkS Inner.getS Open.isoSum Arg.isoSum ?
+ fun op *` ? = op2 This.mkP Inner.getP Inner.getP Open.*` Arg.*` ?
+ fun T ? = t Open.T Arg.T ?
+ fun R ? = r Open.R Arg.R ?
+ fun tuple ? = p Open.tuple Arg.tuple ?
+ fun record ? = p Open.record Arg.record ?
+ fun op +` ? = op2 This.mkS Inner.getS Inner.getS Open.+` Arg.+` ?
+ fun C0 ? = c0 Open.C0 Arg.C0 ?
+ fun C1 ? = c1 Open.C1 Arg.C1 ?
+ fun data ? = s Open.data Arg.data ?
+ fun unit ? = op0t Open.unit Arg.unit ?
+ fun Y ? = y Open.Y Arg.Y ?
+ fun op --> ? = op2 This.mkT Inner.getT Inner.getT Open.--> Arg.--> ?
+ fun exn ? = op0t Open.exn Arg.exn ?
+ fun regExn0 ? = re0 Open.regExn0 Arg.regExn0 ?
+ fun regExn1 ? = re1 Open.regExn1 Arg.regExn1 ?
+ fun array ? = op1t Open.array Arg.array ?
+ fun refc ? = op1t Open.refc Arg.refc ?
+ fun vector ? = op1t Open.vector Arg.vector ?
+ fun fixedInt ? = op0t Open.fixedInt Arg.fixedInt ?
+ fun largeInt ? = op0t Open.largeInt Arg.largeInt ?
+ fun largeReal ? = op0t Open.largeReal Arg.largeReal ?
+ fun largeWord ? = op0t Open.largeWord Arg.largeWord ?
+ fun word8 ? = op0t Open.word8 Arg.word8 ?
+ fun word32 ? = op0t Open.word32 Arg.word32 ?
+ fun word64 ? = op0t Open.word64 Arg.word64 ?
+ fun list ? = op1t Open.list Arg.list ?
+ fun bool ? = op0t Open.bool Arg.bool ?
+ fun char ? = op0t Open.char Arg.char ?
+ fun int ? = op0t Open.int Arg.int ?
+ fun real ? = op0t Open.real Arg.real ?
+ fun string ? = op0t Open.string Arg.string ?
+ fun word ? = op0t Open.word Arg.word ?
end
functor LayerCases (Arg : LAYER_CASES_DOM) :>
OPEN_CASES
- where type ('a, 'x) Rep.t = ('a, 'x) Arg.Result.t
- where type ('a, 'x) Rep.s = ('a, 'x) Arg.Result.s
- where type ('a, 'k, 'x) Rep.p = ('a, 'k, 'x) Arg.Result.p =
+ where type ('a, 'x) Rep.t = ('a, 'x) Arg.t
+ where type ('a, 'x) Rep.s = ('a, 'x) Arg.s
+ where type ('a, 'k, 'x) Rep.p = ('a, 'k, 'x) Arg.p =
LayerDepCases
- (open Arg Arg.Result.This
- fun iso b = Arg.iso (getT b)
- fun isoProduct b = Arg.isoProduct (getP b)
- fun isoSum b = Arg.isoSum (getS b)
- fun op2 geta getb this = this o Pair.map (geta, getb)
- fun op *` ? = op2 getP getP Arg.*` ?
- fun op +` ? = op2 getS getS Arg.+` ?
- fun op --> ? = op2 getT getT Arg.--> ?
- fun array a = Arg.array (getT a)
- fun vector a = Arg.vector (getT a)
- fun list a = Arg.list (getT a)
- fun refc a = Arg.refc (getT a)
- fun T a = Arg.T (getT a)
- fun R l a = Arg.R l (getT a)
- fun tuple a = Arg.tuple (getP a)
- fun record a = Arg.record (getP a)
- fun C1 c a = Arg.C1 c (getT a)
- fun data a = Arg.data (getS a)
- fun regExn1 c = Arg.regExn1 c o getT)
+ (open Arg
+ local
+ open Arg.This
+ in
+ fun iso b = Arg.iso (getT b)
+ fun isoProduct b = Arg.isoProduct (getP b)
+ fun isoSum b = Arg.isoSum (getS b)
+ fun op2 geta getb this = this o Pair.map (geta, getb)
+ fun op *` ? = op2 getP getP Arg.*` ?
+ fun op +` ? = op2 getS getS Arg.+` ?
+ fun op --> ? = op2 getT getT Arg.--> ?
+ fun array a = Arg.array (getT a)
+ fun vector a = Arg.vector (getT a)
+ fun list a = Arg.list (getT a)
+ fun refc a = Arg.refc (getT a)
+ fun T a = Arg.T (getT a)
+ fun R l a = Arg.R l (getT a)
+ fun tuple a = Arg.tuple (getP a)
+ fun record a = Arg.record (getP a)
+ fun C1 c a = Arg.C1 c (getT a)
+ fun data a = Arg.data (getS a)
+ fun regExn1 c = Arg.regExn1 c o getT
+ end)
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-09-23 13:19:11 UTC (rev 6048)
@@ -38,6 +38,7 @@
../../../public/value/type-hash.sig
../../../public/value/type-info.sig
../../close-generic.fun
+ ../../close-pretty-with-extra.fun
../../generics-util.sml
../../generics.sml
../../hash-map.sml
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml 2007-09-23 13:19:11 UTC (rev 6048)
@@ -63,18 +63,16 @@
end
structure ArbitraryRep = LayerRep
- (structure Outer = Arg.Rep
- structure Closed = MkClosedRep (type 'a t = 'a t))
+ (open Arg
+ structure Rep = MkClosedRep (type 'a t = 'a t))
open ArbitraryRep.This
fun arbitrary ? = #gen (out (getT ?))
fun withGen gen = mapT (fn IN {cog, ...} => IN {gen = gen, cog = cog})
- structure Layered = LayerDepCases
- (structure Outer = Arg and Result = ArbitraryRep
-
- fun iso aT = iso' (getT aT)
+ structure Open = LayerDepCases
+ (fun iso aT = iso' (getT aT)
fun isoProduct aP = iso' (getP aP)
fun isoSum aS = iso' (getS aS)
@@ -126,7 +124,7 @@
val exn = IN {gen = G.return () >>= (fn () =>
G.intInRange (0, Buffer.length exns-1) >>= (fn i =>
Buffer.sub (exns, i))),
- cog = G.variant o Arg.hash (Arg.exn ())}
+ cog = G.variant o Arg.hash (Arg.Open.exn ())}
fun regExn0 _ (e, _) = Buffer.push exns (G.return e)
fun regExn1 _ aT (a2e, _) = Buffer.push exns (map a2e (arbitrary aT))
@@ -137,24 +135,26 @@
fun refc a = iso' (getT a) (!, ref)
- val fixedInt = mkInt FixedInt.precision FixedInt.fromLarge Arg.fixedInt
- val largeInt = mkInt LargeInt.precision LargeInt.fromLarge Arg.largeInt
+ val fixedInt =
+ mkInt FixedInt.precision FixedInt.fromLarge Arg.Open.fixedInt
+ val largeInt =
+ mkInt LargeInt.precision LargeInt.fromLarge Arg.Open.largeInt
val largeWord =
- mkWord LargeWord.wordSize LargeWord.fromLargeInt Arg.largeWord
- val largeReal = mkReal R.toLarge Arg.largeReal
+ mkWord LargeWord.wordSize LargeWord.fromLargeInt Arg.Open.largeWord
+ val largeReal = mkReal R.toLarge Arg.Open.largeReal
val bool = IN {gen = G.bool, cog = G.variant o W.fromInt o Bool.toInt}
val char = IN {gen = map Byte.byteToChar G.word8,
cog = G.variant o Word8.toWord o Byte.charToByte}
- val int = mkInt Int.precision Int.fromLarge Arg.int
- val real = mkReal id Arg.real
+ val int = mkInt Int.precision Int.fromLarge Arg.Open.int
+ val real = mkReal id Arg.Open.real
val string = iso' (list' char) String.isoList
val word = IN {gen = G.lift G.RNG.value, cog = G.variant}
val word8 = IN {gen = G.word8, cog = G.variant o Word8.toWord}
- val word32 = mkWord Word32.wordSize Word32.fromLargeInt Arg.word32
- val word64 = mkWord Word64.wordSize Word64.fromLargeInt Arg.word64)
+ val word32 = mkWord Word32.wordSize Word32.fromLargeInt Arg.Open.word32
+ val word64 = mkWord Word64.wordSize Word64.fromLargeInt Arg.Open.word64
- open Layered
+ open Arg ArbitraryRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/data-rec-info.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/data-rec-info.sml 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/data-rec-info.sml 2007-09-23 13:19:11 UTC (rev 6048)
@@ -4,7 +4,7 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-functor WithDataRecInfo (Arg : OPEN_CASES) : DATA_REC_INFO_CASES = struct
+functor WithDataRecInfo (Arg : WITH_DATA_REC_INFO_DOM) : DATA_REC_INFO_CASES = struct
(* <-- SML/NJ workaround *)
open TopLevel
infix 2 andAlso
@@ -35,8 +35,8 @@
INT {exn = exn, pure = false, recs = recs}
structure DataRecInfoRep = LayerRep
- (structure Outer = Arg.Rep
- structure Closed = struct
+ (open Arg
+ structure Rep = struct
type 'a t = t
type 'a s = s
type ('a, 'k) p = p
@@ -52,11 +52,8 @@
fun mayBeCyclic ? =
(isMutableType andAlso (mayContainExn orElse mayBeRecData)) ?
- structure Layered = LayerCases
- (structure Outer=Arg and Result=DataRecInfoRep
- and Rep=DataRecInfoRep.Closed
-
- val iso = const
+ structure Open = LayerCases
+ (val iso = const
val isoProduct = const
val isoSum = const
@@ -112,7 +109,7 @@
val word8 = base
val word32 = base
- val word64 = base)
+ val word64 = base
- open Layered
+ open Arg DataRecInfoRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml 2007-09-23 13:19:11 UTC (rev 6048)
@@ -4,7 +4,11 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-functor WithDebug (Arg : OPEN_CASES) : OPEN_CASES = struct
+signature WITH_DEBUG_DOM = sig
+ structure Open : OPEN_CASES
+end
+
+functor WithDebug (Arg : WITH_DEBUG_DOM) : OPEN_CASES = struct
(* <-- SML/NJ workaround *)
open TopLevel
(* SML/NJ workaround --> *)
@@ -20,18 +24,19 @@
fun addN kind (xs, ys) = foldl (add1 kind) xs ys
- structure Check = LayerRep
- (structure Outer = Arg.Rep
- structure Closed = struct
+ val exns : String.t List.t Ref.t = ref []
+ fun regExn c = exns := add1 "exception constructor" (Con.toString c, !exns)
+
+ structure DebugRep = LayerRep
+ (open Arg
+ structure Rep = struct
type 'a t = Unit.t
type 'a s = String.t List.t
type ('a, 'k) p = String.t List.t
end)
structure Layered = LayerCases
- (structure Outer = Arg and Result = Check and Rep = Check.Closed
-
- val iso = const
+ (val iso = const
val isoProduct = const
val isoSum = const
@@ -51,10 +56,7 @@
val op --> = ignore
- val exns : String.t List.t Ref.t = ref []
val exn = ()
- fun regExn c =
- exns := add1 "exception constructor" (Con.toString c, !exns)
fun regExn0 c _ = regExn c
fun regExn1 c _ _ = regExn c
@@ -78,7 +80,9 @@
val word8 = ()
val word32 = ()
- val word64 = ())
+ val word64 = ()
+ open Arg DebugRep)
+
open Layered
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml 2007-09-23 13:19:11 UTC (rev 6048)
@@ -4,7 +4,7 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-functor WithDynamic (Arg : OPEN_CASES) : DYNAMIC_CASES = struct
+functor WithDynamic (Arg : WITH_DYNAMIC_DOM) : DYNAMIC_CASES = struct
(* <-- SML/NJ workaround *)
open TopLevel
infix <-->
@@ -42,8 +42,8 @@
fun isoUnsupported text = (failing text, failing text)
structure DynamicRep = LayerRep
- (structure Outer = Arg.Rep
- structure Closed = MkClosedRep (type 'a t = ('a, t) Iso.t))
+ (open Arg
+ structure Rep = MkClosedRep (type 'a t = ('a, t) Iso.t))
open DynamicRep.This
@@ -51,10 +51,8 @@
fun fromDynamic t d =
SOME (Iso.from (getT t) d) handle Dynamic.Dynamic => NONE
- structure Layered = LayerCases
- (structure Outer=Arg and Result=DynamicRep and Rep=DynamicRep.Closed
-
- fun iso bId aIb = bId <--> aIb
+ structure Open = LayerCases
+ (fun iso bId aIb = bId <--> aIb
val isoProduct = iso
val isoSum = iso
@@ -102,7 +100,7 @@
val word8 = (WORD8, fn WORD8 ? => ? | _ => raise Dynamic)
val word32 = (WORD32, fn WORD32 ? => ? | _ => raise Dynamic)
- val word64 = (WORD64, fn WORD64 ? => ? | _ => raise Dynamic))
+ val word64 = (WORD64, fn WORD64 ? => ? | _ => raise Dynamic)
- open Layered
+ open Arg DynamicRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2007-09-23 13:19:11 UTC (rev 6048)
@@ -4,7 +4,7 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-functor WithEq (Arg : OPEN_CASES) : EQ_CASES = struct
+functor WithEq (Arg : WITH_EQ_DOM) : EQ_CASES = struct
(* <-- SML/NJ workaround *)
open TopLevel
infix 0 &
@@ -32,9 +32,7 @@
| SOME l & SOME r => t (l, r)
| _ => false) exnHandler
- structure EqRep = LayerRep
- (structure Outer = Arg.Rep
- structure Closed = MkClosedRep (BinPr))
+ structure EqRep = LayerRep (open Arg structure Rep = MkClosedRep (BinPr))
open EqRep.This
@@ -42,10 +40,8 @@
fun notEq t = not o eq t
fun withEq eq = mapT (const eq)
- structure Layered = LayerCases
- (structure Outer = Arg and Result = EqRep and Rep = EqRep.Closed
-
- fun iso b (a2b, _) = BinPr.map a2b b
+ structure Open = LayerCases
+ (fun iso b (a2b, _) = BinPr.map a2b b
val isoProduct = iso
val isoSum = iso
@@ -56,7 +52,7 @@
val record = id
val op +` = Sum.equal
- val unit = op = : Unit.t Rep.t
+ val unit = op = : Unit.t t
fun C0 _ = unit
fun C1 _ = id
val data = id
@@ -73,25 +69,25 @@
fun vector ? = seq Vector.length Vector.sub ?
- fun array _ = op = : 'a Array.t Rep.t
- fun refc _ = op = : 'a Ref.t Rep.t
+ fun array _ = op = : 'a Array.t t
+ fun refc _ = op = : 'a Ref.t t
- val fixedInt = op = : FixedInt.t Rep.t
- val largeInt = op = : LargeInt.t Rep.t
+ val fixedInt = op = : FixedInt.t t
+ val largeInt = op = : LargeInt.t t
val largeReal = iso op = CastLargeReal.isoBits
- val largeWord = op = : LargeWord.t Rep.t
+ val largeWord = op = : LargeWord.t t
- val bool = op = : Bool.t Rep.t
- val char = op = : Char.t Rep.t
- val int = op = : Int.t Rep.t
+ val bool = op = : Bool.t t
+ val char = op = : Char.t t
+ val int = op = : Int.t t
val real = iso op = CastReal.isoBits
- val string = op = : String.t Rep.t
- val word = op = : Word.t Rep.t
+ val string = op = : String.t t
+ val word = op = : Word.t t
- val word8 = op = : Word8.t Rep.t
- val word32 = op = : Word32.t Rep.t
- val word64 = op = : Word64.t Rep.t)
+ val word8 = op = : Word8.t t
+ val word32 = op = : Word32.t t
+ val word64 = op = : Word64.t t
- open Layered
+ open Arg EqRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml 2007-09-23 13:19:11 UTC (rev 6048)
@@ -41,8 +41,8 @@
val exns : (Exn.t * p -> Word.t Option.t) Buffer.t = Buffer.new ()
structure HashRep = LayerRep
- (structure Outer = Arg.Rep
- structure Closed = MkClosedRep (type 'a t = 'a t))
+ (open Arg
+ structure Rep = MkClosedRep (type 'a t = 'a t))
open HashRep.This
@@ -60,10 +60,8 @@
fun hash t = hashParam t defaultHashParam
- structure Layered = LayerDepCases
- (structure Outer = Arg and Result = HashRep
-
- fun iso ? = iso' (getT ?)
+ structure Open = LayerDepCases
+ (fun iso ? = iso' (getT ?)
fun isoProduct ? = iso' (getP ?)
fun isoSum ? = iso' (getS ?)
@@ -177,7 +175,7 @@
val word8 = prim Word8.toWord
val word32 = prim Word32.toWord
- val word64 = viaWord id op mod Word64.isoWord)
+ val word64 = viaWord id op mod Word64.isoWord
- open Layered
+ open Arg HashRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-09-23 13:19:11 UTC (rev 6048)
@@ -29,22 +29,21 @@
lp (e, toSlice l, toSlice r)
end
- fun cyclic aT aO = let
- val (to, _) = HashUniv.new {eq = op =, hash = Arg.hash aT}
- in
- fn (e, (l, r)) => let
- val lD = to l
- val rD = to r
- in
- if case HashMap.find e lD
- of SOME rD' => HashUniv.eq (rD, rD')
- | NONE => false
- then EQUAL
- else (HashMap.insert e (lD, rD)
- ; HashMap.insert e (rD, lD)
- ; aO (e, (l, r)))
- end
- end
+ fun cyclic aT aO =
+ case HashUniv.new {eq = op =, hash = Arg.hash aT}
+ of (to, _) =>
+ fn (e, (l, r)) => let
+ val lD = to l
+ val rD = to r
+ in
+ if case HashMap.find e lD
+ of SOME rD' => HashUniv.eq (rD, rD')
+ | NONE => false
+ then EQUAL
+ else (HashMap.insert e (lD, rD)
+ ; HashMap.insert e (rD, lD)
+ ; aO (e, (l, r)))
+ end
val exns : (e * Exn.t Sq.t -> Order.t Option.t) Buffer.t = Buffer.new ()
fun regExn aO (_, e2a) =
@@ -59,8 +58,8 @@
fun iso' getX bX (a2b, _) (e, bp) = getX bX (e, Sq.map a2b bp)
structure OrdRep = LayerRep
- (structure Outer = Arg.Rep
- structure Closed = MkClosedRep (type 'a t = 'a t))
+ (open Arg
+ structure Rep = MkClosedRep (type 'a t = 'a t))
open OrdRep.This
@@ -71,10 +70,8 @@
end
fun withOrd cmp = mapT (const (lift cmp))
- structure Layered = LayerDepCases
- (structure Outer = Arg and Result = OrdRep
-
- fun iso ? = iso' getT ?
+ structure Open = LayerDepCases
+ (fun iso ? = iso' getT ?
fun isoProduct ? = iso' getP ?
fun isoSum ? = iso' getS ?
@@ -119,14 +116,14 @@
fun regExn0 _ = regExn unit
fun regExn1 _ = regExn o getT
- fun array aT = cyclic (Arg.array ignore aT)
+ fun array aT = cyclic (Arg.Open.array ignore aT)
(sequ {toSlice = ArraySlice.full,
getItem = ArraySlice.getItem} (getT aT))
fun list aT = sequ {toSlice = id, getItem = List.getItem} (getT aT)
fun vector aT = sequ {toSlice = VectorSlice.full,
getItem = VectorSlice.getItem} (getT aT)
- fun refc aT = cyclic (Arg.refc ignore aT) (iso aT (!, undefined))
+ fun refc aT = cyclic (Arg.Open.refc ignore aT) (iso aT (!, undefined))
val fixedInt = lift FixedInt.compare
val largeInt = lift LargeInt.compare
@@ -144,7 +141,7 @@
val word8 = lift Word8.compare
val word32 = lift Word32.compare
- val word64 = lift Word64.compare)
+ val word64 = lift Word64.compare
- open Layered
+ open Arg OrdRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2007-09-23 13:19:11 UTC (rev 6048)
@@ -373,7 +373,7 @@
sz = NONE : OptInt.t}
val string =
- share (Arg.string ())
+ share (Arg.Open.string ())
(seq {length = String.length, toSlice = Substring.full,
getItem = Substring.getc, fromList = String.fromList}
char)
@@ -458,8 +458,8 @@
end
structure PickleRep = LayerRep
- (structure Outer = Arg.Rep
- structure Closed = struct
+ (open Arg
+ structure Rep = struct
type 'a t = 'a t and 'a s = 'a s and ('a, 'k) p = 'a t
end)
@@ -499,15 +499,13 @@
Pair.fst o unpickler t (IOSMonad.fromReader Substring.getc) o
Substring.full
- structure Layered = LayerDepCases
- (structure Outer = Arg and Result = PickleRep
-
- fun iso bT aIb = let
+ structure Open = LayerDepCases
+ (fun iso bT aIb = let
val bP = getT bT
val aP = iso' bP aIb
in
if case sz bP of NONE => true | SOME n => 8 < n
- then share (Arg.iso (const (const ())) bT aIb) aP
+ then share (Arg.Open.iso (const (const ())) bT aIb) aP
else aP
end
@@ -587,7 +585,7 @@
fun refc aT = let
val P {rd, wr, ...} = getT aT
- val self = Arg.refc ignore aT
+ val self = Arg.Open.refc ignore aT
in
if Arg.mayBeCyclic self
then cyclic {readProxy = I.thunk (ref o const (Arg.some aT)),
@@ -620,16 +618,16 @@
in
wr size (Array.length a) >>= (fn () => lp 0)
end,
- self = Arg.array ignore aT}
+ self = Arg.Open.array ignore aT}
end
fun list aT =
- share (Arg.list ignore aT)
+ share (Arg.Open.list ignore aT)
(seq {length = List.length, toSlice = id,
getItem = List.getItem, fromList = id} (getT aT))
fun vector aT =
- share (Arg.vector ignore aT)
+ share (Arg.Open.vector ignore aT)
(seq {length = Vector.length, toSlice = VectorSlice.full,
getItem = VectorSlice.getItem,
fromList = Vector.fromList} (getT aT))
@@ -672,7 +670,7 @@
val word8 = word8
val word32 = word32
- val word64 = bits false Word64.ops Iso.id)
+ val word64 = bits false Word64.ops Iso.id
- open Layered
+ open Arg PickleRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-09-23 13:19:11 UTC (rev 6048)
@@ -4,6 +4,8 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
+(* XXX indentation formatting option(s) *)
+
functor MkOpts (type 'a t) = struct
type t = {intRadix : StringCvt.radix t,
wordRadix : StringCvt.radix t,
@@ -225,11 +227,9 @@
fun iso' bP = inj bP o Iso.to
structure PrettyRep = LayerRep
- (structure Outer = Arg.Rep
- structure Closed = struct
- type 'a t = 'a t
- type 'a s = 'a t
- type ('a, 'k) p = 'a p
+ (open Arg
+ structure Rep = struct
+ type 'a t = 'a t and 'a s = 'a t and ('a, 'k) p = 'a p
end)
open PrettyRep.This
@@ -300,10 +300,8 @@
fun pretty t = fmt t Fmt.default
fun show t = Prettier.render NONE o pretty t
- structure Layered = LayerDepCases
- (structure Outer = Arg and Result = PrettyRep
-
- fun iso aT = iso' (getT aT)
+ structure Open = LayerDepCases
+ (fun iso aT = iso' (getT aT)
fun isoProduct aP = iso' (getP aP)
fun isoSum aS = iso' (getS aS)
@@ -342,9 +340,10 @@
fun regExn0 c = case C0 c of uP => regExn uP o Pair.snd
fun regExn1 c aT = case C1 c aT of aP => regExn aP o Pair.snd
- fun refc aT = cyclic (Arg.refc ignore aT) o flip inj ! |< C1 ctorRef aT
+ fun refc aT =
+ cyclic (Arg.Open.refc ignore aT) o flip inj ! |< C1 ctorRef aT
fun array aT =
- cyclic (Arg.array ignore aT) |<
+ cyclic (Arg.Open.array ignore aT) |<
sequ hashParens ArraySlice.full ArraySlice.getItem (T aT)
fun vector aT =
sequ hashBrackets VectorSlice.full VectorSlice.getItem (T aT)
@@ -387,7 +386,7 @@
val word8 = mkWord Word8.fmt
val word32 = mkWord Word32.fmt
- val word64 = mkWord Word64.fmt)
+ val word64 = mkWord Word64.fmt
- open Layered
+ open Arg PrettyRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml 2007-09-23 13:19:11 UTC (rev 6048)
@@ -4,7 +4,7 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-functor WithReduce (Arg : OPEN_CASES) : REDUCE_CASES = struct
+functor WithReduce (Arg : WITH_REDUCE_DOM) : REDUCE_CASES = struct
(* <-- SML/NJ workaround *)
open TopLevel
infix 0 &
@@ -24,8 +24,8 @@
fun default (z, _, _) = z
structure ReduceRep = LayerRep
- (structure Outer = Arg.Rep
- structure Closed = MkClosedRep
+ (open Arg
+ structure Rep = MkClosedRep
(type 'a t = Univ.t * Univ.t BinOp.t * 'a -> Univ.t))
open ReduceRep.This
@@ -40,10 +40,8 @@
fn x => from (bR (z, p, x))
end
- structure Layered = LayerCases
- (structure Outer = Arg and Result = ReduceRep and Rep = ReduceRep.Closed
-
- fun iso bR (a2b, _) (z, p, a) = bR (z, p, a2b a)
+ structure Open = LayerCases
+ (fun iso bR (a2b, _) (z, p, a) = bR (z, p, a2b a)
val isoProduct = iso
val isoSum = iso
@@ -91,7 +89,7 @@
val word8 = default
val word32 = default
- val word64 = default)
+ val word64 = default
- open Layered
+ open Arg ReduceRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml 2007-09-23 13:19:11 UTC (rev 6048)
@@ -56,8 +56,8 @@
of bE => fn (a2b, _) => fn (e, bp) => bE (e, Sq.map a2b bp)
structure SeqRep = LayerRep
- (structure Outer = Arg.Rep
- structure Closed = MkClosedRep (type 'a t = 'a t))
+ (open Arg
+ structure Rep = MkClosedRep (type 'a t = 'a t))
open SeqRep.This
@@ -68,10 +68,8 @@
fun notSeq t = negate (seq t)
fun withSeq eq = mapT (const (lift eq))
- structure Layered = LayerDepCases
- (structure Outer = Arg and Result = SeqRep
-
- fun iso ? = iso' getT ?
+ structure Open = LayerDepCases
+ (fun iso ? = iso' getT ?
fun isoProduct ? = iso' getP ?
fun isoSum ? = iso' getS ?
@@ -111,31 +109,31 @@
fun regExn0 _ (e, p) = regExn unit (const e, p)
fun regExn1 _ = regExn o getT
- fun array aT = cyclic (Arg.array ignore aT)
+ fun array aT = cyclic (Arg.Open.array ignore aT)
(sequ {toSlice = ArraySlice.full,
getItem = ArraySlice.getItem} (getT aT))
fun list aT = sequ {toSlice = id, getItem = List.getItem} (getT aT)
fun vector aT = sequ {toSlice = VectorSlice.full,
getItem = VectorSlice.getItem} (getT aT)
- fun refc aT = cyclic (Arg.refc ignore aT) (iso aT (!, undefined))
+ fun refc aT = cyclic (Arg.Open.refc ignore aT) (iso aT (!, undefined))
- val fixedInt = lift (op = : FixedInt.t BinPr.t)
- val largeInt = lift (op = : LargeInt.t BinPr.t)
+ val fixedInt = lift op = : FixedInt.t t
+ val largeInt = lift op = : LargeInt.t t
- val largeWord = lift (op = : LargeWord.t BinPr.t)
+ val largeWord = lift op = : LargeWord.t t
val largeReal = iso' id (lift op =) CastLargeReal.isoBits
- val bool = lift (op = : Bool.t BinPr.t)
- val char = lift (op = : Char.t BinPr.t)
- val int = lift (op = : Int.t BinPr.t)
+ val bool = lift op = : Bool.t t
+ val char = lift op = : Char.t t
+ val int = lift op = : Int.t t
val real = iso' id (lift op =) CastReal.isoBits
- val string = lift (op = : String.t BinPr.t)
- val word = lift (op = : Word.t BinPr.t)
+ val string = lift op = : String.t t
+ val word = lift op = : Word.t t
- val word8 = lift (op = : Word8.t BinPr.t)
- val word32 = lift (op = : Word32.t BinPr.t)
- val word64 = lift (op = : Word64.t BinPr.t))
+ val word8 = lift op = : Word8.t t
+ val word32 = lift op = : Word32.t t
+ val word64 = lift op = : Word64.t t
- open Layered
+ open Arg SeqRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml 2007-09-23 13:19:11 UTC (rev 6048)
@@ -55,8 +55,8 @@
| DYNAMIC bS => fn (a2b, _) => DYNAMIC (bS o Pair.map (id, a2b))
structure SizeRep = LayerRep
- (structure Outer = Arg.Rep
- structure Closed = MkClosedRep (type 'a t = 'a t))
+ (open Arg
+ structure Rep = MkClosedRep (type 'a t = 'a t))
open SizeRep.This
@@ -71,10 +71,8 @@
| DYNAMIC f => fn x =>
f (HashMap.new {eq = HashUniv.eq, hash = HashUniv.hash} , x)
- structure Layered = LayerDepCases
- (structure Outer = Arg and Result = SizeRep
-
- fun iso bT = iso' (getT bT)
+ structure Open = LayerDepCases
+ (fun iso bT = iso' (getT bT)
fun isoProduct bP = iso' (getP bP)
fun isoSum bS = iso' (getS bS)
@@ -139,11 +137,11 @@
fun vector xT = DYNAMIC (sequ Vector.length Vector.foldl (getT xT))
fun array xT =
- cyclic (Arg.array ignore xT)
+ cyclic (Arg.Open.array ignore xT)
(sequ Array.length Array.foldl (getT xT))
fun refc xT =
- cyclic (Arg.refc ignore xT)
+ cyclic (Arg.Open.refc ignore xT)
(case getT xT
of STATIC s => const (s + wordSize)
| DYNAMIC f => fn (e, x) => wordSize + f (e, !x))
@@ -163,7 +161,7 @@
val word8 = mkWord Word8.wordSize : Word8.t t
val word32 = mkWord Word32.wordSize : Word32.t t
- val word64 = mkWord Word64.wordSize : Word64.t t)
+ val word64 = mkWord Word64.wordSize : Word64.t t
- open Layered
+ open Arg SizeRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml 2007-09-23 13:19:11 UTC (rev 6048)
@@ -13,8 +13,8 @@
fun iso' b (_, b2a) = b2a o b
structure SomeRep = LayerRep
- (structure Outer = Arg.Rep
- structure Closed = MkClosedRep (Thunk))
+ (open Arg
+ structure Rep = MkClosedRep (Thunk))
open SomeRep.This
@@ -24,10 +24,8 @@
fun withNone ? = mapT (const (raising Option)) ?
fun withSome v = mapT (const (const v))
- structure Layered = LayerDepCases
- (structure Outer = Arg and Result = SomeRep
-
- fun iso ? = iso' (getT ?)
+ structure Open = LayerDepCases
+ (fun iso ? = iso' (getT ?)
fun isoProduct ? = iso' (getP ?)
fun isoSum ? = iso' (getS ?)
@@ -88,7 +86,7 @@
val word8 = fn () => 0w0 : Word8.t
val word32 = fn () => 0w0 : Word32.t
- val word64 = fn () => 0w0 : Word64.t)
+ val word64 = fn () => 0w0 : Word64.t
- open Layered
+ open Arg SomeRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml 2007-09-23 13:19:11 UTC (rev 6048)
@@ -36,8 +36,8 @@
fun iso' getX bX (a2b, b2a) = un (Fn.map (Pair.map (a2b, id), b2a)) (getX bX)
structure TransformRep = LayerRep
- (structure Outer = Arg.Rep
- structure Closed = MkClosedRep (type 'a t = 'a t))
+ (open Arg
+ structure Rep = MkClosedRep (type 'a t = 'a t))
open TransformRep.This
@@ -46,10 +46,8 @@
of (_, f) =>
fn x => f (x, HashMap.new {eq = HashUniv.eq, hash = HashUniv.hash})
- structure Layered = LayerDepCases
- (structure Outer = Arg and Result = TransformRep
-
- fun iso ? = iso' getT ?
+ structure Open = LayerDepCases
+ (fun iso ? = iso' getT ?
fun isoProduct ? = iso' getP ?
fun isoSum ? = iso' getS ?
@@ -91,12 +89,12 @@
fun vector aT = un (fn xF => fn (v, e) => Vector.map (xF /> e) v) (getT aT)
fun array aT =
- un (fn xF => cyclic (Arg.array ignore aT)
+ un (fn xF => cyclic (Arg.Open.array ignore aT)
(fn (a, e) => (Array.modify (xF /> e) a ; a)))
(getT aT)
fun refc aT =
- un (fn xF => cyclic (Arg.refc ignore aT)
+ un (fn xF => cyclic (Arg.Open.refc ignore aT)
(fn (r, e) => (r := xF (!r, e) ; r)))
(getT aT)
@@ -115,7 +113,7 @@
val word8 = default
val word32 = default
- val word64 = default)
+ val word64 = default
- open Layered
+ open Arg TransformRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-exp.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-exp.sml 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-exp.sml 2007-09-23 13:19:11 UTC (rev 6048)
@@ -4,7 +4,7 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-functor WithTypeExp (Arg : OPEN_CASES) : TYPE_EXP_CASES = struct
+functor WithTypeExp (Arg : WITH_TYPE_EXP_DOM) : TYPE_EXP_CASES = struct
(* <-- SML/NJ workaround *)
open TopLevel
(* SML/NJ workaround --> *)
@@ -22,19 +22,17 @@
| ELEM e => ELEM (f e)
structure TypeExpRep = LayerRep
- (structure Outer = Arg.Rep
- structure Closed = struct
+ (open Arg
+ structure Rep = struct
type 'a t = TypeVar.t Ty.t
- type 'a s = TypeVar.t Ty.t Sum.t
- type ('a, 'k) p = (Label.t Option.t * TypeVar.t Ty.t) Product.t
+ and 'a s = TypeVar.t Ty.t Sum.t
+ and ('a, 'k) p = (Label.t Option.t * TypeVar.t Ty.t) Product.t
end)
val ty = TypeExpRep.This.getT
- structure Layered = LayerCases
- (structure Outer = Arg and Result = TypeExpRep and Rep = TypeExpRep.Closed
-
- fun iso bT _ = ISO bT
+ structure Open = LayerCases
+ (fun iso bT _ = ISO bT
fun isoProduct bP _ = ISO_PRODUCT bP
fun isoSum bS _ = ISO_SUM bS
@@ -82,7 +80,7 @@
val word8 = CON0 WORD8
val word32 = CON0 WORD32
- val word64 = CON0 WORD64)
+ val word64 = CON0 WORD64
- open Layered
+ open Arg TypeExpRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-hash.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-hash.sml 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-hash.sml 2007-09-23 13:19:11 UTC (rev 6048)
@@ -4,7 +4,7 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-functor WithTypeHash (Arg : OPEN_CASES) : TYPE_HASH_CASES = struct
+functor WithTypeHash (Arg : WITH_TYPE_HASH_DOM) : TYPE_HASH_CASES = struct
(* <-- SML/NJ workaround *)
open TopLevel
(* SML/NJ workaround --> *)
@@ -22,15 +22,13 @@
end
structure TypeHashRep = LayerRep
- (structure Outer = Arg.Rep
- structure Closed = MkClosedRep (type 'a t = Word32.t))
+ (open Arg
+ structure Rep = MkClosedRep (type 'a t = Word32.t))
val typeHash = TypeHashRep.This.getT
- structure Layered = LayerCases
- (structure Outer=Arg and Result=TypeHashRep and Rep=TypeHashRep.Closed
-
- fun iso ? _ = unary 0wxD00B6B6B ?
+ structure Open = LayerCases
+ (fun iso ? _ = unary 0wxD00B6B6B ?
fun isoProduct ? _ = unary 0wxC01B56DB ?
fun isoSum ? _ = unary 0wxB006B6DB ?
@@ -76,7 +74,7 @@
val word8 = 0wxB6DB6809 : Word32.t
val word32 = 0wxCDB6D501 : Word32.t
- val word64 = 0wxDB6DB101 : Word32.t)
+ val word64 = 0wxDB6DB101 : Word32.t
- open Layered
+ open Arg TypeHashRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml 2007-09-23 13:19:11 UTC (rev 6048)
@@ -4,7 +4,7 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-functor WithTypeInfo (Arg : OPEN_CASES) : TYPE_INFO_CASES = struct
+functor WithTypeInfo (Arg : WITH_TYPE_INFO_DOM) : TYPE_INFO_CASES = struct
(* <-- SML/NJ workaround *)
open TopLevel
(* SML/NJ workaround --> *)
@@ -17,8 +17,8 @@
fun pure (INT {...}) = INT {base = true}
structure TypeInfoRep = LayerRep
- (structure Outer = Arg.Rep
- structure Closed = struct
+ (open Arg
+ structure Rep = struct
type 'a t = t
type 'a s = s
type ('a, 'k) p = p
@@ -34,10 +34,8 @@
fun numElems ? = (#elems o outP o getP) ?
- structure Layered = LayerCases
- (structure Outer=Arg and Result=TypeInfoRep and Rep=TypeInfoRep.Closed
-
- val iso = const
+ structure Open = LayerCases
+ (val iso = const
val isoProduct = const
val isoSum = const
@@ -84,7 +82,7 @@
val word8 = base
val word32 = base
- val word64 = base)
+ val word64 = base
- open Layered
+ open Arg TypeInfoRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib-with-default.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib-with-default.mlb 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib-with-default.mlb 2007-09-23 13:19:11 UTC (rev 6048)
@@ -9,5 +9,14 @@
$(MLTON_LIB)/com/ssh/random/unstable/lib.mlb
in
lib.mlb
- detail/generic.sml
+
+ (* Order matters: *)
+ with/generic.sml
+ with/eq.sml
+ with/type-hash.sml
+ with/type-info.sml
+ with/hash.sml
+ with/ord.sml
+ with/pretty.sml
+ with/close-pretty-with-extra.sml
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-09-23 13:19:11 UTC (rev 6048)
@@ -129,6 +129,10 @@
public/value/type-exp.sig
detail/value/type-exp.sml
+
+ (* Convenience *)
+
+ detail/close-pretty-with-extra.fun
in
public/export.sml
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-09-23 13:19:11 UTC (rev 6048)
@@ -34,24 +34,16 @@
functor MkClosedRep (type 'a t) : CLOSED_REP = MkClosedRep (type 'a t = 'a t)
(** Makes a closed representation by replicating the given type. *)
-functor CloseCases (Arg : OPEN_CASES) :>
- CLOSED_CASES
- where type 'a Rep.t = ('a, Unit.t) Arg.Rep.t
- where type 'a Rep.s = ('a, Unit.t) Arg.Rep.s
- where type ('a, 'k) Rep.p = ('a, 'k, Unit.t) Arg.Rep.p =
- CloseCases (Arg)
-(** Closes open structural cases. *)
-
-signature LAYER_REP_DOM = LAYER_REP_DOM
+signature LAYER_REP_DOM = LAYER_REP_DOM and LAYER_REP_COD = LAYER_REP_COD
functor LayerRep (Arg : LAYER_REP_DOM) :>
- LAYERED_REP
- where type 'a Closed.t = 'a Arg.Closed.t
- where type 'a Closed.s = 'a Arg.Closed.s
- where type ('a, 'k) Closed.p = ('a, 'k) Arg.Closed.p
+ LAYER_REP_COD
+ where type 'a This.t = 'a Arg.Rep.t
+ where type 'a This.s = 'a Arg.Rep.s
+ where type ('a, 'k) This.p = ('a, 'k) Arg.Rep.p
- where type ('a, 'x) Outer.t = ('a, 'x) Arg.Outer.t
- where type ('a, 'x) Outer.s = ('a, 'x) Arg.Outer.s
- where type ('a, 'k, 'x) Outer.p = ('a, 'k, 'x) Arg.Outer.p =
+ where type ('a, 'x) Outer.t = ('a, 'x) Arg.Open.Rep.t
+ where type ('a, 'x) Outer.s = ('a, 'x) Arg.Open.Rep.s
+ where type ('a, 'k, 'x) Outer.p = ('a, 'k, 'x) Arg.Open.Rep.p =
LayerRep (Arg)
(**
* Creates a layered representation for {LayerCases} and {LayerDepCases}.
@@ -60,9 +52,9 @@
signature LAYER_CASES_DOM = LAYER_CASES_DOM
functor LayerCases (Arg : LAYER_CASES_DOM) :>
OPEN_CASES
- where type ('a, 'x) Rep.t = ('a, 'x) Arg.Result.t
- where type ('a, 'x) Rep.s = ('a, 'x) Arg.Result.s
- where type ('a, 'k, 'x) Rep.p = ('a, 'k, 'x) Arg.Result.p =
+ where type ('a, 'x) Rep.t = ('a, 'x) Arg.t
+ where type ('a, 'x) Rep.s = ('a, 'x) Arg.s
+ where type ('a, 'k, 'x) Rep.p = ('a, 'k, 'x) Arg.p =
LayerCases (Arg)
(**
* Joins an outer open generic function and a closed generic function.
@@ -71,15 +63,25 @@
signature LAYER_DEP_CASES_DOM = LAYER_DEP_CASES_DOM
functor LayerDepCases (Arg : LAYER_DEP_CASES_DOM) :>
OPEN_CASES
- where type ('a, 'x) Rep.t = ('a, 'x) Arg.Result.t
- where type ('a, 'x) Rep.s = ('a, 'x) Arg.Result.s
- where type ('a, 'k, 'x) Rep.p = ('a, 'k, 'x) Arg.Result.p =
+ where type ('a, 'x) Rep.t = ('a, 'x) Arg.t
+ where type ('a, 'x) Rep.s = ('a, 'x) Arg.s
+ where type ('a, 'k, 'x) Rep.p = ('a, 'k, 'x) Arg.p =
LayerDepCases (Arg)
(**
* Joins an outer open generic function and a closed generic function that
* depends on the outer generic.
*)
+(** === Closing Generics === *)
+
+functor CloseCases (Arg : OPEN_CASES) :>
+ CLOSED_CASES
+ where type 'a Rep.t = ('a, Unit.t) Arg.Rep.t
+ where type 'a Rep.s = ('a, Unit.t) Arg.Rep.s
+ where type ('a, 'k) Rep.p = ('a, 'k, Unit.t) Arg.Rep.p =
+ CloseCases (Arg)
+(** Closes open structural cases. *)
+
signature GENERIC_EXTRA = GENERIC_EXTRA
functor WithExtra (Arg : GENERIC) : GENERIC_EXTRA = WithExtra (Arg)
(**
@@ -88,6 +90,13 @@
* over time.
*)
+functor ClosePrettyWithExtra (Arg : PRETTY_CASES) : GENERIC_EXTRA =
+ ClosePrettyWithExtra (Arg)
+(**
+ * Convenience for the common case of closing a collection of generics
+ * including {Pretty} with extra type representations.
+ *)
+
functor RegBasisExns (Arg : CLOSED_CASES) = RegBasisExns (Arg)
(** Registers handlers for most standard exceptions as a side-effect. *)
@@ -95,10 +104,12 @@
signature DATA_REC_INFO = DATA_REC_INFO
and DATA_REC_INFO_CASES = DATA_REC_INFO_CASES
-functor WithDataRecInfo (Arg : OPEN_CASES) : DATA_REC_INFO_CASES =
+ and WITH_DATA_REC_INFO_DOM = WITH_DATA_REC_INFO_DOM
+functor WithDataRecInfo (Arg : WITH_DATA_REC_INFO_DOM) : DATA_REC_INFO_CASES =
WithDataRecInfo (Arg)
-functor WithDebug (Arg : OPEN_CASES) : OPEN_CASES = WithDebug (Arg)
+signature WITH_DEBUG_DOM = WITH_DEBUG_DOM
+functor WithDebug (Arg : WITH_DEBUG_DOM) : OPEN_CASES = WithDebug (Arg)
(**
* Checks dynamically that
* - labels are unique within each record,
@@ -107,10 +118,14 @@
*)
signature TYPE_EXP = TYPE_EXP and TYPE_EXP_CASES = TYPE_EXP_CASES
-functor WithTypeExp (Arg : OPEN_CASES) : TYPE_EXP_CASES = WithTypeExp (Arg)
+ and WITH_TYPE_EXP_DOM = WITH_TYPE_EXP_DOM
+functor WithTypeExp (Arg : WITH_TYPE_EXP_DOM) : TYPE_EXP_CASES =
+ WithTypeExp (Arg)
signature TYPE_INFO = TYPE_INFO and TYPE_INFO_CASES = TYPE_INFO_CASES
-functor WithTypeInfo (Arg : OPEN_CASES) : TYPE_INFO_CASES = WithTypeInfo (Arg)
+ and WITH_TYPE_INFO_DOM = WITH_TYPE_INFO_DOM
+functor WithTypeInfo (Arg : WITH_TYPE_INFO_DOM) : TYPE_INFO_CASES =
+ WithTypeInfo (Arg)
(** == Generics ==
*
@@ -124,10 +139,11 @@
WithArbitrary (Arg)
signature DYNAMIC = DYNAMIC and DYNAMIC_CASES = DYNAMIC_CASES
-functor WithDynamic (Arg : OPEN_CASES) : DYNAMIC_CASES = WithDynamic (Arg)
+ and WITH_DYNAMIC_DOM = WITH_DYNAMIC_DOM
+functor WithDynamic (Arg : WITH_DYNAMIC_DOM) : DYNAMIC_CASES = WithDynamic (Arg)
-signature EQ = EQ and EQ_CASES = EQ_CASES
-functor WithEq (Arg : OPEN_CASES) : EQ_CASES = WithEq (Arg)
+signature EQ = EQ and EQ_CASES = EQ_CASES and WITH_EQ_DOM = WITH_EQ_DOM
+functor WithEq (Arg : WITH_EQ_DOM) : EQ_CASES = WithEq (Arg)
signature HASH = HASH and HASH_CASES = HASH_CASES
and WITH_HASH_DOM = WITH_HASH_DOM
@@ -145,7 +161,8 @@
functor WithPretty (Arg : WITH_PRETTY_DOM) : PRETTY_CASES = WithPretty (Arg)
signature REDUCE = REDUCE and REDUCE_CASES = REDUCE_CASES
-functor WithReduce (Arg : OPEN_CASES) : REDUCE_CASES = WithReduce (Arg)
+ and WITH_REDUCE_DOM = WITH_REDUCE_DOM
+functor WithReduce (Arg : WITH_REDUCE_DOM) : REDUCE_CASES = WithReduce (Arg)
signature SEQ = SEQ and SEQ_CASES = SEQ_CASES and WITH_SEQ_DOM = WITH_SEQ_DOM
functor WithSeq (Arg : WITH_SEQ_DOM) : SEQ_CASES = WithSeq (Arg)
@@ -164,4 +181,6 @@
WithTransform (Arg)
signature TYPE_HASH = TYPE_HASH and TYPE_HASH_CASES = TYPE_HASH_CASES
-functor WithTypeHash (Arg : OPEN_CASES) : TYPE_HASH_CASES = WithTypeHash (Arg)
+ and WITH_TYPE_HASH_DOM = WITH_TYPE_HASH_DOM
+functor WithTypeHash (Arg : WITH_TYPE_HASH_DOM) : TYPE_HASH_CASES =
+ WithTypeHash (Arg)
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/layer-cases-fun.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/layer-cases-fun.sig 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/layer-cases-fun.sig 2007-09-23 13:19:11 UTC (rev 6048)
@@ -8,9 +8,8 @@
* Signature for the domain of the {LayerCases} functor.
*)
signature LAYER_CASES_DOM = sig
- structure Outer : OPEN_CASES
- structure Result : LAYERED_REP
- sharing Outer.Rep = Result.Outer
- include CLOSED_CASES
- sharing Rep = Result.Closed
+ structure Open : OPEN_CASES
+ include LAYERED_REP CLOSED_CASES
+ sharing Open.Rep = Outer
+ sharing Rep = This
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/layer-dep-cases-fun.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/layer-dep-cases-fun.sig 2007-09-22 16:33:06 UTC (rev 6047)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/layer-dep-cases-fun.sig 2007-09-23 13:19:11 UTC (rev 6048)
@@ -8,42 +8,42 @@
* Signature for the domain of the {LayerDepCases} functor.
*)
signature LAYER_DEP_CASES_DOM = sig
- structure Outer : OPEN_CASES
- structure Result : LAYERED_REP
- sharing Outer.Rep = Result.Outer
- val iso : ('b, 'y) Result.t -> ('a, 'b) Iso.t -> 'a Result.Closed.t
- val isoProduct : ('b, 'k, 'y) Result.p -> ('a, 'b) Iso.t -> ('a, 'k) Result.Closed.p
- val isoSum : ('b, 'y) Result.s -> ('a, 'b) Iso.t -> 'a Result.Closed.s
- val *` : ('a, 'k, 'x) Result.p * ('b, 'k, 'y) Result.p -> (('a, 'b) Product.t, 'k) Result.Closed.p
- val T : ('a, 'x) Result.t -> ('a, Generics.Tuple.t) Result.Closed.p
- val R : Generics.Label.t -> ('a, 'x) Result.t -> ('a, Generics.Record.t) Result.Closed.p
- val tuple : ('a, Generics.Tuple.t, 'x) Result.p -> 'a Result.Closed.t
- val record : ('a, Generics.Record.t, 'x) Result.p -> 'a Result.Closed.t
- val +` : ('a, 'x) Result.s * ('b, 'y) Result.s ->
More information about the MLton-commit
mailing list