Mercurial > urweb

annotate src/mono_util.sml @ 2258:b1ba35ce2613

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix bug where pure caching didn't treat FFI applications as effectful.
author Ziv Scully <ziv@mit.edu>
date Sun, 27 Sep 2015 17:02:14 -0400
parents 8428c534913a
children
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
ziv@2218 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)))
ziv@2218 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
ziv@2255 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' =>
ziv@2221 337 (* ASK: is this the right thing to do? *)
ziv@2255 338 S.map2 (mfe ctx initial,
adamc@267 339 fn initial' =>
ziv@2255 340 (EQuery {exps = exps',
ziv@2255 341 tables = tables',
ziv@2255 342 state = state',
ziv@2255 343 query = query',
ziv@2255 344 body = body',
ziv@2255 345 initial = initial'},
ziv@2255 346 loc)))))))
adamc@307 347
adam@1293 348 | EDml (e, fm) =>
adamc@307 349 S.map2 (mfe ctx e,
adamc@307 350 fn e' =>
adam@1293 351 (EDml (e', fm), loc))
adamc@338 352 | ENextval e =>
adamc@338 353 S.map2 (mfe ctx e,
adamc@338 354 fn e' =>
adamc@338 355 (ENextval e', loc))
adamc@1073 356 | ESetval (e1, e2) =>
adamc@1073 357 S.bind2 (mfe ctx e1,
adamc@1073 358 fn e1' =>
adamc@1073 359 S.map2 (mfe ctx e2,
adamc@1073 360 fn e2' =>
adamc@1073 361 (ESetval (e1', e2'), loc)))
adamc@1112 362 | EUnurlify (e, t, b) =>
adamc@463 363 S.bind2 (mfe ctx e,
adamc@463 364 fn e' =>
adamc@463 365 S.map2 (mft t,
adamc@463 366 fn t' =>
adamc@1112 367 (EUnurlify (e', t', b), loc)))
adamc@815 368 | EJavaScript (m, e) =>
adamc@729 369 S.bind2 (mfmode ctx m,
adamc@729 370 fn m' =>
adamc@729 371 S.map2 (mfe ctx e,
adamc@729 372 fn e' =>
adamc@815 373 (EJavaScript (m', e'), loc)))
adamc@569 374
adamc@568 375 | ESignalReturn e =>
adamc@568 376 S.map2 (mfe ctx e,
adamc@568 377 fn e' =>
adamc@568 378 (ESignalReturn e', loc))
adamc@572 379 | ESignalBind (e1, e2) =>
adamc@572 380 S.bind2 (mfe ctx e1,
adamc@572 381 fn e1' =>
adamc@572 382 S.map2 (mfe ctx e2,
adamc@572 383 fn e2' =>
adamc@572 384 (ESignalBind (e1', e2'), loc)))
adamc@574 385 | ESignalSource e =>
adamc@574 386 S.map2 (mfe ctx e,
adamc@574 387 fn e' =>
adamc@574 388 (ESignalSource e', loc))
adamc@608 389
adam@1848 390 | EServerCall (s, t, eff, fm) =>
adamc@642 391 S.bind2 (mfe ctx s,
adamc@642 392 fn s' =>
adamc@1020 393 S.map2 (mft t,
adamc@1020 394 fn t' =>
adam@1848 395 (EServerCall (s', t', eff, fm), loc)))
adamc@1021 396 | ERecv (s, t) =>
adamc@670 397 S.bind2 (mfe ctx s,
adamc@695 398 fn s' =>
adamc@1021 399 S.map2 (mft t,
adamc@1021 400 fn t' =>
adamc@1021 401 (ERecv (s', t'), loc)))
adamc@1021 402 | ESleep s =>
adamc@1021 403 S.map2 (mfe ctx s,
adamc@695 404 fn s' =>
adamc@1021 405 (ESleep s', loc))
adamc@1021 406
adamc@1021 407 | ESpawn s =>
adamc@1021 408 S.map2 (mfe ctx s,
adamc@1021 409 fn s' =>
adamc@1021 410 (ESpawn s', loc))
adamc@729 411
adamc@729 412 and mfmode ctx mode =
adamc@729 413 case mode of
adamc@729 414 Attribute => S.return2 mode
adamc@729 415 | Script => S.return2 mode
adamc@729 416 | Source t =>
adamc@729 417 S.map2 (mft t,
adamc@729 418 fn t' => Source t')
adamc@26 419 in
adamc@26 420 mfe
adamc@26 421 end
adamc@26 422
adamc@26 423 fun mapfold {typ = fc, exp = fe} =
adamc@26 424 mapfoldB {typ = fc,
adamc@26 425 exp = fn () => fe,
adamc@26 426 bind = fn ((), _) => ()} ()
adamc@26 427
adamc@26 428 fun mapB {typ, exp, bind} ctx e =
adamc@26 429 case mapfoldB {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@26 430 exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()),
adamc@26 431 bind = bind} ctx e () of
adamc@26 432 S.Continue (e, ()) => e
adamc@26 433 | S.Return _ => raise Fail "MonoUtil.Exp.mapB: Impossible"
adamc@26 434
adamc@26 435 fun map {typ, exp} e =
adamc@26 436 case mapfold {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@26 437 exp = fn e => fn () => S.Continue (exp e, ())} e () of
adamc@26 438 S.Return () => raise Fail "Mono_util.Exp.map"
adamc@26 439 | S.Continue (e, ()) => e
adamc@26 440
adamc@26 441 fun fold {typ, exp} s e =
adamc@26 442 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
adamc@26 443 exp = fn e => fn s => S.Continue (e, exp (e, s))} e s of
adamc@26 444 S.Continue (_, s) => s
adamc@26 445 | S.Return _ => raise Fail "MonoUtil.Exp.fold: Impossible"
adamc@26 446
adamc@26 447 fun exists {typ, exp} k =
adamc@26 448 case mapfold {typ = fn c => fn () =>
adamc@26 449 if typ c then
adamc@26 450 S.Return ()
adamc@26 451 else
adamc@26 452 S.Continue (c, ()),
adamc@26 453 exp = fn e => fn () =>
adamc@26 454 if exp e then
adamc@26 455 S.Return ()
adamc@26 456 else
adamc@26 457 S.Continue (e, ())} k () of
adamc@26 458 S.Return _ => true
adamc@26 459 | S.Continue _ => false
adamc@26 460
adamc@919 461 fun existsB {typ, exp, bind} ctx e =
adamc@919 462 case mapfoldB {typ = fn t => fn () =>
adamc@919 463 if typ t then
adamc@919 464 S.Return ()
adamc@919 465 else
adamc@919 466 S.Continue (t, ()),
adamc@919 467 exp = fn ctx => fn e => fn () =>
adamc@919 468 if exp (ctx, e) then
adamc@919 469 S.Return ()
adamc@919 470 else
adamc@919 471 S.Continue (e, ()),
adamc@919 472 bind = bind} ctx e () of
adamc@919 473 S.Return _ => true
adamc@919 474 | S.Continue _ => false
adamc@919 475
adamc@567 476 fun foldB {typ, exp, bind} ctx s e =
adamc@567 477 case mapfoldB {typ = fn t => fn s => S.Continue (t, typ (t, s)),
adamc@567 478 exp = fn ctx => fn e => fn s => S.Continue (e, exp (ctx, e, s)),
adamc@567 479 bind = bind} ctx e s of
adamc@567 480 S.Continue (_, s) => s
adamc@567 481 | S.Return _ => raise Fail "MonoUtil.Exp.foldB: Impossible"
adamc@567 482
adam@1612 483 fun appLoc f =
adam@1612 484 let
adam@1612 485 fun appl e =
adam@1612 486 (f e;
adam@1612 487 case #1 e of
adam@1612 488 EPrim _ => ()
adam@1612 489 | ERel _ => ()
adam@1612 490 | ENamed _ => ()
adam@1612 491 | ECon (_, _, eo) => Option.app appl eo
adam@1612 492 | ENone _ => ()
adam@1612 493 | ESome (_, e) => appl e
adam@1612 494 | EFfi _ => ()
adam@1663 495 | EFfiApp (_, _, es) => app (appl o #1) es
adam@1612 496 | EApp (e1, e2) => (appl e1; appl e2)
adam@1612 497 | EAbs (_, _, _, e1) => appl e1
adam@1612 498 | EUnop (_, e1) => appl e1
adam@1612 499 | EBinop (_, _, e1, e2) => (appl e1; appl e2)
adam@1612 500 | ERecord xets => app (appl o #2) xets
adam@1612 501 | EField (e1, _) => appl e1
adam@1612 502 | ECase (e1, pes, _) => (appl e1; app (appl o #2) pes)
adam@1612 503 | EStrcat (e1, e2) => (appl e1; appl e2)
adam@1612 504 | EError (e1, _) => appl e1
adam@1932 505 | EReturnBlob {blob = NONE, mimeType = e2, ...} => appl e2
adam@1932 506 | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => (appl e1; appl e2)
adam@1612 507 | ERedirect (e1, _) => appl e1
adam@1612 508 | EWrite e1 => appl e1
adam@1612 509 | ESeq (e1, e2) => (appl e1; appl e2)
adam@1612 510 | ELet (_, _, e1, e2) => (appl e1; appl e2)
adam@1612 511 | EClosure (_, es) => app appl es
adam@1612 512 | EQuery {query = e1, body = e2, initial = e3, ...} => (appl e1; appl e2; appl e3)
adam@1612 513 | EDml (e1, _) => appl e1
adam@1612 514 | ENextval e1 => appl e1
adam@1612 515 | ESetval (e1, e2) => (appl e1; appl e2)
adam@1612 516 | EUnurlify (e1, _, _) => appl e1
adam@1612 517 | EJavaScript (_, e1) => appl e1
adam@1612 518 | ESignalReturn e1 => appl e1
adam@1612 519 | ESignalBind (e1, e2) => (appl e1; appl e2)
adam@1612 520 | ESignalSource e1 => appl e1
adam@1848 521 | EServerCall (e1, _, _, _) => appl e1
adam@1612 522 | ERecv (e1, _) => appl e1
adam@1612 523 | ESleep e1 => appl e1
adam@1612 524 | ESpawn e1 => appl e1)
adam@1612 525 in
adam@1612 526 appl
adam@1612 527 end
adam@1612 528
adamc@26 529 end
adamc@26 530
adamc@26 531 structure Decl = struct
adamc@26 532
adamc@26 533 datatype binder = datatype Exp.binder
adamc@26 534
adamc@26 535 fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
adamc@26 536 let
adamc@26 537 val mft = Typ.mapfold fc
adamc@26 538
adamc@26 539 val mfe = Exp.mapfoldB {typ = fc, exp = fe, bind = bind}
adamc@26 540
adamc@26 541 fun mfd ctx d acc =
adamc@26 542 S.bindP (mfd' ctx d acc, fd ctx)
adamc@26 543
adamc@26 544 and mfd' ctx (dAll as (d, loc)) =
adamc@26 545 case d of
adamc@808 546 DDatatype dts =>
adamc@808 547 S.map2 (ListUtil.mapfold (fn (x, n, xncs) =>
adamc@808 548 S.map2 (ListUtil.mapfold (fn (x, n, c) =>
adamc@808 549 case c of
adamc@808 550 NONE => S.return2 (x, n, c)
adamc@808 551 | SOME c =>
adamc@808 552 S.map2 (mft c,
adamc@808 553 fn c' => (x, n, SOME c'))) xncs,
adamc@808 554 fn xncs' => (x, n, xncs'))) dts,
adamc@808 555 fn dts' =>
adamc@808 556 (DDatatype dts', loc))
adamc@164 557 | DVal vi =>
adamc@126 558 S.map2 (mfvi ctx vi,
adamc@126 559 fn vi' =>
adamc@126 560 (DVal vi', loc))
adamc@126 561 | DValRec vis =>
adamc@196 562 let
adamc@196 563 val ctx' = foldl (fn ((x, n, t, _, s), ctx') => bind (ctx', NamedE (x, n, t, NONE, s))) ctx vis
adamc@196 564 in
adamc@196 565 S.map2 (ListUtil.mapfold (mfvi ctx') vis,
adamc@196 566 fn vis' =>
adamc@196 567 (DValRec vis', loc))
adamc@196 568 end
adamc@1104 569 | DExport (ek, s, n, ts, t, b) =>
adamc@609 570 S.bind2 (ListUtil.mapfold mft ts,
adamc@120 571 fn ts' =>
adamc@609 572 S.map2 (mft t,
adamc@609 573 fn t' =>
adamc@1104 574 (DExport (ek, s, n, ts', t', b), loc)))
adamc@707 575 | DTable (s, xts, pe, ce) =>
adamc@707 576 S.bind2 (mfe ctx pe,
adamc@707 577 fn pe' =>
adamc@707 578 S.map2 (mfe ctx ce,
adamc@707 579 fn ce' =>
adamc@707 580 (DTable (s, xts, pe', ce'), loc)))
adamc@338 581 | DSequence _ => S.return2 dAll
adamc@754 582 | DView (s, xts, e) =>
adamc@754 583 S.map2 (mfe ctx e,
adamc@754 584 fn e' =>
adamc@754 585 (DView (s, xts, e'), loc))
adamc@271 586 | DDatabase _ => S.return2 dAll
adamc@569 587 | DJavaScript _ => S.return2 dAll
adamc@725 588 | DCookie _ => S.return2 dAll
adamc@718 589 | DStyle _ => S.return2 dAll
adamc@1075 590 | DTask (e1, e2) =>
adamc@1075 591 S.bind2 (mfe ctx e1,
adamc@1075 592 fn e1' =>
adamc@1075 593 S.map2 (mfe ctx e2,
adamc@1075 594 fn e2' =>
adamc@1075 595 (DTask (e1', e2'), loc)))
adamc@1199 596 | DPolicy pol =>
adamc@1199 597 S.map2 (mfpol ctx pol,
adamc@1199 598 fn p' =>
adamc@1199 599 (DPolicy p', loc))
adam@1294 600 | DOnError _ => S.return2 dAll
adamc@1199 601
adamc@1199 602 and mfpol ctx pol =
adamc@1199 603 case pol of
adamc@1214 604 PolClient e =>
adamc@1199 605 S.map2 (mfe ctx e,
adamc@1214 606 PolClient)
adamc@1220 607 | PolInsert e =>
adamc@1220 608 S.map2 (mfe ctx e,
adamc@1220 609 PolInsert)
adamc@1221 610 | PolDelete e =>
adamc@1221 611 S.map2 (mfe ctx e,
adamc@1221 612 PolDelete)
adamc@1223 613 | PolUpdate e =>
adamc@1223 614 S.map2 (mfe ctx e,
adamc@1223 615 PolUpdate)
adamc@1229 616 | PolSequence e =>
adamc@1229 617 S.map2 (mfe ctx e,
adamc@1229 618 PolSequence)
adamc@126 619
adamc@126 620 and mfvi ctx (x, n, t, e, s) =
adamc@126 621 S.bind2 (mft t,
adamc@126 622 fn t' =>
adamc@126 623 S.map2 (mfe ctx e,
adamc@126 624 fn e' =>
adamc@126 625 (x, n, t', e', s)))
adamc@26 626 in
adamc@26 627 mfd
ziv@2218 628 end
adamc@26 629
adamc@26 630 fun mapfold {typ = fc, exp = fe, decl = fd} =
adamc@26 631 mapfoldB {typ = fc,
adamc@26 632 exp = fn () => fe,
adamc@26 633 decl = fn () => fd,
adamc@26 634 bind = fn ((), _) => ()} ()
adamc@26 635
adamc@26 636 fun fold {typ, exp, decl} s d =
adamc@26 637 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
adamc@26 638 exp = fn e => fn s => S.Continue (e, exp (e, s)),
adamc@26 639 decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
adamc@26 640 S.Continue (_, s) => s
adamc@26 641 | S.Return _ => raise Fail "MonoUtil.Decl.fold: Impossible"
adamc@26 642
adamc@506 643 fun map {typ, exp, decl} e =
adamc@506 644 case mapfold {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@506 645 exp = fn e => fn () => S.Continue (exp e, ()),
adamc@506 646 decl = fn d => fn () => S.Continue (decl d, ())} e () of
adamc@506 647 S.Return () => raise Fail "MonoUtil.Decl.map: Impossible"
adamc@506 648 | S.Continue (e, ()) => e
adamc@506 649
adam@1800 650 fun foldMap {typ, exp, decl} s d =
adam@1800 651 case mapfold {typ = fn c => fn s => S.Continue (typ (c, s)),
adam@1800 652 exp = fn e => fn s => S.Continue (exp (e, s)),
adam@1800 653 decl = fn d => fn s => S.Continue (decl (d, s))} d s of
adam@1800 654 S.Continue v => v
adam@1800 655 | S.Return _ => raise Fail "MonoUtil.Decl.foldMap: Impossible"
adam@1800 656
adamc@567 657 fun foldMapB {typ, exp, decl, bind} ctx s d =
adamc@567 658 case mapfoldB {typ = fn c => fn s => S.Continue (typ (c, s)),
adamc@567 659 exp = fn ctx => fn e => fn s => S.Continue (exp (ctx, e, s)),
adamc@567 660 decl = fn ctx => fn d => fn s => S.Continue (decl (ctx, d, s)),
adamc@567 661 bind = bind} ctx d s of
adamc@567 662 S.Continue v => v
adamc@567 663 | S.Return _ => raise Fail "MonoUtil.Decl.foldMapB: Impossible"
adamc@567 664
adam@1847 665 fun exists {typ, exp, decl} k =
adam@1847 666 case mapfold {typ = fn c => fn () =>
adam@1847 667 if typ c then
adam@1847 668 S.Return ()
adam@1847 669 else
adam@1847 670 S.Continue (c, ()),
adam@1847 671 exp = fn e => fn () =>
adam@1847 672 if exp e then
adam@1847 673 S.Return ()
adam@1847 674 else
adam@1847 675 S.Continue (e, ()),
adam@1847 676 decl = fn d => fn () =>
adam@1847 677 if decl d then
adam@1847 678 S.Return ()
adam@1847 679 else
adam@1847 680 S.Continue (d, ())} k () of
adam@1847 681 S.Return _ => true
adam@1847 682 | S.Continue _ => false
adam@1847 683
adamc@26 684 end
adamc@26 685
adamc@26 686 structure File = struct
adamc@26 687
adamc@26 688 datatype binder = datatype Exp.binder
adamc@26 689
adamc@26 690 fun mapfoldB (all as {bind, ...}) =
adamc@26 691 let
adamc@26 692 val mfd = Decl.mapfoldB all
adamc@26 693
ziv@2252 694 fun mff ctx (ds, ps) =
ziv@2252 695 case ds of
ziv@2252 696 nil => S.return2 (nil, ps)
adamc@26 697 | d :: ds' =>
adamc@26 698 S.bind2 (mfd ctx d,
adamc@26 699 fn d' =>
adamc@26 700 let
adamc@100 701 val ctx' =
adamc@26 702 case #1 d' of
adamc@808 703 DDatatype dts =>
adamc@808 704 foldl (fn ((x, n, xncs), ctx) =>
adamc@808 705 let
adamc@808 706 val ctx = bind (ctx, Datatype (x, n, xncs))
adamc@808 707 val t = (TDatatype (n, ref (ElabUtil.classifyDatatype xncs, xncs)),
adamc@808 708 #2 d')
adamc@808 709 in
adamc@808 710 foldl (fn ((x, n, to), ctx) =>
adamc@808 711 let
adamc@808 712 val t = case to of
adamc@808 713 NONE => t
adamc@808 714 | SOME t' => (TFun (t', t), #2 d')
adamc@808 715 in
adamc@808 716 bind (ctx, NamedE (x, n, t, NONE, ""))
adamc@808 717 end)
adamc@808 718 ctx xncs
adamc@808 719 end) ctx dts
adamc@164 720 | DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s))
adamc@126 721 | DValRec vis => foldl (fn ((x, n, t, e, s), ctx) =>
adamc@196 722 bind (ctx, NamedE (x, n, t, NONE, s))) ctx vis
adamc@109 723 | DExport _ => ctx
adamc@273 724 | DTable _ => ctx
adamc@338 725 | DSequence _ => ctx
adamc@754 726 | DView _ => ctx
adamc@271 727 | DDatabase _ => ctx
adamc@569 728 | DJavaScript _ => ctx
adamc@725 729 | DCookie _ => ctx
adamc@718 730 | DStyle _ => ctx
adamc@1075 731 | DTask _ => ctx
adamc@1199 732 | DPolicy _ => ctx
adam@1294 733 | DOnError _ => ctx
adamc@26 734 in
ziv@2252 735 S.map2 (mff ctx' (ds', ps),
ziv@2252 736 fn (ds', _) =>
ziv@2252 737 (d' :: ds', ps))
adamc@26 738 end)
adamc@26 739 in
adamc@26 740 mff
adamc@26 741 end
adamc@26 742
adamc@26 743 fun mapfold {typ = fc, exp = fe, decl = fd} =
adamc@26 744 mapfoldB {typ = fc,
adamc@26 745 exp = fn () => fe,
adamc@26 746 decl = fn () => fd,
adamc@26 747 bind = fn ((), _) => ()} ()
adamc@26 748
adamc@26 749 fun mapB {typ, exp, decl, bind} ctx ds =
adamc@26 750 case mapfoldB {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@26 751 exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()),
adamc@26 752 decl = fn ctx => fn d => fn () => S.Continue (decl ctx d, ()),
adamc@26 753 bind = bind} ctx ds () of
adamc@26 754 S.Continue (ds, ()) => ds
adamc@26 755 | S.Return _ => raise Fail "MonoUtil.File.mapB: Impossible"
adamc@26 756
adamc@96 757 fun map {typ, exp, decl} e =
adamc@96 758 case mapfold {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@96 759 exp = fn e => fn () => S.Continue (exp e, ()),
adamc@96 760 decl = fn d => fn () => S.Continue (decl d, ())} e () of
adamc@506 761 S.Return () => raise Fail "MonoUtil.File.map: Impossible"
adamc@96 762 | S.Continue (e, ()) => e
adamc@96 763
adamc@26 764 fun fold {typ, exp, decl} s d =
adamc@26 765 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
adamc@26 766 exp = fn e => fn s => S.Continue (e, exp (e, s)),
adamc@26 767 decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
adamc@26 768 S.Continue (_, s) => s
adamc@26 769 | S.Return _ => raise Fail "MonoUtil.File.fold: Impossible"
adamc@26 770
adam@1845 771 fun maxName (f : file) =
adam@1845 772 foldl (fn ((d, _) : decl, count) =>
adam@1845 773 case d of
adam@1845 774 DDatatype dts =>
adam@1845 775 foldl (fn ((_, n, ns), count) =>
adam@1845 776 foldl (fn ((_, n', _), m) => Int.max (n', m))
adam@1845 777 (Int.max (n, count)) ns) count dts
adam@1845 778 | DVal (_, n, _, _, _) => Int.max (n, count)
adam@1845 779 | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis
adam@1845 780 | DExport _ => count
adam@1845 781 | DTable _ => count
adam@1845 782 | DSequence _ => count
adam@1845 783 | DView _ => count
adam@1845 784 | DDatabase _ => count
adam@1845 785 | DJavaScript _ => count
adam@1845 786 | DCookie _ => count
adam@1845 787 | DStyle _ => count
adam@1845 788 | DTask _ => count
adam@1845 789 | DPolicy _ => count
ziv@2252 790 | DOnError _ => count) 0 (#1 f)
adamc@506 791
adam@1845 792 fun appLoc f (fl : file) =
adam@1612 793 let
adam@1612 794 val eal = Exp.appLoc f
adam@1612 795
adam@1612 796 fun appl (d : decl) =
adam@1612 797 case #1 d of
adam@1612 798 DDatatype _ => ()
adam@1612 799 | DVal (_, _, _, e1, _) => eal e1
adam@1612 800 | DValRec vis => app (eal o #4) vis
adam@1612 801 | DExport _ => ()
adam@1612 802 | DTable (_, _, e1, e2) => (eal e1; eal e2)
adam@1612 803 | DSequence _ => ()
adam@1612 804 | DView (_, _, e1) => eal e1
adam@1612 805 | DDatabase _ => ()
adam@1612 806 | DJavaScript _ => ()
adam@1612 807 | DCookie _ => ()
adam@1612 808 | DStyle _ => ()
adam@1612 809 | DTask (e1, e2) => (eal e1; eal e2)
adam@1612 810 | DPolicy pol => applPolicy pol
adam@1612 811 | DOnError _ => ()
adam@1612 812
adam@1612 813 and applPolicy p =
adam@1612 814 case p of
adam@1612 815 PolClient e1 => eal e1
adam@1612 816 | PolInsert e1 => eal e1
adam@1612 817 | PolDelete e1 => eal e1
adam@1612 818 | PolUpdate e1 => eal e1
adam@1612 819 | PolSequence e1 => eal e1
adam@1612 820 in
ziv@2252 821 app appl (#1 fl)
adam@1612 822 end
adam@1612 823
adamc@26 824 end
adamc@26 825
adamc@26 826 end