Menu
▾
▴
mlton-commit — [MLton-commit] Code commits
You can subscribe to this list here.
| 2005 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
(56) |
Sep
(40) |
Oct
(30) |
Nov
(144) |
Dec
(23) |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2006 |
Jan
(41) |
Feb
(29) |
Mar
(31) |
Apr
(39) |
May
(193) |
Jun
(45) |
Jul
(19) |
Aug
(3) |
Sep
(23) |
Oct
(83) |
Nov
(92) |
Dec
(123) |
| 2007 |
Jan
(90) |
Feb
(267) |
Mar
(120) |
Apr
(51) |
May
(40) |
Jun
(121) |
Jul
(109) |
Aug
(173) |
Sep
(77) |
Oct
(52) |
Nov
(121) |
Dec
(62) |
| 2008 |
Jan
(76) |
Feb
(53) |
Mar
(98) |
Apr
(87) |
May
(26) |
Jun
(27) |
Jul
(23) |
Aug
(136) |
Sep
(79) |
Oct
(68) |
Nov
(29) |
Dec
(14) |
| 2009 |
Jan
(7) |
Feb
(2) |
Mar
(11) |
Apr
(75) |
May
(1) |
Jun
(95) |
Jul
(19) |
Aug
(4) |
Sep
(8) |
Oct
(93) |
Nov
(43) |
Dec
(21) |
| 2010 |
Jan
(20) |
Feb
(23) |
Mar
(18) |
Apr
(6) |
May
(20) |
Jun
(23) |
Jul
(1) |
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
| 2011 |
Jan
(2) |
Feb
(6) |
Mar
(15) |
Apr
(5) |
May
(9) |
Jun
(14) |
Jul
(9) |
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
| 2012 |
Jan
|
Feb
(3) |
Mar
|
Apr
|
May
(2) |
Jun
(17) |
Jul
(37) |
Aug
|
Sep
(1) |
Oct
(6) |
Nov
|
Dec
|
| 2013 |
Jan
|
Feb
|
Mar
(5) |
Apr
(2) |
May
(7) |
Jun
(11) |
Jul
(8) |
Aug
|
Sep
(1) |
Oct
(2) |
Nov
|
Dec
|
| 2014 |
Jan
|
Feb
(2) |
Mar
(1) |
Apr
|
May
(1) |
Jun
(1) |
Jul
(7) |
Aug
(2) |
Sep
|
Oct
(5) |
Nov
(2) |
Dec
(4) |
| 2015 |
Jan
|
Feb
(2) |
Mar
(2) |
Apr
|
May
|
Jun
(9) |
Jul
(1) |
Aug
|
Sep
|
Oct
(4) |
Nov
(1) |
Dec
|
| 2016 |
Jan
(2) |
Feb
(1) |
Mar
(1) |
Apr
(1) |
May
(1) |
Jun
(2) |
Jul
(1) |
Aug
|
Sep
(5) |
Oct
|
Nov
|
Dec
|
| 2017 |
Jan
(1) |
Feb
(3) |
Mar
(3) |
Apr
(7) |
May
(2) |
Jun
(2) |
Jul
(5) |
Aug
(1) |
Sep
(2) |
Oct
(17) |
Nov
(4) |
Dec
(7) |
| 2018 |
Jan
(5) |
Feb
(14) |
Mar
(2) |
Apr
(5) |
May
(2) |
Jun
(5) |
Jul
|
Aug
(2) |
Sep
|
Oct
(3) |
Nov
(5) |
Dec
|
| 2019 |
Jan
(4) |
Feb
(2) |
Mar
(3) |
Apr
(1) |
May
(8) |
Jun
(14) |
Jul
(2) |
Aug
|
Sep
(2) |
Oct
(2) |
Nov
(15) |
Dec
(2) |
| 2020 |
Jan
(10) |
Feb
(3) |
Mar
(1) |
Apr
|
May
(9) |
Jun
(4) |
Jul
(16) |
Aug
(10) |
Sep
(4) |
Oct
(3) |
Nov
|
Dec
|
| 2021 |
Jan
(11) |
Feb
(2) |
Mar
(2) |
Apr
|
May
|
Jun
(1) |
Jul
|
Aug
(5) |
Sep
|
Oct
(6) |
Nov
(4) |
Dec
(4) |
| 2022 |
Jan
(4) |
Feb
(2) |
Mar
(2) |
Apr
|
May
(6) |
Jun
(3) |
Jul
|
Aug
(1) |
Sep
|
Oct
|
Nov
(1) |
Dec
|
| 2023 |
Jan
|
Feb
|
Mar
|
Apr
(2) |
May
(5) |
Jun
(1) |
Jul
(4) |
Aug
(1) |
Sep
|
Oct
(1) |
Nov
(13) |
Dec
|
| 2024 |
Jan
(1) |
Feb
|
Mar
(5) |
Apr
|
May
(10) |
Jun
|
Jul
|
Aug
(3) |
Sep
|
Oct
|
Nov
(1) |
Dec
(14) |
| 2025 |
Jan
(3) |
Feb
|
Mar
(1) |
Apr
|
May
(2) |
Jun
(3) |
Jul
|
Aug
|
Sep
(2) |
Oct
(2) |
Nov
|
Dec
|
| S | M | T | W | T | F | S |
|---|---|---|---|---|---|---|
|
|
|
|
|
|
|
1
(10) |
|
2
(5) |
3
(3) |
4
(2) |
5
|
6
(5) |
7
|
8
|
|
9
|
10
(1) |
11
(6) |
12
(2) |
13
(3) |
14
(4) |
15
(3) |
|
16
(1) |
17
(2) |
18
(2) |
19
(10) |
20
(5) |
21
|
22
(1) |
|
23
(2) |
24
|
25
|
26
|
27
(3) |
28
(4) |
29
(3) |
|
30
|
|
|
|
|
|
|
|
From: Vesa K. <ve...@ml...> - 2007-09-29 12:03:46
|
Added a base signature for CASES.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml
U mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
A mltonlib/trunk/com/ssh/generic/unstable/public/cases.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
U mltonlib/trunk/com/ssh/generic/unstable/public/generic.sig
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/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/shrink.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
----------------------------------------------------------------------
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-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-09-29 19:03:42 UTC (rev 6059)
@@ -8,6 +8,7 @@
../../../../../extended-basis/unstable/basis.cm
../../../../../prettier/unstable/lib.cm
../../../../../random/unstable/lib.cm
+ ../../../public/cases.sig
../../../public/closed-cases.sig
../../../public/closed-rep.sig
../../../public/generic-extra.sig
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml 2007-09-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/debug.sml 2007-09-29 19:03:42 UTC (rev 6059)
@@ -4,11 +4,7 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-signature WITH_DEBUG_DOM = sig
- structure Open : OPEN_CASES
-end
-
-functor WithDebug (Arg : WITH_DEBUG_DOM) : OPEN_CASES = struct
+functor WithDebug (Arg : CASES) : OPEN_CASES = struct
(* <-- SML/NJ workaround *)
open TopLevel
(* SML/NJ workaround --> *)
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-09-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-09-29 19:03:42 UTC (rev 6059)
@@ -38,6 +38,8 @@
public/open-rep.sig
public/open-cases.sig
+ public/cases.sig
+
public/generic.sig
public/generic-extra.sig
Added: mltonlib/trunk/com/ssh/generic/unstable/public/cases.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/cases.sig 2007-09-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/cases.sig 2007-09-29 19:03:42 UTC (rev 6059)
@@ -0,0 +1,12 @@
+(* 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.
+ *)
+
+(**
+ * A base signature for the "cases" of generics.
+ *)
+signature CASES = sig
+ structure Open : OPEN_CASES
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/cases.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-09-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-09-29 19:03:42 UTC (rev 6059)
@@ -12,6 +12,8 @@
signature OPEN_CASES = OPEN_CASES
signature OPEN_REP = OPEN_REP
+signature CASES = CASES
+
signature LAYERED_REP = LAYERED_REP
signature GENERIC = GENERIC
@@ -108,8 +110,7 @@
functor WithDataRecInfo (Arg : WITH_DATA_REC_INFO_DOM) : DATA_REC_INFO_CASES =
WithDataRecInfo (Arg)
-signature WITH_DEBUG_DOM = WITH_DEBUG_DOM
-functor WithDebug (Arg : WITH_DEBUG_DOM) : OPEN_CASES = WithDebug (Arg)
+functor WithDebug (Arg : CASES) : OPEN_CASES = WithDebug (Arg)
(**
* Checks dynamically that
* - labels are unique within each record,
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/generic.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/generic.sig 2007-09-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/generic.sig 2007-09-29 19:03:42 UTC (rev 6059)
@@ -8,8 +8,7 @@
* Base signature for a module of directly usable generics.
*)
signature GENERIC = sig
- structure Open : OPEN_CASES
-
+ include CASES
include CLOSED_CASES
where type 'a Rep.t = ('a, Unit.t) Open.Rep.t
where type 'a Rep.s = ('a, Unit.t) Open.Rep.s
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-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/layer-cases-fun.sig 2007-09-29 19:03:42 UTC (rev 6059)
@@ -8,8 +8,7 @@
* Signature for the domain of the {LayerCases} functor.
*)
signature LAYER_CASES_DOM = sig
- structure Open : OPEN_CASES
- include LAYERED_REP CLOSED_CASES
+ include CASES 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-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/layer-dep-cases-fun.sig 2007-09-29 19:03:42 UTC (rev 6059)
@@ -8,8 +8,7 @@
* Signature for the domain of the {LayerDepCases} functor.
*)
signature LAYER_DEP_CASES_DOM = sig
- structure Open : OPEN_CASES
- include LAYERED_REP
+ include CASES LAYERED_REP
sharing Open.Rep = Outer
val iso : ('b, 'y) t -> ('a, 'b) Iso.t -> 'a This.t
val isoProduct : ('b, 'k, 'y) p -> ('a, 'b) Iso.t -> ('a, 'k) This.p
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/arbitrary.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/arbitrary.sig 2007-09-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/arbitrary.sig 2007-09-29 19:03:42 UTC (rev 6059)
@@ -24,14 +24,12 @@
end
signature ARBITRARY_CASES = sig
- structure Open : OPEN_CASES
- include ARBITRARY
+ include CASES ARBITRARY
sharing Open.Rep = ArbitraryRep
end
signature WITH_ARBITRARY_DOM = sig
- structure Open : OPEN_CASES
- include HASH TYPE_INFO
+ include CASES HASH TYPE_INFO
sharing Open.Rep = HashRep = TypeInfoRep
structure RandomGen : RANDOM_GEN
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/data-rec-info.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/data-rec-info.sig 2007-09-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/data-rec-info.sig 2007-09-29 19:03:42 UTC (rev 6059)
@@ -55,11 +55,8 @@
end
signature DATA_REC_INFO_CASES = sig
- structure Open : OPEN_CASES
- include DATA_REC_INFO
+ include CASES DATA_REC_INFO
sharing Open.Rep = DataRecInfoRep
end
-signature WITH_DATA_REC_INFO_DOM = sig
- structure Open : OPEN_CASES
-end
+signature WITH_DATA_REC_INFO_DOM = CASES
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/dynamic.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/dynamic.sig 2007-09-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/dynamic.sig 2007-09-29 19:03:42 UTC (rev 6059)
@@ -61,11 +61,8 @@
end
signature DYNAMIC_CASES = sig
- structure Open : OPEN_CASES
- include DYNAMIC
+ include CASES DYNAMIC
sharing Open.Rep = DynamicRep
end
-signature WITH_DYNAMIC_DOM = sig
- structure Open : OPEN_CASES
-end
+signature WITH_DYNAMIC_DOM = CASES
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig 2007-09-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/eq.sig 2007-09-29 19:03:42 UTC (rev 6059)
@@ -60,11 +60,8 @@
end
signature EQ_CASES = sig
- structure Open : OPEN_CASES
- include EQ
+ include CASES EQ
sharing Open.Rep = EqRep
end
-signature WITH_EQ_DOM = sig
- structure Open : OPEN_CASES
-end
+signature WITH_EQ_DOM = CASES
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/hash.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/hash.sig 2007-09-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/hash.sig 2007-09-29 19:03:42 UTC (rev 6059)
@@ -41,13 +41,11 @@
end
signature HASH_CASES = sig
- structure Open : OPEN_CASES
- include HASH
+ include CASES HASH
sharing Open.Rep = HashRep
end
signature WITH_HASH_DOM = sig
- structure Open : OPEN_CASES
- include TYPE_HASH TYPE_INFO
+ include CASES TYPE_HASH TYPE_INFO
sharing Open.Rep = TypeHashRep = TypeInfoRep
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig 2007-09-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/ord.sig 2007-09-29 19:03:42 UTC (rev 6059)
@@ -46,8 +46,7 @@
end
signature ORD_CASES = sig
- structure Open : OPEN_CASES
- include ORD
+ include CASES ORD
sharing Open.Rep = OrdRep
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig 2007-09-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig 2007-09-29 19:03:42 UTC (rev 6059)
@@ -138,14 +138,12 @@
end
signature PICKLE_CASES = sig
- structure Open : OPEN_CASES
- include PICKLE
+ include CASES PICKLE
sharing Open.Rep = PickleRep
end
signature WITH_PICKLE_DOM = sig
- structure Open : OPEN_CASES
- include DATA_REC_INFO EQ HASH SOME TYPE_HASH TYPE_INFO
+ include CASES DATA_REC_INFO EQ HASH SOME TYPE_HASH TYPE_INFO
sharing Open.Rep = DataRecInfoRep = EqRep = HashRep = SomeRep = TypeHashRep
= TypeInfoRep
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig 2007-09-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig 2007-09-29 19:03:42 UTC (rev 6059)
@@ -174,8 +174,7 @@
end
signature PRETTY_CASES = sig
- structure Open : OPEN_CASES
- include PRETTY
+ include CASES PRETTY
sharing Open.Rep = PrettyRep
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/reduce.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/reduce.sig 2007-09-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/reduce.sig 2007-09-29 19:03:42 UTC (rev 6059)
@@ -39,11 +39,8 @@
end
signature REDUCE_CASES = sig
- structure Open : OPEN_CASES
- include REDUCE
+ include CASES REDUCE
sharing Open.Rep = ReduceRep
end
-signature WITH_REDUCE_DOM = sig
- structure Open : OPEN_CASES
-end
+signature WITH_REDUCE_DOM = CASES
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/seq.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/seq.sig 2007-09-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/seq.sig 2007-09-29 19:03:42 UTC (rev 6059)
@@ -31,8 +31,7 @@
end
signature SEQ_CASES = sig
- structure Open : OPEN_CASES
- include SEQ
+ include CASES SEQ
sharing Open.Rep = SeqRep
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/shrink.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/shrink.sig 2007-09-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/shrink.sig 2007-09-29 19:03:42 UTC (rev 6059)
@@ -34,13 +34,11 @@
end
signature SHRINK_CASES = sig
- structure Open : OPEN_CASES
- include SHRINK
+ include CASES SHRINK
sharing Open.Rep = ShrinkRep
end
signature WITH_SHRINK_DOM = sig
- structure Open : OPEN_CASES
- include ORD SIZE
+ include CASES ORD SIZE
sharing Open.Rep = OrdRep = SizeRep
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/size.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/size.sig 2007-09-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/size.sig 2007-09-29 19:03:42 UTC (rev 6059)
@@ -30,13 +30,11 @@
end
signature SIZE_CASES = sig
- structure Open : OPEN_CASES
- include SIZE
+ include CASES SIZE
sharing Open.Rep = SizeRep
end
signature WITH_SIZE_DOM = sig
- structure Open : OPEN_CASES
- include HASH TYPE_INFO
+ include CASES HASH TYPE_INFO
sharing Open.Rep = HashRep = TypeInfoRep
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/some.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/some.sig 2007-09-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/some.sig 2007-09-29 19:03:42 UTC (rev 6059)
@@ -30,8 +30,7 @@
end
signature SOME_CASES = sig
- structure Open : OPEN_CASES
- include SOME
+ include CASES SOME
sharing Open.Rep = SomeRep
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/transform.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/transform.sig 2007-09-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/transform.sig 2007-09-29 19:03:42 UTC (rev 6059)
@@ -32,8 +32,7 @@
end
signature TRANSFORM_CASES = sig
- structure Open : OPEN_CASES
- include TRANSFORM
+ include CASES TRANSFORM
sharing Open.Rep = TransformRep
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/type-exp.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/type-exp.sig 2007-09-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/type-exp.sig 2007-09-29 19:03:42 UTC (rev 6059)
@@ -20,11 +20,8 @@
end
signature TYPE_EXP_CASES = sig
- structure Open : OPEN_CASES
- include TYPE_EXP
+ include CASES TYPE_EXP
sharing Open.Rep = TypeExpRep
end
-signature WITH_TYPE_EXP_DOM = sig
- structure Open : OPEN_CASES
-end
+signature WITH_TYPE_EXP_DOM = CASES
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/type-hash.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/type-hash.sig 2007-09-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/type-hash.sig 2007-09-29 19:03:42 UTC (rev 6059)
@@ -17,11 +17,8 @@
end
signature TYPE_HASH_CASES = sig
- structure Open : OPEN_CASES
- include TYPE_HASH
+ include CASES TYPE_HASH
sharing Open.Rep = TypeHashRep
end
-signature WITH_TYPE_HASH_DOM = sig
- structure Open : OPEN_CASES
-end
+signature WITH_TYPE_HASH_DOM = CASES
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sig 2007-09-29 16:04:31 UTC (rev 6058)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sig 2007-09-29 19:03:42 UTC (rev 6059)
@@ -35,11 +35,8 @@
end
signature TYPE_INFO_CASES = sig
- structure Open : OPEN_CASES
- include TYPE_INFO
+ include CASES TYPE_INFO
sharing Open.Rep = TypeInfoRep
end
-signature WITH_TYPE_INFO_DOM = sig
- structure Open : OPEN_CASES
-end
+signature WITH_TYPE_INFO_DOM = CASES
|
|
From: Matthew F. <fl...@ml...> - 2007-09-29 09:04:33
|
An expert control to enable the CPS transform
----------------------------------------------------------------------
U mlton/trunk/mlton/control/control-flags.sig
U mlton/trunk/mlton/control/control-flags.sml
U mlton/trunk/mlton/main/main.fun
U mlton/trunk/mlton/xml/sxml-simplify.fun
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/control/control-flags.sig
===================================================================
--- mlton/trunk/mlton/control/control-flags.sig 2007-09-29 13:45:53 UTC (rev 6057)
+++ mlton/trunk/mlton/control/control-flags.sig 2007-09-29 16:04:31 UTC (rev 6058)
@@ -52,6 +52,8 @@
val contifyIntoMain: bool ref
+ val cpsTransform: bool ref
+
(* Generate an executable with debugging info. *)
val debug: bool ref
Modified: mlton/trunk/mlton/control/control-flags.sml
===================================================================
--- mlton/trunk/mlton/control/control-flags.sml 2007-09-29 13:45:53 UTC (rev 6057)
+++ mlton/trunk/mlton/control/control-flags.sml 2007-09-29 16:04:31 UTC (rev 6058)
@@ -81,6 +81,10 @@
default = false,
toString = Bool.toString}
+val cpsTransform = control {name = "cpsTransform",
+ default = false,
+ toString = Bool.toString}
+
val debug = control {name = "debug",
default = false,
toString = Bool.toString}
Modified: mlton/trunk/mlton/main/main.fun
===================================================================
--- mlton/trunk/mlton/main/main.fun 2007-09-29 13:45:53 UTC (rev 6057)
+++ mlton/trunk/mlton/main/main.fun 2007-09-29 16:04:31 UTC (rev 6058)
@@ -256,6 +256,9 @@
(Expert, "contify-into-main", " {false|true}",
"contify functions into main",
boolRef contifyIntoMain),
+ (Expert, "cps-transform", " {false|true}",
+ "perform cps transform on sxml il",
+ boolRef cpsTransform),
(Expert, "debug", " {false|true}", "produce executable with debug info",
Bool (fn b => (debug := b
; debugRuntime := b))),
Modified: mlton/trunk/mlton/xml/sxml-simplify.fun
===================================================================
--- mlton/trunk/mlton/xml/sxml-simplify.fun 2007-09-29 13:45:53 UTC (rev 6057)
+++ mlton/trunk/mlton/xml/sxml-simplify.fun 2007-09-29 16:04:31 UTC (rev 6058)
@@ -24,25 +24,41 @@
fn () => Polyvariance.duplicate p)
type pass = {name: string,
+ enable: unit -> bool,
doit: Program.t -> Program.t}
val sxmlPassesDefault =
- {name = "sxmlShrink1", doit = S.shrink} ::
- {name = "implementSuffix", doit = ImplementSuffix.doit} ::
- {name = "sxmlShrink2", doit = S.shrink} ::
- {name = "implementExceptions", doit = ImplementExceptions.doit} ::
- {name = "sxmlShrink3", doit = S.shrink} ::
+ {name = "sxmlShrink1",
+ enable = fn () => true, doit = S.shrink} ::
+ {name = "implementSuffix",
+ enable = fn () => true, doit = ImplementSuffix.doit} ::
+ {name = "sxmlShrink2",
+ enable = fn () => true, doit = S.shrink} ::
+ {name = "implementExceptions",
+ enable = fn () => true, doit = ImplementExceptions.doit} ::
+ {name = "sxmlShrink3",
+ enable = fn () => true, doit = S.shrink} ::
(*
- {name = "uncurry", doit = Uncurry.uncurry} ::
- {name = "sxmlShrink4", doit = S.shrink} ::
+ {name = "uncurry",
+ enable = fn () => true, doit = Uncurry.uncurry} ::
+ {name = "sxmlShrink4",
+ enable = fn () => true, doit = S.shrink} ::
*)
- {name = "polyvariance", doit = Polyvariance.duplicate} ::
+ {name = "cpsTransform",
+ enable = fn () => !Control.cpsTransform, doit = CPSTransform.doit} ::
+ {name = "sxmlShrink4",
+ enable = fn () => !Control.cpsTransform, doit = S.shrink} ::
+ {name = "polyvariance",
+ enable = fn () => true, doit = Polyvariance.duplicate} ::
nil
val sxmlPassesMinimal =
- {name = "implementSuffix", doit = ImplementSuffix.doit} ::
- {name = "sxmlShrink2", doit = S.shrink} ::
- {name = "implementExceptions", doit = ImplementExceptions.doit} ::
+ {name = "implementSuffix",
+ enable = fn () => true, doit = ImplementSuffix.doit} ::
+ {name = "sxmlShrink2",
+ enable = fn () => true, doit = S.shrink} ::
+ {name = "implementExceptions",
+ enable = fn () => true, doit = ImplementExceptions.doit} ::
nil
val sxmlPasses : pass list ref = ref sxmlPassesDefault
@@ -55,6 +71,7 @@
in fn s => if s = name
then SOME {name = name ^ "#" ^
(Int.toString (Counter.next count)),
+ enable = fn () => true,
doit = doit}
else NONE
end
@@ -89,6 +106,7 @@
Int.toString small, ",",
Int.toString product, ")#",
Int.toString (Counter.next count)],
+ enable = fn () => true,
doit = polyvariance (rounds, small, product)}
val s = String.dropPrefix (s, String.size "polyvariance")
in
@@ -142,9 +160,10 @@
fun simplify p =
(stats p
; (List.fold
- (!sxmlPasses, p, fn ({name, doit}, p) =>
+ (!sxmlPasses, p, fn ({name, enable, doit}, p) =>
if List.exists (!Control.dropPasses, fn re =>
Regexp.Compiled.matchesAll (re, name))
+ orelse not (enable ())
then p
else
let
|
|
From: Matthew F. <fl...@ml...> - 2007-09-29 06:45:54
|
Unused variable
----------------------------------------------------------------------
U mlton/trunk/mlton/xml/cps-transform.fun
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/xml/cps-transform.fun
===================================================================
--- mlton/trunk/mlton/xml/cps-transform.fun 2007-09-28 22:31:56 UTC (rev 6056)
+++ mlton/trunk/mlton/xml/cps-transform.fun 2007-09-29 13:45:53 UTC (rev 6057)
@@ -451,7 +451,7 @@
in
Error.bug "ImplementContinuations.transPrimExp: Profile"
end
- | Raise {exn, extend} =>
+ | Raise {exn, ...} =>
DirectExp.app
{func = h,
arg = transVarExp exn,
|
|
From: Matthew F. <fl...@ml...> - 2007-09-28 15:31:58
|
A whole-program cps-transform on the SXML IL
----------------------------------------------------------------------
A mlton/trunk/mlton/xml/cps-transform.fun
A mlton/trunk/mlton/xml/cps-transform.sig
U mlton/trunk/mlton/xml/sources.cm
U mlton/trunk/mlton/xml/sources.mlb
U mlton/trunk/mlton/xml/sxml-simplify.fun
U mlton/trunk/mlton/xml/xml-tree.fun
U mlton/trunk/mlton/xml/xml-tree.sig
----------------------------------------------------------------------
Added: mlton/trunk/mlton/xml/cps-transform.fun
===================================================================
--- mlton/trunk/mlton/xml/cps-transform.fun 2007-09-28 11:17:53 UTC (rev 6055)
+++ mlton/trunk/mlton/xml/cps-transform.fun 2007-09-28 22:31:56 UTC (rev 6056)
@@ -0,0 +1,594 @@
+(* Copyright (C) 2007-2007 Henry Cejtin, Matthew Fluet, Suresh
+ * Jagannathan, and Stephen Weeks.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+functor CPSTransform (S: CPS_TRANSFORM_STRUCTS): CPS_TRANSFORM =
+struct
+
+open S
+datatype z = datatype Dec.t
+datatype z = datatype PrimExp.t
+
+fun doit (prog: Program.t): Program.t =
+ let
+ val Program.T {datatypes, body, overflow} = prog
+
+ (* Answer type is always unit in an XML IL program. *)
+ val ansTy = Type.unit
+ (* Exception type is always exn in an XML IL program. *)
+ val exnTy = Type.exn
+
+
+ (* Style of function-type translation. *)
+ datatype style = Curried | Mixed | Uncurried
+ val style = Uncurried
+
+ val {hom = transType, destroy = destroyTransType} =
+ Type.makeMonoHom
+ {con = fn (_, c, tys) =>
+ if Tycon.equals (c, Tycon.arrow)
+ then let
+ val argTy = Vector.sub (tys, 0)
+ val resTy = Vector.sub (tys, 1)
+ in
+ case style of
+ Curried =>
+ Type.arrow
+ (Type.arrow (resTy, ansTy),
+ Type.arrow
+ (Type.arrow (exnTy, ansTy),
+ Type.arrow (argTy, ansTy)))
+ | Mixed =>
+ Type.arrow
+ ((Type.tuple o Vector.new2)
+ (Type.arrow (resTy, ansTy),
+ Type.arrow (exnTy, ansTy)),
+ Type.arrow (argTy, ansTy))
+ | Uncurried =>
+ Type.arrow
+ ((Type.tuple o Vector.new3)
+ (Type.arrow (resTy, ansTy),
+ Type.arrow (exnTy, ansTy),
+ argTy),
+ ansTy)
+ end
+ else Type.con (c, tys)}
+
+ (* A property to record (original) type of each bound variable. *)
+ val {get = getVarOrigType: Var.t -> Type.t, set = setVarOrigType, ...} =
+ Property.getSetOnce
+ (Var.plist, Property.initRaise ("getVarOrigType", Var.layout))
+ val getVarExpOrigType = getVarOrigType o VarExp.var
+
+ (* A mayOverflow primitive needs a special translation with a wrapper
+ * datatype. See transPrimExp:PrimApp.
+ *)
+ val wrapDatatypes = ref []
+ val {get = getWrap, destroy = destroyWrap, ...} =
+ Property.destGet
+ (Type.plist, Property.initFun (fn ty =>
+ let
+ val successCon = Con.newString "Success"
+ val failureCon = Con.newString "Failure"
+ val wrapTycon = Tycon.newString "Wrap"
+ val wrapTy = Type.con (wrapTycon, Vector.new0 ())
+ val wrapDatatype =
+ {cons = Vector.new2
+ ({arg = SOME ty, con = successCon},
+ {arg = SOME exnTy, con = failureCon}),
+ tycon = wrapTycon,
+ tyvars = Vector.new0 ()}
+ val () = List.push (wrapDatatypes, wrapDatatype)
+ in
+ {successCon = successCon,
+ failureCon = failureCon,
+ wrapTy = wrapTy}
+ end))
+
+ fun transVarExpWithType (x: VarExp.t) : DirectExp.t * Type.t =
+ let
+ val xTy = transType (getVarExpOrigType x)
+ in
+ (DirectExp.varExp (x, xTy), xTy)
+ end
+ val transVarExp = #1 o transVarExpWithType
+
+ fun transLambda (l: Lambda.t): Lambda.t =
+ let
+ val {arg = argVar, argType = argTy, body, mayInline} = Lambda.dest l
+ val resTy = getVarExpOrigType (Exp.result body)
+
+ val argTy = transType argTy
+ val resTy = transType resTy
+ val kVar = Var.newString "k"
+ val kTy = Type.arrow (resTy, ansTy)
+ val hVar = Var.newString "h"
+ val hTy = Type.arrow (exnTy, ansTy)
+ val bodyKHA = transExp (body, kVar, kTy, hVar, hTy)
+ in
+ case style of
+ Curried =>
+ let
+ val bodyKH =
+ DirectExp.lambda
+ {arg = argVar,
+ argType = argTy,
+ body = bodyKHA,
+ bodyType = ansTy,
+ mayInline = mayInline}
+ val bodyK =
+ DirectExp.lambda
+ {arg = hVar,
+ argType = hTy,
+ body = bodyKH,
+ bodyType = Type.arrow (argTy, ansTy),
+ mayInline = true}
+ in
+ Lambda.make
+ {arg = kVar,
+ argType = kTy,
+ body = DirectExp.toExp bodyK,
+ mayInline = true}
+ end
+ | Mixed =>
+ let
+ val xVar = Var.newNoname ()
+ val xTy = Type.tuple (Vector.new2 (kTy, hTy))
+ val x = DirectExp.monoVar (xVar, xTy)
+ val bodyKH =
+ DirectExp.lambda
+ {arg = argVar,
+ argType = argTy,
+ body = bodyKHA,
+ bodyType = ansTy,
+ mayInline = mayInline}
+ val bodyXK =
+ DirectExp.let1
+ {var = hVar,
+ exp = (DirectExp.select {tuple = x,
+ offset = 1,
+ ty = hTy}),
+ body = bodyKH}
+ val bodyX =
+ DirectExp.let1
+ {var = kVar,
+ exp = (DirectExp.select {tuple = x,
+ offset = 0,
+ ty = kTy}),
+ body = bodyXK}
+ in
+ Lambda.make
+ {arg = xVar,
+ argType = xTy,
+ body = DirectExp.toExp bodyX,
+ mayInline = mayInline}
+ end
+ | Uncurried =>
+ let
+ val xVar = Var.newNoname ()
+ val xTy = Type.tuple (Vector.new3 (kTy, hTy, argTy))
+ val x = DirectExp.monoVar (xVar, xTy)
+ val bodyXKH =
+ DirectExp.let1
+ {var = argVar,
+ exp = (DirectExp.select {tuple = x,
+ offset = 2,
+ ty = argTy}),
+ body = bodyKHA}
+ val bodyXK =
+ DirectExp.let1
+ {var = hVar,
+ exp = (DirectExp.select {tuple = x,
+ offset = 1,
+ ty = hTy}),
+ body = bodyXKH}
+ val bodyX =
+ DirectExp.let1
+ {var = kVar,
+ exp = (DirectExp.select {tuple = x,
+ offset = 0,
+ ty = kTy}),
+ body = bodyXK}
+ in
+ Lambda.make
+ {arg = xVar,
+ argType = xTy,
+ body = DirectExp.toExp bodyX,
+ mayInline = mayInline}
+ end
+ end
+ and transPrimExp (e: PrimExp.t, eTy: Type.t,
+ kVar: Var.t, kTy: Type.t,
+ hVar: Var.t, hTy: Type.t): DirectExp.t =
+ let
+ val eTy = transType eTy
+ val k = DirectExp.monoVar (kVar, kTy)
+ val h = DirectExp.monoVar (hVar, hTy)
+ fun return x = DirectExp.app {func = k, arg = x, ty = ansTy}
+ in
+ case e of
+ App {arg, func} =>
+ let
+ val (arg, argTy) = transVarExpWithType arg
+ val func = transVarExp func
+ in
+ case style of
+ Curried =>
+ let
+ val app1 =
+ DirectExp.app
+ {func = func,
+ arg = k,
+ ty = Type.arrow (hTy, Type.arrow (argTy, ansTy))}
+ val app2 =
+ DirectExp.app
+ {func = app1,
+ arg = h,
+ ty = Type.arrow (argTy, ansTy)}
+ val app3 =
+ DirectExp.app
+ {func = app2,
+ arg = arg,
+ ty = ansTy}
+ in
+ app3
+ end
+ | Mixed =>
+ let
+ val arg2 =
+ DirectExp.tuple
+ {exps = Vector.new2 (k, h),
+ ty = (Type.tuple o Vector.new2) (kTy, hTy)}
+ val app2 =
+ DirectExp.app
+ {func = func,
+ arg = arg2,
+ ty = Type.arrow (argTy, ansTy)}
+ val app3 =
+ DirectExp.app
+ {func = app2,
+ arg = arg,
+ ty = ansTy}
+ in
+ app3
+ end
+ | Uncurried =>
+ let
+ val arg3 =
+ DirectExp.tuple
+ {exps = Vector.new3 (k, h, arg),
+ ty = (Type.tuple o Vector.new3) (kTy, hTy, argTy)}
+ val app3 =
+ DirectExp.app
+ {func = func,
+ arg = arg3,
+ ty = ansTy}
+ in
+ app3
+ end
+ end
+ | Case {cases, default, test} =>
+ let
+ val cases =
+ case cases of
+ Cases.Con cases =>
+ let
+ val cases =
+ Vector.map
+ (cases, fn (Pat.T {arg, con, targs}, e) =>
+ let
+ val arg =
+ Option.map
+ (arg, fn (arg, argTy) =>
+ (arg, transType argTy))
+ val targs = Vector.map (targs, transType)
+ in
+ (Pat.T {arg = arg, con = con, targs = targs},
+ transExp (e, kVar, kTy, hVar, hTy))
+ end)
+ in
+ Cases.Con cases
+ end
+ | Cases.Word (ws, cases) =>
+ let
+ val cases =
+ Vector.map
+ (cases, fn (w, e) =>
+ (w, transExp (e, kVar, kTy, hVar, hTy)))
+ in
+ Cases.Word (ws, cases)
+ end
+ val default =
+ Option.map
+ (default, fn (e, r) =>
+ (transExp (e, kVar, kTy, hVar, hTy), r))
+ in
+ DirectExp.casee
+ {cases = cases,
+ default = default,
+ test = transVarExp test,
+ ty = ansTy}
+ end
+ | ConApp {arg, con, targs} =>
+ (return o DirectExp.conApp)
+ {arg = Option.map (arg, transVarExp),
+ con = con,
+ targs = Vector.map (targs, transType),
+ ty = eTy}
+ | Const c => return (DirectExp.const c)
+ | Handle {catch = (cVar, _), handler, try} =>
+ let
+ val h'Var = Var.newString "h"
+ val h'Ty = Type.arrow (exnTy, ansTy)
+ val h'Body =
+ DirectExp.lambda
+ {arg = cVar,
+ argType = exnTy,
+ body = transExp (handler, kVar, kTy, hVar, hTy),
+ bodyType = ansTy,
+ mayInline = true}
+ in
+ DirectExp.let1 {var = h'Var, exp = h'Body, body =
+ transExp (try, kVar, kTy, h'Var, h'Ty)}
+ end
+ | Lambda l =>
+ let
+ val l = transLambda l
+ in
+ return (DirectExp.fromLambda (l, eTy))
+ end
+ | PrimApp {args, prim, targs} =>
+ let
+ val primAppExp =
+ DirectExp.primApp
+ {args = Vector.map (args, transVarExp),
+ prim = prim,
+ targs = Vector.map (targs, transType),
+ ty = eTy}
+ in
+ if Prim.mayOverflow prim
+ then let
+ (* A mayOverflow primitive has an
+ * implicit raise, which is introduced
+ * explicitly by closure-convert
+ * (transformation from SXML to SSA).
+ *
+ * We leave an explicit Handle around
+ * the primitive to catch the
+ * exception. The non-exceptional
+ * result goes to the (normal)
+ * continuation, while the exception
+ * goes to the exception continuation.
+ *
+ * Naively, we would do:
+ * (k (primApp)) handle x => h x
+ * But, this evaluates the (normal)
+ * continuation in the context of the
+ * handler.
+ *
+ * Rather, we do:
+ * case ((Success (primApp))
+ * handle x => Failure x) of
+ * Success x => k x
+ * Failure x => h x
+ * This evaluates the (normal)
+ * continuation outside the context of
+ * the handler.
+ *
+ * See <src>/lib/mlton/basic/exn0.sml
+ * and "Exceptional Syntax" by Benton
+ * and Kennedy.
+ *
+ *)
+
+ val {successCon, failureCon, wrapTy} =
+ getWrap eTy
+
+ val testExp =
+ let
+ val xVar = Var.newNoname ()
+ val x = DirectExp.monoVar (xVar, exnTy)
+ in
+ DirectExp.handlee
+ {try = DirectExp.conApp
+ {arg = SOME primAppExp,
+ con = successCon,
+ targs = Vector.new0 (),
+ ty = wrapTy},
+ catch = (xVar, exnTy),
+ handler = DirectExp.conApp
+ {arg = SOME x,
+ con = failureCon,
+ targs = Vector.new0 (),
+ ty = wrapTy},
+ ty = wrapTy}
+ end
+
+ val successCase =
+ let
+ val xVar = Var.newNoname ()
+ in
+ (Pat.T {arg = SOME (xVar, eTy),
+ con = successCon,
+ targs = Vector.new0 ()},
+ DirectExp.app
+ {func = k,
+ arg = DirectExp.monoVar (xVar, eTy),
+ ty = ansTy})
+ end
+ val failureCase =
+ let
+ val xVar = Var.newNoname ()
+ in
+ (Pat.T
+ {arg = SOME (xVar, exnTy),
+ con = failureCon,
+ targs = Vector.new0 ()},
+ DirectExp.app
+ {func = h,
+ arg = DirectExp.monoVar (xVar, exnTy),
+ ty = ansTy})
+ end
+ val cases =
+ Cases.Con (Vector.new2 (successCase, failureCase))
+ in
+ DirectExp.casee
+ {test = testExp,
+ cases = cases,
+ default = NONE,
+ ty = ansTy}
+ end
+ else return primAppExp
+ end
+ | Profile _ =>
+ let
+ (* Profile statements won't properly nest after
+ * CPS conversion.
+ *)
+ in
+ Error.bug "ImplementContinuations.transPrimExp: Profile"
+ end
+ | Raise {exn, extend} =>
+ DirectExp.app
+ {func = h,
+ arg = transVarExp exn,
+ ty = ansTy}
+ | Select {offset, tuple} =>
+ (return o DirectExp.select)
+ {tuple = transVarExp tuple,
+ offset = offset,
+ ty = eTy}
+ | Tuple xs =>
+ (return o DirectExp.tuple)
+ {exps = Vector.map (xs, transVarExp),
+ ty = eTy}
+ | Var x => return (transVarExp x)
+ end
+ and transDec (d: Dec.t,
+ kBody: DirectExp.t,
+ hVar: Var.t, hTy: Type.t): DirectExp.t =
+ let
+ in
+ case d of
+ Exception _ => Error.bug "ImplementContinuations.transDec: Exception"
+ | Fun {decs, tyvars} =>
+ let
+ val decs =
+ Vector.map
+ (decs, fn {var, ty, lambda} =>
+ {var = var,
+ ty = transType ty,
+ lambda = transLambda lambda})
+ val d = Fun {decs = decs, tyvars = tyvars}
+ in
+ DirectExp.lett {decs = [d], body = kBody}
+ end
+ | MonoVal {var, ty, exp} =>
+ let
+ val expTy = ty
+ val argVar = var
+ val argTy = transType ty
+ val k'Var = Var.newString "k"
+ val k'Ty = Type.arrow (argTy, ansTy)
+ val k'Body =
+ DirectExp.lambda
+ {arg = argVar,
+ argType = argTy,
+ body = kBody,
+ bodyType = ansTy,
+ mayInline = true}
+ in
+ DirectExp.let1 {var = k'Var, exp = k'Body, body =
+ transPrimExp (exp, expTy, k'Var, k'Ty, hVar, hTy)}
+ end
+ | PolyVal _ => Error.bug "ImplementContinuations.transDec: PolyVal"
+ end
+ and transExp (e: Exp.t,
+ kVar: Var.t, kTy: Type.t,
+ hVar: Var.t, hTy: Type.t): DirectExp.t =
+ let
+ val {decs, result} = Exp.dest e
+ val k = DirectExp.monoVar (kVar, kTy)
+ val k'Body =
+ DirectExp.app
+ {func = k, arg = transVarExp result, ty = ansTy}
+ in
+ List.foldr
+ (decs, k'Body, fn (dec, kBody) =>
+ transDec (dec, kBody, hVar, hTy))
+ end
+
+ (* Set (original) type of each bound variable. *)
+ val () =
+ Exp.foreachBoundVar
+ (body, fn (v, _, ty) =>
+ setVarOrigType (v, ty))
+
+ (* Translate datatypes. *)
+ val datatypes =
+ Vector.map
+ (datatypes, fn {cons, tycon, tyvars} =>
+ {cons = Vector.map (cons, fn {arg, con} =>
+ {arg = Option.map (arg, transType),
+ con = con}),
+ tycon = tycon,
+ tyvars = tyvars})
+
+ (* Initial continuation. *)
+ val k0 = Var.newString "k0"
+ val k0Body =
+ DirectExp.lambda
+ {arg = Var.newNoname (),
+ argType = ansTy,
+ body = DirectExp.unit (),
+ bodyType = ansTy,
+ mayInline = true}
+ val k0Ty = Type.arrow (ansTy, Type.unit)
+ (* Initial exception continuation. *)
+ val h0 = Var.newString "h0"
+ val h0Body =
+ DirectExp.lambda
+ {arg = Var.newNoname (),
+ argType = exnTy,
+ body = DirectExp.unit (),
+ bodyType = ansTy,
+ mayInline = true}
+ val h0Ty = Type.arrow (exnTy, Type.unit)
+
+ (* Translate body, in context of initial continuations. *)
+ val body = DirectExp.let1 {var = k0, exp = k0Body, body =
+ DirectExp.let1 {var = h0, exp = h0Body, body =
+ transExp (body, k0, k0Ty, h0, h0Ty)}}
+
+ (* Closure-convert (transformation from SXML to SSA) introduces
+ * every (non-main) SSA function with "raises = [exn]";
+ * we need a top-level handler to avoid a "raise mismatch" type
+ * error in the SSA IL.
+ *)
+ val body = DirectExp.handlee
+ {try = body,
+ catch = (Var.newNoname (), exnTy),
+ handler = DirectExp.unit (),
+ ty = ansTy}
+ val body = DirectExp.toExp body
+
+ (* Fetch accumulated wrap datatypes. *)
+ val wrapDatatypes = Vector.fromList (!wrapDatatypes)
+ val datatypes = Vector.concat [datatypes, wrapDatatypes]
+
+ val prog = Program.T {datatypes = datatypes,
+ body = body,
+ overflow = overflow}
+
+ (* Clear and destroy properties. *)
+ val () = Exp.clear body
+ val () = destroyTransType ()
+ val () = destroyWrap ()
+ in
+ prog
+ end
+
+end
Added: mlton/trunk/mlton/xml/cps-transform.sig
===================================================================
--- mlton/trunk/mlton/xml/cps-transform.sig 2007-09-28 11:17:53 UTC (rev 6055)
+++ mlton/trunk/mlton/xml/cps-transform.sig 2007-09-28 22:31:56 UTC (rev 6056)
@@ -0,0 +1,18 @@
+(* Copyright (C) 2007-2007 Henry Cejtin, Matthew Fluet, Suresh
+ * Jagannathan, and Stephen Weeks.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+signature CPS_TRANSFORM_STRUCTS =
+ sig
+ include SXML_TREE
+ end
+
+signature CPS_TRANSFORM =
+ sig
+ include CPS_TRANSFORM_STRUCTS
+
+ val doit: Program.t -> Program.t
+ end
Modified: mlton/trunk/mlton/xml/sources.cm
===================================================================
--- mlton/trunk/mlton/xml/sources.cm 2007-09-28 11:17:53 UTC (rev 6055)
+++ mlton/trunk/mlton/xml/sources.cm 2007-09-28 22:31:56 UTC (rev 6056)
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -47,6 +47,8 @@
implement-suffix.fun
polyvariance.sig
polyvariance.fun
+cps-transform.sig
+cps-transform.fun
sxml-simplify.sig
sxml-simplify.fun
sxml.sig
Modified: mlton/trunk/mlton/xml/sources.mlb
===================================================================
--- mlton/trunk/mlton/xml/sources.mlb 2007-09-28 11:17:53 UTC (rev 6055)
+++ mlton/trunk/mlton/xml/sources.mlb 2007-09-28 22:31:56 UTC (rev 6056)
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -36,6 +36,8 @@
implement-suffix.fun
polyvariance.sig
polyvariance.fun
+ cps-transform.sig
+ cps-transform.fun
sxml-simplify.sig
sxml-simplify.fun
sxml.sig
Modified: mlton/trunk/mlton/xml/sxml-simplify.fun
===================================================================
--- mlton/trunk/mlton/xml/sxml-simplify.fun 2007-09-28 11:17:53 UTC (rev 6055)
+++ mlton/trunk/mlton/xml/sxml-simplify.fun 2007-09-28 22:31:56 UTC (rev 6056)
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -15,6 +15,7 @@
structure ImplementSuffix = ImplementSuffix (open S)
structure Polyvariance = Polyvariance (open S)
(* structure Uncurry = Uncurry (open S) *)
+structure CPSTransform = CPSTransform (open S)
fun polyvariance (rounds, small, product) p =
Ref.fluidLet
Modified: mlton/trunk/mlton/xml/xml-tree.fun
===================================================================
--- mlton/trunk/mlton/xml/xml-tree.fun 2007-09-28 11:17:53 UTC (rev 6055)
+++ mlton/trunk/mlton/xml/xml-tree.fun 2007-09-28 22:31:56 UTC (rev 6056)
@@ -771,6 +771,9 @@
mayInline = mayInline}),
Type.arrow (argType, bodyType))
+ fun fromLambda (l, ty) =
+ simple (Lambda l, ty)
+
fun detupleGen (e: PrimExp.t,
t: Type.t,
components: Var.t vector,
Modified: mlton/trunk/mlton/xml/xml-tree.sig
===================================================================
--- mlton/trunk/mlton/xml/xml-tree.sig 2007-09-28 11:17:53 UTC (rev 6055)
+++ mlton/trunk/mlton/xml/xml-tree.sig 2007-09-28 22:31:56 UTC (rev 6056)
@@ -198,6 +198,7 @@
val equal: t * t -> t
val falsee: unit -> t
val fromExp: Exp.t * Type.t -> t
+ val fromLambda: Lambda.t * Type.t -> t
val handlee: {catch: Var.t * Type.t,
handler: t,
try: t,
|
|
From: Vesa K. <ve...@ml...> - 2007-09-28 04:17:55
|
Simple shrinking based counterexample minimization.
----------------------------------------------------------------------
U 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.mlb
U mltonlib/trunk/com/ssh/unit-test/unstable/public/mk-unit-test-fun.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/detail/generic.sml
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/detail/generic.sml 2007-09-28 10:20:49 UTC (rev 6054)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/detail/generic.sml 2007-09-28 11:17:53 UTC (rev 6055)
@@ -9,10 +9,19 @@
(*
* We assume here that {Eq} and {Pretty} have already been provided. The
* {Arbitrary} generic is rather specific to randomized testing and has
- * little use otherwise. The {Size} generic is probably also not used
- * much outside testing.
+ * probably little use otherwise. The same goes for {Shrink}. The {Size}
+ * generic is probably also not used much outside testing.
*)
+signature Generic = sig include Generic ARBITRARY end
+structure Generic : Generic = struct
+ structure Open = WithArbitrary
+ (open Generic
+ structure HashRep = Open.Rep and TypeInfoRep = Open.Rep
+ structure RandomGen = RanQD1Gen)
+ open Generic Open
+end
+
signature Generic = sig include Generic SIZE end
structure Generic : Generic = struct
structure Open = WithSize
@@ -21,12 +30,11 @@
open Generic Open
end
-signature Generic = sig include Generic ARBITRARY end
+signature Generic = sig include Generic SHRINK end
structure Generic : Generic = struct
- structure Open = WithArbitrary
+ structure Open = WithShrink
(open Generic
- structure HashRep = Open.Rep and TypeInfoRep = Open.Rep
- structure RandomGen = RanQD1Gen)
+ structure OrdRep = Open.Rep and SizeRep = Open.Rep)
open Generic Open
end
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/detail/mk-unit-test.fun
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/detail/mk-unit-test.fun 2007-09-28 10:20:49 UTC (rev 6054)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/detail/mk-unit-test.fun 2007-09-28 11:17:53 UTC (rev 6055)
@@ -20,7 +20,6 @@
structure Rep = Open.Rep
- fun sizeOf t v = Arg.sizeOf t v handle _ => 0
fun named t n v = group (nest 2 (str n <$> pretty t v))
val strs = str o concat
local
@@ -122,8 +121,8 @@
fun testRaises exnPr th = test (fn () => thatRaises exnPr th)
fun testFails th = test (fn () => thatFails th)
- datatype result =
- BUG of Int.t * Prettier.t
+ datatype 'a result =
+ BUG of 'a * Prettier.t
| OK
| SKIP
@@ -145,26 +144,25 @@
exception Skip
fun allParam {size, maxPass, maxSkip} t ef = let
- fun genTest passN = let
- val v = RandomGen.generate (size passN) (nextRNG ()) (arbitrary t)
+ fun test v =
+ (ef v : Unit.t ; OK)
+ handle Skip => SKIP
+ | Failure d => BUG (v, named t "with" v <$> d)
+ | e => BUG (v, named t "with" v <$> namedExn "raised" e)
+
+ fun genTest passN =
+ test (RandomGen.generate (size passN) (nextRNG ()) (arbitrary t))
+
+ fun minimize (v, ms) = let
+ fun lp [] = failure ms
+ | lp (v::vs) =
+ case test v
+ of BUG (v, ms) => minimize (v, ms)
+ | _ => lp vs
in
- (ef v : Unit.t ; OK)
- handle Skip => SKIP
- | Failure d => BUG (sizeOf t v, named t "with" v <$> d)
- | e => BUG (sizeOf t v,
- named t "with" v <$> namedExn "raised" e)
+ lp (shrink t v)
end
- fun minimize (genSz, origSz, minSz, minMsg) =
- if genSz < 0
- then failure minMsg
- else case genTest genSz
- of BUG (sz, msg) =>
- if sz < minSz
- then minimize (genSz-1, origSz, sz, msg)
- else minimize (genSz-1, origSz, minSz, minMsg)
- | _ => minimize (genSz-1, origSz, minSz, minMsg)
-
fun find (passN, skipN) =
if maxPass <= passN then
()
@@ -177,8 +175,8 @@
find (passN, skipN + 1)
| OK =>
find (passN + 1, skipN)
- | BUG (sz, ms) =>
- minimize (size passN, sz, sz, ms)
+ | BUG (v, ms) =>
+ minimize (v, ms)
in
find (0, 0)
end
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/detail/unit-test.sml
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/detail/unit-test.sml 2007-09-28 10:20:49 UTC (rev 6054)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/detail/unit-test.sml 2007-09-28 11:17:53 UTC (rev 6055)
@@ -7,4 +7,5 @@
structure UnitTest = MkUnitTest
(open Generic
structure ArbitraryRep = Open.Rep and EqRep = Open.Rep
- and PrettyRep = Open.Rep and SizeRep = Open.Rep)
+ and PrettyRep = Open.Rep and ShrinkRep = Open.Rep
+ and SizeRep = Open.Rep)
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/lib-with-default.mlb
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/lib-with-default.mlb 2007-09-28 10:20:49 UTC (rev 6054)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/lib-with-default.mlb 2007-09-28 11:17:53 UTC (rev 6055)
@@ -12,8 +12,9 @@
lib.mlb
(* Order matters: *)
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/arbitrary.sml
$(MLTON_LIB)/com/ssh/generic/unstable/with/size.sml
- $(MLTON_LIB)/com/ssh/generic/unstable/with/arbitrary.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/shrink.sml
$(MLTON_LIB)/com/ssh/generic/unstable/with/close-pretty-with-extra.sml
detail/unit-test.sml
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/public/mk-unit-test-fun.sig
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/public/mk-unit-test-fun.sig 2007-09-28 10:20:49 UTC (rev 6054)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/public/mk-unit-test-fun.sig 2007-09-28 11:17:53 UTC (rev 6055)
@@ -12,5 +12,6 @@
include ARBITRARY sharing Open.Rep = ArbitraryRep
include EQ sharing Open.Rep = EqRep
include PRETTY sharing Open.Rep = PrettyRep
+ include SHRINK sharing Open.Rep = ShrinkRep
include SIZE sharing Open.Rep = SizeRep
end
|
|
From: Vesa K. <ve...@ml...> - 2007-09-28 03:20:52
|
An experimental implementation of generic "shrinking".
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
A mltonlib/trunk/com/ssh/generic/unstable/detail/value/shrink.sml
U mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
A mltonlib/trunk/com/ssh/generic/unstable/public/value/shrink.sig
A mltonlib/trunk/com/ssh/generic/unstable/with/shrink.sml
----------------------------------------------------------------------
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-28 08:33:52 UTC (rev 6053)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-09-28 10:20:49 UTC (rev 6054)
@@ -31,6 +31,7 @@
../../../public/value/pretty.sig
../../../public/value/reduce.sig
../../../public/value/seq.sig
+ ../../../public/value/shrink.sig
../../../public/value/size.sig
../../../public/value/some.sig
../../../public/value/transform.sig
@@ -61,6 +62,7 @@
../../value/pretty.sml
../../value/reduce.sml
../../value/seq.sml
+ ../../value/shrink.sml
../../value/size.sml
../../value/some.sml
../../value/transform.sml
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/value/shrink.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/shrink.sml 2007-09-28 08:33:52 UTC (rev 6053)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/shrink.sml 2007-09-28 10:20:49 UTC (rev 6054)
@@ -0,0 +1,163 @@
+(* 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 WithShrink (Arg : WITH_SHRINK_DOM) : SHRINK_CASES = struct
+ (* <-- SML/NJ workaround *)
+ open TopLevel
+ infix 0 &
+ (* SML/NJ workaround --> *)
+
+ type e = Univ.t List.t
+ datatype 'a t =
+ IN of {kids : Unit.t Ref.t * e * 'a -> e,
+ shrink : 'a -> 'a List.t}
+
+ fun iso' (IN {kids, shrink}) (a2b, b2a) =
+ IN {kids = fn (i, e, a) => kids (i, e, a2b a),
+ shrink = map b2a o shrink o a2b}
+
+ fun list' (IN {kids, shrink}) = let
+ fun shrinkL [] = []
+ | shrinkL (x::xs) =
+ [xs] @
+ map (fn x => x::xs) (shrink x) @
+ map (fn xs => x::xs) (shrinkL xs)
+ in
+ IN {kids = fn (i, e, xs) => foldl (fn (x, e) => kids (i, e, x)) e xs,
+ shrink = shrinkL}
+ end
+
+ val none =
+ IN {kids = fn (_, e, _) => e,
+ shrink = fn _ => []}
+
+ structure ShrinkRep = LayerRep
+ (open Arg
+ structure Rep = MkClosedRep (type 'a t = 'a t))
+
+ open ShrinkRep.This
+
+ fun sortUniq aT = let
+ val sizeOf = Arg.sizeOf aT
+ val ord = Arg.ord aT
+ fun uniq xs = let
+ fun lp (ys, xs) =
+ case xs
+ of [] => ys
+ | [(_ & x)] => x::ys
+ | (s1 & x1)::(s2 & x2)::xs =>
+ if s1 = s2 andalso EQUAL = ord (x1, x2)
+ then lp (ys, (s2 & x2)::xs)
+ else lp (x1::ys, (s2 & x2)::xs)
+ in
+ rev (lp ([], xs))
+ end
+ in
+ uniq o
+ List.sort (Cmp.*` (Int.compare, ord)) o
+ map (fn x => sizeOf x & x)
+ end
+
+ fun shrink aT =
+ case getT aT
+ of IN {shrink, ...} => sortUniq aT o shrink
+
+ fun shrinkFix aT = let (* XXX suboptimal *)
+ val shrink = shrink aT
+ val sortUniq = sortUniq aT
+ fun lp (toShrink, shrunken) = let
+ val shrunken = sortUniq (toShrink @ shrunken)
+ val toShrink = List.concatMap shrink toShrink
+ in
+ if null toShrink then shrunken else lp (toShrink, shrunken)
+ end
+ in
+ fn x => lp (shrink x, [])
+ end
+
+ structure Open = LayerDepCases
+ (fun iso aT = iso' (getT aT)
+ fun isoProduct aP = iso' (getP aP)
+ fun isoSum aS = iso' (getS aS)
+
+ fun op *` (aP, bP) = let
+ val IN aS = getP aP
+ val IN bS = getP bP
+ in
+ IN {kids = fn (i, e, a & b) => #kids bS (i, #kids aS (i, e, a), b),
+ shrink = fn a & b =>
+ map (fn a => a & b) (#shrink aS a) @
+ map (fn b => a & b) (#shrink bS b)}
+ end
+ val T = getT
+ fun R _ = getT
+ val tuple = getP
+ val record = getP
+
+ fun op +` (aS, bS) = let
+ val IN aS = getS aS
+ val IN bS = getS bS
+ in
+ IN {kids = fn (i, e, INL a) => #kids aS (i, e, a)
+ | (i, e, INR b) => #kids bS (i, e, b),
+ shrink = fn INL a => map INL (#shrink aS a)
+ | INR b => map INR (#shrink bS b)}
+ end
+ val unit = none
+ fun C0 _ = unit
+ fun C1 _ = getT
+ val data = getS
+
+ fun Y ? = Tie.pure (fn () => let
+ val i = ref ()
+ val (to, from) = Univ.Iso.new ()
+ val r = ref (raising Fix.Fix)
+ in
+ (IN {kids = fn (i', e, x) => if i = i' then to x :: e else e,
+ shrink = fn x => !r x},
+ fn IN {kids, shrink} => let
+ fun shrinkT x = let
+ val ks = map from (kids (i, [], x))
+ in
+ ks @ shrink x
+ end
+ in
+ r := shrinkT
+ ; IN {kids = kids, shrink = shrinkT}
+ end)
+ end) ?
+
+ fun op --> _ = none
+
+ val exn = none
+ fun regExn0 _ _ = ()
+ fun regExn1 _ _ _ = ()
+
+ fun array _ = none
+ fun list aT = list' (getT aT)
+ fun vector aT = iso' (list aT) Vector.isoList
+
+ fun refc _ = none
+
+ 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 = iso' (list' char) String.isoList
+ val word = none
+
+ val word8 = none
+ val word32 = none
+ val word64 = none
+
+ open Arg ShrinkRep)
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/value/shrink.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-09-28 08:33:52 UTC (rev 6053)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-09-28 10:20:49 UTC (rev 6054)
@@ -124,6 +124,9 @@
public/value/size.sig
detail/value/size.sml
+ public/value/shrink.sig
+ detail/value/shrink.sml
+
public/value/transform.sig
detail/value/transform.sml
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-09-28 08:33:52 UTC (rev 6053)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-09-28 10:20:49 UTC (rev 6054)
@@ -167,6 +167,10 @@
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)
+signature SHRINK = SHRINK and SHRINK_CASES = SHRINK_CASES
+ and WITH_SHRINK_DOM = WITH_SHRINK_DOM
+functor WithShrink (Arg : WITH_SHRINK_DOM) : SHRINK_CASES = WithShrink (Arg)
+
signature SIZE = SIZE and SIZE_CASES = SIZE_CASES
and WITH_SIZE_DOM = WITH_SIZE_DOM
functor WithSize (Arg : WITH_SIZE_DOM) : SIZE_CASES = WithSize (Arg)
Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/shrink.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/shrink.sig 2007-09-28 08:33:52 UTC (rev 6053)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/shrink.sig 2007-09-28 10:20:49 UTC (rev 6054)
@@ -0,0 +1,46 @@
+(* 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.
+ *)
+
+(**
+ * Signature for a generic shrinking function.
+ *
+ * The basic idea is to "shrink" a given value by producing a list of
+ * maximal proper (or strict) subvalues (or subsets) of the given value.
+ * For example, given a list of booleans, calling {shrink} on the list
+ * would produce a list of lists of booleans where each list of booleans
+ * is the same as the given list except that it omits one element of the
+ * given list.
+ *
+ * The main application of shrinking is randomized testing.
+ *)
+signature SHRINK = sig
+ structure ShrinkRep : OPEN_REP
+
+ val shrink : ('a, 'x) ShrinkRep.t -> 'a -> 'a List.t
+ (** Extracts the single-layer shrinking function. *)
+
+ val shrinkFix : ('a, 'x) ShrinkRep.t -> 'a -> 'a List.t
+ (**
+ * Shrinks the given value to a fixpoint.
+ *
+ * WARNING: This function is impractical for most purposes, because the
+ * size of the output grows extremely rapidly depending on the type and
+ * size of the input. Frankly, this is mostly provided for playing
+ * with in a REPL and might be removed in the future.
+ *)
+end
+
+signature SHRINK_CASES = sig
+ structure Open : OPEN_CASES
+ include SHRINK
+ sharing Open.Rep = ShrinkRep
+end
+
+signature WITH_SHRINK_DOM = sig
+ structure Open : OPEN_CASES
+ include ORD SIZE
+ sharing Open.Rep = OrdRep = SizeRep
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/shrink.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/generic/unstable/with/shrink.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/with/shrink.sml 2007-09-28 08:33:52 UTC (rev 6053)
+++ mltonlib/trunk/com/ssh/generic/unstable/with/shrink.sml 2007-09-28 10:20:49 UTC (rev 6054)
@@ -0,0 +1,16 @@
+(* 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.
+ *)
+
+signature Generic = sig
+ include Generic SHRINK
+end
+
+structure Generic : Generic = struct
+ structure Open = WithShrink
+ (open Generic
+ structure OrdRep = Open.Rep and SizeRep = Open.Rep)
+ open Generic Open
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/with/shrink.sml
___________________________________________________________________
Name: svn:eol-style
+ native
|
|
From: Vesa K. <ve...@ml...> - 2007-09-28 01:33:54
|
Lexicographic product combinator for orderings.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml
U mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fn/cmp.sml
U mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/cmp.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml 2007-09-27 10:53:54 UTC (rev 6052)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml 2007-09-28 08:33:52 UTC (rev 6053)
@@ -56,7 +56,7 @@
structure Fix = struct type 'a t = 'a UnOp.t -> 'a end
structure Reader = struct type ('a, 'b) t = 'b -> ('a * 'b) Option.t end
structure Writer = struct type ('a, 'b) t = 'a * 'b -> 'b end
-structure Cmp = struct type 'a t = 'a Sq.t -> Order.t end
+structure Cmp = struct open Product type 'a t = 'a Sq.t -> Order.t end
structure BinOp = struct type 'a t = 'a Sq.t -> 'a end
structure BinPr = struct type 'a t = 'a Sq.t UnPr.t end
structure Emb = struct type ('a, 'b) t = ('a -> 'b) * ('b -> 'a Option.t) end
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fn/cmp.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fn/cmp.sml 2007-09-27 10:53:54 UTC (rev 6052)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fn/cmp.sml 2007-09-28 08:33:52 UTC (rev 6053)
@@ -7,8 +7,15 @@
structure Cmp :> CMP = struct
open Cmp
+ infix &
+
fun map b2a = Fn.map (Sq.map b2a, Fn.id)
+ fun op *` (aO, bO) (lA & lB, rA & rB) =
+ case aO (lA, rA)
+ of EQUAL => bO (lB, rB)
+ | other => other
+
local
open Order
in
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/cmp.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/cmp.sig 2007-09-27 10:53:54 UTC (rev 6052)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/cmp.sig 2007-09-28 08:33:52 UTC (rev 6053)
@@ -15,6 +15,12 @@
val map : ('b -> 'a) -> 'a t -> 'b t
(** Changes the domain of an ordering. *)
+ val *` : 'a t * 'b t -> ('a, 'b) Product.t t
+ (**
+ * Given orderings for {'a} and {'b} returns the lexicographic ordering
+ * for their product {('a, 'b) Product.t}.
+ *)
+
val mkRelOps : 'a t -> {< : 'a BinPr.t, <= : 'a BinPr.t,
> : 'a BinPr.t, >= : 'a BinPr.t,
== : 'a BinPr.t, != : 'a BinPr.t}
|
|
From: Vesa K. <ve...@ml...> - 2007-09-27 03:53:55
|
Comments.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/unit-test/unstable/public/unit-test.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/public/unit-test.sig
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/public/unit-test.sig 2007-09-27 10:49:03 UTC (rev 6051)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/public/unit-test.sig 2007-09-27 10:53:54 UTC (rev 6052)
@@ -83,8 +83,13 @@
(** == Collecting Statistics == *)
type table
+ (** Type of tables for collecting data. *)
+
val withFreq : table Effect.t Effect.t
+ (** Prints a table of frequencies after the test has finished succesfully. *)
+
val collect : ('a, 'x) Rep.t -> table -> 'a Effect.t
+ (** Adds a data point to the table. *)
(** == Assertions == *)
|
|
From: Vesa K. <ve...@ml...> - 2007-09-27 03:49:12
|
Redesigned the unit test framework and random testing interface in
particular.
The old random testing interface was largely a copy of QuickCheck. The
main difference is that there is no separate concept of a "property" or
"law". A test, whether randomized or not, is an effectful procedure that
raises an exception upon failure. In general, this reduces or eliminates
differences between randomized and non-randomized tests. A particular
benefit of this approach is that the same assertion procedures can be used
in both randomized and non-randomized tests --- there is no need to
provide two sets of assertion procedures.
Another notable difference compared to the old design is that data
collection, for debugging randomized tests, is no longer an integral part
of the framework. In the original QuickCheck design, data collection is
an integral part of the framework, because all data must be passed through
the property combinators. In SML, we can instead use side-effects to
avoid having to bundle data collection with the framework. This
simplifies the implementation considerably.
The main disadvantage of the new design seems to be a small increase in
verbosity (an extra thunk in some cases and more work to collect
statistics).
There is also no longer need to reveal that random generators are
functions.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml
U mltonlib/trunk/com/ssh/random/unstable/public/random-gen.sig
U 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/example/assoc-test.sml
U mltonlib/trunk/com/ssh/unit-test/unstable/example/qc-test.sml
U mltonlib/trunk/com/ssh/unit-test/unstable/public/unit-test.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml 2007-09-27 08:36:26 UTC (rev 6050)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml 2007-09-27 10:49:03 UTC (rev 6051)
@@ -10,27 +10,27 @@
open Generic UnitTest
- fun chkSeq t =
- (chk o all t)
- (fn x => let
- val p = pickle t x
- in
- that (seq t (x, unpickle t p))
- end)
+ fun thatSeq t args =
+ if seq t (#actual args, #expect args) then () else thatEq t args
+ fun thatPU t x = let
+ val p = pickle t x
+ in
+ thatSeq t {expect = x, actual = unpickle t p}
+ end
+
+ fun testAllSeq t =
+ testAll t (thatPU t)
+
fun testSeq t x =
- test (fn () => let
- val p = pickle t x
- in
- verifyTrue (seq t (x, unpickle t p))
- end)
+ test (fn () => thatPU t x)
fun testTypeMismatch t u =
test (fn () => let
val p = pickle t (some t)
in
- verifyFailsWith
- (fn Pickle.TypeMismatch => true | _ => false)
+ thatRaises'
+ (fn Pickle.TypeMismatch => ())
(fn () => unpickle u p)
end)
in
@@ -38,11 +38,11 @@
unitTests
(title "Generic.Pickle")
- (chkSeq (vector (option (list real))))
- (chkSeq (tuple2 (fixedInt, largeInt)))
- (chkSeq (largeReal &` largeWord))
- (chkSeq (tuple3 (word8, word32, word64)))
- (chkSeq (bool &` char &` int &` real &` string &` word))
+ (testAllSeq (vector (option (list real))))
+ (testAllSeq (tuple2 (fixedInt, largeInt)))
+ (testAllSeq (largeReal &` largeWord))
+ (testAllSeq (tuple3 (word8, word32, word64)))
+ (testAllSeq (bool &` char &` int &` real &` string &` word))
(title "Generic.Pickle.Cyclic")
@@ -52,8 +52,8 @@
(title "Generic.Pickle.TypeMismatch")
(testTypeMismatch int word)
- (testTypeMismatch (list char) (vector char))
- (testTypeMismatch (array real) (option real))
+ (testTypeMismatch (list char) (vector word8))
+ (testTypeMismatch (array real) (option largeReal))
$
end
Modified: mltonlib/trunk/com/ssh/random/unstable/public/random-gen.sig
===================================================================
--- mltonlib/trunk/com/ssh/random/unstable/public/random-gen.sig 2007-09-27 08:36:26 UTC (rev 6050)
+++ mltonlib/trunk/com/ssh/random/unstable/public/random-gen.sig 2007-09-27 10:49:03 UTC (rev 6051)
@@ -12,8 +12,7 @@
signature RANDOM_GEN = sig
structure RNG : RNG
- type 'a dom and 'a cod
- type 'a t = 'a dom -> 'a cod
+ type 'a t
val generate : Int.t -> RNG.t -> 'a t -> 'a
@@ -39,7 +38,7 @@
val inRange : ('b Sq.t -> 'b t) -> ('a, 'b) Iso.t -> 'a Sq.t -> 'a t
- val intInRange : Int.t Sq.t -> Int.t t
+ val intInRange : Int.t Sq.t -> Int.t t
val realInRange : Real.t Sq.t -> Real.t t
val wordInRange : Word.t Sq.t -> Word.t t
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/detail/generic.sml
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/detail/generic.sml 2007-09-27 08:36:26 UTC (rev 6050)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/detail/generic.sml 2007-09-27 10:49:03 UTC (rev 6051)
@@ -4,6 +4,8 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
+(* This whole file is a SML/NJ workaround. *)
+
(*
* We assume here that {Eq} and {Pretty} have already been provided. The
* {Arbitrary} generic is rather specific to randomized testing and has
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/detail/mk-unit-test.fun
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/detail/mk-unit-test.fun 2007-09-27 08:36:26 UTC (rev 6050)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/detail/mk-unit-test.fun 2007-09-27 10:49:03 UTC (rev 6051)
@@ -12,97 +12,49 @@
struct
(* <-- SML/NJ workaround *)
open TopLevel
- infix <^> <\ >| &
+ infix <$> <^> <\ >| &
infixr @` |<
(* SML/NJ workaround --> *)
- structure G=Arg.RandomGen and I=Int
+ open Arg Prettier
- structure Rep = Arg.Open.Rep
+ structure Rep = Open.Rep
+ fun sizeOf t v = Arg.sizeOf t v handle _ => 0
+ fun named t n v = group (nest 2 (str n <$> pretty t v))
+ val strs = str o concat
local
- open Arg
+ open Maybe
+ val I = Int.fromString
+ val cols = Monad.sum [S"-w"@`I, L"--width"@`I, E"COLUMNS"@`I, `70]
in
- val arbitrary = arbitrary
- val bool = bool
- val eq = eq
- val exn = exn
- val pretty = pretty
- val show = show
- fun sizeOf t v = Arg.sizeOf t v handle _ => 0
+ val println = println (get cols)
end
- local
- open Prettier
- in
- val indent = nest 2 o sep
- fun named t n v = str n <^> nest 2 (line <^> pretty t v)
- val comma = comma
- val dot = dot
- val group = group
- val op <^> = op <^>
+ val i2s = Int.toString
- local
- open Maybe
- val I = I.fromString
- val cols = Monad.sum [S"-w"@`I, L"--width"@`I, E"COLUMNS"@`I, `70]
- in
- val println = println (get cols)
- end
-
- val punctuate = punctuate
- val str = str
- end
-
datatype t =
IN of {title : String.t Option.t,
- idx : Int.t,
- size : Int.t UnOp.t,
- passM : Int.t,
- skipM : Int.t}
+ idx : Int.t}
type 'a s = (t, t, Unit.t, t, t, Unit.t, 'a) Fold.s
exception Failure of Prettier.t
- fun failure ? = Exn.throw (Failure ?)
+ fun failure d = raise Failure d
val defaultCfg =
IN {title = NONE,
- idx = 1,
- size = fn n => n div 2 + 3,
- passM = 100,
- skipM = 200}
+ idx = 1}
- local
- val ~ = (fn {title=a, idx=b, size=c, passM=d, skipM=e} => a&b&c&d&e,
- fn a&b&c&d&e => {title=a, idx=b, size=c, passM=d, skipM=e})
- open FRU
- in
- val U = U
- fun updCfg ? = fruData (fn IN ? => ?, IN) A5 $ ~ ~ ?
- end
-
val succeeded = ref 0
val failed = ref 0
- val i2s = I.toString
-
fun inc r = r := !r + 1
- fun runTest safeTest =
- Fold.mapSt (fn cfg as IN {idx, ...} =>
- (inc (if safeTest cfg then succeeded else failed)
- ; updCfg (U#idx (idx + 1)) $ cfg))
+ val printlnStrs = println o group o strs
- fun header (IN {title, idx, ...}) =
- case title
- of NONE => "An untitled test"
- | SOME t => concat [i2s idx, ". ", t, " test"]
-
(* We assume here that we're the first call to atExit so that it
* is (relatively) safe to call terminate in our atExit effect.
*)
-
- val printlnStrs = println o group o str o concat
val () =
OS.Process.atExit
(fn () =>
@@ -114,185 +66,150 @@
i2s (!failed), " failed."]
; OS.Process.terminate OS.Process.failure))
- (* TEST SPECIFICATION INTERFACE *)
+ fun namedExn label e =
+ named exn label e <^> dot <$>
+ (case Exn.history e
+ of [] => str "No exception history available"
+ | hs => nest 2 (sep (str "Exception history:" ::
+ punctuate comma (map str hs))))
fun unitTests ? = Fold.wrap (defaultCfg, ignore) ?
- fun title title = Fold.mapSt (updCfg (U #idx 1) (U #title (SOME title)) $)
+ fun title title = Fold.mapSt (const (IN {title = SOME title, idx = 1}))
- (* AD HOC TESTING HELPERS *)
-
- fun verifyEq t {actual, expect} =
+ fun thatEq t {actual, expect} =
if eq t (actual, expect) then ()
- else failure (indent [str "Equality test failed:",
- named t "expected" expect <^> comma,
- named t "but got" actual])
+ else failure (nest 2 (sep [str "equality test failed:",
+ named t "expected" expect <^> comma,
+ named t "but got" actual]))
- fun verifyTrue b = verifyEq bool {expect = true, actual = b}
- fun verifyFalse b = verifyEq bool {expect = false, actual = b}
+ fun that b = thatEq bool {expect = true, actual = b}
+ fun thatNot b = thatEq bool {expect = false, actual = b}
- fun verifyFailsWith ePr th =
+ fun thatRaises exnPr th =
try (th,
- fn _ => failure (str "Test didn't raise an exception as expected"),
- fn e => if ePr e then ()
- else failure o group |<
- named exn "Test raised an unexpected exception" e)
+ fn _ => failure (str "didn't get an exception as expected"),
+ fn e => if exnPr e then ()
+ else failure (namedExn "got an unexpected exception" e))
+ fun thatRaises' exnEf =
+ thatRaises (fn e => (exnEf e : Unit.t ; true) handle Match => false)
+ fun thatFails ? = thatRaises (const true) ?
- fun verifyFails ? = verifyFailsWith (const true) ?
- fun verifyRaises e = verifyFailsWith (e <\ eq exn)
-
(* TEST REGISTRATION INTERFACE *)
- fun history e =
- case Exn.history e
- of [] => str "No exception history available"
- | hs => indent (map str ("Exception history:"::hs))
-
fun test body =
- runTest
- (fn cfg =>
- try (body,
- fn _ =>
- (printlnStrs [header cfg, " succeeded."]
- ; true),
- fn e =>
- ((println o indent)
- [str (header cfg ^ " failed."),
- case e
- of Failure doc => doc <^> dot
- | _ => indent [str "Unhandled exception",
- str (Exn.message e) <^> dot],
- history e <^> dot]
- ; false)))
+ Fold.mapSt
+ (fn IN {title, idx} =>
+ (printlnStrs (case title
+ of NONE => ["An untitled test"]
+ | SOME t => [i2s idx, ". ", t, " test"])
+ ; try (body,
+ fn () =>
+ inc succeeded,
+ fn e =>
+ (inc failed
+ ; println
+ (indent 2
+ (txt "FAILED:" <$>
+ indent 2
+ (case e
+ of Failure d => d
+ | _ => namedExn "with exception" e) <^> dot))))
+ ; IN {title = title, idx = idx + 1}))
- fun testEq t th = test (verifyEq t o th)
+ fun testEq t th = test (thatEq t o th)
- fun testTrue th = test (verifyTrue o th)
- fun testFalse th = test (verifyFalse o th)
+ fun testRaises' exnEf th = test (fn () => thatRaises' exnEf th)
+ fun testRaises exnPr th = test (fn () => thatRaises exnPr th)
+ fun testFails th = test (fn () => thatFails th)
- fun testFailsWith ep th = test (fn () => verifyFailsWith ep th)
- fun testFails th = test (fn () => verifyFails th)
- fun testRaises e th = test (fn () => verifyRaises e th)
-
- (* RANDOM TESTING INTERFACE *)
-
datatype result =
- BUG of Int.t * Prettier.t List.t
- | OK of String.t List.t
+ BUG of Int.t * Prettier.t
+ | OK
| SKIP
- type law = result G.t
-
local
- fun mk field value = Fold.mapSt (updCfg (U field value) $)
+ open RandomGen.RNG
+ val rng =
+ ref (make (Seed.fromWord let
+ open Maybe
+ val W = Word.fromString
+ in
+ getOpt (get (Monad.sum [S"-s"@`W, L"--seed"@`W,
+ mk RandomDev.seed ()]),
+ 0w0)
+ end))
in
- fun sizeFn ? = mk #size ?
- fun maxPass ? = mk #passM ?
- fun maxSkip ? = mk #skipM ?
+ fun nextRNG () = !rng before Ref.modify next rng
end
- val rng = ref (G.RNG.make (G.RNG.Seed.fromWord let
- open Maybe
- val W = Word.fromString
- in
- getOpt (get (Monad.sum [S"-s"@`W, L"--seed"@`W,
- mk RandomDev.seed ()]),
- 0w0)
- end))
+ exception Skip
- fun sort ? = SortedList.stableSort #n ?
+ fun allParam {size, maxPass, maxSkip} t ef = let
+ fun genTest passN = let
+ val v = RandomGen.generate (size passN) (nextRNG ()) (arbitrary t)
+ in
+ (ef v : Unit.t ; OK)
+ handle Skip => SKIP
+ | Failure d => BUG (sizeOf t v, named t "with" v <$> d)
+ | e => BUG (sizeOf t v,
+ named t "with" v <$> namedExn "raised" e)
+ end
- fun table n =
- punctuate comma o
- map (fn (n, m) => str (concat [i2s n, "% ", m])) o
- sort (I.compare o Pair.swap o Pair.map (Sq.mk Pair.fst)) o
- map (Pair.map (fn l => Int.quot (100 * length l, n), hd) o Sq.mk) o
- List.divideByEq op =
+ fun minimize (genSz, origSz, minSz, minMsg) =
+ if genSz < 0
+ then failure minMsg
+ else case genTest genSz
+ of BUG (sz, msg) =>
+ if sz < minSz
+ then minimize (genSz-1, origSz, sz, msg)
+ else minimize (genSz-1, origSz, minSz, minMsg)
+ | _ => minimize (genSz-1, origSz, minSz, minMsg)
- fun chk prop =
- runTest
- (fn cfg as IN {size, passM, skipM, ...} => let
- fun done (msg, passN, tags) =
- ((println o indent)
- ((str o concat)
- [header cfg, ":\n", msg, " ", i2s passN,
- " random cases passed."]::
- (if null tags then
- []
- else
- [indent (str "Statistics:" ::
- table passN tags) <^> dot]))
- ; true)
+ fun find (passN, skipN) =
+ if maxPass <= passN then
+ ()
+ else if maxSkip <= skipN then
+ println (indent 2 (strs ["Arguments exhausted after ", i2s passN,
+ " tests."]))
+ else
+ case genTest (size passN)
+ of SKIP =>
+ find (passN, skipN + 1)
+ | OK =>
+ find (passN + 1, skipN)
+ | BUG (sz, ms) =>
+ minimize (size passN, sz, sz, ms)
+ in
+ find (0, 0)
+ end
- fun gen passN =
- G.generate (size passN)
- (!rng before Ref.modify G.RNG.next rng)
- prop
+ fun all t =
+ allParam {size = fn n => n div 2 + 3,
+ maxPass = 100,
+ maxSkip = 100} t
- fun minimize (genSz, origSz, minSz, minMsgs) =
- if genSz < 0
- then (println |< indent
- [str (header cfg ^ " failed."),
- indent (str "Falsifiable:"::minMsgs) <^> dot,
- (str o concat)
- (if minSz < origSz
- then ["Reduced counterexample from size ",
- Int.toString origSz, " to size ",
- Int.toString minSz, "."]
- else ["Couldn't find a counterexample smaller\
- \ than size ", Int.toString origSz, "."])]
- ; false)
- else
- case gen genSz
- of BUG (sz, msgs) =>
- if sz < minSz
- then minimize (genSz-1, origSz, sz, msgs)
- else minimize (genSz-1, origSz, minSz, minMsgs)
- | _ =>
- minimize (genSz-1, origSz, minSz, minMsgs)
+ fun testAll t ef = test (fn () => all t ef)
- fun find (passN, skipN, allTags) =
- if passM <= passN then
- done ("OK,", passN, allTags)
- else if skipM <= skipN then
- done ("Arguments exhausted after", passN, allTags)
- else
- case gen (size passN)
- of SKIP =>
- find (passN, skipN + 1, allTags)
- | OK tags =>
- find (passN + 1, skipN, List.revAppend (tags, allTags))
- | BUG (sz, msgs) =>
- minimize (size passN, sz, sz, msgs)
- in
- find (0, 0, [])
- end)
+ fun skip () = raise Skip
- fun all t toProp =
- G.>>= (arbitrary t,
- fn v => fn ? =>
- (G.>>= (toProp v,
- fn BUG (sz, msgs) =>
- G.return (BUG (sz + sizeOf t v,
- named t "with" v :: msgs))
- | p =>
- G.return p) ?
- handle e =>
- G.return (BUG (sizeOf t v,
- [named t "with" v,
- named exn "raised" e <^> dot,
- history e])) ?))
+ fun table t = let
+ val n = length t
+ in
+ punctuate comma o
+ map (fn (n, m) => str (concat [i2s n, "% ", m])) o
+ List.sort (Int.compare o Pair.swap o Pair.map (Sq.mk Pair.fst)) o
+ map (Pair.map (fn l => Int.quot (100 * length l, n), hd) o Sq.mk) o
+ List.divideByEq op = |< List.map (render NONE) t
+ end
- fun that b = G.return (if b then OK [] else BUG (0, []))
- val skip = G.return SKIP
-
- fun classify tOpt =
- G.Monad.map (fn r =>
- case tOpt & r
- of SOME t & OK ts => OK (t::ts)
- | _ => r)
- fun trivial b = classify (if b then SOME "trivial" else NONE)
-
- fun collect t v =
- G.Monad.map (fn OK ts => OK (show t v::ts)
- | res => res)
+ type table = Prettier.t List.t Ref.t
+ fun withFreq tblEf = let
+ val tbl = ref []
+ in
+ tblEf tbl : Unit.t
+ ; println (indent 2 (nest 2 (sep (str "Statistics:" :: table (!tbl)))) <^>
+ dot)
+ end
+ fun collect t tbl x =
+ List.push tbl (pretty t x)
end
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/example/assoc-test.sml
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/example/assoc-test.sml 2007-09-27 08:36:26 UTC (rev 6050)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/example/assoc-test.sml 2007-09-27 10:49:03 UTC (rev 6051)
@@ -12,18 +12,19 @@
val () = let
open Generic UnitTest
- fun assoc op + t =
+ fun thatAssoc op + t =
all (t &` t &` t)
(fn x & y & z =>
- that (eq t ((x + y) + z, x + (y + z))))
+ thatEq t {actual = (x + y) + z,
+ expect = x + (y + z)})
in
unitTests
(title "Assoc")
- (chk (assoc op + word))
+ (test (fn () => thatAssoc op + word))
(* This law holds. *)
- (chk (assoc op + real))
+ (test (fn () => thatAssoc op + real))
(* This law does not hold. *)
$
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/example/qc-test.sml
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/example/qc-test.sml 2007-09-27 08:36:26 UTC (rev 6050)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/example/qc-test.sml 2007-09-27 10:49:03 UTC (rev 6051)
@@ -37,29 +37,29 @@
unitTests
(title "Reverse")
- (chk (all int
- (fn x =>
- that (rev [x] = [x]))))
+ (testAll int
+ (fn x =>
+ that (rev [x] = [x])))
(* Read the above as:
*
- * "check for all integers x that the reverse of the singleton
+ * "test for all integers x that the reverse of the singleton
* list x equals the singleton list x"
*
- * (Of course, in reality, the property is only checked for a small
- * finite number of random integers at a time.)
+ * Of course, in reality, the property is only checked for a small
+ * finite number of random integers at a time.
*
- * In contrast to QuickCheck/Haskell, one must explicitly lift
- * boolean values to properties using {that}.
+ * In contrast to QuickCheck, properties are explicitly checked
+ * using {that} and other assertion procedures.
*)
- (chk (all (sq (list int))
- (fn (xs, ys) =>
- that (rev (xs @ ys) = rev ys @ rev xs))))
+ (testAll (sq (list int))
+ (fn (xs, ys) =>
+ that (rev (xs @ ys) = rev ys @ rev xs)))
- (chk (all (list int)
- (fn xs =>
- that (rev (rev xs) = xs))))
+ (testAll (list int)
+ (fn xs =>
+ that (rev (rev xs) = xs)))
(title "Functions")
@@ -68,10 +68,10 @@
fun (f === g) x = that (f x = g x)
(* An approximation of extensional equality for functions. *)
in
- chk (all (case unOp int of t => t &` t &` t)
- (fn f & g & h =>
- all int
- (f o (g o h) === (f o g) o h)))
+ testAll (case unOp int of t => t &` t &` t)
+ (fn f & g & h =>
+ all int
+ (f o (g o h) === (f o g) o h))
(* Note that one can (of course) also write local auxiliary
* definitions inside let -expressions.
@@ -80,46 +80,53 @@
(title "Conditional laws")
- (chk (all (sq int)
- (fn (x, y) =>
- if x <= y
- then that (Int.max (x, y) = y)
- else skip)))
+ (testAll (sq int)
+ (fn (x, y) =>
+ if x <= y
+ then that (Int.max (x, y) = y)
+ else skip ()))
(* Read the above as:
*
- * "check for all integer pairs (x, y) that
+ * "test for all integer pairs (x, y) that
* if x <= y then max (x, y) = y"
*
- * In contrast to QuickCheck/Haskell, conditional properties are
- * specified using conditionals and {skip} rather than using an
- * implication operator.
+ * In contrast to QuickCheck, conditional properties are specified
+ * using conditionals and {skip ()} rather than using an implication
+ * operator.
*)
(title "Monitoring test data")
- (chk (all (int &` list int)
- (fn x & xs =>
- if isSorted xs
- then (trivial (null xs))
- (that (isSorted (insert x xs)))
- else skip)))
+ (test (fn () =>
+ withFreq (fn tbl =>
+ all (int &` list int)
+ (fn x & xs =>
+ if isSorted xs
+ then (collect int tbl (length xs)
+ ; that (isSorted (insert x xs)))
+ else skip ()))))
- (chk (all (int &` list int)
- (fn x & xs =>
- if isSorted xs
- then (collect int (length xs))
- (that (isSorted (insert x xs)))
- else skip)))
+ (* Above we collect the generated sorted lists and print a table of
+ * the frequencies of their lengths using {withFreq} and {collect}.
+ *
+ * In contrast to QuickCheck, data collection is not bolted into the
+ * test framework.
+ *)
- (chk (all (int &` sortedList)
- (fn x & xs =>
- that o isSorted |< insert x xs)))
+ (test (fn () =>
+ withFreq (fn tbl =>
+ all (int &` sortedList)
+ (fn x & xs =>
+ (collect int tbl (length xs)
+ ; that (isSorted (insert x xs)))))))
(* Above we use a custom test data generator for sorted (or ordered)
- * lists. In contrast to QuickCheck/Haskell, the custom data
- * generator needs to be injected into a type-index (recall the use
- * of {withGen} in the implementation of {sortedList} above).
+ * lists.
+ *
+ * In contrast to QuickCheck, the custom data generator is
+ * explicitly injected into a type representation. Recall the use
+ * of {withGen} in the implementation of {sortedList} above.
*)
$
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/public/unit-test.sig
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/public/unit-test.sig 2007-09-27 08:36:26 UTC (rev 6050)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/public/unit-test.sig 2007-09-27 10:49:03 UTC (rev 6051)
@@ -25,140 +25,92 @@
val title : String.t -> 'a s
(** {title string} specifies the title for subsequent tests. *)
- (** === Test Registration Interface === *)
+ (** === Test Registration === *)
val test : Unit.t Effect.t -> 'a s
(**
- * Registers an ad hoc test. An ad hoc test should indicate failure by
- * raising an exception.
+ * Registers a test. A test is just an arbitrary unit effect that
+ * should indicate failure by raising an exception.
*)
val testEq : ('a, 'x) Rep.t -> {actual : 'a, expect : 'a} Thunk.t -> 'b s
(** Tests that the expected and actual values are equal. *)
- val testTrue : Bool.t Thunk.t -> 'a s
- (** Tests that the thunk evaluates to {true}. *)
-
- val testFalse : Bool.t Thunk.t -> 'a s
- (** Tests that the thunk evaluates to {false}. *)
-
- val testFailsWith : Exn.t UnPr.t -> 'a Thunk.t -> 'b s
+ val testRaises' : Exn.t Effect.t -> 'a Thunk.t -> 'b s
+ val testRaises : Exn.t UnPr.t -> 'a Thunk.t -> 'b s
(** Tests that the thunk raises an exception satisfying the predicate. *)
val testFails : 'a Thunk.t -> 'b s
(** Tests that the thunk raises an exception. *)
- val testRaises : Exn.t -> 'a Thunk.t -> 'b s
- (**
- * Tests that the thunk raises an exception equal to the given one.
- * The exception constructor must be registered with {regExn}.
- *)
+ (** == Random Testing == *)
- (** == Random Testing Interface == *)
+ val testAll : ('a, 'x) Rep.t -> 'a Effect.t -> 'b s
+ (** {testAll ty body} is equivalent to {test (fn () => all ty body)}. *)
- val sizeFn : Int.t UnOp.t -> 'a s
+ val all : ('a, 'x) Rep.t -> 'a Effect.t Effect.t
(**
- * Sets the function to determine the "size" of generated random test
- * data. The argument to the function is the number of tests passed.
- * The default function is {fn n => n div 2 + 3}.
- *)
-
- val maxPass : Int.t -> 'a s
- (**
- * Sets the maximum number of passed random test cases to try per test.
- * The default is 100.
- *)
-
- val maxSkip : Int.t -> 'a s
- (**
- * Sets the maximum number of skipped random test cases to accept per
- * test. The default is 200. If a lot of tests are being skipped, you
- * should implement a better test data generator or a more
- * comprehensive law.
- *)
-
- type law
- (** The type of testable laws or properties. *)
-
- val chk : law -> 'b s
- (**
- * Tries to find counter examples to a given law by testing the law
- * with randomly generated cases.
- *)
-
- val all : ('a, 'x) Rep.t -> ('a -> law) -> law
- (**
- * Specifies that a law must hold for all values of type {'a}. For
- * example,
+ * Procedurally, tries to fault the given test effect by calling it
+ * with randomly generated data.
*
+ * Declaratively, specifies that a law must hold for all values of type
+ * {'a}. For example,
+ *
*> all int (fn x => that (x = x))
*
* specifies that all integers must be equal to themselves.
*)
- val that : Bool.t -> law
+ val skip : 'a Thunk.t
(**
- * Specifies a primitive boolean law. For example,
+ * Calling {skip ()} specifies that the premises of a conditional law
+ * aren't satisfied so the specific test case of the law should be
+ * ignored. For example,
*
- *> that (1 <= 2)
- *
- * specifies that {1} is less than or equal to {2}.
- *)
-
- val skip : law
- (**
- * Specifies that the premises of a conditional law aren't satisfied so
- * the specific test case of the law should be ignored. For example,
- *
*> all (sq int)
*> (fn (x, y) =>
*> if x <= y
*> then that (Int.max (x, y) = y)
- *> else skip)
+ *> else skip ())
*
* specifies that if {x <= y} then {Int.max (x, y) = y}.
+ *
+ * Skipping tests is inefficient. If a lot of tests are being skipped,
+ * you should implement a better test data generator or a more
+ * comprehensive law.
*)
- val classify : String.t Option.t -> law UnOp.t
- (**
- * Classifies cases of a law. The distribution of classified cases
- * will be logged.
- *)
+ (** == Collecting Statistics == *)
- val trivial : Bool.t -> law UnOp.t
- (** Convenience function to classify cases of a law as "trivial". *)
+ type table
+ val withFreq : table Effect.t Effect.t
+ val collect : ('a, 'x) Rep.t -> table -> 'a Effect.t
- val collect : ('a, 'x) Rep.t -> 'a -> law UnOp.t
+ (** == Assertions == *)
+
+ exception Failure of Prettier.t
(**
- * Classifies test cases by value of type {'a}. The distribution as
- * well as the (pretty printed) values will be logged.
+ * Exception for reporting prettier errors from tests. Unlike other
+ * exceptions, the unit test framework just prints the document
+ * contained by a {Failure} exception with a dot at the end.
*)
- (** == Ad Hoc Testing Helpers == *)
-
- exception Failure of Prettier.t
- (** Exception for reporting prettier errors. *)
-
- val verifyEq : ('a, 'x) Rep.t -> {actual : 'a, expect : 'a} Effect.t
- (** Verifies that the expected and actual values are equal. *)
-
- val verifyTrue : Bool.t Effect.t
+ val that : Bool.t Effect.t
(** Verifies that the given value is {true}. *)
- val verifyFalse : Bool.t Effect.t
+ val thatNot : Bool.t Effect.t
(** Verifies that the given value is {false}. *)
- val verifyFailsWith : Exn.t UnPr.t -> 'a Thunk.t Effect.t
+ val thatEq : ('a, 'x) Rep.t -> {actual : 'a, expect : 'a} Effect.t
+ (** Verifies that the expected and actual values are equal. *)
+
+ val thatRaises' : Exn.t Effect.t -> 'a Thunk.t Effect.t
+ val thatRaises : Exn.t UnPr.t -> 'a Thunk.t Effect.t
(**
* Verifies that the thunk fails with an exception satisfying the
* predicate.
*)
- val verifyFails : 'a Thunk.t Effect.t
+ val thatFails : 'a Thunk.t Effect.t
(** Verifies that the given thunk fails with an exception. *)
-
- val verifyRaises : Exn.t -> 'a Thunk.t Effect.t
- (**
- * Verifies that the thunk raises an exception equal to the given one.
- *)
end
|
|
From: Vesa K. <ve...@ml...> - 2007-09-27 01:36:28
|
To reduce recompilation with SML/NJ.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/Test-smlnj.sh
U mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml
A mltonlib/trunk/com/ssh/generic/unstable/test/generic.sml
U mltonlib/trunk/com/ssh/generic/unstable/test/utils.fun
U mltonlib/trunk/com/ssh/generic/unstable/test.cm
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/Test-smlnj.sh
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/Test-smlnj.sh 2007-09-23 13:32:02 UTC (rev 6049)
+++ mltonlib/trunk/com/ssh/generic/unstable/Test-smlnj.sh 2007-09-27 08:36:26 UTC (rev 6050)
@@ -13,14 +13,5 @@
time \
echo '' | \
sml -m test.cm \
- $eb/public/export/{open-top-level.sml,infixes.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')
+ $eb/public/export/{open-top-level.sml,infixes.sml} \
+ $(find test/ -name '*.sml' -a -not -name 'generic.sml')
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml 2007-09-23 13:32:02 UTC (rev 6049)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml 2007-09-27 08:36:26 UTC (rev 6050)
@@ -4,6 +4,8 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
+(* This whole file is a SML/NJ workaround. *)
+
signature Generic = sig structure Open : OPEN_CASES end
structure Generic : Generic = struct
structure Open = RootGeneric
Added: mltonlib/trunk/com/ssh/generic/unstable/test/generic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/generic.sml 2007-09-23 13:32:02 UTC (rev 6049)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/generic.sml 2007-09-27 08:36:26 UTC (rev 6050)
@@ -0,0 +1,62 @@
+(* 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.
+ *)
+
+(* This whole file is a SML/NJ workaround. *)
+
+signature Generic = sig include Generic DATA_REC_INFO end
+structure Generic : Generic = struct
+ structure Open = WithDataRecInfo (Generic)
+ open Generic Open
+end
+
+signature Generic = sig include Generic SOME end
+structure Generic : Generic = struct
+ structure Open = WithSome
+ (open Generic
+ structure TypeInfoRep = Open.Rep)
+ open Generic Open
+end
+
+signature Generic = sig include Generic PICKLE end
+structure Generic : Generic = struct
+ structure Open = WithPickle
+ (open Generic
+ structure DataRecInfoRep = Open.Rep and EqRep = Open.Rep
+ and HashRep = Open.Rep and SomeRep = Open.Rep
+ and TypeHashRep = Open.Rep and TypeInfoRep = Open.Rep)
+ open Generic Open
+end
+
+signature Generic = sig include Generic SEQ end
+structure Generic : Generic = struct
+ structure Open = WithSeq
+ (open Generic
+ structure HashRep = Open.Rep)
+ open Generic Open
+end
+
+signature Generic = sig include Generic REDUCE end
+structure Generic : Generic = struct
+ structure Open = WithReduce (Generic)
+ open Generic Open
+end
+
+signature Generic = sig include Generic TRANSFORM end
+structure Generic : Generic = struct
+ structure Open = WithTransform
+ (open Generic
+ structure HashRep = Open.Rep)
+ open Generic Open
+end
+
+structure Generic = struct
+ structure Rep = ClosePrettyWithExtra
+ (open Generic
+ structure PrettyRep = Open.Rep)
+ open Generic Rep
+end
+
+local structure ? = RegBasisExns (Generic) open ? in end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/test/generic.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/utils.fun
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/utils.fun 2007-09-23 13:32:02 UTC (rev 6049)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/utils.fun 2007-09-27 08:36:26 UTC (rev 6050)
@@ -62,6 +62,11 @@
datatype 'a t = LF | BR of 'a t * 'a * 'a t
val t : 'a Rep.t -> 'a t Rep.t
end = struct
+ (* <--- SML/NJ workaround *)
+ open TopLevel
+ infix +`
+ (* SML/NJ workaround --> *)
+
datatype 'a t = LF | BR of 'a t * 'a * 'a t
local
val cLF = C "LF"
@@ -98,6 +103,11 @@
val t' : t Rep.t UnOp.t
val t : t Rep.t
end = struct
+ (* <--- SML/NJ workaround *)
+ open TopLevel
+ infix +`
+ (* SML/NJ workaround --> *)
+
structure Id = Id
datatype 't f =
Modified: mltonlib/trunk/com/ssh/generic/unstable/test.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test.cm 2007-09-23 13:32:02 UTC (rev 6049)
+++ mltonlib/trunk/com/ssh/generic/unstable/test.cm 2007-09-27 08:36:26 UTC (rev 6050)
@@ -9,8 +9,11 @@
library(../../prettier/unstable/lib.cm)
library(../../unit-test/unstable/lib-with-default.cm)
library(lib.cm)
+ source(-)
is
../../extended-basis/unstable/basis.cm
../../prettier/unstable/lib.cm
../../unit-test/unstable/lib-with-default.cm
lib.cm
+ test/generic.sml
+ test/utils.fun
|
|
From: Vesa K. <ve...@ml...> - 2007-09-23 06:32:03
|
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.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/unit-test/unstable/example.cm
U mltonlib/trunk/com/ssh/unit-test/unstable/example.mlb
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/example.cm
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/example.cm 2007-09-23 13:19:11 UTC (rev 6048)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/example.cm 2007-09-23 13:32:02 UTC (rev 6049)
@@ -6,13 +6,13 @@
group
library(../../extended-basis/unstable/basis.cm)
- library(../../generic/unstable/lib-with-default.cm)
+ library(../../generic/unstable/lib.cm)
library(../../random/unstable/lib.cm)
library(detail/sorted-list.cm)
library(lib-with-default.cm)
is
../../extended-basis/unstable/basis.cm
- ../../generic/unstable/lib-with-default.cm
+ ../../generic/unstable/lib.cm
../../random/unstable/lib.cm
detail/sorted-list.cm
lib-with-default.cm
Modified: mltonlib/trunk/com/ssh/unit-test/unstable/example.mlb
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/example.mlb 2007-09-23 13:19:11 UTC (rev 6048)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/example.mlb 2007-09-23 13:32:02 UTC (rev 6049)
@@ -8,7 +8,7 @@
lib-with-default.mlb (* This should preferably be the first *)
$(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
- $(MLTON_LIB)/com/ssh/generic/unstable/lib-with-default.mlb
+ $(MLTON_LIB)/com/ssh/generic/unstable/lib.mlb
$(MLTON_LIB)/com/ssh/random/unstable/lib.mlb
detail/sorted-list.sml
|
|
From: Vesa K. <ve...@ml...> - 2007-09-23 06:19:26
|
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.... [truncated message content] |
|
From: Matthew F. <fl...@ml...> - 2007-09-22 09:33:07
|
When required to conjure up a bogus type, do so at the appropriate
arity.
This avoids both cascading type-errors and an Error.bug abort of
elaboration.
The following program demonstrates the cascading type-error;
uncommenting the 'where type' constraint demonstrates the Error.bug.
signature Z = sig type ('a, 'b) zzz end
functor cpZ (Arg : Z) : Z (* where type ('a, 'b) zzz = ('a, 'b) Arg.zzz *) =
struct
open Arg
end
structure Z1 = struct datatype ('a, 'b) zzz = Z end
structure Z2 = cpZ(structure Arg = Z1)
Previously, this would yield:
[fluet@shadow temp]$ mlton z.sml
Error: z.sml 7.20.
Type zzz in argument signature but not in structure.
Error: z.sml 2.25.
Type zzz has arity n-ary in structure but arity 2 in signature.
compilation aborted: parseAndElaborate reported errors
[fluet@shadow temp]$ mlton z.sml
Error: z.sml 7.20.
Type zzz in argument signature but not in structure.
ElaborateEnv.transparentCut.handleType: Nary tycon
Now, this yields:
[fluet@shadow temp]$ ../mlton.svn.trunk/build/bin/mlton z.sml
Error: z.sml 7.20.
Type zzz in argument signature but not in structure.
compilation aborted: parseAndElaborate reported errors
[fluet@shadow temp]$ ../mlton.svn.trunk/build/bin/mlton z.sml
Error: z.sml 7.20.
Type zzz in argument signature but not in structure.
compilation aborted: parseAndElaborate reported errors
----------------------------------------------------------------------
U mlton/trunk/mlton/elaborate/elaborate-env.fun
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/elaborate/elaborate-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-env.fun 2007-09-20 22:16:47 UTC (rev 6046)
+++ mlton/trunk/mlton/elaborate/elaborate-env.fun 2007-09-22 16:33:06 UTC (rev 6047)
@@ -404,11 +404,6 @@
fun tycon (c, kind) = T {kind = kind,
node = Tycon c}
-
- fun ignoreNone (s: t option): t =
- case s of
- NONE => tycon (Tycon.tuple, Kind.Nary)
- | SOME s => s
end
local
@@ -575,6 +570,11 @@
val toEnv = typeStrToEnv
+ fun toEnvNoNone s =
+ case toEnv s of
+ NONE => EtypeStr.tycon (EtypeStr.Tycon.tuple, TypeStr.kind s)
+ | SOME s => s
+
fun fromEnv (s: EtypeStr.t) =
let
val kind = EtypeStr.kind s
@@ -588,10 +588,6 @@
| EtypeStr.Tycon c =>
tycon (Tycon.fromEnv (c, kind), kind)
end
-
- val fromEnv =
- Trace.trace ("ElaborateEnv.Interface.TypeStr.fromEnv", EtypeStr.layout, layout)
- fromEnv
end
end
@@ -1519,8 +1515,7 @@
val types =
Array.map (types, fn (name, s) =>
{domain = name,
- range = (TypeStr.ignoreNone
- (Interface.TypeStr.toEnv s)),
+ range = Interface.TypeStr.toEnvNoNone s,
time = time,
uses = Uses.new ()})
val vals =
@@ -2849,7 +2844,7 @@
val types =
map (structTypes, sigTypes, strids,
"type", Ast.Tycon.equals, Ast.Tycon.layout,
- TypeStr.ignoreNone o Interface.TypeStr.toEnv,
+ Interface.TypeStr.toEnvNoNone,
fn (name, s, s') => handleType (s, s', strids, name))
val vals =
map
|
|
From: Matthew F. <fl...@ml...> - 2007-09-20 15:16:49
|
Fixed bug in elaboration of structures with signature constraints
----------------------------------------------------------------------
U mlton/trunk/doc/changelog
U mlton/trunk/mlton/elaborate/elaborate-env.fun
----------------------------------------------------------------------
Modified: mlton/trunk/doc/changelog
===================================================================
--- mlton/trunk/doc/changelog 2007-09-20 22:12:15 UTC (rev 6045)
+++ mlton/trunk/doc/changelog 2007-09-20 22:16:47 UTC (rev 6046)
@@ -1,5 +1,11 @@
Here are the changes from version 20070826 to version YYYYMMDD.
+* 2007-09-20
+ - Fixed bug in elaboration of structures with signature
+ constraints. This would later cause the compiler to raise the
+ TypeError exception. Thanks to Vesa Karvonen for the bug report.
+
+
* 2007-09-11
- Fixed bug in interaction of _export-ed functions and signal
handlers. Thanks to Sean McLaughlin for the bug report.
Modified: mlton/trunk/mlton/elaborate/elaborate-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-env.fun 2007-09-20 22:12:15 UTC (rev 6045)
+++ mlton/trunk/mlton/elaborate/elaborate-env.fun 2007-09-20 22:16:47 UTC (rev 6046)
@@ -681,7 +681,7 @@
val newTycon: string * Kind.t * AdmitsEquality.t * Region.t -> Tycon.t =
fn (s, k, a, r) =>
let
- val c = Tycon.fromString s
+ val c = Tycon.newString s
val _ = TypeEnv.initAdmitsEquality (c, a)
val _ = TypeEnv.tyconRegion c := SOME r
val _ = List.push (allTycons, c)
@@ -1527,8 +1527,8 @@
Array.map
(vals, fn (name, (status, scheme)) =>
let
- val con = CoreML.Con.fromString o Ast.Vid.toString
- val var = CoreML.Var.fromString o Ast.Vid.toString
+ val con = CoreML.Con.newString o Ast.Vid.toString
+ val var = CoreML.Var.newString o Ast.Vid.toString
val vid =
case status of
Status.Con => Vid.Con (con name)
@@ -1936,8 +1936,8 @@
make (fn z => PeekResult.map (peekLongtycon z, SOME),
fn () => NONE,
"type",
- Longtycon.region,
- Longtycon.layout)
+ Ast.Longtycon.region,
+ Ast.Longtycon.layout)
val lookupLongvid =
make (peekLongvid,
fn () => (Vid.bogus, NONE),
@@ -2398,58 +2398,66 @@
val _ = instantiate (S, fn (c, s) =>
TypeEnv.setOpaqueTyconExpansion
(c, fn ts => TypeStr.apply (s, ts)))
- val {destroy,
- get = replacements: (Structure.t
- -> {formal: Structure.t,
- new: Structure.t} list ref), ...} =
- Property.destGet (Structure.plist,
- Property.initFun (fn _ => ref []))
- fun loop (S, S'): Structure.t =
+ val {destroy,
+ get : Structure.t -> {formal: Structure.t, new: Structure.t} list ref,
+ ...} =
+ Property.destGet (Structure.plist, Property.initFun (fn _ => ref []))
+(*
+ fun replace (S, S'): Structure.t =
+ reallyReplace (S, S')
+*)
+ fun replace (S, S'): Structure.t =
let
- val rs = replacements S
+ val seen = get S
in
- case List.peek (!rs, fn {formal, ...} =>
+ case List.peek (!seen, fn {formal, ...} =>
Structure.eq (S', formal)) of
- NONE =>
- let
- val Structure.T {strs, types, vals, ...} = S
- val Structure.T {strs = strs',
- types = types',
- vals = vals', ...} = S'
- val strs = Info.map2 (strs, strs', loop)
- val types =
- Info.map2
- (types, types', fn (s, s') =>
- let
- datatype z = datatype TypeStr.node
- in
- case TypeStr.node s' of
- Datatype {cons = cs', tycon} =>
- (case TypeStr.node s of
- Datatype {cons = cs, ...} =>
- TypeStr.data
- (tycon, TypeStr.kind s',
- fixCons (cs, cs'))
- | _ => s')
- | Scheme _ => s'
- | Tycon _ => s'
- end)
- val vals =
- Info.map2 (vals, vals', fn ((v, _), (_, s)) =>
- (v, s))
- val new =
- Structure.T {interface = Structure.interface S',
- plist = PropertyList.new (),
- strs = strs,
- types = types,
- vals = vals}
- val _ = List.push (rs, {formal = S', new = new})
- in
- new
- end
+ NONE => let
+ val new = reallyReplace (S, S')
+ val _ = List.push (seen, {formal = S', new = new})
+ in
+ new
+ end
| SOME {new, ...} => new
end
- val S'' = loop (S, S')
+ and reallyReplace (S, S'): Structure.t =
+ let
+ val Structure.T {strs,
+ types,
+ vals, ...} = S
+ val Structure.T {strs = strs',
+ types = types',
+ vals = vals', ...} = S'
+ val strs = Info.map2 (strs, strs', replace)
+ val types =
+ Info.map2
+ (types, types', fn (s, s') =>
+ let
+ datatype z = datatype TypeStr.node
+ in
+ case TypeStr.node s' of
+ Datatype {cons = cs', tycon} =>
+ (case TypeStr.node s of
+ Datatype {cons = cs, ...} =>
+ TypeStr.data
+ (tycon, TypeStr.kind s',
+ fixCons (cs, cs'))
+ | _ => s')
+ | Scheme _ => s'
+ | Tycon _ => s'
+ end)
+ val vals =
+ Info.map2
+ (vals, vals', fn ((v, _), (_, s')) =>
+ (v, s'))
+ in
+ Structure.T {interface = Structure.interface S',
+ plist = PropertyList.new (),
+ strs = strs,
+ types = types,
+ vals = vals}
+ end
+ val S'' = replace (S, S')
val _ = destroy ()
in
S''
@@ -2788,7 +2796,11 @@
val {destroy, get: Structure.t -> (Interface.t * Structure.t) list ref,
...} =
Property.destGet (Structure.plist, Property.initFun (fn _ => ref []))
+(*
fun cut (S, I, strids): Structure.t =
+ reallyCut (S, I, strids)
+*)
+ fun cut (S, I, strids): Structure.t =
let
val seen = get S
in
@@ -2796,20 +2808,26 @@
NONE =>
let
fun really () = reallyCut (S, I, strids)
- val S =
+ val S =
case Structure.interface S of
NONE => really ()
| SOME I' =>
+ if Interface.equals (I, I')
+ then S
+ else really ()
+(*
let
- val I'' = Interface.original I
+ val origI = Interface.original I
+ val origI' = Interface.original I'
in
- if Interface.equals (I'', Interface.original I')
+ if Interface.equals (origI, origI')
then (checkMatch
- (Interface.flexibleTycons I'',
+ (Interface.flexibleTycons origI,
S, I, strids)
; S)
else really ()
end
+*)
val _ = List.push (seen, (I, S))
in
S
@@ -2903,6 +2921,7 @@
Scheme.layoutPretty sigScheme]])
end
+ val strArgs = strArgs ()
fun addDec (name: string, n: Exp.node): Vid.t =
let
val x = Var.newString name
@@ -2924,15 +2943,16 @@
Vid.Var x
end
fun con (c: Con.t): Vid.t =
- addDec (Con.originalName c, Exp.Con (c, strArgs ()))
+ addDec (Con.originalName c, Exp.Con (c, strArgs))
val vid =
case (vid, status) of
(Vid.Con c, Status.Var) => con c
| (Vid.Exn c, Status.Var) => con c
| (Vid.Var x, Status.Var) =>
if 0 < Vector.length sigArgs
- orelse 0 < Vector.length (strArgs ())
- then addDec (Var.originalName x, Exp.Var (fn () => x, strArgs))
+ orelse 0 < Vector.length strArgs
+ then addDec (Var.originalName x,
+ Exp.Var (fn () => x, fn () => strArgs))
else vid
| (Vid.Con _, Status.Con) => vid
| (Vid.Exn _, Status.Exn) => vid
@@ -3007,7 +3027,7 @@
: Structure.t * Decs.t =
let
val (S, decs) = transparentCut (E, S, I, {isFunctor = isFunctor}, region)
- (* Aoid doing the opaque match if numErrors > 0 because it can lead
+ (* Avoid doing the opaque match if numErrors > 0 because it can lead
* to internal errors that might be confusing to the user.
*)
val S =
|
|
From: Matthew F. <fl...@ml...> - 2007-09-20 15:12:16
|
Pretty-printing functions
----------------------------------------------------------------------
U mlton/trunk/mlton/elaborate/type-env.fun
U mlton/trunk/mlton/elaborate/type-env.sig
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/elaborate/type-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/type-env.fun 2007-09-20 14:16:04 UTC (rev 6044)
+++ mlton/trunk/mlton/elaborate/type-env.fun 2007-09-20 22:12:15 UTC (rev 6045)
@@ -1393,10 +1393,18 @@
("tyvars", Vector.layout Tyvar.layout tyvars),
("ty", Type.layout ty)]
+ fun layoutPrettyAux (s, {expandOpaque, localTyvarNames}) =
+ case s of
+ Type ty =>
+ Type.layoutPrettyAux
+ (ty, {expandOpaque = expandOpaque,
+ localTyvarNames = localTyvarNames})
+ | General {ty, ...} =>
+ Type.layoutPrettyAux
+ (ty, {expandOpaque = expandOpaque,
+ localTyvarNames = localTyvarNames})
fun layoutPretty s =
- case s of
- Type t => Type.layoutPretty t
- | General {ty, ...} => Type.layoutPretty ty
+ layoutPrettyAux (s, {expandOpaque = false, localTyvarNames = true})
val bound =
fn General {bound, ...} => bound ()
Modified: mlton/trunk/mlton/elaborate/type-env.sig
===================================================================
--- mlton/trunk/mlton/elaborate/type-env.sig 2007-09-20 14:16:04 UTC (rev 6044)
+++ mlton/trunk/mlton/elaborate/type-env.sig 2007-09-20 22:12:15 UTC (rev 6045)
@@ -90,6 +90,9 @@
val instantiate: t -> {args: unit -> Type.t vector,
instance: Type.t}
val layout: t -> Layout.t
+ val layoutPrettyAux:
+ t * {expandOpaque: bool,
+ localTyvarNames: bool} -> Layout.t
val layoutPretty: t -> Layout.t
val make: {canGeneralize: bool,
ty: Type.t,
|
|
From: Vesa K. <ve...@ml...> - 2007-09-20 07:16:05
|
A generic size function. The idea is to use this in the unit testing
library while searching for smaller counterexamples.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
A mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml
U mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
A mltonlib/trunk/com/ssh/generic/unstable/public/value/size.sig
----------------------------------------------------------------------
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-20 14:08:06 UTC (rev 6043)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-09-20 14:16:04 UTC (rev 6044)
@@ -31,6 +31,7 @@
../../../public/value/pretty.sig
../../../public/value/reduce.sig
../../../public/value/seq.sig
+ ../../../public/value/size.sig
../../../public/value/some.sig
../../../public/value/transform.sig
../../../public/value/type-exp.sig
@@ -59,6 +60,7 @@
../../value/pretty.sml
../../value/reduce.sml
../../value/seq.sml
+ ../../value/size.sml
../../value/some.sml
../../value/transform.sml
../../value/type-exp.sml
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml 2007-09-20 14:08:06 UTC (rev 6043)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml 2007-09-20 14:16:04 UTC (rev 6044)
@@ -0,0 +1,169 @@
+(* 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 WithSize (Arg : WITH_SIZE_DOM) : SIZE_CASES = struct
+ (* <-- SML/NJ workaround *)
+ open TopLevel
+ infix 0 &
+ (* SML/NJ workaround --> *)
+
+ type e = (HashUniv.t, Unit.t) HashMap.t
+
+ datatype 'a t =
+ STATIC of Int.t
+ | DYNAMIC of e * 'a -> Int.t
+
+ val sz =
+ fn STATIC s => const s
+ | DYNAMIC f => f
+
+ fun bytes i = Word.toInt (Word.>> (Word.fromInt i + 0w7, 0w3))
+
+ val wordSize = bytes Word.wordSize
+
+ fun sequ length foldl =
+ fn STATIC s => (fn (_, a) => (s * length a + 2 * wordSize))
+ | DYNAMIC f => (fn (e, a) =>
+ foldl (fn (x, s) => s + f (e, x)) (2 * wordSize) a)
+
+ fun cyclic xT xS = let
+ val (to, _) = HashUniv.new {eq = op =, hash = Arg.hash xT}
+ in
+ DYNAMIC (fn (e, x) => let
+ val d = to x
+ in
+ case HashMap.find e d
+ of SOME () => wordSize
+ | NONE => (HashMap.insert e (d, ()) ; xS (e, x))
+ end)
+ end
+
+ fun intSize toLarge i =
+ bytes (IntInf.log2 (abs (toLarge i) + 1))
+
+ fun mkInt toLarge =
+ fn SOME prec => STATIC (bytes prec)
+ | NONE => DYNAMIC (intSize toLarge o #2)
+
+ fun mkWord wordSize = STATIC (bytes wordSize)
+
+ val iso' =
+ fn STATIC s => const (STATIC s)
+ | 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 SizeRep.This
+
+ fun staticSizeOf t =
+ case getT t
+ of STATIC s => SOME s
+ | _ => NONE
+
+ fun sizeOf t =
+ case getT t
+ of STATIC s => const s
+ | 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)
+ fun isoProduct bP = iso' (getP bP)
+ fun isoSum bS = iso' (getS bS)
+
+ fun op *` (xP, yP) = let
+ val xS = getP xP
+ val yS = getP yP
+ in
+ case xS & yS
+ of STATIC x & STATIC y => STATIC (x + y)
+ | _ =>
+ DYNAMIC (fn (e, x & y) => sz xS (e, x) + sz yS (e, y))
+ end
+ val T = getT
+ fun R _ = getT
+ val tuple = getP
+ val record = getP
+
+ fun op +` (xS, yS) = let
+ val xS = getS xS
+ val yS = getS yS
+ val dyn =
+ DYNAMIC (fn (e, INL x) => sz xS (e, x)
+ | (e, INR y) => sz yS (e, y))
+ in
+ case xS & yS
+ of STATIC x & STATIC y => if x = y then STATIC x else dyn
+ | _ => dyn
+ end
+
+ val unit = STATIC 0
+ fun C0 _ = unit
+ fun C1 _ = getT
+ fun data xS = let
+ val tagS = intSize Int.toLarge (Arg.numAlts xS)
+ in
+ case getS xS
+ of STATIC s => STATIC (tagS + s)
+ | DYNAMIC f => DYNAMIC (fn ex => tagS + f ex)
+ end
+
+ fun Y ? = Tie.pure (fn () => let
+ val r = ref (raising Fix.Fix)
+ val f = DYNAMIC (fn ? => !r ?)
+ in
+ (f,
+ fn DYNAMIC f' => (r := f' ; f)
+ | STATIC s => (r := const s ; STATIC s))
+ end) ?
+
+ fun op --> _ = DYNAMIC (failing "Size.--> unsupported")
+
+ val exn : Exn.t t = DYNAMIC (failing "Size.exn not yet implemented")
+ fun regExn0 _ _ = ()
+ fun regExn1 _ _ _ = ()
+
+ fun list xT =
+ case getT xT
+ of STATIC c => DYNAMIC (fn (_, xs) => (c + wordSize) * length xs)
+ | DYNAMIC f =>
+ DYNAMIC (fn (e, xs) => foldl (fn (x, s) => s + f (e, x)) 0 xs)
+
+ fun vector xT = DYNAMIC (sequ Vector.length Vector.foldl (getT xT))
+
+ fun array xT =
+ cyclic (Arg.array ignore xT)
+ (sequ Array.length Array.foldl (getT xT))
+
+ fun refc xT =
+ cyclic (Arg.refc ignore xT)
+ (case getT xT
+ of STATIC s => const (s + wordSize)
+ | DYNAMIC f => fn (e, x) => wordSize + f (e, !x))
+
+ val fixedInt = mkInt FixedInt.toLarge FixedInt.precision
+ val largeInt = mkInt LargeInt.toLarge LargeInt.precision
+
+ val largeReal = mkWord CastLargeReal.Bits.wordSize : LargeReal.t t
+ val largeWord = mkWord LargeWord.wordSize : LargeWord.t t
+
+ val bool = STATIC 1
+ val char = STATIC 1
+ val int = mkInt Int.toLarge Int.precision
+ val real = mkWord CastReal.Bits.wordSize : Real.t t
+ val string = DYNAMIC (fn (_, s) => size s + 2 * wordSize)
+ val word = mkWord Word.wordSize : Word.t t
+
+ val word8 = mkWord Word8.wordSize : Word8.t t
+ val word32 = mkWord Word32.wordSize : Word32.t t
+ val word64 = mkWord Word64.wordSize : Word64.t t)
+
+ open Layered
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-09-20 14:08:06 UTC (rev 6043)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-09-20 14:16:04 UTC (rev 6044)
@@ -121,6 +121,9 @@
public/value/seq.sig
detail/value/seq.sml
+ public/value/size.sig
+ detail/value/size.sml
+
public/value/transform.sig
detail/value/transform.sml
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-09-20 14:08:06 UTC (rev 6043)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-09-20 14:16:04 UTC (rev 6044)
@@ -150,6 +150,10 @@
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)
+signature SIZE = SIZE and SIZE_CASES = SIZE_CASES
+ and WITH_SIZE_DOM = WITH_SIZE_DOM
+functor WithSize (Arg : WITH_SIZE_DOM) : SIZE_CASES = WithSize (Arg)
+
signature SOME = SOME and SOME_CASES = SOME_CASES
and WITH_SOME_DOM = WITH_SOME_DOM
functor WithSome (Arg : WITH_SOME_DOM) : SOME_CASES = WithSome (Arg)
Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/size.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/size.sig 2007-09-20 14:08:06 UTC (rev 6043)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/size.sig 2007-09-20 14:16:04 UTC (rev 6044)
@@ -0,0 +1,40 @@
+(* 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.
+ *)
+
+(**
+ * A signature for a generic size function.
+ *)
+signature SIZE = sig
+ structure SizeRep : OPEN_REP
+
+ val staticSizeOf : ('a, 'x) SizeRep.t -> Int.t Option.t
+ (**
+ * Returns an abstract, statically estimated, size of values of the
+ * type {'a} in bytes.
+ *
+ * The sizes of functions (closures), sequences, arbitrary precision
+ * integers, non-trivial sums, exceptions, and recursive datatypes
+ * cannot be estimated statically.
+ *)
+
+ val sizeOf : ('a, 'x) SizeRep.t -> 'a -> Int.t
+ (**
+ * Returns an abstractly computed size of the given value in bytes.
+ *
+ * The size of a function (closure) cannot be computed in Standard ML.
+ * An attempt to compute the size of a function will fail at run-time.
+ *)
+end
+
+signature SIZE_CASES = sig
+ include OPEN_CASES SIZE
+ sharing Rep = SizeRep
+end
+
+signature WITH_SIZE_DOM = sig
+ include OPEN_CASES HASH TYPE_INFO
+ sharing Rep = HashRep = TypeInfoRep
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/size.sig
___________________________________________________________________
Name: svn:eol-style
+ native
|
|
From: Vesa K. <ve...@ml...> - 2007-09-20 07:08:08
|
Suffixed type representation substructures with Rep.
----------------------------------------------------------------------
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/transform.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-exp.sml
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/transform.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/type-exp.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml 2007-09-20 07:20:22 UTC (rev 6042)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/reduce.sml 2007-09-20 14:08:06 UTC (rev 6043)
@@ -23,23 +23,25 @@
fun default (z, _, _) = z
- structure Reduce = LayerRep
+ structure ReduceRep = LayerRep
(structure Outer = Arg.Rep
structure Closed = MkClosedRep
(type 'a t = Univ.t * Univ.t BinOp.t * 'a -> Univ.t))
+ open ReduceRep.This
+
fun makeReduce z p a2r aT aT2bT = let
val (to, from) = Univ.Iso.new ()
val z = to z
val p = BinOp.map (from, to) p
- val aT = Reduce.This.mapT (const (to o a2r o #3)) aT
- val bR = Reduce.This.getT (aT2bT aT)
+ val aT = mapT (const (to o a2r o #3)) aT
+ val bR = getT (aT2bT aT)
in
fn x => from (bR (z, p, x))
end
structure Layered = LayerCases
- (structure Outer = Arg and Result = Reduce and Rep = Reduce.Closed
+ (structure Outer = Arg and Result = ReduceRep and Rep = ReduceRep.Closed
fun iso bR (a2b, _) (z, p, a) = bR (z, p, a2b a)
val isoProduct = iso
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml 2007-09-20 07:20:22 UTC (rev 6042)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml 2007-09-20 14:08:06 UTC (rev 6043)
@@ -55,21 +55,21 @@
case getX bX
of bE => fn (a2b, _) => fn (e, bp) => bE (e, Sq.map a2b bp)
- structure Seq = LayerRep
+ structure SeqRep = LayerRep
(structure Outer = Arg.Rep
structure Closed = MkClosedRep (type 'a t = 'a t))
- open Seq.This
+ open SeqRep.This
fun seq t =
case getT t
- of eq => fn xy => eq (HashMap.new {eq = HashUniv.eq,
- hash = HashUniv.hash}, xy)
+ of eq => fn xy =>
+ eq (HashMap.new {eq = HashUniv.eq, hash = HashUniv.hash}, xy)
fun notSeq t = negate (seq t)
fun withSeq eq = mapT (const (lift eq))
structure Layered = LayerDepCases
- (structure Outer = Arg and Result = Seq
+ (structure Outer = Arg and Result = SeqRep
fun iso ? = iso' getT ?
fun isoProduct ? = iso' getP ?
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml 2007-09-20 07:20:22 UTC (rev 6042)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml 2007-09-20 14:08:06 UTC (rev 6043)
@@ -35,11 +35,11 @@
fun iso' getX bX (a2b, b2a) = un (Fn.map (Pair.map (a2b, id), b2a)) (getX bX)
- structure Transform = LayerRep
+ structure TransformRep = LayerRep
(structure Outer = Arg.Rep
structure Closed = MkClosedRep (type 'a t = 'a t))
- open Transform.This
+ open TransformRep.This
fun makeTransform a2a t t2u =
case getT (t2u (mapT (const (CUSTOM, lift a2a)) t))
@@ -47,7 +47,7 @@
fn x => f (x, HashMap.new {eq = HashUniv.eq, hash = HashUniv.hash})
structure Layered = LayerDepCases
- (structure Outer = Arg and Result = Transform
+ (structure Outer = Arg and Result = TransformRep
fun iso ? = iso' getT ?
fun isoProduct ? = iso' getP ?
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-20 07:20:22 UTC (rev 6042)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-exp.sml 2007-09-20 14:08:06 UTC (rev 6043)
@@ -17,11 +17,11 @@
end
fun mapElem f =
- fn TIMES (a, b) => TIMES (mapElem f a, mapElem f b)
- | ISO_PRODUCT b => ISO_PRODUCT (mapElem f b)
- | ELEM e => ELEM (f e)
+ fn TIMES (a, b) => TIMES (mapElem f a, mapElem f b)
+ | ISO_PRODUCT b => ISO_PRODUCT (mapElem f b)
+ | ELEM e => ELEM (f e)
- structure TypeExp = LayerRep
+ structure TypeExpRep = LayerRep
(structure Outer = Arg.Rep
structure Closed = struct
type 'a t = TypeVar.t Ty.t
@@ -29,10 +29,10 @@
type ('a, 'k) p = (Label.t Option.t * TypeVar.t Ty.t) Product.t
end)
- val ty = TypeExp.This.getT
+ val ty = TypeExpRep.This.getT
structure Layered = LayerCases
- (structure Outer = Arg and Result = TypeExp and Rep = TypeExp.Closed
+ (structure Outer = Arg and Result = TypeExpRep and Rep = TypeExpRep.Closed
fun iso bT _ = ISO bT
fun isoProduct bP _ = ISO_PRODUCT bP
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/reduce.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/reduce.sig 2007-09-20 07:20:22 UTC (rev 6042)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/reduce.sig 2007-09-20 14:08:06 UTC (rev 6043)
@@ -26,19 +26,19 @@
* This design is experimental.
*)
signature REDUCE = sig
- structure Reduce : OPEN_REP
+ structure ReduceRep : OPEN_REP
val makeReduce :
'r
-> 'r BinOp.t
-> ('a -> 'r)
- -> ('a, 'x) Reduce.t
- -> (('a, 'x) Reduce.t -> ('b, 'y) Reduce.t)
+ -> ('a, 'x) ReduceRep.t
+ -> (('a, 'x) ReduceRep.t -> ('b, 'y) ReduceRep.t)
-> 'b -> 'r
(** Creates a reduce operation. *)
end
signature REDUCE_CASES = sig
include OPEN_CASES REDUCE
- sharing Rep = Reduce
+ sharing Rep = ReduceRep
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/seq.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/seq.sig 2007-09-20 07:20:22 UTC (rev 6042)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/seq.sig 2007-09-20 14:08:06 UTC (rev 6043)
@@ -18,21 +18,21 @@
* other similar generics.
*)
signature SEQ = sig
- structure Seq : OPEN_REP
+ structure SeqRep : OPEN_REP
- val seq : ('a, 'x) Seq.t -> 'a BinPr.t
+ val seq : ('a, 'x) SeqRep.t -> 'a BinPr.t
(** Extracts the equality predicate. *)
- val notSeq : ('a, 'x) Seq.t -> 'a BinPr.t
+ val notSeq : ('a, 'x) SeqRep.t -> 'a BinPr.t
(** {notSeq t = not o seq t} *)
- val withSeq : 'a BinPr.t -> ('a, 'x) Seq.t UnOp.t
+ val withSeq : 'a BinPr.t -> ('a, 'x) SeqRep.t UnOp.t
(** Functionally updates the equality predicate. *)
end
signature SEQ_CASES = sig
include OPEN_CASES SEQ
- sharing Rep = Seq
+ sharing Rep = SeqRep
end
signature WITH_SEQ_DOM = HASH_CASES
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/transform.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/transform.sig 2007-09-20 07:20:22 UTC (rev 6042)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/transform.sig 2007-09-20 14:08:06 UTC (rev 6043)
@@ -21,19 +21,19 @@
* This design is experimental.
*)
signature TRANSFORM = sig
- structure Transform : OPEN_REP
+ structure TransformRep : OPEN_REP
val makeTransform :
'a UnOp.t
- -> ('a, 'x) Transform.t
- -> (('a, 'x) Transform.t -> ('b, 'y) Transform.t)
+ -> ('a, 'x) TransformRep.t
+ -> (('a, 'x) TransformRep.t -> ('b, 'y) TransformRep.t)
-> 'b UnOp.t
(** Creates a transform operation. *)
end
signature TRANSFORM_CASES = sig
include OPEN_CASES TRANSFORM
- sharing Rep = Transform
+ sharing Rep = TransformRep
end
signature WITH_TRANSFORM_DOM = HASH_CASES
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/type-exp.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/type-exp.sig 2007-09-20 07:20:22 UTC (rev 6042)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/type-exp.sig 2007-09-20 14:08:06 UTC (rev 6043)
@@ -8,18 +8,18 @@
* Signature for generic type representation expression.
*)
signature TYPE_EXP = sig
- structure TypeExp : OPEN_REP
+ structure TypeExpRep : OPEN_REP
(** A minimalistic type variable representation providing only equality. *)
structure TypeVar : sig
eqtype t
end
- val ty : ('a, 'x) TypeExp.t -> TypeVar.t Ty.t
+ val ty : ('a, 'x) TypeExpRep.t -> TypeVar.t Ty.t
(** Returns the type expression given a type representation. *)
end
signature TYPE_EXP_CASES = sig
include OPEN_CASES TYPE_EXP
- sharing Rep = TypeExp
+ sharing Rep = TypeExpRep
end
|
|
From: Vesa K. <ve...@ml...> - 2007-09-20 00:20:23
|
Simplification.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml
----------------------------------------------------------------------
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-20 03:29:02 UTC (rev 6041)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml 2007-09-20 07:20:22 UTC (rev 6042)
@@ -59,7 +59,7 @@
fun op --> _ = base
- val exn = INT {base = true}
+ val exn = base
fun regExn0 _ _ = ()
fun regExn1 _ _ _ = ()
|
|
From: Vesa K. <ve...@ml...> - 2007-09-19 20:29:03
|
Moved OptInt to a separate file.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
A mltonlib/trunk/com/ssh/generic/unstable/detail/opt-int.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/lib.mlb
----------------------------------------------------------------------
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-20 03:08:27 UTC (rev 6040)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-09-20 03:29:02 UTC (rev 6041)
@@ -43,6 +43,7 @@
../../hash-univ.sml
../../layer-generic.fun
../../mk-closed-rep.fun
+ ../../opt-int.sml
../../reg-basis-exns.fun
../../root-generic.sml
../../sml-syntax.sml
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/opt-int.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/opt-int.sml 2007-09-20 03:08:27 UTC (rev 6040)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/opt-int.sml 2007-09-20 03:29:02 UTC (rev 6041)
@@ -0,0 +1,18 @@
+(* 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.
+ *)
+
+structure OptInt = struct
+ type t = Int.t Option.t
+ local
+ fun mk bop =
+ fn (SOME l, SOME r) => SOME (bop (l, r))
+ | _ => NONE
+ in
+ val op + = mk op +
+ val op - = mk op -
+ val op div = mk op div
+ end
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/opt-int.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2007-09-20 03:08:27 UTC (rev 6040)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2007-09-20 03:29:02 UTC (rev 6041)
@@ -165,18 +165,6 @@
end
end
- structure OptInt = struct
- type t = Int.t Option.t
- local
- fun mk bop =
- fn (SOME l, SOME r) => SOME (bop (l, r))
- | _ => NONE
- in
- val op + = mk op +
- val op div = mk op div
- end
- end
-
datatype 'a t =
P of {rd : 'a I.monad,
wr : 'a -> Unit.t O.monad,
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-09-20 03:08:27 UTC (rev 6040)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-09-20 03:29:02 UTC (rev 6041)
@@ -61,17 +61,6 @@
fun surround (n, p) = nest n o enclose p
fun atomize (a, d) = if ATOMIC = a then d else surround parens d
- structure OptInt = struct
- type t = Int.t Option.t
- local
- fun mk bop =
- fn (SOME l, SOME r) => SOME (bop (l, r))
- | _ => NONE
- in
- val op - = mk op -
- end
- end
-
structure Fmt = struct
structure Opts = MkOpts (type 'a t = 'a)
@@ -255,7 +244,9 @@
((), E ({cnt = cnt, fmt = fmt, map = map}, v))
fun getRemDepth (e as E (_, {maxDepth})) = (maxDepth, e)
- fun setRemDepth maxDepth (E (c, _)) = ((), E (c, {maxDepth = maxDepth}))
+ fun setRemDepth remDepth =
+ (Fmt.notNegOpt remDepth
+ ; fn (E (c, _)) => ((), E (c, {maxDepth = remDepth})))
structure Fixity = Fixity
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-09-20 03:08:27 UTC (rev 6040)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-09-20 03:29:02 UTC (rev 6041)
@@ -48,6 +48,8 @@
detail/mk-closed-rep.fun
+ detail/opt-int.sml (* XXX Should really go to Extended Basis? *)
+
local
local
$(SML_LIB)/smlnj-lib/Util/smlnj-lib.mlb
|
|
From: Vesa K. <ve...@ml...> - 2007-09-19 20:08:28
|
Comments.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig 2007-09-19 22:16:16 UTC (rev 6039)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/pretty.sig 2007-09-20 03:08:27 UTC (rev 6040)
@@ -21,13 +21,14 @@
* specified.
* - The radix of integers and words is shown in the output with a "b"
* (binary ; HaMLet-S), "o" (octal ; non-standard), or "x" prefix.
- * - Sharing of mutable objects is shown in the output. Shared mutable
- * objects are assigned a sequence number, indicated by a "#n=" prefix at
- * the first occurrence. Subsequent occurrences of the shared object are
- * indicated by a "#n".
+ * - Sharing of mutable objects is shown in the output. Each shared
+ * mutable object is assigned a sequence number that is indicated by a
+ * "#n=" prefix at the first occurrence. Subsequent occurrences of the
+ * shared object are indicated by a "#n".
* - Handles arbitrary cyclic data structures.
* - Supports pretty printing infix constructors in infix notation with a
* given fixity.
+ * - Supports customizing pretty printers.
*)
signature PRETTY = sig
structure PrettyRep : OPEN_REP
|
|
From: Matthew F. <fl...@ml...> - 2007-09-19 15:16:19
|
More improvements to pretty-printing of CoreML IL
----------------------------------------------------------------------
U mlton/trunk/mlton/elaborate/elaborate-env.fun
U mlton/trunk/mlton/elaborate/type-env.fun
U mlton/trunk/mlton/elaborate/type-env.sig
U mlton/trunk/mlton/main/compile.fun
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/elaborate/elaborate-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-env.fun 2007-09-19 19:32:07 UTC (rev 6038)
+++ mlton/trunk/mlton/elaborate/elaborate-env.fun 2007-09-19 22:16:16 UTC (rev 6039)
@@ -48,7 +48,6 @@
structure Tycon = Tycon
structure Tyvar = Tyvar
structure Var = Var
- structure Var = Var
end
local
@@ -852,7 +851,8 @@
layoutTypeSpec' (Ast.Tycon.layout n, s, {isWhere = false})
and layoutTypeSpec' (name: Layout.t, s, {isWhere: bool}) =
let
- val {destroy, lay} = Type.makeLayoutPretty {localTyvarNames = true}
+ val {destroy, lay} =
+ Type.makeLayoutPretty {expandOpaque = false, localTyvarNames = true}
val lay = #1 o lay
val tyvars =
case TypeStr.kind s of
@@ -2903,9 +2903,9 @@
Scheme.layoutPretty sigScheme]])
end
- fun addDec (n: Exp.node): Vid.t =
+ fun addDec (name: string, n: Exp.node): Vid.t =
let
- val x = Var.newNoname ()
+ val x = Var.newString name
val e = Exp.make (n, strType)
val _ =
List.push
@@ -2924,7 +2924,7 @@
Vid.Var x
end
fun con (c: Con.t): Vid.t =
- addDec (Exp.Con (c, strArgs ()))
+ addDec (Con.originalName c, Exp.Con (c, strArgs ()))
val vid =
case (vid, status) of
(Vid.Con c, Status.Var) => con c
@@ -2932,7 +2932,7 @@
| (Vid.Var x, Status.Var) =>
if 0 < Vector.length sigArgs
orelse 0 < Vector.length (strArgs ())
- then addDec (Exp.Var (fn () => x, strArgs))
+ then addDec (Var.originalName x, Exp.Var (fn () => x, strArgs))
else vid
| (Vid.Con _, Status.Con) => vid
| (Vid.Exn _, Status.Exn) => vid
Modified: mlton/trunk/mlton/elaborate/type-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/type-env.fun 2007-09-19 19:32:07 UTC (rev 6038)
+++ mlton/trunk/mlton/elaborate/type-env.fun 2007-09-19 22:16:16 UTC (rev 6039)
@@ -597,7 +597,7 @@
Exn.finally (fn () => hom ty, destroy)
end
- fun makeLayoutPretty {localTyvarNames} :
+ fun makeLayoutPretty {expandOpaque, localTyvarNames} :
{destroy: unit -> unit,
lay: t -> Layout.t * ({isChar: bool} * Tycon.BindingStrength.t)} =
let
@@ -663,7 +663,7 @@
fun var (_, a) = prettyTyvar a
fun lay t =
hom (t, {con = con,
- expandOpaque = false,
+ expandOpaque = expandOpaque,
flexRecord = flexRecord,
genFlexRecord = genFlexRecord,
overload = overload,
@@ -676,15 +676,19 @@
lay = lay}
end
- fun layoutPrettyAux (t, {localTyvarNames}) =
+ fun layoutPrettyAux (t, {expandOpaque, localTyvarNames}) =
let
- val {destroy, lay} = makeLayoutPretty {localTyvarNames = localTyvarNames}
+ val {destroy, lay} =
+ makeLayoutPretty {expandOpaque = expandOpaque,
+ localTyvarNames = localTyvarNames}
val res = #1 (lay t)
val _ = destroy ()
in
res
end
- fun layoutPretty t = layoutPrettyAux (t, {localTyvarNames = true})
+ fun layoutPretty t =
+ layoutPrettyAux (t, {expandOpaque = false,
+ localTyvarNames = true})
fun deConOpt t =
case toType t of
@@ -928,7 +932,8 @@
fun unify (t, t', {preError: unit -> unit}): UnifyResult.t =
let
- val {destroy, lay = layoutPretty} = makeLayoutPretty {localTyvarNames = true}
+ val {destroy, lay = layoutPretty} =
+ makeLayoutPretty {expandOpaque = false, localTyvarNames = true}
val dontCare' = fn _ => dontCare
val layoutRecord = fn z => layoutRecord (z, true)
fun unify arg =
Modified: mlton/trunk/mlton/elaborate/type-env.sig
===================================================================
--- mlton/trunk/mlton/elaborate/type-env.sig 2007-09-19 19:32:07 UTC (rev 6038)
+++ mlton/trunk/mlton/elaborate/type-env.sig 2007-09-19 22:16:16 UTC (rev 6039)
@@ -44,14 +44,15 @@
val isInt: t -> bool
val isUnit: t -> bool
val layout: t -> Layout.t
- val layoutPrettyAux: t * {localTyvarNames: bool} -> Layout.t
+ val layoutPrettyAux: t * {expandOpaque: bool, localTyvarNames: bool} -> Layout.t
val layoutPretty: t -> Layout.t
val makeHom: {con: Tycon.t * 'a vector -> 'a,
expandOpaque: bool,
var: Tyvar.t -> 'a} -> {destroy: unit -> unit,
hom: t -> 'a}
val makeLayoutPretty:
- {localTyvarNames: bool} -> {destroy: unit -> unit,
+ {expandOpaque:bool,
+ localTyvarNames: bool} -> {destroy: unit -> unit,
lay: t -> Layout.t * ({isChar: bool}
* Tycon.BindingStrength.t)}
(* minTime (t, time) makes every component of t occur no later than
Modified: mlton/trunk/mlton/main/compile.fun
===================================================================
--- mlton/trunk/mlton/main/compile.fun 2007-09-19 19:32:07 UTC (rev 6038)
+++ mlton/trunk/mlton/main/compile.fun 2007-09-19 22:16:16 UTC (rev 6039)
@@ -64,7 +64,8 @@
fun layout t =
layoutPrettyAux
- (t, {localTyvarNames = false})
+ (t, {expandOpaque = true,
+ localTyvarNames = false})
end)
structure Xml = Xml (open Atoms)
structure Sxml = Sxml (open Xml)
|
|
From: Matthew F. <fl...@ml...> - 2007-09-19 12:32:08
|
Tracing
----------------------------------------------------------------------
U mlton/trunk/mlton/atoms/hash-type.fun
U mlton/trunk/mlton/defunctorize/defunctorize.fun
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/atoms/hash-type.fun
===================================================================
--- mlton/trunk/mlton/atoms/hash-type.fun 2007-09-19 16:50:01 UTC (rev 6037)
+++ mlton/trunk/mlton/atoms/hash-type.fun 2007-09-19 19:32:07 UTC (rev 6038)
@@ -166,11 +166,13 @@
| SOME (_, ty) => ty),
con = con}
-(* val substitute =
- * Trace.trace2 ("HashType.substitute", layout,
- * List.layout (Layout.tuple2 (Tyvar.layout, Type.layout)),
- * layout) substitute
- *)
+val substitute =
+ Trace.trace2
+ ("HashType.substitute",
+ layout,
+ Vector.layout (Layout.tuple2 (Tyvar.layout, Type.layout)),
+ layout)
+ substitute
(* fun equalss (ts: t list): t option =
* case ts of
Modified: mlton/trunk/mlton/defunctorize/defunctorize.fun
===================================================================
--- mlton/trunk/mlton/defunctorize/defunctorize.fun 2007-09-19 16:50:01 UTC (rev 6037)
+++ mlton/trunk/mlton/defunctorize/defunctorize.fun 2007-09-19 19:32:07 UTC (rev 6038)
@@ -514,6 +514,10 @@
in
Ctype.makeHom {con = con, var = Xtype.var}
end
+ val loopTy =
+ Trace.trace
+ ("Defunctorize.loopTy", Ctype.layout, Xtype.layout)
+ loopTy
fun conTargs (c: Con.t, ts: Ctype.t vector): Xtype.t vector =
let
val ts = Vector.map (ts, loopTy)
|
|
From: Matthew F. <fl...@ml...> - 2007-09-19 09:50:04
|
Improvements to pretty-printing of CoreML IL
----------------------------------------------------------------------
U mlton/trunk/mlton/core-ml/core-ml.fun
U mlton/trunk/mlton/elaborate/elaborate-env.fun
U mlton/trunk/mlton/elaborate/type-env.fun
U mlton/trunk/mlton/elaborate/type-env.sig
U mlton/trunk/mlton/main/compile.fun
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/core-ml/core-ml.fun
===================================================================
--- mlton/trunk/mlton/core-ml/core-ml.fun 2007-09-19 13:49:47 UTC (rev 6036)
+++ mlton/trunk/mlton/core-ml/core-ml.fun 2007-09-19 16:50:01 UTC (rev 6037)
@@ -22,6 +22,16 @@
else x
end
+fun layoutTargs (ts: Type.t vector) =
+ let
+ open Layout
+ in
+ if !Control.showTypes
+ andalso 0 < Vector.length ts
+ then list (Vector.toListMap (ts, Type.layout))
+ else empty
+ end
+
structure Pat =
struct
datatype t = T of {node: node,
@@ -56,9 +66,7 @@
case node p of
Con {arg, con, targs} =>
seq [Con.layout con,
- if !Control.showTypes andalso 0 < Vector.length targs
- then tuple (Vector.toListMap (targs, Type.layout))
- else empty,
+ layoutTargs targs,
case arg of
NONE => empty
| SOME p => seq [str " ", layout p]]
@@ -194,7 +202,7 @@
local
open Layout
in
- fun layoutTyvars ts =
+ fun layoutTyvars (ts: Tyvar.t vector) =
case Vector.length ts of
0 => empty
| 1 => seq [str " ", Tyvar.layout (Vector.sub (ts, 0))]
@@ -238,7 +246,7 @@
rules = Vector.map (rules, fn {exp, pat, ...} =>
(Pat.layout pat, layoutExp exp)),
test = layoutExp test}
- | Con (c, _) => Con.layout c
+ | Con (c, targs) => seq [Con.layout c, layoutTargs targs]
| Const f => Const.layout (f ())
| EnterLeave (e, si) =>
seq [str "EnterLeave ",
@@ -265,19 +273,32 @@
record = r,
separator = " = "}
| Seq es => Pretty.seq (Vector.map (es, layoutExp))
- | Var (x, _) => Var.layout (x ())
+ | Var (var, targs) =>
+ if !Control.showTypes
+ then let
+ open Layout
+ val targs = targs ()
+ in
+ if Vector.isEmpty targs
+ then Var.layout (var ())
+ else seq [Var.layout (var ()), str " ",
+ Vector.layout Type.layout targs]
+ end
+ else Var.layout (var ())
and layoutFuns (tyvars, decs) =
if 0 = Vector.length decs
then empty
else
align [seq [str "val rec", layoutTyvars (tyvars ())],
indent (align (Vector.toListMap
- (decs, fn {lambda, var} =>
- align [seq [Var.layout var, str " = "],
+ (decs, fn {lambda as Lam {argType, body = Exp {ty = bodyType, ...}, ...}, var} =>
+ align [seq [maybeConstrain (Var.layout var, Type.arrow (argType, bodyType)), str " = "],
indent (layoutLambda lambda, 3)])),
3)]
- and layoutLambda (Lam {arg, body, ...}) =
- paren (align [seq [str "fn ", Var.layout arg, str " =>"],
+ and layoutLambda (Lam {arg, argType, body, ...}) =
+ paren (align [seq [str "fn ",
+ maybeConstrain (Var.layout arg, argType),
+ str " =>"],
layoutExp body])
end
Modified: mlton/trunk/mlton/elaborate/elaborate-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-env.fun 2007-09-19 13:49:47 UTC (rev 6036)
+++ mlton/trunk/mlton/elaborate/elaborate-env.fun 2007-09-19 16:50:01 UTC (rev 6037)
@@ -852,7 +852,7 @@
layoutTypeSpec' (Ast.Tycon.layout n, s, {isWhere = false})
and layoutTypeSpec' (name: Layout.t, s, {isWhere: bool}) =
let
- val {destroy, lay} = Type.makeLayoutPretty ()
+ val {destroy, lay} = Type.makeLayoutPretty {localTyvarNames = true}
val lay = #1 o lay
val tyvars =
case TypeStr.kind s of
Modified: mlton/trunk/mlton/elaborate/type-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/type-env.fun 2007-09-19 13:49:47 UTC (rev 6036)
+++ mlton/trunk/mlton/elaborate/type-env.fun 2007-09-19 16:50:01 UTC (rev 6037)
@@ -597,10 +597,9 @@
Exn.finally (fn () => hom ty, destroy)
end
- fun makeLayoutPretty (): {destroy: unit -> unit,
- lay: t -> Layout.t
- * ({isChar: bool}
- * Tycon.BindingStrength.t)} =
+ fun makeLayoutPretty {localTyvarNames} :
+ {destroy: unit -> unit,
+ lay: t -> Layout.t * ({isChar: bool} * Tycon.BindingStrength.t)} =
let
val str = Layout.str
fun con (_, c, ts) = Tycon.layoutApp (c, ts)
@@ -632,30 +631,35 @@
| SOME ts => Tycon.layoutApp (Tycon.tuple, ts)
fun recursive _ = simple (str "<recur>")
fun unknown _ = simple (str "???")
- val {destroy, get = prettyTyvar, ...} =
- Property.destGet
- (Tyvar.plist,
- Property.initFun
- (let
- val r = ref (Char.toInt #"a")
- in
- fn _ =>
- let
- val n = !r
- val l =
- simple
- (str (concat
- ["'",
- if n > Char.toInt #"z" then
- concat ["a",
- Int.toString (n - Char.toInt #"z")]
- else
- Char.toString (Char.fromInt n )]))
- val _ = r := 1 + n
- in
- l
- end
- end))
+ val (destroy, prettyTyvar) =
+ if localTyvarNames
+ then let
+ val {destroy, get = prettyTyvar, ...} =
+ Property.destGet
+ (Tyvar.plist,
+ Property.initFun
+ (let
+ val r = ref (Char.toInt #"a")
+ in
+ fn _ =>
+ let
+ val n = !r
+ val l =
+ simple
+ (str (concat
+ ["'",
+ if n > Char.toInt #"z"
+ then concat ["a", Int.toString (n - Char.toInt #"z")]
+ else Char.toString (Char.fromInt n )]))
+ val _ = r := 1 + n
+ in
+ l
+ end
+ end))
+ in
+ (destroy, prettyTyvar)
+ end
+ else (fn () => (), simple o Tyvar.layout)
fun var (_, a) = prettyTyvar a
fun lay t =
hom (t, {con = con,
@@ -672,14 +676,15 @@
lay = lay}
end
- fun layoutPretty t =
+ fun layoutPrettyAux (t, {localTyvarNames}) =
let
- val {destroy, lay} = makeLayoutPretty ()
+ val {destroy, lay} = makeLayoutPretty {localTyvarNames = localTyvarNames}
val res = #1 (lay t)
val _ = destroy ()
in
res
end
+ fun layoutPretty t = layoutPrettyAux (t, {localTyvarNames = true})
fun deConOpt t =
case toType t of
@@ -923,7 +928,7 @@
fun unify (t, t', {preError: unit -> unit}): UnifyResult.t =
let
- val {destroy, lay = layoutPretty} = makeLayoutPretty ()
+ val {destroy, lay = layoutPretty} = makeLayoutPretty {localTyvarNames = true}
val dontCare' = fn _ => dontCare
val layoutRecord = fn z => layoutRecord (z, true)
fun unify arg =
Modified: mlton/trunk/mlton/elaborate/type-env.sig
===================================================================
--- mlton/trunk/mlton/elaborate/type-env.sig 2007-09-19 13:49:47 UTC (rev 6036)
+++ mlton/trunk/mlton/elaborate/type-env.sig 2007-09-19 16:50:01 UTC (rev 6037)
@@ -44,15 +44,16 @@
val isInt: t -> bool
val isUnit: t -> bool
val layout: t -> Layout.t
+ val layoutPrettyAux: t * {localTyvarNames: bool} -> Layout.t
val layoutPretty: t -> Layout.t
val makeHom: {con: Tycon.t * 'a vector -> 'a,
expandOpaque: bool,
var: Tyvar.t -> 'a} -> {destroy: unit -> unit,
hom: t -> 'a}
val makeLayoutPretty:
- unit -> {destroy: unit -> unit,
- lay: t -> Layout.t * ({isChar: bool}
- * Tycon.BindingStrength.t)}
+ {localTyvarNames: bool} -> {destroy: unit -> unit,
+ lay: t -> Layout.t * ({isChar: bool}
+ * Tycon.BindingStrength.t)}
(* minTime (t, time) makes every component of t occur no later than
* time. This will display a type error message if time is before
* the definition time of some component of t.
Modified: mlton/trunk/mlton/main/compile.fun
===================================================================
--- mlton/trunk/mlton/main/compile.fun 2007-09-19 13:49:47 UTC (rev 6036)
+++ mlton/trunk/mlton/main/compile.fun 2007-09-19 16:50:01 UTC (rev 6037)
@@ -62,7 +62,9 @@
expandOpaque = true,
var = var}
- val layout = layoutPretty
+ fun layout t =
+ layoutPrettyAux
+ (t, {localTyvarNames = false})
end)
structure Xml = Xml (open Atoms)
structure Sxml = Sxml (open Xml)
|
|
From: Vesa K. <ve...@ml...> - 2007-09-19 06:49:48
|
Script for running tests with SML/NJ. ---------------------------------------------------------------------- A mltonlib/trunk/com/ssh/generic/unstable/Test-smlnj.sh A mltonlib/trunk/com/ssh/generic/unstable/test.cm ---------------------------------------------------------------------- Added: mltonlib/trunk/com/ssh/generic/unstable/Test-smlnj.sh =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/Test-smlnj.sh 2007-09-19 13:00:00 UTC (rev 6035) +++ mltonlib/trunk/com/ssh/generic/unstable/Test-smlnj.sh 2007-09-19 13:49:47 UTC (rev 6036) @@ -0,0 +1,18 @@ +#!/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 + +eb=../../extended-basis/unstable + +time \ +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') Property changes on: mltonlib/trunk/com/ssh/generic/unstable/Test-smlnj.sh ___________________________________________________________________ Name: svn:executable + * Name: svn:eol-style + native Added: mltonlib/trunk/com/ssh/generic/unstable/test.cm =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/test.cm 2007-09-19 13:00:00 UTC (rev 6035) +++ mltonlib/trunk/com/ssh/generic/unstable/test.cm 2007-09-19 13:49:47 UTC (rev 6036) @@ -0,0 +1,20 @@ +(* 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. + *) + +group + library(../../extended-basis/unstable/basis.cm) + library(../../generic/unstable/lib-with-default.cm) + library(../../prettier/unstable/lib.cm) + library(../../random/unstable/lib.cm) + library(../../unit-test/unstable/lib-with-default.cm) + library(lib-with-default.cm) +is + ../../extended-basis/unstable/basis.cm + ../../generic/unstable/lib-with-default.cm + ../../prettier/unstable/lib.cm + ../../random/unstable/lib.cm + ../../unit-test/unstable/lib-with-default.cm + lib-with-default.cm |
|
From: Vesa K. <ve...@ml...> - 2007-09-19 06:00:01
|
Be verbose and type-check.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/Test.sh
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/Test.sh
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/Test.sh 2007-09-19 12:56:08 UTC (rev 6034)
+++ mltonlib/trunk/com/ssh/generic/unstable/Test.sh 2007-09-19 13:00:00 UTC (rev 6035)
@@ -19,6 +19,8 @@
-show-def-use generated/test.du \
-output generated/test \
-const 'Exn.keepHistory true' \
+ -type-check true \
+ -verbose 2 \
test.mlb
time \
|
