1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
|
exception Unreachable and Unimplemented
fun $ (x, y) = x y
infixr 0 $
fun assert truth = if not truth then raise Unreachable else ()
(* All global values which computations may raise an exception must be
* wrapped in lazy, so that no exception is thrown before custom
* top-level handler is set.
*)
fun lazy thunk =
let
datatype 'a value =
Unevaluated of unit -> 'a |
Evaluated of 'a |
Exn of exn
val value = ref $ Unevaluated thunk
in
fn () =>
case !value of
Unevaluated th =>
let
val x = th () handle e => (value := Exn e; raise e)
in
value := Evaluated x;
x
end
| Evaluated v => v
| Exn e => raise e
end
structure Fold = struct
fun fold (a, f) g = g (a, f)
fun step0 h (a, f) = fold (h a, f)
fun step1 h (a, f) b = fold (h (b, a), f)
fun step2 h (a, f) b c = fold (h (b, c, a), f)
fun step3 h (a, f) b c d = fold (h (b, c, d, a), f)
fun step4 h (a, f) b c d e = fold (h (b, c, d, e, a), f)
end
structure FRU = struct
fun next g (f, z) x = g (f x, z)
fun f1 (f, z) x = f (z x)
fun f2 z = next f1 z
fun f3 z = next f2 z
fun f4 z = next f3 z
fun f5 z = next f4 z
fun f6 z = next f5 z
fun f7 z = next f6 z
fun f8 z = next f7 z
fun f9 z = next f8 z
fun c0 from = from
fun c1 from = c0 from f1
fun c2 from = c1 from f2
fun c3 from = c2 from f3
fun c4 from = c3 from f4
fun c5 from = c4 from f5
fun c6 from = c5 from f6
fun c7 from = c6 from f7
fun c8 from = c7 from f8
fun c9 from = c8 from f9
fun makeUpdate cX (from, from', to) record =
let
fun ops () = cX from'
fun vars f = to f record
in
Fold.fold ((vars, ops), fn (vars, _) => vars from)
end
fun makeUpdate0 z = makeUpdate c0 z
fun makeUpdate1 z = makeUpdate c1 z
fun makeUpdate2 z = makeUpdate c2 z
fun makeUpdate3 z = makeUpdate c3 z
fun makeUpdate4 z = makeUpdate c4 z
fun makeUpdate5 z = makeUpdate c5 z
fun makeUpdate6 z = makeUpdate c6 z
fun makeUpdate7 z = makeUpdate c7 z
fun makeUpdate8 z = makeUpdate c8 z
fun makeUpdate9 z = makeUpdate c9 z
fun upd z = Fold.step2
(fn (s, f, (vars, ops)) =>
(fn out => vars (s (ops ()) (out, f)), ops)) z
fun set z = Fold.step2
(fn (s, v, (vars, ops)) =>
(fn out => vars (s (ops ()) (out, fn _ => v)), ops)) z
fun set2 s v = Fold.step0
(fn (vars, ops) => (fn out => vars (s (ops ()) (out, fn _ => v)), ops))
fun upd2 s f = Fold.step0
(fn (vars, ops) => (fn out => vars (s (ops ()) (out, f)), ops))
end
fun % (a, f) = f a
val s = FRU.set
val u = FRU.upd
fun sysExit code = Posix.Process.exit $ Word8.fromInt code
fun exit code = (
TextIO.closeOut TextIO.stdOut;
TextIO.closeOut TextIO.stdErr;
sysExit code
)
fun output stream s = TextIO.output (stream, s)
fun makePrintfBase output =
let
val firstOnLine = ref true
fun endsWithNL "" = raise Unreachable
| endsWithNL s = String.sub (s, size s - 1) = #"\n"
fun output' "" = ()
| output' s = (
output s;
firstOnLine := endsWithNL s
)
fun mf () =
if not $ !firstOnLine then
(output "\n"; firstOnLine := true)
else
()
in
(output', mf)
end
type 'a acc = (string -> unit) * 'a
local
val ctx = ((false, makePrintfBase $ output TextIO.stdOut),
fn (_: bool * ((string -> unit) * (unit -> unit))) => ())
in
fun printf g = Fold.fold ctx g
end
fun sprintf g =
let
val buf = ref []
fun output s = buf := s :: !buf
fun finish _ = String.concat $ rev $ !buf
in
Fold.fold ((false, makePrintfBase output), finish)
end g
fun Printf out g = Fold.fold ((false, out), fn _ => ()) g
local
fun ifF flag cl = if not flag then cl () else ()
in
fun ` z = Fold.step1 (fn (s, (ign, out as (output, _))) =>
(ifF ign (fn () => output s); (ign, out))) z
fun A0 z = Fold.step1 (fn (f, (ign, out)) =>
(ifF ign (fn () => f out); (ign, out))) z
fun A1 z = Fold.step2 (fn (f, v, (ign, out)) =>
(ifF ign (fn () => f v out); (ign, out))) z
fun A2 z = Fold.step3 (fn (f, v1, v2, (ign, out)) =>
(ifF ign (fn () => f v1 v2 out); (ign, out))) z
fun A3 z = Fold.step4 (fn (f, v1, v2, v3, (ign, out)) =>
(ifF ign (fn () => f v1 v2 v3 out); (ign, out))) z
end
fun Ign z = Fold.step0 (fn (_, out) => (true, out)) z
fun bind A f = fn z => Fold.fold z A f
fun bindWith2str to = bind A1 (fn v => fn (output, _) => output $ to v)
fun F z = bind A0 (fn (_, mf) => mf ()) z
val I = fn z => bindWith2str Int.toString z
val C = fn z => bindWith2str str z
val B = fn z => bindWith2str Bool.toString z
val R = fn z => bind A1 (fn n => fn (output, _) => app (fn f => f ())
(List.tabulate (n, fn _ => fn () => output " "))) z
type ('t, 'a, 'b, 'c) a1printer = (bool * ((string -> unit) * 'a)) * 'b
-> 't -> ((bool * ((string -> unit) * 'a)) * 'b -> 'c) -> 'c
type ('t1, 't2, 'a, 'b, 'c) a2printer =
(bool * ((string -> unit) * 'a)) * 'b -> 't1 -> 't2 ->
((bool * ((string -> unit) * 'a)) * 'b -> 'c) -> 'c
fun popt p v out =
case v of
NONE => Printf out `"none" %
| SOME v => Printf out A1 p v %
val Popt = fn z => bind A2 popt z
fun plist p l (s, parens) out =
let
fun f [] _ = ()
| f [e] out = Printf out A1 p e %
| f (e1 :: e2 :: tail) out =
(Printf out A1 p e1 %; Printf out `s A1 f (e2 :: tail) %)
in
if parens andalso length l > 1 then
Printf out `"(" A1 f l `")" %
else
Printf out A1 f l %
end
val Plist = fn z => bind A3 plist z
fun die code g =
let
fun finish (true, _) = raise Unreachable
| finish (false, (output, _)) = (
output "\n";
exit code
)
in
printf `"error: " (fn (a, _) => g (a, finish))
end
|
