Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2017 Matthew Fluet. |
2 | * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh | |
3 | * Jagannathan, and Stephen Weeks. | |
4 | * Copyright (C) 1997-2000 NEC Research Institute. | |
5 | * | |
6 | * MLton is released under a BSD-style license. | |
7 | * See the file MLton-LICENSE for details. | |
8 | *) | |
9 | ||
10 | (* empty tuple is also a record *) | |
11 | ||
12 | functor Record (S: RECORD_STRUCTS): RECORD = | |
13 | struct | |
14 | ||
15 | open S | |
16 | ||
17 | datatype 'a t = | |
18 | Tuple of 'a vector | |
19 | | Record of (Field.t * 'a) vector | |
20 | ||
21 | val tuple = Tuple | |
22 | ||
23 | fun toVector r = | |
24 | case r of | |
25 | Tuple v => Vector.mapi (v, fn (i, x) => (Field.Int i, x)) | |
26 | | Record r => r | |
27 | ||
28 | fun detupleOpt (r: 'a t): 'a vector option = | |
29 | case r of | |
30 | Tuple t => SOME t | |
31 | | Record _ => NONE | |
32 | ||
33 | fun sort v = | |
34 | QuickSort.sortVector (v, fn ((s, _), (s', _)) => Field.<= (s, s')) | |
35 | ||
36 | fun fromVector v = | |
37 | let | |
38 | fun isTuple v : bool = | |
39 | Vector.foralli | |
40 | (v, fn (i, (f, _)) => | |
41 | case f of | |
42 | Field.Int i' => Int.equals (i, i') | |
43 | | _ => false) | |
44 | val v = if isSorted then sort v else v | |
45 | in | |
46 | if isTuple v andalso Vector.length v <> 1 | |
47 | then Tuple (Vector.map (v, #2)) | |
48 | else Record v | |
49 | end | |
50 | ||
51 | fun unzip r = Vector.unzip (toVector r) | |
52 | fun zip z = fromVector (Vector.zip z) | |
53 | ||
54 | val peek: 'a t * Field.t -> 'a option = | |
55 | fn (r, f) => | |
56 | case r of | |
57 | Record r => | |
58 | (case Vector.peek (r, fn (f', _) => Field.equals (f, f')) of | |
59 | NONE => NONE | |
60 | | SOME (_, x) => SOME x) | |
61 | | Tuple t => | |
62 | if Vector.isEmpty t | |
63 | then NONE | |
64 | else (case f of | |
65 | Field.Int i => | |
66 | if 0 <= i andalso i < Vector.length t | |
67 | then SOME (Vector.sub (t, i)) | |
68 | else NONE | |
69 | | Field.Symbol _ => NONE) | |
70 | ||
71 | fun domain r = | |
72 | case r of | |
73 | Tuple v => Vector.mapi (v, fn (i, _) => Field.Int i) | |
74 | | Record r => Vector.map (r, #1) | |
75 | ||
76 | fun range r = | |
77 | case r of | |
78 | Tuple t => t | |
79 | | Record r => Vector.map (r, #2) | |
80 | ||
81 | fun exists (r, p) = | |
82 | case r of | |
83 | Tuple xs => Vector.exists (xs, p) | |
84 | | Record r => Vector.exists (r, fn (_, x) => p x) | |
85 | ||
86 | fun forall (r, p) = not (exists (r, not o p)) | |
87 | ||
88 | fun fold (r: 'a t, b: 'b, f: 'a * 'b -> 'b): 'b = | |
89 | case r of | |
90 | Tuple xs => Vector.fold (xs, b, f) | |
91 | | Record r => Vector.fold (r, b, fn ((_, x), b) => f (x, b)) | |
92 | ||
93 | fun map (r: 'a t, f: 'a -> 'b): 'b t = | |
94 | case r of | |
95 | Tuple xs => Tuple (Vector.map (xs, f)) | |
96 | | Record r => Record (Vector.map (r, fn (field, a) => (field, f a))) | |
97 | ||
98 | fun foreach (r: 'a t, f: 'a -> unit): unit = | |
99 | case r of | |
100 | Tuple xs => Vector.foreach (xs, f) | |
101 | | Record r => Vector.foreach (r, f o #2) | |
102 | ||
103 | fun change (r: 'a t, f: 'a vector -> 'b vector * 'c): 'b t * 'c = | |
104 | case r of | |
105 | Tuple xs => let val (ys, c) = f xs | |
106 | in (Tuple ys, c) | |
107 | end | |
108 | | Record r => let val (fs, xs) = Vector.unzip r | |
109 | val (ys, c) = f xs | |
110 | in (Record (Vector.zip (fs, ys)), c) | |
111 | end | |
112 | ||
113 | fun layout {record, layoutTuple, separator, extra, layoutElt} = | |
114 | case (record, extra) of | |
115 | (Tuple xs, "") => layoutTuple xs | |
116 | | _ => | |
117 | let | |
118 | val r = toVector record | |
119 | open Layout | |
120 | in seq [str "{", | |
121 | mayAlign (separateRight (Vector.toListMap | |
122 | (r, fn (f, x) => | |
123 | seq [Field.layout f, | |
124 | str separator, | |
125 | layoutElt x]), | |
126 | ",")), | |
127 | str extra, | |
128 | str "}"] | |
129 | end | |
130 | ||
131 | end |