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