1(*
2    Copyright (c) 2000
3        Cambridge University Technical Services Limited
4
5    This library is free software; you can redistribute it and/or
6    modify it under the terms of the GNU Lesser General Public
7    License as published by the Free Software Foundation; either
8    version 2.1 of the License, or (at your option) any later version.
9    
10    This library is distributed in the hope that it will be useful,
11    but WITHOUT ANY WARRANTY; without even the implied warranty of
12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13    Lesser General Public License for more details.
14    
15    You should have received a copy of the GNU Lesser General Public
16    License along with this library; if not, write to the Free Software
17    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
18*)
19
20structure Universal :>
21
22sig
23  type universal
24  type 'a tag
25  
26  val tag : unit -> 'a tag
27  
28  val tagIs      : 'a tag -> universal -> bool
29  val tagInject  : 'a tag -> 'a -> universal
30  val tagProject : 'a tag -> universal -> 'a
31  
32end =
33
34
35struct
36
37    (* The universal type is based on exn which provides a tagged union.
38       We use opaque signature matching to create a different type. *)
39    type universal = exn
40
41    type 'a tag =
42      { 
43        is:      universal -> bool,
44        inject: 'a -> universal,
45        project: universal -> 'a
46      };
47
48    (* The Match exception is created in the General structure in the basis
49       library which hasn't been built yet. *)  
50    fun tag () : 'a tag =
51    let
52      exception E of 'a;
53    in
54      { 
55        inject  = fn x => E x,
56        project = fn E x => x    | _ => raise RunCall.Match,
57        is      = fn E _ => true | _ => false
58      }
59    end ;
60
61    val tagIs      : 'a tag -> universal -> bool  = #is
62    val tagInject  : 'a tag -> 'a -> universal    = #inject
63    val tagProject : 'a tag -> universal -> 'a    = #project
64  
65end;
66
67(*
68This code will test the above structure
69
70
71datatype t = T of int ;
72datatype x = X of string ;
73
74val {is=ist,inject=injectT:t->universal,project=projectT} = tag();
75val {is=isx,inject=injectX:x->universal,project=projectX} = tag();
76
77val a = injectT (T 42) ;
78val b = injectT (T 24) ;
79val c = injectX (X "hello") ;
80val d = injectX (X "mike") ;
81
82map ist [a,b,c,d] ;
83map isx [a,b,c,d] ;
84
85projectT a ;
86projectT b ;
87projectT c ;
88projectT d ;
89
90projectX a ;
91projectX b ;
92projectX c ;
93projectX d ;
94*)
95
96