Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh |
2 | * Jagannathan, and Stephen Weeks. | |
3 | * | |
4 | * MLton is released under a BSD-style license. | |
5 | * See the file MLton-LICENSE for details. | |
6 | *) | |
7 | ||
8 | structure IntermediateComputation: INTERMEDIATE_COMPUTATION = | |
9 | struct | |
10 | ||
11 | structure In = In0 | |
12 | structure Int = Pervasive.Int | |
13 | ||
14 | structure Result = | |
15 | struct | |
16 | datatype t = | |
17 | Raise | |
18 | | Return of unit -> Layout.t | |
19 | ||
20 | local open Layout | |
21 | in | |
22 | fun layout r = | |
23 | case r of | |
24 | Raise => str "raise" | |
25 | | Return f => f() | |
26 | end | |
27 | end | |
28 | ||
29 | structure Computation = | |
30 | struct | |
31 | structure Time = Time | |
32 | ||
33 | datatype t = T of callResult list | |
34 | withtype callResult = {name: string, | |
35 | layoutArg: unit -> Layout.t, | |
36 | time: Time.t option, | |
37 | body: t, | |
38 | result: Result.t} | |
39 | ||
40 | structure CR = | |
41 | struct | |
42 | open Layout | |
43 | ||
44 | type t = callResult | |
45 | ||
46 | fun layoutName({name, ...}:t) = str(name ^ " ") | |
47 | ||
48 | fun layoutCall(cr as {layoutArg, ...}:t) = | |
49 | seq[layoutName cr, layoutArg()] | |
50 | ||
51 | val darrow = str "==> " | |
52 | ||
53 | fun layoutDarrow _ = darrow | |
54 | ||
55 | fun layoutTime({time, ...}:t) = | |
56 | case time of | |
57 | SOME t => Time.layout t | |
58 | | NONE => empty | |
59 | ||
60 | fun layoutReturn({result, ...}:t) = | |
61 | seq[darrow, Result.layout result] | |
62 | end | |
63 | ||
64 | fun time(T crs) = List.fold(crs, Time.zero, fn ({time, ...}, t) => | |
65 | case time of | |
66 | NONE => t | |
67 | | SOME t' => Time.+(t, t')) | |
68 | ||
69 | fun keepAll(c, pred) = | |
70 | let | |
71 | fun keepAll(T crs) = | |
72 | T(List.foldr(crs, [], | |
73 | fn ({name, body, layoutArg, time, result}, crs) => | |
74 | let val body as T crs' = keepAll body | |
75 | in if pred name | |
76 | then {name = name, body = body, | |
77 | layoutArg = layoutArg, time = time, | |
78 | result = result} :: crs | |
79 | else crs' @ crs | |
80 | end)) | |
81 | in keepAll c | |
82 | end | |
83 | ||
84 | fun makeOutputs(pre, post, filter) out = | |
85 | let val indentation = ref 0 | |
86 | val space = 3 | |
87 | fun left() = indentation := !indentation - space | |
88 | fun right() = indentation := !indentation + space | |
89 | fun print l = (Layout.output(Layout.indent(l, !indentation), out) | |
90 | ; Out.newline out) | |
91 | fun output(T crs) = List.foreach(crs, outputCr) | |
92 | and outputCr(cr as {body, ...}) = | |
93 | let val printCr = filter cr | |
94 | in if printCr | |
95 | then (print(pre cr); right()) | |
96 | else () | |
97 | ; output body | |
98 | ; if printCr then (left(); print(post cr)) else () | |
99 | end | |
100 | in (output, outputCr) | |
101 | end | |
102 | ||
103 | val makeOutput = | |
104 | makeOutputs(CR.layoutCall, CR.layoutReturn, fn _ => true) | |
105 | fun output(c, out) = #1(makeOutput out) c | |
106 | fun outputCr(cr, out) = #2(makeOutput out) cr | |
107 | ||
108 | val makeOutputCalls = | |
109 | makeOutputs(CR.layoutName, CR.layoutDarrow, fn _ => true) | |
110 | fun outputCalls(c, out) = #1(makeOutputCalls out) c | |
111 | fun outputCrCalls(cr, out) = #2(makeOutputCalls out) cr | |
112 | ||
113 | fun outputTimes(c, out) = | |
114 | #1(makeOutputs(CR.layoutName, CR.layoutTime, | |
115 | fn {time, ...} => | |
116 | case time of | |
117 | NONE => false | |
118 | | SOME _ => true) out) c | |
119 | ||
120 | local | |
121 | val out = Out.error | |
122 | val print = Out.outputc out | |
123 | ||
124 | structure Int = | |
125 | struct | |
126 | open Int | |
127 | ||
128 | exception Input | |
129 | fun input i = (In.ignoreSpaces i | |
130 | ; (case fromString(In.inputToSpace i) of | |
131 | NONE => raise Input | |
132 | | SOME n => n)) | |
133 | ||
134 | fun inputBetween{ins, error: unit -> unit, min, max} = | |
135 | let | |
136 | fun loop() = | |
137 | let fun continue() = (error() ; loop()) | |
138 | in let val n = input ins | |
139 | in if min <= n andalso n <= max | |
140 | then n | |
141 | else continue() | |
142 | end handle Input => continue() | |
143 | end | |
144 | in loop() | |
145 | end | |
146 | ||
147 | val layout = Layout.str o toString | |
148 | end | |
149 | ||
150 | fun inputBetween(min, max) = | |
151 | Int.inputBetween{ins = In.standard, | |
152 | error = fn () => Out.output(out, "? "), | |
153 | min = min, max = max} | |
154 | ||
155 | fun choose (choices: (string * 'a) list): 'a = | |
156 | let | |
157 | val n = | |
158 | List.fold(choices, 0, fn ((name, _),n) => | |
159 | (Layout.output(Int.layout n, out) | |
160 | ; print(concat[". ", name, "\n"]) | |
161 | ; n+1)) | |
162 | val _ = Out.output(out, "? ") | |
163 | val m = inputBetween(0,n-1) | |
164 | in #2(List.nth(choices, m)) | |
165 | end | |
166 | ||
167 | fun chooseThunk cs = choose cs () | |
168 | ||
169 | exception Quit | |
170 | exception Back | |
171 | ||
172 | val standardChoices = [("quit", fn () => raise Quit), | |
173 | ("back", fn () => raise Back)] | |
174 | ||
175 | fun inspect(c as T crs) = | |
176 | case crs of | |
177 | [cr] => inspectCr cr | |
178 | | _ => | |
179 | let | |
180 | fun loop() = | |
181 | (chooseThunk | |
182 | (standardChoices | |
183 | @ [("skip raises", fn () => | |
184 | (skipRaises c; raise Back)), | |
185 | ("output", fn () => output(c, out)), | |
186 | ("output calls", | |
187 | fn () => outputCalls(c, out))] | |
188 | @ choices c) | |
189 | ; loop()) | |
190 | in loop() handle Back => () | |
191 | end | |
192 | and choices(T crs) = | |
193 | List.map(crs, fn cr as {name, ...} => | |
194 | (" " ^ name, fn () => inspectCr cr)) | |
195 | and inspectCr(cr as {name, layoutArg, body, result, time = _}) = | |
196 | (print(concat["Call to ", name, "\n"]) | |
197 | ; let | |
198 | fun loop() = | |
199 | (chooseThunk | |
200 | (standardChoices | |
201 | @ [("skip raises", fn () => | |
202 | (skipRaisesCr cr; raise Back)), | |
203 | ("output", fn () => | |
204 | outputCr(cr, out)), | |
205 | ("output calls", fn () => | |
206 | outputCrCalls(cr, out)), | |
207 | ("argument", fn () => | |
208 | (Layout.output(layoutArg(), out) | |
209 | ; Out.newline out)), | |
210 | ("result", fn () => | |
211 | (Layout.output(Result.layout result, out) | |
212 | ; Out.newline out))] | |
213 | @ choices body) | |
214 | ; loop()) | |
215 | in loop() handle Back => () | |
216 | end) | |
217 | and skipRaises(c as T crs) = | |
218 | case crs of | |
219 | [] => () | |
220 | | _ => (skipRaisesCr(List.last crs) | |
221 | ; inspect c) | |
222 | and skipRaisesCr(cr as {result, body, ...}) = | |
223 | (case result of | |
224 | Result.Raise => skipRaises body | |
225 | | Result.Return _ => () | |
226 | ; inspectCr cr) | |
227 | in val inspect = fn c => inspect c handle Quit => () | |
228 | end | |
229 | ||
230 | end | |
231 | ||
232 | (*---------------------------------------------------*) | |
233 | (* Main Datatype *) | |
234 | (*---------------------------------------------------*) | |
235 | ||
236 | datatype t = | |
237 | T of {calls: {name: string, | |
238 | layoutArg: unit -> Layout.t, | |
239 | prev: Computation.callResult list} list ref, | |
240 | after: Computation.callResult list ref} | |
241 | ||
242 | fun empty() = T{calls = ref [], | |
243 | after = ref []} | |
244 | ||
245 | fun atTopLevel(T{calls, ...}) = List.isEmpty(!calls) | |
246 | ||
247 | fun call(T{calls, after},name, layoutArg) = | |
248 | (List.push(calls, {name = name, layoutArg = layoutArg, prev = !after}) | |
249 | ; after := []) | |
250 | ||
251 | fun return(T{calls, after}, result, time) = | |
252 | case !calls of | |
253 | [] => Error.bug "IntermediateComputation.return: without a call" | |
254 | | {name, layoutArg, prev} :: cs => | |
255 | (calls := cs | |
256 | ; after := {name = name, layoutArg = layoutArg, | |
257 | result = result, time = time, | |
258 | body = Computation.T(List.rev(!after))} :: prev) | |
259 | ||
260 | fun raisee(c, t) = return(c, Result.Raise, t) | |
261 | val return = fn (c, r, t) => return(c, Result.Return r, t) | |
262 | ||
263 | fun finish(c as T{calls, after}) = | |
264 | let | |
265 | fun loop() = | |
266 | case !calls of | |
267 | [] => Computation.T(List.rev(!after)) | |
268 | | _ => (raisee(c, NONE); loop()) | |
269 | in loop() | |
270 | end | |
271 | ||
272 | end |