Mercurial > urweb

annotate src/mono_util.sml @ 1932:98895243b5b6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Change handling of returned text blobs, to activate the normal EWrite optimizations
author Adam Chlipala <adam@chlipala.net>
date Wed, 11 Dec 2013 18:22:10 -0500
parents e15234fbb163
children f7113855f3b7
rev   line source
adam@1847 1 (* Copyright (c) 2008, 2013, Adam Chlipala
adamc@26 2 * All rights reserved.
adamc@26 3 *
adamc@26 4 * Redistribution and use in source and binary forms, with or without
adamc@26 5 * modification, are permitted provided that the following conditions are met:
adamc@26 6 *
adamc@26 7 * - Redistributions of source code must retain the above copyright notice,
adamc@26 8 * this list of conditions and the following disclaimer.
adamc@26 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@26 10 * this list of conditions and the following disclaimer in the documentation
adamc@26 11 * and/or other materials provided with the distribution.
adamc@26 12 * - The names of contributors may not be used to endorse or promote products
adamc@26 13 * derived from this software without specific prior written permission.
adamc@26 14 *
adamc@26 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@26 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@26 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@26 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@26 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@26 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@26 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@26 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@26 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@26 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@26 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@26 26 *)
adamc@26 27
adamc@26 28 structure MonoUtil :> MONO_UTIL = struct
adamc@26 29
adamc@26 30 open Mono
adamc@26 31
adamc@26 32 structure S = Search
adamc@26 33
adamc@267 34 val dummyt = (TRecord [], ErrorMsg.dummySpan)
adamc@267 35
adamc@26 36 structure Typ = struct
adamc@26 37
adamc@193 38 open Order
adamc@109 39
adamc@109 40 fun compare ((t1, _), (t2, _)) =
adamc@109 41 case (t1, t2) of
adamc@109 42 (TFun (d1, r1), TFun (d2, r2)) =>
adamc@109 43 join (compare (d1, d2), fn () => compare (r1, r2))
adamc@109 44 | (TRecord xts1, TRecord xts2) =>
adamc@109 45 let
adamc@109 46 val xts1 = sortFields xts1
adamc@109 47 val xts2 = sortFields xts2
adamc@109 48 in
adamc@109 49 joinL compareFields (xts1, xts2)
adamc@109 50 end
adamc@196 51 | (TDatatype (n1, _), TDatatype (n2, _)) => Int.compare (n1, n2)
adamc@109 52 | (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2))
adamc@288 53 | (TOption t1, TOption t2) => compare (t1, t2)
adamc@757 54 | (TList t1, TList t2) => compare (t1, t2)
adamc@577 55 | (TSource, TSource) => EQUAL
adamc@568 56 | (TSignal t1, TSignal t2) => compare (t1, t2)
adamc@109 57
adamc@109 58 | (TFun _, _) => LESS
adamc@109 59 | (_, TFun _) => GREATER
adamc@109 60
adamc@109 61 | (TRecord _, _) => LESS
adamc@109 62 | (_, TRecord _) => GREATER
adamc@109 63
adamc@168 64 | (TDatatype _, _) => LESS
adamc@168 65 | (_, TDatatype _) => GREATER
adamc@109 66
adamc@288 67 | (TFfi _, _) => LESS
adamc@288 68 | (_, TFfi _) => GREATER
adamc@288 69
adamc@568 70 | (TOption _, _) => LESS
adamc@568 71 | (_, TOption _) => GREATER
adamc@568 72
adamc@757 73 | (TList _, _) => LESS
adamc@757 74 | (_, TList _) => GREATER
adamc@757 75
adamc@577 76 | (TSource, _) => LESS
adamc@577 77 | (_, TSource) => GREATER
adamc@577 78
adamc@109 79 and compareFields ((x1, t1), (x2, t2)) =
adamc@109 80 join (String.compare (x1, x2),
adamc@109 81 fn () => compare (t1, t2))
adamc@109 82
adam@1314 83 and sortFields xts = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) xts
adamc@109 84
adamc@26 85 fun mapfold fc =
adamc@26 86 let
adamc@26 87 fun mft c acc =
adamc@26 88 S.bindP (mft' c acc, fc)
adamc@26 89
adamc@26 90 and mft' (cAll as (c, loc)) =
adamc@26 91 case c of
adamc@26 92 TFun (t1, t2) =>
adamc@26 93 S.bind2 (mft t1,
adamc@26 94 fn t1' =>
adamc@26 95 S.map2 (mft t2,
adamc@26 96 fn t2' =>
adamc@26 97 (TFun (t1', t2'), loc)))
adamc@26 98 | TRecord xts =>
adamc@26 99 S.map2 (ListUtil.mapfold (fn (x, t) =>
adamc@26 100 S.map2 (mft t,
adamc@26 101 fn t' =>
adamc@26 102 (x, t')))
adamc@26 103 xts,
adamc@26 104 fn xts' => (TRecord xts', loc))
adamc@168 105 | TDatatype _ => S.return2 cAll
adamc@51 106 | TFfi _ => S.return2 cAll
adamc@288 107 | TOption t =>
adamc@288 108 S.map2 (mft t,
adamc@288 109 fn t' =>
adamc@288 110 (TOption t, loc))
adamc@757 111 | TList t =>
adamc@757 112 S.map2 (mft t,
adamc@757 113 fn t' =>
adamc@757 114 (TList t, loc))
adamc@577 115 | TSource => S.return2 cAll
adamc@568 116 | TSignal t =>
adamc@568 117 S.map2 (mft t,
adamc@568 118 fn t' =>
adamc@568 119 (TSignal t, loc))
adamc@26 120 in
adamc@26 121 mft
adamc@26 122 end
adamc@26 123
adamc@26 124 fun map typ c =
adamc@26 125 case mapfold (fn c => fn () => S.Continue (typ c, ())) c () of
adamc@26 126 S.Return () => raise Fail "Mono_util.Typ.map"
adamc@26 127 | S.Continue (c, ()) => c
adamc@26 128
adamc@26 129 fun fold typ s c =
adamc@26 130 case mapfold (fn c => fn s => S.Continue (c, typ (c, s))) c s of
adamc@26 131 S.Continue (_, s) => s
adamc@26 132 | S.Return _ => raise Fail "MonoUtil.Typ.fold: Impossible"
adamc@26 133
adamc@26 134 fun exists typ k =
adamc@26 135 case mapfold (fn c => fn () =>
adamc@26 136 if typ c then
adamc@26 137 S.Return ()
adamc@26 138 else
adamc@26 139 S.Continue (c, ())) k () of
adamc@26 140 S.Return _ => true
adamc@26 141 | S.Continue _ => false
adamc@26 142
adamc@26 143 end
adamc@26 144
adamc@26 145 structure Exp = struct
adamc@26 146
adamc@26 147 datatype binder =
adamc@168 148 Datatype of string * int * (string * int * typ option) list
adamc@26 149 | RelE of string * typ
adamc@109 150 | NamedE of string * int * typ * exp option * string
adamc@26 151
adamc@26 152 fun mapfoldB {typ = fc, exp = fe, bind} =
adamc@26 153 let
adamc@26 154 val mft = Typ.mapfold fc
adamc@26 155
adamc@26 156 fun mfe ctx e acc =
adamc@26 157 S.bindP (mfe' ctx e acc, fe ctx)
adamc@26 158
adam@1663 159 and mfet ctx (e, t) =
adam@1663 160 S.bind2 (mfe ctx e,
adam@1663 161 fn e' =>
adam@1663 162 S.map2 (mft t,
adam@1663 163 fn t' => (e', t')))
adam@1663 164
adamc@26 165 and mfe' ctx (eAll as (e, loc)) =
adamc@26 166 case e of
adamc@26 167 EPrim _ => S.return2 eAll
adamc@26 168 | ERel _ => S.return2 eAll
adamc@26 169 | ENamed _ => S.return2 eAll
adamc@188 170 | ECon (_, _, NONE) => S.return2 eAll
adamc@188 171 | ECon (dk, n, SOME e) =>
adamc@178 172 S.map2 (mfe ctx e,
adamc@178 173 fn e' =>
adamc@188 174 (ECon (dk, n, SOME e'), loc))
adamc@297 175 | ENone t =>
adamc@297 176 S.map2 (mft t,
adamc@297 177 fn t' =>
adamc@297 178 (ENone t', loc))
adamc@290 179 | ESome (t, e) =>
adamc@290 180 S.bind2 (mft t,
adamc@290 181 fn t' =>
adamc@290 182 S.map2 (mfe ctx e,
adamc@290 183 fn e' =>
adamc@290 184 (ESome (t', e'), loc)))
adamc@51 185 | EFfi _ => S.return2 eAll
adamc@51 186 | EFfiApp (m, x, es) =>
adam@1663 187 S.map2 (ListUtil.mapfold (fn e => mfet ctx e) es,
adamc@51 188 fn es' =>
adamc@51 189 (EFfiApp (m, x, es'), loc))
adamc@26 190 | EApp (e1, e2) =>
adamc@26 191 S.bind2 (mfe ctx e1,
adamc@26 192 fn e1' =>
adamc@26 193 S.map2 (mfe ctx e2,
adamc@26 194 fn e2' =>
adamc@26 195 (EApp (e1', e2'), loc)))
adamc@26 196 | EAbs (x, dom, ran, e) =>
adamc@26 197 S.bind2 (mft dom,
adamc@26 198 fn dom' =>
adamc@26 199 S.bind2 (mft ran,
adamc@26 200 fn ran' =>
adamc@26 201 S.map2 (mfe (bind (ctx, RelE (x, dom'))) e,
adamc@26 202 fn e' =>
adamc@26 203 (EAbs (x, dom', ran', e'), loc))))
adamc@26 204
adamc@387 205 | EUnop (s, e) =>
adamc@387 206 S.map2 (mfe ctx e,
adamc@387 207 fn e' =>
adamc@387 208 (EUnop (s, e'), loc))
adam@1360 209 | EBinop (bi, s, e1, e2) =>
adamc@387 210 S.bind2 (mfe ctx e1,
adamc@387 211 fn e1' =>
adamc@387 212 S.map2 (mfe ctx e2,
adamc@387 213 fn e2' =>
adam@1360 214 (EBinop (bi, s, e1', e2'), loc)))
adamc@387 215
adamc@26 216 | ERecord xes =>
adamc@29 217 S.map2 (ListUtil.mapfold (fn (x, e, t) =>
adamc@29 218 S.bind2 (mfe ctx e,
adamc@26 219 fn e' =>
adamc@29 220 S.map2 (mft t,
adamc@29 221 fn t' =>
adamc@29 222 (x, e', t'))))
adamc@26 223 xes,
adamc@26 224 fn xes' =>
adamc@26 225 (ERecord xes', loc))
adamc@26 226 | EField (e, x) =>
adamc@26 227 S.map2 (mfe ctx e,
adamc@26 228 fn e' =>
adamc@26 229 (EField (e', x), loc))
adamc@94 230
adamc@182 231 | ECase (e, pes, {disc, result}) =>
adamc@178 232 S.bind2 (mfe ctx e,
adamc@178 233 fn e' =>
adamc@178 234 S.bind2 (ListUtil.mapfold (fn (p, e) =>
adamc@179 235 let
adamc@179 236 fun pb ((p, _), ctx) =
adamc@179 237 case p of
adamc@179 238 PWild => ctx
adamc@182 239 | PVar (x, t) => bind (ctx, RelE (x, t))
adamc@179 240 | PPrim _ => ctx
adamc@188 241 | PCon (_, _, NONE) => ctx
adamc@188 242 | PCon (_, _, SOME p) => pb (p, ctx)
adamc@182 243 | PRecord xps => foldl (fn ((_, p, _), ctx) =>
adamc@179 244 pb (p, ctx)) ctx xps
adamc@288 245 | PNone _ => ctx
adamc@288 246 | PSome (_, p) => pb (p, ctx)
adamc@179 247 in
adamc@179 248 S.map2 (mfe (pb (p, ctx)) e,
adamc@179 249 fn e' => (p, e'))
adamc@179 250 end) pes,
adamc@178 251 fn pes' =>
adamc@182 252 S.bind2 (mft disc,
adamc@182 253 fn disc' =>
adamc@182 254 S.map2 (mft result,
adamc@182 255 fn result' =>
adamc@182 256 (ECase (e', pes', {disc = disc', result = result'}), loc)))))
adamc@178 257
adamc@283 258 | EError (e, t) =>
adamc@283 259 S.bind2 (mfe ctx e,
adamc@283 260 fn e' =>
adamc@283 261 S.map2 (mft t,
adamc@283 262 fn t' =>
adamc@283 263 (EError (e', t'), loc)))
adam@1932 264 | EReturnBlob {blob = NONE, mimeType, t} =>
adam@1932 265 S.bind2 (mfe ctx mimeType,
adam@1932 266 fn mimeType' =>
adam@1932 267 S.map2 (mft t,
adam@1932 268 fn t' =>
adam@1932 269 (EReturnBlob {blob = NONE, mimeType = mimeType', t = t'}, loc)))
adam@1932 270 | EReturnBlob {blob = SOME blob, mimeType, t} =>
adamc@741 271 S.bind2 (mfe ctx blob,
adamc@741 272 fn blob' =>
adamc@741 273 S.bind2 (mfe ctx mimeType,
adamc@741 274 fn mimeType' =>
adamc@741 275 S.map2 (mft t,
adamc@741 276 fn t' =>
adam@1932 277 (EReturnBlob {blob = SOME blob', mimeType = mimeType', t = t'}, loc))))
adamc@1065 278 | ERedirect (e, t) =>
adamc@1065 279 S.bind2 (mfe ctx e,
adamc@1065 280 fn e' =>
adamc@1065 281 S.map2 (mft t,
adamc@1065 282 fn t' =>
adamc@1065 283 (ERedirect (e', t'), loc)))
adamc@741 284
adamc@94 285 | EStrcat (e1, e2) =>
adamc@94 286 S.bind2 (mfe ctx e1,
adamc@94 287 fn e1' =>
adamc@94 288 S.map2 (mfe ctx e2,
adamc@94 289 fn e2' =>
adamc@94 290 (EStrcat (e1', e2'), loc)))
adamc@102 291
adamc@102 292 | EWrite e =>
adamc@102 293 S.map2 (mfe ctx e,
adamc@102 294 fn e' =>
adamc@102 295 (EWrite e', loc))
adamc@106 296
adamc@106 297 | ESeq (e1, e2) =>
adamc@106 298 S.bind2 (mfe ctx e1,
adamc@106 299 fn e1' =>
adamc@106 300 S.map2 (mfe ctx e2,
adamc@106 301 fn e2' =>
adamc@106 302 (ESeq (e1', e2'), loc)))
adamc@251 303 | ELet (x, t, e1, e2) =>
adamc@251 304 S.bind2 (mft t,
adamc@251 305 fn t' =>
adamc@251 306 S.bind2 (mfe ctx e1,
adamc@251 307 fn e1' =>
adamc@252 308 S.map2 (mfe (bind (ctx, RelE (x, t'))) e2,
adamc@251 309 fn e2' =>
adamc@251 310 (ELet (x, t', e1', e2'), loc))))
adamc@111 311
adamc@111 312 | EClosure (n, es) =>
adamc@111 313 S.map2 (ListUtil.mapfold (mfe ctx) es,
adamc@111 314 fn es' =>
adamc@111 315 (EClosure (n, es'), loc))
adamc@252 316
adamc@252 317 | EQuery {exps, tables, state, query, body, initial} =>
adamc@252 318 S.bind2 (ListUtil.mapfold (fn (x, t) =>
adamc@252 319 S.map2 (mft t,
adamc@252 320 fn t' => (x, t'))) exps,
adamc@252 321 fn exps' =>
adamc@252 322 S.bind2 (ListUtil.mapfold (fn (x, xts) =>
adamc@252 323 S.map2 (ListUtil.mapfold
adamc@252 324 (fn (x, t) =>
adamc@252 325 S.map2 (mft t,
adamc@252 326 fn t' => (x, t'))) xts,
adamc@252 327 fn xts' => (x, xts'))) tables,
adamc@252 328 fn tables' =>
adamc@252 329 S.bind2 (mft state,
adamc@252 330 fn state' =>
adamc@252 331 S.bind2 (mfe ctx query,
adamc@252 332 fn query' =>
adamc@267 333 S.bind2 (mfe (bind (bind (ctx, RelE ("r", dummyt)),
adamc@267 334 RelE ("acc", dummyt)))
adamc@267 335 body,
adamc@267 336 fn body' =>
adamc@267 337 S.map2 (mfe ctx initial,
adamc@267 338 fn initial' =>
adamc@267 339 (EQuery {exps = exps',
adamc@267 340 tables = tables',
adamc@267 341 state = state',
adamc@267 342 query = query',
adamc@267 343 body = body',
adamc@267 344 initial = initial'},
adamc@267 345 loc)))))))
adamc@307 346
adam@1293 347 | EDml (e, fm) =>
adamc@307 348 S.map2 (mfe ctx e,
adamc@307 349 fn e' =>
adam@1293 350 (EDml (e', fm), loc))
adamc@338 351 | ENextval e =>
adamc@338 352 S.map2 (mfe ctx e,
adamc@338 353 fn e' =>
adamc@338 354 (ENextval e', loc))
adamc@1073 355 | ESetval (e1, e2) =>
adamc@1073 356 S.bind2 (mfe ctx e1,
adamc@1073 357 fn e1' =>
adamc@1073 358 S.map2 (mfe ctx e2,
adamc@1073 359 fn e2' =>
adamc@1073 360 (ESetval (e1', e2'), loc)))
adamc@1112 361 | EUnurlify (e, t, b) =>
adamc@463 362 S.bind2 (mfe ctx e,
adamc@463 363 fn e' =>
adamc@463 364 S.map2 (mft t,
adamc@463 365 fn t' =>
adamc@1112 366 (EUnurlify (e', t', b), loc)))
adamc@815 367 | EJavaScript (m, e) =>
adamc@729 368 S.bind2 (mfmode ctx m,
adamc@729 369 fn m' =>
adamc@729 370 S.map2 (mfe ctx e,
adamc@729 371 fn e' =>
adamc@815 372 (EJavaScript (m', e'), loc)))
adamc@569 373
adamc@568 374 | ESignalReturn e =>
adamc@568 375 S.map2 (mfe ctx e,
adamc@568 376 fn e' =>
adamc@568 377 (ESignalReturn e', loc))
adamc@572 378 | ESignalBind (e1, e2) =>
adamc@572 379 S.bind2 (mfe ctx e1,
adamc@572 380 fn e1' =>
adamc@572 381 S.map2 (mfe ctx e2,
adamc@572 382 fn e2' =>
adamc@572 383 (ESignalBind (e1', e2'), loc)))
adamc@574 384 | ESignalSource e =>
adamc@574 385 S.map2 (mfe ctx e,
adamc@574 386 fn e' =>
adamc@574 387 (ESignalSource e', loc))
adamc@608 388
adam@1848 389 | EServerCall (s, t, eff, fm) =>
adamc@642 390 S.bind2 (mfe ctx s,
adamc@642 391 fn s' =>
adamc@1020 392 S.map2 (mft t,
adamc@1020 393 fn t' =>
adam@1848 394 (EServerCall (s', t', eff, fm), loc)))
adamc@1021 395 | ERecv (s, t) =>
adamc@670 396 S.bind2 (mfe ctx s,
adamc@695 397 fn s' =>
adamc@1021 398 S.map2 (mft t,
adamc@1021 399 fn t' =>
adamc@1021 400 (ERecv (s', t'), loc)))
adamc@1021 401 | ESleep s =>
adamc@1021 402 S.map2 (mfe ctx s,
adamc@695 403 fn s' =>
adamc@1021 404 (ESleep s', loc))
adamc@1021 405
adamc@1021 406 | ESpawn s =>
adamc@1021 407 S.map2 (mfe ctx s,
adamc@1021 408 fn s' =>
adamc@1021 409 (ESpawn s', loc))
adamc@729 410
adamc@729 411 and mfmode ctx mode =
adamc@729 412 case mode of
adamc@729 413 Attribute => S.return2 mode
adamc@729 414 | Script => S.return2 mode
adamc@729 415 | Source t =>
adamc@729 416 S.map2 (mft t,
adamc@729 417 fn t' => Source t')
adamc@26 418 in
adamc@26 419 mfe
adamc@26 420 end
adamc@26 421
adamc@26 422 fun mapfold {typ = fc, exp = fe} =
adamc@26 423 mapfoldB {typ = fc,
adamc@26 424 exp = fn () => fe,
adamc@26 425 bind = fn ((), _) => ()} ()
adamc@26 426
adamc@26 427 fun mapB {typ, exp, bind} ctx e =
adamc@26 428 case mapfoldB {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@26 429 exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()),
adamc@26 430 bind = bind} ctx e () of
adamc@26 431 S.Continue (e, ()) => e
adamc@26 432 | S.Return _ => raise Fail "MonoUtil.Exp.mapB: Impossible"
adamc@26 433
adamc@26 434 fun map {typ, exp} e =
adamc@26 435 case mapfold {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@26 436 exp = fn e => fn () => S.Continue (exp e, ())} e () of
adamc@26 437 S.Return () => raise Fail "Mono_util.Exp.map"
adamc@26 438 | S.Continue (e, ()) => e
adamc@26 439
adamc@26 440 fun fold {typ, exp} s e =
adamc@26 441 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
adamc@26 442 exp = fn e => fn s => S.Continue (e, exp (e, s))} e s of
adamc@26 443 S.Continue (_, s) => s
adamc@26 444 | S.Return _ => raise Fail "MonoUtil.Exp.fold: Impossible"
adamc@26 445
adamc@26 446 fun exists {typ, exp} k =
adamc@26 447 case mapfold {typ = fn c => fn () =>
adamc@26 448 if typ c then
adamc@26 449 S.Return ()
adamc@26 450 else
adamc@26 451 S.Continue (c, ()),
adamc@26 452 exp = fn e => fn () =>
adamc@26 453 if exp e then
adamc@26 454 S.Return ()
adamc@26 455 else
adamc@26 456 S.Continue (e, ())} k () of
adamc@26 457 S.Return _ => true
adamc@26 458 | S.Continue _ => false
adamc@26 459
adamc@919 460 fun existsB {typ, exp, bind} ctx e =
adamc@919 461 case mapfoldB {typ = fn t => fn () =>
adamc@919 462 if typ t then
adamc@919 463 S.Return ()
adamc@919 464 else
adamc@919 465 S.Continue (t, ()),
adamc@919 466 exp = fn ctx => fn e => fn () =>
adamc@919 467 if exp (ctx, e) then
adamc@919 468 S.Return ()
adamc@919 469 else
adamc@919 470 S.Continue (e, ()),
adamc@919 471 bind = bind} ctx e () of
adamc@919 472 S.Return _ => true
adamc@919 473 | S.Continue _ => false
adamc@919 474
adamc@567 475 fun foldB {typ, exp, bind} ctx s e =
adamc@567 476 case mapfoldB {typ = fn t => fn s => S.Continue (t, typ (t, s)),
adamc@567 477 exp = fn ctx => fn e => fn s => S.Continue (e, exp (ctx, e, s)),
adamc@567 478 bind = bind} ctx e s of
adamc@567 479 S.Continue (_, s) => s
adamc@567 480 | S.Return _ => raise Fail "MonoUtil.Exp.foldB: Impossible"
adamc@567 481
adam@1612 482 fun appLoc f =
adam@1612 483 let
adam@1612 484 fun appl e =
adam@1612 485 (f e;
adam@1612 486 case #1 e of
adam@1612 487 EPrim _ => ()
adam@1612 488 | ERel _ => ()
adam@1612 489 | ENamed _ => ()
adam@1612 490 | ECon (_, _, eo) => Option.app appl eo
adam@1612 491 | ENone _ => ()
adam@1612 492 | ESome (_, e) => appl e
adam@1612 493 | EFfi _ => ()
adam@1663 494 | EFfiApp (_, _, es) => app (appl o #1) es
adam@1612 495 | EApp (e1, e2) => (appl e1; appl e2)
adam@1612 496 | EAbs (_, _, _, e1) => appl e1
adam@1612 497 | EUnop (_, e1) => appl e1
adam@1612 498 | EBinop (_, _, e1, e2) => (appl e1; appl e2)
adam@1612 499 | ERecord xets => app (appl o #2) xets
adam@1612 500 | EField (e1, _) => appl e1
adam@1612 501 | ECase (e1, pes, _) => (appl e1; app (appl o #2) pes)
adam@1612 502 | EStrcat (e1, e2) => (appl e1; appl e2)
adam@1612 503 | EError (e1, _) => appl e1
adam@1932 504 | EReturnBlob {blob = NONE, mimeType = e2, ...} => appl e2
adam@1932 505 | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => (appl e1; appl e2)
adam@1612 506 | ERedirect (e1, _) => appl e1
adam@1612 507 | EWrite e1 => appl e1
adam@1612 508 | ESeq (e1, e2) => (appl e1; appl e2)
adam@1612 509 | ELet (_, _, e1, e2) => (appl e1; appl e2)
adam@1612 510 | EClosure (_, es) => app appl es
adam@1612 511 | EQuery {query = e1, body = e2, initial = e3, ...} => (appl e1; appl e2; appl e3)
adam@1612 512 | EDml (e1, _) => appl e1
adam@1612 513 | ENextval e1 => appl e1
adam@1612 514 | ESetval (e1, e2) => (appl e1; appl e2)
adam@1612 515 | EUnurlify (e1, _, _) => appl e1
adam@1612 516 | EJavaScript (_, e1) => appl e1
adam@1612 517 | ESignalReturn e1 => appl e1
adam@1612 518 | ESignalBind (e1, e2) => (appl e1; appl e2)
adam@1612 519 | ESignalSource e1 => appl e1
adam@1848 520 | EServerCall (e1, _, _, _) => appl e1
adam@1612 521 | ERecv (e1, _) => appl e1
adam@1612 522 | ESleep e1 => appl e1
adam@1612 523 | ESpawn e1 => appl e1)
adam@1612 524 in
adam@1612 525 appl
adam@1612 526 end
adam@1612 527
adamc@26 528 end
adamc@26 529
adamc@26 530 structure Decl = struct
adamc@26 531
adamc@26 532 datatype binder = datatype Exp.binder
adamc@26 533
adamc@26 534 fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
adamc@26 535 let
adamc@26 536 val mft = Typ.mapfold fc
adamc@26 537
adamc@26 538 val mfe = Exp.mapfoldB {typ = fc, exp = fe, bind = bind}
adamc@26 539
adamc@26 540 fun mfd ctx d acc =
adamc@26 541 S.bindP (mfd' ctx d acc, fd ctx)
adamc@26 542
adamc@26 543 and mfd' ctx (dAll as (d, loc)) =
adamc@26 544 case d of
adamc@808 545 DDatatype dts =>
adamc@808 546 S.map2 (ListUtil.mapfold (fn (x, n, xncs) =>
adamc@808 547 S.map2 (ListUtil.mapfold (fn (x, n, c) =>
adamc@808 548 case c of
adamc@808 549 NONE => S.return2 (x, n, c)
adamc@808 550 | SOME c =>
adamc@808 551 S.map2 (mft c,
adamc@808 552 fn c' => (x, n, SOME c'))) xncs,
adamc@808 553 fn xncs' => (x, n, xncs'))) dts,
adamc@808 554 fn dts' =>
adamc@808 555 (DDatatype dts', loc))
adamc@164 556 | DVal vi =>
adamc@126 557 S.map2 (mfvi ctx vi,
adamc@126 558 fn vi' =>
adamc@126 559 (DVal vi', loc))
adamc@126 560 | DValRec vis =>
adamc@196 561 let
adamc@196 562 val ctx' = foldl (fn ((x, n, t, _, s), ctx') => bind (ctx', NamedE (x, n, t, NONE, s))) ctx vis
adamc@196 563 in
adamc@196 564 S.map2 (ListUtil.mapfold (mfvi ctx') vis,
adamc@196 565 fn vis' =>
adamc@196 566 (DValRec vis', loc))
adamc@196 567 end
adamc@1104 568 | DExport (ek, s, n, ts, t, b) =>
adamc@609 569 S.bind2 (ListUtil.mapfold mft ts,
adamc@120 570 fn ts' =>
adamc@609 571 S.map2 (mft t,
adamc@609 572 fn t' =>
adamc@1104 573 (DExport (ek, s, n, ts', t', b), loc)))
adamc@707 574 | DTable (s, xts, pe, ce) =>
adamc@707 575 S.bind2 (mfe ctx pe,
adamc@707 576 fn pe' =>
adamc@707 577 S.map2 (mfe ctx ce,
adamc@707 578 fn ce' =>
adamc@707 579 (DTable (s, xts, pe', ce'), loc)))
adamc@338 580 | DSequence _ => S.return2 dAll
adamc@754 581 | DView (s, xts, e) =>
adamc@754 582 S.map2 (mfe ctx e,
adamc@754 583 fn e' =>
adamc@754 584 (DView (s, xts, e'), loc))
adamc@271 585 | DDatabase _ => S.return2 dAll
adamc@569 586 | DJavaScript _ => S.return2 dAll
adamc@725 587 | DCookie _ => S.return2 dAll
adamc@718 588 | DStyle _ => S.return2 dAll
adamc@1075 589 | DTask (e1, e2) =>
adamc@1075 590 S.bind2 (mfe ctx e1,
adamc@1075 591 fn e1' =>
adamc@1075 592 S.map2 (mfe ctx e2,
adamc@1075 593 fn e2' =>
adamc@1075 594 (DTask (e1', e2'), loc)))
adamc@1199 595 | DPolicy pol =>
adamc@1199 596 S.map2 (mfpol ctx pol,
adamc@1199 597 fn p' =>
adamc@1199 598 (DPolicy p', loc))
adam@1294 599 | DOnError _ => S.return2 dAll
adamc@1199 600
adamc@1199 601 and mfpol ctx pol =
adamc@1199 602 case pol of
adamc@1214 603 PolClient e =>
adamc@1199 604 S.map2 (mfe ctx e,
adamc@1214 605 PolClient)
adamc@1220 606 | PolInsert e =>
adamc@1220 607 S.map2 (mfe ctx e,
adamc@1220 608 PolInsert)
adamc@1221 609 | PolDelete e =>
adamc@1221 610 S.map2 (mfe ctx e,
adamc@1221 611 PolDelete)
adamc@1223 612 | PolUpdate e =>
adamc@1223 613 S.map2 (mfe ctx e,
adamc@1223 614 PolUpdate)
adamc@1229 615 | PolSequence e =>
adamc@1229 616 S.map2 (mfe ctx e,
adamc@1229 617 PolSequence)
adamc@126 618
adamc@126 619 and mfvi ctx (x, n, t, e, s) =
adamc@126 620 S.bind2 (mft t,
adamc@126 621 fn t' =>
adamc@126 622 S.map2 (mfe ctx e,
adamc@126 623 fn e' =>
adamc@126 624 (x, n, t', e', s)))
adamc@26 625 in
adamc@26 626 mfd
adamc@26 627 end
adamc@26 628
adamc@26 629 fun mapfold {typ = fc, exp = fe, decl = fd} =
adamc@26 630 mapfoldB {typ = fc,
adamc@26 631 exp = fn () => fe,
adamc@26 632 decl = fn () => fd,
adamc@26 633 bind = fn ((), _) => ()} ()
adamc@26 634
adamc@26 635 fun fold {typ, exp, decl} s d =
adamc@26 636 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
adamc@26 637 exp = fn e => fn s => S.Continue (e, exp (e, s)),
adamc@26 638 decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
adamc@26 639 S.Continue (_, s) => s
adamc@26 640 | S.Return _ => raise Fail "MonoUtil.Decl.fold: Impossible"
adamc@26 641
adamc@506 642 fun map {typ, exp, decl} e =
adamc@506 643 case mapfold {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@506 644 exp = fn e => fn () => S.Continue (exp e, ()),
adamc@506 645 decl = fn d => fn () => S.Continue (decl d, ())} e () of
adamc@506 646 S.Return () => raise Fail "MonoUtil.Decl.map: Impossible"
adamc@506 647 | S.Continue (e, ()) => e
adamc@506 648
adam@1800 649 fun foldMap {typ, exp, decl} s d =
adam@1800 650 case mapfold {typ = fn c => fn s => S.Continue (typ (c, s)),
adam@1800 651 exp = fn e => fn s => S.Continue (exp (e, s)),
adam@1800 652 decl = fn d => fn s => S.Continue (decl (d, s))} d s of
adam@1800 653 S.Continue v => v
adam@1800 654 | S.Return _ => raise Fail "MonoUtil.Decl.foldMap: Impossible"
adam@1800 655
adamc@567 656 fun foldMapB {typ, exp, decl, bind} ctx s d =
adamc@567 657 case mapfoldB {typ = fn c => fn s => S.Continue (typ (c, s)),
adamc@567 658 exp = fn ctx => fn e => fn s => S.Continue (exp (ctx, e, s)),
adamc@567 659 decl = fn ctx => fn d => fn s => S.Continue (decl (ctx, d, s)),
adamc@567 660 bind = bind} ctx d s of
adamc@567 661 S.Continue v => v
adamc@567 662 | S.Return _ => raise Fail "MonoUtil.Decl.foldMapB: Impossible"
adamc@567 663
adam@1847 664 fun exists {typ, exp, decl} k =
adam@1847 665 case mapfold {typ = fn c => fn () =>
adam@1847 666 if typ c then
adam@1847 667 S.Return ()
adam@1847 668 else
adam@1847 669 S.Continue (c, ()),
adam@1847 670 exp = fn e => fn () =>
adam@1847 671 if exp e then
adam@1847 672 S.Return ()
adam@1847 673 else
adam@1847 674 S.Continue (e, ()),
adam@1847 675 decl = fn d => fn () =>
adam@1847 676 if decl d then
adam@1847 677 S.Return ()
adam@1847 678 else
adam@1847 679 S.Continue (d, ())} k () of
adam@1847 680 S.Return _ => true
adam@1847 681 | S.Continue _ => false
adam@1847 682
adamc@26 683 end
adamc@26 684
adamc@26 685 structure File = struct
adamc@26 686
adamc@26 687 datatype binder = datatype Exp.binder
adamc@26 688
adamc@26 689 fun mapfoldB (all as {bind, ...}) =
adamc@26 690 let
adamc@26 691 val mfd = Decl.mapfoldB all
adamc@26 692
adam@1845 693 fun mff ctx (ds, ps) =
adamc@26 694 case ds of
adam@1845 695 nil => S.return2 (nil, ps)
adamc@26 696 | d :: ds' =>
adamc@26 697 S.bind2 (mfd ctx d,
adamc@26 698 fn d' =>
adamc@26 699 let
adamc@100 700 val ctx' =
adamc@26 701 case #1 d' of
adamc@808 702 DDatatype dts =>
adamc@808 703 foldl (fn ((x, n, xncs), ctx) =>
adamc@808 704 let
adamc@808 705 val ctx = bind (ctx, Datatype (x, n, xncs))
adamc@808 706 val t = (TDatatype (n, ref (ElabUtil.classifyDatatype xncs, xncs)),
adamc@808 707 #2 d')
adamc@808 708 in
adamc@808 709 foldl (fn ((x, n, to), ctx) =>
adamc@808 710 let
adamc@808 711 val t = case to of
adamc@808 712 NONE => t
adamc@808 713 | SOME t' => (TFun (t', t), #2 d')
adamc@808 714 in
adamc@808 715 bind (ctx, NamedE (x, n, t, NONE, ""))
adamc@808 716 end)
adamc@808 717 ctx xncs
adamc@808 718 end) ctx dts
adamc@164 719 | DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s))
adamc@126 720 | DValRec vis => foldl (fn ((x, n, t, e, s), ctx) =>
adamc@196 721 bind (ctx, NamedE (x, n, t, NONE, s))) ctx vis
adamc@109 722 | DExport _ => ctx
adamc@273 723 | DTable _ => ctx
adamc@338 724 | DSequence _ => ctx
adamc@754 725 | DView _ => ctx
adamc@271 726 | DDatabase _ => ctx
adamc@569 727 | DJavaScript _ => ctx
adamc@725 728 | DCookie _ => ctx
adamc@718 729 | DStyle _ => ctx
adamc@1075 730 | DTask _ => ctx
adamc@1199 731 | DPolicy _ => ctx
adam@1294 732 | DOnError _ => ctx
adamc@26 733 in
adam@1845 734 S.map2 (mff ctx' (ds', ps),
adam@1845 735 fn (ds', _) =>
adam@1845 736 (d' :: ds', ps))
adamc@26 737 end)
adamc@26 738 in
adamc@26 739 mff
adamc@26 740 end
adamc@26 741
adamc@26 742 fun mapfold {typ = fc, exp = fe, decl = fd} =
adamc@26 743 mapfoldB {typ = fc,
adamc@26 744 exp = fn () => fe,
adamc@26 745 decl = fn () => fd,
adamc@26 746 bind = fn ((), _) => ()} ()
adamc@26 747
adamc@26 748 fun mapB {typ, exp, decl, bind} ctx ds =
adamc@26 749 case mapfoldB {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@26 750 exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()),
adamc@26 751 decl = fn ctx => fn d => fn () => S.Continue (decl ctx d, ()),
adamc@26 752 bind = bind} ctx ds () of
adamc@26 753 S.Continue (ds, ()) => ds
adamc@26 754 | S.Return _ => raise Fail "MonoUtil.File.mapB: Impossible"
adamc@26 755
adamc@96 756 fun map {typ, exp, decl} e =
adamc@96 757 case mapfold {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@96 758 exp = fn e => fn () => S.Continue (exp e, ()),
adamc@96 759 decl = fn d => fn () => S.Continue (decl d, ())} e () of
adamc@506 760 S.Return () => raise Fail "MonoUtil.File.map: Impossible"
adamc@96 761 | S.Continue (e, ()) => e
adamc@96 762
adamc@26 763 fun fold {typ, exp, decl} s d =
adamc@26 764 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
adamc@26 765 exp = fn e => fn s => S.Continue (e, exp (e, s)),
adamc@26 766 decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
adamc@26 767 S.Continue (_, s) => s
adamc@26 768 | S.Return _ => raise Fail "MonoUtil.File.fold: Impossible"
adamc@26 769
adam@1845 770 fun maxName (f : file) =
adam@1845 771 foldl (fn ((d, _) : decl, count) =>
adam@1845 772 case d of
adam@1845 773 DDatatype dts =>
adam@1845 774 foldl (fn ((_, n, ns), count) =>
adam@1845 775 foldl (fn ((_, n', _), m) => Int.max (n', m))
adam@1845 776 (Int.max (n, count)) ns) count dts
adam@1845 777 | DVal (_, n, _, _, _) => Int.max (n, count)
adam@1845 778 | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis
adam@1845 779 | DExport _ => count
adam@1845 780 | DTable _ => count
adam@1845 781 | DSequence _ => count
adam@1845 782 | DView _ => count
adam@1845 783 | DDatabase _ => count
adam@1845 784 | DJavaScript _ => count
adam@1845 785 | DCookie _ => count
adam@1845 786 | DStyle _ => count
adam@1845 787 | DTask _ => count
adam@1845 788 | DPolicy _ => count
adam@1845 789 | DOnError _ => count) 0 (#1 f)
adamc@506 790
adam@1845 791 fun appLoc f (fl : file) =
adam@1612 792 let
adam@1612 793 val eal = Exp.appLoc f
adam@1612 794
adam@1612 795 fun appl (d : decl) =
adam@1612 796 case #1 d of
adam@1612 797 DDatatype _ => ()
adam@1612 798 | DVal (_, _, _, e1, _) => eal e1
adam@1612 799 | DValRec vis => app (eal o #4) vis
adam@1612 800 | DExport _ => ()
adam@1612 801 | DTable (_, _, e1, e2) => (eal e1; eal e2)
adam@1612 802 | DSequence _ => ()
adam@1612 803 | DView (_, _, e1) => eal e1
adam@1612 804 | DDatabase _ => ()
adam@1612 805 | DJavaScript _ => ()
adam@1612 806 | DCookie _ => ()
adam@1612 807 | DStyle _ => ()
adam@1612 808 | DTask (e1, e2) => (eal e1; eal e2)
adam@1612 809 | DPolicy pol => applPolicy pol
adam@1612 810 | DOnError _ => ()
adam@1612 811
adam@1612 812 and applPolicy p =
adam@1612 813 case p of
adam@1612 814 PolClient e1 => eal e1
adam@1612 815 | PolInsert e1 => eal e1
adam@1612 816 | PolDelete e1 => eal e1
adam@1612 817 | PolUpdate e1 => eal e1
adam@1612 818 | PolSequence e1 => eal e1
adam@1612 819 in
adam@1845 820 app appl (#1 fl)
adam@1612 821 end
adam@1612 822
adamc@26 823 end
adamc@26 824
adamc@26 825 end