Mercurial > urweb

annotate src/mono_util.sml @ 1659:8de2ea0a0701

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Change linking argument order, based on reported problems in Ubuntu 11.10
author Adam Chlipala <adam@chlipala.net>
date Thu, 05 Jan 2012 19:23:34 -0500
parents 7bb8c560f23d
children 0577be31a435
rev   line source
adamc@26 1 (* Copyright (c) 2008, 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
adamc@26 159 and mfe' ctx (eAll as (e, loc)) =
adamc@26 160 case e of
adamc@26 161 EPrim _ => S.return2 eAll
adamc@26 162 | ERel _ => S.return2 eAll
adamc@26 163 | ENamed _ => S.return2 eAll
adamc@188 164 | ECon (_, _, NONE) => S.return2 eAll
adamc@188 165 | ECon (dk, n, SOME e) =>
adamc@178 166 S.map2 (mfe ctx e,
adamc@178 167 fn e' =>
adamc@188 168 (ECon (dk, n, SOME e'), loc))
adamc@297 169 | ENone t =>
adamc@297 170 S.map2 (mft t,
adamc@297 171 fn t' =>
adamc@297 172 (ENone t', loc))
adamc@290 173 | ESome (t, e) =>
adamc@290 174 S.bind2 (mft t,
adamc@290 175 fn t' =>
adamc@290 176 S.map2 (mfe ctx e,
adamc@290 177 fn e' =>
adamc@290 178 (ESome (t', e'), loc)))
adamc@51 179 | EFfi _ => S.return2 eAll
adamc@51 180 | EFfiApp (m, x, es) =>
adamc@51 181 S.map2 (ListUtil.mapfold (fn e => mfe ctx e) es,
adamc@51 182 fn es' =>
adamc@51 183 (EFfiApp (m, x, es'), loc))
adamc@26 184 | EApp (e1, e2) =>
adamc@26 185 S.bind2 (mfe ctx e1,
adamc@26 186 fn e1' =>
adamc@26 187 S.map2 (mfe ctx e2,
adamc@26 188 fn e2' =>
adamc@26 189 (EApp (e1', e2'), loc)))
adamc@26 190 | EAbs (x, dom, ran, e) =>
adamc@26 191 S.bind2 (mft dom,
adamc@26 192 fn dom' =>
adamc@26 193 S.bind2 (mft ran,
adamc@26 194 fn ran' =>
adamc@26 195 S.map2 (mfe (bind (ctx, RelE (x, dom'))) e,
adamc@26 196 fn e' =>
adamc@26 197 (EAbs (x, dom', ran', e'), loc))))
adamc@26 198
adamc@387 199 | EUnop (s, e) =>
adamc@387 200 S.map2 (mfe ctx e,
adamc@387 201 fn e' =>
adamc@387 202 (EUnop (s, e'), loc))
adam@1360 203 | EBinop (bi, s, e1, e2) =>
adamc@387 204 S.bind2 (mfe ctx e1,
adamc@387 205 fn e1' =>
adamc@387 206 S.map2 (mfe ctx e2,
adamc@387 207 fn e2' =>
adam@1360 208 (EBinop (bi, s, e1', e2'), loc)))
adamc@387 209
adamc@26 210 | ERecord xes =>
adamc@29 211 S.map2 (ListUtil.mapfold (fn (x, e, t) =>
adamc@29 212 S.bind2 (mfe ctx e,
adamc@26 213 fn e' =>
adamc@29 214 S.map2 (mft t,
adamc@29 215 fn t' =>
adamc@29 216 (x, e', t'))))
adamc@26 217 xes,
adamc@26 218 fn xes' =>
adamc@26 219 (ERecord xes', loc))
adamc@26 220 | EField (e, x) =>
adamc@26 221 S.map2 (mfe ctx e,
adamc@26 222 fn e' =>
adamc@26 223 (EField (e', x), loc))
adamc@94 224
adamc@182 225 | ECase (e, pes, {disc, result}) =>
adamc@178 226 S.bind2 (mfe ctx e,
adamc@178 227 fn e' =>
adamc@178 228 S.bind2 (ListUtil.mapfold (fn (p, e) =>
adamc@179 229 let
adamc@179 230 fun pb ((p, _), ctx) =
adamc@179 231 case p of
adamc@179 232 PWild => ctx
adamc@182 233 | PVar (x, t) => bind (ctx, RelE (x, t))
adamc@179 234 | PPrim _ => ctx
adamc@188 235 | PCon (_, _, NONE) => ctx
adamc@188 236 | PCon (_, _, SOME p) => pb (p, ctx)
adamc@182 237 | PRecord xps => foldl (fn ((_, p, _), ctx) =>
adamc@179 238 pb (p, ctx)) ctx xps
adamc@288 239 | PNone _ => ctx
adamc@288 240 | PSome (_, p) => pb (p, ctx)
adamc@179 241 in
adamc@179 242 S.map2 (mfe (pb (p, ctx)) e,
adamc@179 243 fn e' => (p, e'))
adamc@179 244 end) pes,
adamc@178 245 fn pes' =>
adamc@182 246 S.bind2 (mft disc,
adamc@182 247 fn disc' =>
adamc@182 248 S.map2 (mft result,
adamc@182 249 fn result' =>
adamc@182 250 (ECase (e', pes', {disc = disc', result = result'}), loc)))))
adamc@178 251
adamc@283 252 | EError (e, t) =>
adamc@283 253 S.bind2 (mfe ctx e,
adamc@283 254 fn e' =>
adamc@283 255 S.map2 (mft t,
adamc@283 256 fn t' =>
adamc@283 257 (EError (e', t'), loc)))
adamc@741 258 | EReturnBlob {blob, mimeType, t} =>
adamc@741 259 S.bind2 (mfe ctx blob,
adamc@741 260 fn blob' =>
adamc@741 261 S.bind2 (mfe ctx mimeType,
adamc@741 262 fn mimeType' =>
adamc@741 263 S.map2 (mft t,
adamc@741 264 fn t' =>
adamc@741 265 (EReturnBlob {blob = blob', mimeType = mimeType', t = t'}, loc))))
adamc@1065 266 | ERedirect (e, t) =>
adamc@1065 267 S.bind2 (mfe ctx e,
adamc@1065 268 fn e' =>
adamc@1065 269 S.map2 (mft t,
adamc@1065 270 fn t' =>
adamc@1065 271 (ERedirect (e', t'), loc)))
adamc@741 272
adamc@94 273 | EStrcat (e1, e2) =>
adamc@94 274 S.bind2 (mfe ctx e1,
adamc@94 275 fn e1' =>
adamc@94 276 S.map2 (mfe ctx e2,
adamc@94 277 fn e2' =>
adamc@94 278 (EStrcat (e1', e2'), loc)))
adamc@102 279
adamc@102 280 | EWrite e =>
adamc@102 281 S.map2 (mfe ctx e,
adamc@102 282 fn e' =>
adamc@102 283 (EWrite e', loc))
adamc@106 284
adamc@106 285 | ESeq (e1, e2) =>
adamc@106 286 S.bind2 (mfe ctx e1,
adamc@106 287 fn e1' =>
adamc@106 288 S.map2 (mfe ctx e2,
adamc@106 289 fn e2' =>
adamc@106 290 (ESeq (e1', e2'), loc)))
adamc@251 291 | ELet (x, t, e1, e2) =>
adamc@251 292 S.bind2 (mft t,
adamc@251 293 fn t' =>
adamc@251 294 S.bind2 (mfe ctx e1,
adamc@251 295 fn e1' =>
adamc@252 296 S.map2 (mfe (bind (ctx, RelE (x, t'))) e2,
adamc@251 297 fn e2' =>
adamc@251 298 (ELet (x, t', e1', e2'), loc))))
adamc@111 299
adamc@111 300 | EClosure (n, es) =>
adamc@111 301 S.map2 (ListUtil.mapfold (mfe ctx) es,
adamc@111 302 fn es' =>
adamc@111 303 (EClosure (n, es'), loc))
adamc@252 304
adamc@252 305 | EQuery {exps, tables, state, query, body, initial} =>
adamc@252 306 S.bind2 (ListUtil.mapfold (fn (x, t) =>
adamc@252 307 S.map2 (mft t,
adamc@252 308 fn t' => (x, t'))) exps,
adamc@252 309 fn exps' =>
adamc@252 310 S.bind2 (ListUtil.mapfold (fn (x, xts) =>
adamc@252 311 S.map2 (ListUtil.mapfold
adamc@252 312 (fn (x, t) =>
adamc@252 313 S.map2 (mft t,
adamc@252 314 fn t' => (x, t'))) xts,
adamc@252 315 fn xts' => (x, xts'))) tables,
adamc@252 316 fn tables' =>
adamc@252 317 S.bind2 (mft state,
adamc@252 318 fn state' =>
adamc@252 319 S.bind2 (mfe ctx query,
adamc@252 320 fn query' =>
adamc@267 321 S.bind2 (mfe (bind (bind (ctx, RelE ("r", dummyt)),
adamc@267 322 RelE ("acc", dummyt)))
adamc@267 323 body,
adamc@267 324 fn body' =>
adamc@267 325 S.map2 (mfe ctx initial,
adamc@267 326 fn initial' =>
adamc@267 327 (EQuery {exps = exps',
adamc@267 328 tables = tables',
adamc@267 329 state = state',
adamc@267 330 query = query',
adamc@267 331 body = body',
adamc@267 332 initial = initial'},
adamc@267 333 loc)))))))
adamc@307 334
adam@1293 335 | EDml (e, fm) =>
adamc@307 336 S.map2 (mfe ctx e,
adamc@307 337 fn e' =>
adam@1293 338 (EDml (e', fm), loc))
adamc@338 339 | ENextval e =>
adamc@338 340 S.map2 (mfe ctx e,
adamc@338 341 fn e' =>
adamc@338 342 (ENextval e', loc))
adamc@1073 343 | ESetval (e1, e2) =>
adamc@1073 344 S.bind2 (mfe ctx e1,
adamc@1073 345 fn e1' =>
adamc@1073 346 S.map2 (mfe ctx e2,
adamc@1073 347 fn e2' =>
adamc@1073 348 (ESetval (e1', e2'), loc)))
adamc@1112 349 | EUnurlify (e, t, b) =>
adamc@463 350 S.bind2 (mfe ctx e,
adamc@463 351 fn e' =>
adamc@463 352 S.map2 (mft t,
adamc@463 353 fn t' =>
adamc@1112 354 (EUnurlify (e', t', b), loc)))
adamc@815 355 | EJavaScript (m, e) =>
adamc@729 356 S.bind2 (mfmode ctx m,
adamc@729 357 fn m' =>
adamc@729 358 S.map2 (mfe ctx e,
adamc@729 359 fn e' =>
adamc@815 360 (EJavaScript (m', e'), loc)))
adamc@569 361
adamc@568 362 | ESignalReturn e =>
adamc@568 363 S.map2 (mfe ctx e,
adamc@568 364 fn e' =>
adamc@568 365 (ESignalReturn e', loc))
adamc@572 366 | ESignalBind (e1, e2) =>
adamc@572 367 S.bind2 (mfe ctx e1,
adamc@572 368 fn e1' =>
adamc@572 369 S.map2 (mfe ctx e2,
adamc@572 370 fn e2' =>
adamc@572 371 (ESignalBind (e1', e2'), loc)))
adamc@574 372 | ESignalSource e =>
adamc@574 373 S.map2 (mfe ctx e,
adamc@574 374 fn e' =>
adamc@574 375 (ESignalSource e', loc))
adamc@608 376
adamc@1020 377 | EServerCall (s, t, eff) =>
adamc@642 378 S.bind2 (mfe ctx s,
adamc@642 379 fn s' =>
adamc@1020 380 S.map2 (mft t,
adamc@1020 381 fn t' =>
adamc@1020 382 (EServerCall (s', t', eff), loc)))
adamc@1021 383 | ERecv (s, t) =>
adamc@670 384 S.bind2 (mfe ctx s,
adamc@695 385 fn s' =>
adamc@1021 386 S.map2 (mft t,
adamc@1021 387 fn t' =>
adamc@1021 388 (ERecv (s', t'), loc)))
adamc@1021 389 | ESleep s =>
adamc@1021 390 S.map2 (mfe ctx s,
adamc@695 391 fn s' =>
adamc@1021 392 (ESleep s', loc))
adamc@1021 393
adamc@1021 394 | ESpawn s =>
adamc@1021 395 S.map2 (mfe ctx s,
adamc@1021 396 fn s' =>
adamc@1021 397 (ESpawn s', loc))
adamc@729 398
adamc@729 399 and mfmode ctx mode =
adamc@729 400 case mode of
adamc@729 401 Attribute => S.return2 mode
adamc@729 402 | Script => S.return2 mode
adamc@729 403 | Source t =>
adamc@729 404 S.map2 (mft t,
adamc@729 405 fn t' => Source t')
adamc@26 406 in
adamc@26 407 mfe
adamc@26 408 end
adamc@26 409
adamc@26 410 fun mapfold {typ = fc, exp = fe} =
adamc@26 411 mapfoldB {typ = fc,
adamc@26 412 exp = fn () => fe,
adamc@26 413 bind = fn ((), _) => ()} ()
adamc@26 414
adamc@26 415 fun mapB {typ, exp, bind} ctx e =
adamc@26 416 case mapfoldB {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@26 417 exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()),
adamc@26 418 bind = bind} ctx e () of
adamc@26 419 S.Continue (e, ()) => e
adamc@26 420 | S.Return _ => raise Fail "MonoUtil.Exp.mapB: Impossible"
adamc@26 421
adamc@26 422 fun map {typ, exp} e =
adamc@26 423 case mapfold {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@26 424 exp = fn e => fn () => S.Continue (exp e, ())} e () of
adamc@26 425 S.Return () => raise Fail "Mono_util.Exp.map"
adamc@26 426 | S.Continue (e, ()) => e
adamc@26 427
adamc@26 428 fun fold {typ, exp} s e =
adamc@26 429 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
adamc@26 430 exp = fn e => fn s => S.Continue (e, exp (e, s))} e s of
adamc@26 431 S.Continue (_, s) => s
adamc@26 432 | S.Return _ => raise Fail "MonoUtil.Exp.fold: Impossible"
adamc@26 433
adamc@26 434 fun exists {typ, exp} k =
adamc@26 435 case mapfold {typ = fn c => fn () =>
adamc@26 436 if typ c then
adamc@26 437 S.Return ()
adamc@26 438 else
adamc@26 439 S.Continue (c, ()),
adamc@26 440 exp = fn e => fn () =>
adamc@26 441 if exp e then
adamc@26 442 S.Return ()
adamc@26 443 else
adamc@26 444 S.Continue (e, ())} k () of
adamc@26 445 S.Return _ => true
adamc@26 446 | S.Continue _ => false
adamc@26 447
adamc@919 448 fun existsB {typ, exp, bind} ctx e =
adamc@919 449 case mapfoldB {typ = fn t => fn () =>
adamc@919 450 if typ t then
adamc@919 451 S.Return ()
adamc@919 452 else
adamc@919 453 S.Continue (t, ()),
adamc@919 454 exp = fn ctx => fn e => fn () =>
adamc@919 455 if exp (ctx, e) then
adamc@919 456 S.Return ()
adamc@919 457 else
adamc@919 458 S.Continue (e, ()),
adamc@919 459 bind = bind} ctx e () of
adamc@919 460 S.Return _ => true
adamc@919 461 | S.Continue _ => false
adamc@919 462
adamc@567 463 fun foldB {typ, exp, bind} ctx s e =
adamc@567 464 case mapfoldB {typ = fn t => fn s => S.Continue (t, typ (t, s)),
adamc@567 465 exp = fn ctx => fn e => fn s => S.Continue (e, exp (ctx, e, s)),
adamc@567 466 bind = bind} ctx e s of
adamc@567 467 S.Continue (_, s) => s
adamc@567 468 | S.Return _ => raise Fail "MonoUtil.Exp.foldB: Impossible"
adamc@567 469
adam@1612 470 fun appLoc f =
adam@1612 471 let
adam@1612 472 fun appl e =
adam@1612 473 (f e;
adam@1612 474 case #1 e of
adam@1612 475 EPrim _ => ()
adam@1612 476 | ERel _ => ()
adam@1612 477 | ENamed _ => ()
adam@1612 478 | ECon (_, _, eo) => Option.app appl eo
adam@1612 479 | ENone _ => ()
adam@1612 480 | ESome (_, e) => appl e
adam@1612 481 | EFfi _ => ()
adam@1612 482 | EFfiApp (_, _, es) => app appl es
adam@1612 483 | EApp (e1, e2) => (appl e1; appl e2)
adam@1612 484 | EAbs (_, _, _, e1) => appl e1
adam@1612 485 | EUnop (_, e1) => appl e1
adam@1612 486 | EBinop (_, _, e1, e2) => (appl e1; appl e2)
adam@1612 487 | ERecord xets => app (appl o #2) xets
adam@1612 488 | EField (e1, _) => appl e1
adam@1612 489 | ECase (e1, pes, _) => (appl e1; app (appl o #2) pes)
adam@1612 490 | EStrcat (e1, e2) => (appl e1; appl e2)
adam@1612 491 | EError (e1, _) => appl e1
adam@1612 492 | EReturnBlob {blob = e1, mimeType = e2, ...} => (appl e1; appl e2)
adam@1612 493 | ERedirect (e1, _) => appl e1
adam@1612 494 | EWrite e1 => appl e1
adam@1612 495 | ESeq (e1, e2) => (appl e1; appl e2)
adam@1612 496 | ELet (_, _, e1, e2) => (appl e1; appl e2)
adam@1612 497 | EClosure (_, es) => app appl es
adam@1612 498 | EQuery {query = e1, body = e2, initial = e3, ...} => (appl e1; appl e2; appl e3)
adam@1612 499 | EDml (e1, _) => appl e1
adam@1612 500 | ENextval e1 => appl e1
adam@1612 501 | ESetval (e1, e2) => (appl e1; appl e2)
adam@1612 502 | EUnurlify (e1, _, _) => appl e1
adam@1612 503 | EJavaScript (_, e1) => appl e1
adam@1612 504 | ESignalReturn e1 => appl e1
adam@1612 505 | ESignalBind (e1, e2) => (appl e1; appl e2)
adam@1612 506 | ESignalSource e1 => appl e1
adam@1612 507 | EServerCall (e1, _, _) => appl e1
adam@1612 508 | ERecv (e1, _) => appl e1
adam@1612 509 | ESleep e1 => appl e1
adam@1612 510 | ESpawn e1 => appl e1)
adam@1612 511 in
adam@1612 512 appl
adam@1612 513 end
adam@1612 514
adamc@26 515 end
adamc@26 516
adamc@26 517 structure Decl = struct
adamc@26 518
adamc@26 519 datatype binder = datatype Exp.binder
adamc@26 520
adamc@26 521 fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
adamc@26 522 let
adamc@26 523 val mft = Typ.mapfold fc
adamc@26 524
adamc@26 525 val mfe = Exp.mapfoldB {typ = fc, exp = fe, bind = bind}
adamc@26 526
adamc@26 527 fun mfd ctx d acc =
adamc@26 528 S.bindP (mfd' ctx d acc, fd ctx)
adamc@26 529
adamc@26 530 and mfd' ctx (dAll as (d, loc)) =
adamc@26 531 case d of
adamc@808 532 DDatatype dts =>
adamc@808 533 S.map2 (ListUtil.mapfold (fn (x, n, xncs) =>
adamc@808 534 S.map2 (ListUtil.mapfold (fn (x, n, c) =>
adamc@808 535 case c of
adamc@808 536 NONE => S.return2 (x, n, c)
adamc@808 537 | SOME c =>
adamc@808 538 S.map2 (mft c,
adamc@808 539 fn c' => (x, n, SOME c'))) xncs,
adamc@808 540 fn xncs' => (x, n, xncs'))) dts,
adamc@808 541 fn dts' =>
adamc@808 542 (DDatatype dts', loc))
adamc@164 543 | DVal vi =>
adamc@126 544 S.map2 (mfvi ctx vi,
adamc@126 545 fn vi' =>
adamc@126 546 (DVal vi', loc))
adamc@126 547 | DValRec vis =>
adamc@196 548 let
adamc@196 549 val ctx' = foldl (fn ((x, n, t, _, s), ctx') => bind (ctx', NamedE (x, n, t, NONE, s))) ctx vis
adamc@196 550 in
adamc@196 551 S.map2 (ListUtil.mapfold (mfvi ctx') vis,
adamc@196 552 fn vis' =>
adamc@196 553 (DValRec vis', loc))
adamc@196 554 end
adamc@1104 555 | DExport (ek, s, n, ts, t, b) =>
adamc@609 556 S.bind2 (ListUtil.mapfold mft ts,
adamc@120 557 fn ts' =>
adamc@609 558 S.map2 (mft t,
adamc@609 559 fn t' =>
adamc@1104 560 (DExport (ek, s, n, ts', t', b), loc)))
adamc@707 561 | DTable (s, xts, pe, ce) =>
adamc@707 562 S.bind2 (mfe ctx pe,
adamc@707 563 fn pe' =>
adamc@707 564 S.map2 (mfe ctx ce,
adamc@707 565 fn ce' =>
adamc@707 566 (DTable (s, xts, pe', ce'), loc)))
adamc@338 567 | DSequence _ => S.return2 dAll
adamc@754 568 | DView (s, xts, e) =>
adamc@754 569 S.map2 (mfe ctx e,
adamc@754 570 fn e' =>
adamc@754 571 (DView (s, xts, e'), loc))
adamc@271 572 | DDatabase _ => S.return2 dAll
adamc@569 573 | DJavaScript _ => S.return2 dAll
adamc@725 574 | DCookie _ => S.return2 dAll
adamc@718 575 | DStyle _ => S.return2 dAll
adamc@1075 576 | DTask (e1, e2) =>
adamc@1075 577 S.bind2 (mfe ctx e1,
adamc@1075 578 fn e1' =>
adamc@1075 579 S.map2 (mfe ctx e2,
adamc@1075 580 fn e2' =>
adamc@1075 581 (DTask (e1', e2'), loc)))
adamc@1199 582 | DPolicy pol =>
adamc@1199 583 S.map2 (mfpol ctx pol,
adamc@1199 584 fn p' =>
adamc@1199 585 (DPolicy p', loc))
adam@1294 586 | DOnError _ => S.return2 dAll
adamc@1199 587
adamc@1199 588 and mfpol ctx pol =
adamc@1199 589 case pol of
adamc@1214 590 PolClient e =>
adamc@1199 591 S.map2 (mfe ctx e,
adamc@1214 592 PolClient)
adamc@1220 593 | PolInsert e =>
adamc@1220 594 S.map2 (mfe ctx e,
adamc@1220 595 PolInsert)
adamc@1221 596 | PolDelete e =>
adamc@1221 597 S.map2 (mfe ctx e,
adamc@1221 598 PolDelete)
adamc@1223 599 | PolUpdate e =>
adamc@1223 600 S.map2 (mfe ctx e,
adamc@1223 601 PolUpdate)
adamc@1229 602 | PolSequence e =>
adamc@1229 603 S.map2 (mfe ctx e,
adamc@1229 604 PolSequence)
adamc@126 605
adamc@126 606 and mfvi ctx (x, n, t, e, s) =
adamc@126 607 S.bind2 (mft t,
adamc@126 608 fn t' =>
adamc@126 609 S.map2 (mfe ctx e,
adamc@126 610 fn e' =>
adamc@126 611 (x, n, t', e', s)))
adamc@26 612 in
adamc@26 613 mfd
adamc@26 614 end
adamc@26 615
adamc@26 616 fun mapfold {typ = fc, exp = fe, decl = fd} =
adamc@26 617 mapfoldB {typ = fc,
adamc@26 618 exp = fn () => fe,
adamc@26 619 decl = fn () => fd,
adamc@26 620 bind = fn ((), _) => ()} ()
adamc@26 621
adamc@26 622 fun fold {typ, exp, decl} s d =
adamc@26 623 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
adamc@26 624 exp = fn e => fn s => S.Continue (e, exp (e, s)),
adamc@26 625 decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
adamc@26 626 S.Continue (_, s) => s
adamc@26 627 | S.Return _ => raise Fail "MonoUtil.Decl.fold: Impossible"
adamc@26 628
adamc@506 629 fun map {typ, exp, decl} e =
adamc@506 630 case mapfold {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@506 631 exp = fn e => fn () => S.Continue (exp e, ()),
adamc@506 632 decl = fn d => fn () => S.Continue (decl d, ())} e () of
adamc@506 633 S.Return () => raise Fail "MonoUtil.Decl.map: Impossible"
adamc@506 634 | S.Continue (e, ()) => e
adamc@506 635
adamc@567 636 fun foldMapB {typ, exp, decl, bind} ctx s d =
adamc@567 637 case mapfoldB {typ = fn c => fn s => S.Continue (typ (c, s)),
adamc@567 638 exp = fn ctx => fn e => fn s => S.Continue (exp (ctx, e, s)),
adamc@567 639 decl = fn ctx => fn d => fn s => S.Continue (decl (ctx, d, s)),
adamc@567 640 bind = bind} ctx d s of
adamc@567 641 S.Continue v => v
adamc@567 642 | S.Return _ => raise Fail "MonoUtil.Decl.foldMapB: Impossible"
adamc@567 643
adamc@26 644 end
adamc@26 645
adamc@26 646 structure File = struct
adamc@26 647
adamc@26 648 datatype binder = datatype Exp.binder
adamc@26 649
adamc@26 650 fun mapfoldB (all as {bind, ...}) =
adamc@26 651 let
adamc@26 652 val mfd = Decl.mapfoldB all
adamc@26 653
adamc@26 654 fun mff ctx ds =
adamc@26 655 case ds of
adamc@26 656 nil => S.return2 nil
adamc@26 657 | d :: ds' =>
adamc@26 658 S.bind2 (mfd ctx d,
adamc@26 659 fn d' =>
adamc@26 660 let
adamc@100 661 val ctx' =
adamc@26 662 case #1 d' of
adamc@808 663 DDatatype dts =>
adamc@808 664 foldl (fn ((x, n, xncs), ctx) =>
adamc@808 665 let
adamc@808 666 val ctx = bind (ctx, Datatype (x, n, xncs))
adamc@808 667 val t = (TDatatype (n, ref (ElabUtil.classifyDatatype xncs, xncs)),
adamc@808 668 #2 d')
adamc@808 669 in
adamc@808 670 foldl (fn ((x, n, to), ctx) =>
adamc@808 671 let
adamc@808 672 val t = case to of
adamc@808 673 NONE => t
adamc@808 674 | SOME t' => (TFun (t', t), #2 d')
adamc@808 675 in
adamc@808 676 bind (ctx, NamedE (x, n, t, NONE, ""))
adamc@808 677 end)
adamc@808 678 ctx xncs
adamc@808 679 end) ctx dts
adamc@164 680 | DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s))
adamc@126 681 | DValRec vis => foldl (fn ((x, n, t, e, s), ctx) =>
adamc@196 682 bind (ctx, NamedE (x, n, t, NONE, s))) ctx vis
adamc@109 683 | DExport _ => ctx
adamc@273 684 | DTable _ => ctx
adamc@338 685 | DSequence _ => ctx
adamc@754 686 | DView _ => ctx
adamc@271 687 | DDatabase _ => ctx
adamc@569 688 | DJavaScript _ => ctx
adamc@725 689 | DCookie _ => ctx
adamc@718 690 | DStyle _ => ctx
adamc@1075 691 | DTask _ => ctx
adamc@1199 692 | DPolicy _ => ctx
adam@1294 693 | DOnError _ => ctx
adamc@26 694 in
adamc@26 695 S.map2 (mff ctx' ds',
adamc@26 696 fn ds' =>
adamc@26 697 d' :: ds')
adamc@26 698 end)
adamc@26 699 in
adamc@26 700 mff
adamc@26 701 end
adamc@26 702
adamc@26 703 fun mapfold {typ = fc, exp = fe, decl = fd} =
adamc@26 704 mapfoldB {typ = fc,
adamc@26 705 exp = fn () => fe,
adamc@26 706 decl = fn () => fd,
adamc@26 707 bind = fn ((), _) => ()} ()
adamc@26 708
adamc@26 709 fun mapB {typ, exp, decl, bind} ctx ds =
adamc@26 710 case mapfoldB {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@26 711 exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()),
adamc@26 712 decl = fn ctx => fn d => fn () => S.Continue (decl ctx d, ()),
adamc@26 713 bind = bind} ctx ds () of
adamc@26 714 S.Continue (ds, ()) => ds
adamc@26 715 | S.Return _ => raise Fail "MonoUtil.File.mapB: Impossible"
adamc@26 716
adamc@96 717 fun map {typ, exp, decl} e =
adamc@96 718 case mapfold {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@96 719 exp = fn e => fn () => S.Continue (exp e, ()),
adamc@96 720 decl = fn d => fn () => S.Continue (decl d, ())} e () of
adamc@506 721 S.Return () => raise Fail "MonoUtil.File.map: Impossible"
adamc@96 722 | S.Continue (e, ()) => e
adamc@96 723
adamc@26 724 fun fold {typ, exp, decl} s d =
adamc@26 725 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
adamc@26 726 exp = fn e => fn s => S.Continue (e, exp (e, s)),
adamc@26 727 decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
adamc@26 728 S.Continue (_, s) => s
adamc@26 729 | S.Return _ => raise Fail "MonoUtil.File.fold: Impossible"
adamc@26 730
adamc@506 731 val maxName = foldl (fn ((d, _) : decl, count) =>
adamc@506 732 case d of
adamc@808 733 DDatatype dts =>
adamc@808 734 foldl (fn ((_, n, ns), count) =>
adamc@808 735 foldl (fn ((_, n', _), m) => Int.max (n', m))
adamc@808 736 (Int.max (n, count)) ns) count dts
adamc@506 737 | DVal (_, n, _, _, _) => Int.max (n, count)
adamc@506 738 | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis
adamc@506 739 | DExport _ => count
adamc@506 740 | DTable _ => count
adamc@506 741 | DSequence _ => count
adamc@754 742 | DView _ => count
adamc@569 743 | DDatabase _ => count
adamc@718 744 | DJavaScript _ => count
adamc@725 745 | DCookie _ => count
adamc@1073 746 | DStyle _ => count
adamc@1199 747 | DTask _ => count
adam@1294 748 | DPolicy _ => count
adam@1294 749 | DOnError _ => count) 0
adamc@506 750
adam@1612 751 fun appLoc f =
adam@1612 752 let
adam@1612 753 val eal = Exp.appLoc f
adam@1612 754
adam@1612 755 fun appl (d : decl) =
adam@1612 756 case #1 d of
adam@1612 757 DDatatype _ => ()
adam@1612 758 | DVal (_, _, _, e1, _) => eal e1
adam@1612 759 | DValRec vis => app (eal o #4) vis
adam@1612 760 | DExport _ => ()
adam@1612 761 | DTable (_, _, e1, e2) => (eal e1; eal e2)
adam@1612 762 | DSequence _ => ()
adam@1612 763 | DView (_, _, e1) => eal e1
adam@1612 764 | DDatabase _ => ()
adam@1612 765 | DJavaScript _ => ()
adam@1612 766 | DCookie _ => ()
adam@1612 767 | DStyle _ => ()
adam@1612 768 | DTask (e1, e2) => (eal e1; eal e2)
adam@1612 769 | DPolicy pol => applPolicy pol
adam@1612 770 | DOnError _ => ()
adam@1612 771
adam@1612 772 and applPolicy p =
adam@1612 773 case p of
adam@1612 774 PolClient e1 => eal e1
adam@1612 775 | PolInsert e1 => eal e1
adam@1612 776 | PolDelete e1 => eal e1
adam@1612 777 | PolUpdate e1 => eal e1
adam@1612 778 | PolSequence e1 => eal e1
adam@1612 779 in
adam@1612 780 app appl
adam@1612 781 end
adam@1612 782
adamc@26 783 end
adamc@26 784
adamc@26 785 end