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