Mercurial > urweb

annotate src/mono_util.sml @ 1775:6bc2a8cb3a67

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