|
From: Vesa K. <ve...@ml...> - 2007-01-12 04:39:40
|
Initial commit of a lib of misc utils to be refactored. ---------------------------------------------------------------------- A mltonlib/trunk/com/ssh/misc-util/unstable/type.sml ---------------------------------------------------------------------- Added: mltonlib/trunk/com/ssh/misc-util/unstable/type.sml =================================================================== --- mltonlib/trunk/com/ssh/misc-util/unstable/type.sml 2007-01-12 12:39:02 UTC (rev 5062) +++ mltonlib/trunk/com/ssh/misc-util/unstable/type.sml 2007-01-12 12:39:26 UTC (rev 5063) @@ -0,0 +1,201 @@ +(* 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. + *) + +(* + * An implementation of the {TYPE} signature done by combining some of the + * utility implementations of the {TYPE} signature. + *) + +structure Type :> + sig + include TYPE + + (** == STRUCTURAL TYPE-INDEXED VALUES == *) + + include ARBITRARY + include COMPARE + include EQ + + (** == NOMINAL TYPE-INDEXED VALUES == *) + + include SHOW + + (* Sharing constraints *) + + sharing type t + = arbitrary_t + = compare_t + = eq_t + = show_t + sharing type s + = show_s + sharing type p + = show_p + end = struct + structure Type = + TypePair + (structure A = Show + structure B = + StructuralTypeToType + (StructuralTypePair + (structure A = Arbitrary + structure B = + StructuralTypePair + (structure A = Compare + structure B = Eq)))) + + structure T : + sig + type 'a t + type 'a s + type ('a, 'k) p + end = Type + + local + open Lift + in + val A = A + val B = B + val op ^ = op ^ + end + + structure Arbitrary = LiftArbitrary (open Arbitrary T fun lift () = B^A) + structure Compare = LiftCompare (open Compare T fun lift () = B^B^A) + structure Eq = LiftEq (open Eq T fun lift () = B^B^B) + + structure Show = LiftShow (open Show T fun liftT () = A) + + open Type + Arbitrary + Compare + Eq + Show + end + +(** + * Here we extend the Type module with type-indices for some standard + * types and type constructors as well as implement some utilities. + *) +structure Type = + struct + open TypeSupport Type + + (* Convenience functions for making constructors and labels. Use + * these only for defining monomorphic type-indices. + *) + fun C0' n = C0 (C n) + fun C1' n = C1 (C n) + fun R' n = R (L n) + + (* Convenience functions for registering exceptions. *) + fun regExn0 e p n = regExn (C0' n) (const e, p) + fun regExn1 e p n t = regExn (C1' n t) (e, p) + + (* Convenience functions for defining small tuples. *) + local + fun mk t = iso (tuple t) + in + fun tuple2 (a, b) = mk (T a *` T b) Product.isoTuple2 + fun tuple3 (a, b, c) = mk (T a *` T b *` T c) Product.isoTuple3 + fun tuple4 (a, b, c, d) = mk (T a *` T b *` T c *` T d) Product.isoTuple4 + end + + (* Type-indices for some standard types. *) + local + fun mk precision int' large' = + if isSome Int.precision andalso + valOf precision <= valOf Int.precision then + iso int int' + else + iso largeInt large' + in + (* Warning: The following encodings of sized integer types are + * not optimal for serialization. (They do work, however.) + * For serialization, one should encode sized integer types + * in terms of the corresponding sized word types. + *) + val int8 = mk Int8.precision Int8.isoInt Int8.isoLarge + val int16 = mk Int16.precision Int16.isoInt Int16.isoLarge + val int32 = mk Int32.precision Int32.isoInt Int32.isoLarge + val int64 = mk Int64.precision Int64.isoInt Int64.isoLarge + end + + local + val none = C "NONE" + val some = C "SOME" + in + fun option a = + iso (data (C0 none +` C1 some a)) + (fn NONE => INL () | SOME a => INR a, + fn INL () => NONE | INR a => SOME a) + end + + val order = + iso (data (C0' "LESS" +` C0' "EQUAL" +` C0' "GREATER")) + (fn LESS => INL (INL ()) + | EQUAL => INL (INR ()) + | GREATER => INR (), + fn INL (INL ()) => LESS + | INL (INR ()) => EQUAL + | INR () => GREATER) + + structure OS' = + struct + val syserror = iso string (OS.errorName, valOf o OS.syserror) + end + + (* Type-indices for some util library types. *) + local + val et = C "&" + in + fun a &` b = data (C1 et (tuple (T a *` T b))) + end + + local + val inl = C "INL" + val inr = C "INR" + in + fun a |` b = data (C1 inl a +` C1 inr b) + end + + (* Abbreviations for type-indices. *) + fun sq a = tuple2 (Sq.mk a) + fun uop a = a --> a + fun bop a = sq a --> a + end + +val () = + let + open IEEEReal OS OS.IO OS.Path Time Type + val s = SOME + val n = NONE + val su = SOME () + val syserr = tuple2 (string, option OS'.syserror) + in + (* Handlers for (most if not all) standard exceptions: *) + regExn0 Bind (fn Bind => su | _ => n) "Bind" + ; regExn0 Chr (fn Chr => su | _ => n) "Chr" + ; regExn0 Date.Date (fn Date.Date => su | _ => n) "Date.Date" + ; regExn0 Div (fn Div => su | _ => n) "Div" + ; regExn0 Domain (fn Domain => su | _ => n) "Domain" + ; regExn0 Empty (fn Empty => su | _ => n) "Empty" + ; regExn0 InvalidArc (fn InvalidArc => su | _ => n) "OS.Path.InvalidArc" + ; regExn0 Match (fn Match => su | _ => n) "Match" + ; regExn0 Option (fn Option => su | _ => n) "Option" + ; regExn0 Overflow (fn Overflow => su | _ => n) "Overflow" + ; regExn0 Path (fn Path => su | _ => n) "OS.Path.Path" + ; regExn0 Poll (fn Poll => su | _ => n) "OS.IO.Poll" + ; regExn0 Size (fn Size => su | _ => n) "Size" + ; regExn0 Span (fn Span => su | _ => n) "Span" + ; regExn0 Subscript (fn Subscript => su | _ => n) "Subscript" + ; regExn0 Time (fn Time => su | _ => n) "Time.Time" + ; regExn0 Unordered (fn Unordered => su | _ => n) "IEEEReal.Unordered" + ; regExn1 Fail (fn Fail ? => s? | _ => n) "Fail" string + ; regExn1 SysErr (fn SysErr ? => s? | _ => n) "OS.SysErr" syserr + (* Handlers for some util library exceptions: *) + ; regExn0 Sum.Sum (fn Sum.Sum => su | _ => n) "Sum" + ; regExn0 Fix.Fix (fn Fix.Fix => su | _ => n) "Fix" + end Property changes on: mltonlib/trunk/com/ssh/misc-util/unstable/type.sml ___________________________________________________________________ Name: svn:eol-style + native |