1(* ========================================================================= *) 2(* PRESERVING SHARING OF ML VALUES *) 3(* Copyright (c) 2005 Joe Hurd, distributed under the BSD License *) 4(* ========================================================================= *) 5 6structure Sharing :> Sharing = 7struct 8 9infix == 10 11val op== = Portable.pointerEqual; 12 13(* ------------------------------------------------------------------------- *) 14(* Option operations. *) 15(* ------------------------------------------------------------------------- *) 16 17fun mapOption f xo = 18 case xo of 19 SOME x => 20 let 21 val y = f x 22 in 23 if x == y then xo else SOME y 24 end 25 | NONE => xo; 26 27fun mapsOption f xo acc = 28 case xo of 29 SOME x => 30 let 31 val (y,acc) = f x acc 32 in 33 if x == y then (xo,acc) else (SOME y, acc) 34 end 35 | NONE => (xo,acc); 36 37(* ------------------------------------------------------------------------- *) 38(* List operations. *) 39(* ------------------------------------------------------------------------- *) 40 41fun map f = 42 let 43 fun m ys ys_xs xs = 44 case xs of 45 [] => List.revAppend ys_xs 46 | x :: xs => 47 let 48 val y = f x 49 val ys = y :: ys 50 val ys_xs = if x == y then ys_xs else (ys,xs) 51 in 52 m ys ys_xs xs 53 end 54 in 55 fn xs => m [] ([],xs) xs 56 end; 57 58fun maps f = 59 let 60 fun m acc ys ys_xs xs = 61 case xs of 62 [] => (List.revAppend ys_xs, acc) 63 | x :: xs => 64 let 65 val (y,acc) = f x acc 66 val ys = y :: ys 67 val ys_xs = if x == y then ys_xs else (ys,xs) 68 in 69 m acc ys ys_xs xs 70 end 71 in 72 fn xs => fn acc => m acc [] ([],xs) xs 73 end; 74 75local 76 fun revTails acc xs = 77 case xs of 78 [] => acc 79 | x :: xs' => revTails ((x,xs) :: acc) xs'; 80in 81 fun revMap f = 82 let 83 fun m ys same xxss = 84 case xxss of 85 [] => ys 86 | (x,xs) :: xxss => 87 let 88 val y = f x 89 val same = same andalso x == y 90 val ys = if same then xs else y :: ys 91 in 92 m ys same xxss 93 end 94 in 95 fn xs => m [] true (revTails [] xs) 96 end; 97 98 fun revMaps f = 99 let 100 fun m acc ys same xxss = 101 case xxss of 102 [] => (ys,acc) 103 | (x,xs) :: xxss => 104 let 105 val (y,acc) = f x acc 106 val same = same andalso x == y 107 val ys = if same then xs else y :: ys 108 in 109 m acc ys same xxss 110 end 111 in 112 fn xs => fn acc => m acc [] true (revTails [] xs) 113 end; 114end; 115 116fun updateNth (n,x) l = 117 let 118 val (a,b) = Useful.revDivide l n 119 in 120 case b of 121 [] => raise Subscript 122 | h :: t => if x == h then l else List.revAppend (a, x :: t) 123 end; 124 125fun setify l = 126 let 127 val l' = Useful.setify l 128 in 129 if length l' = length l then l else l' 130 end; 131 132(* ------------------------------------------------------------------------- *) 133(* Function caching. *) 134(* ------------------------------------------------------------------------- *) 135 136fun cache cmp f = 137 let 138 val cache = ref (Map.new cmp) 139 in 140 fn a => 141 case Map.peek (!cache) a of 142 SOME b => b 143 | NONE => 144 let 145 val b = f a 146 val () = cache := Map.insert (!cache) (a,b) 147 in 148 b 149 end 150 end; 151 152(* ------------------------------------------------------------------------- *) 153(* Hash consing. *) 154(* ------------------------------------------------------------------------- *) 155 156fun hashCons cmp = cache cmp Useful.I; 157 158end 159