Mercurial > urweb

annotate src/mono_util.sml @ 1327:1cc67fdac4d3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
New argument to transactional free functions, to specify whether we are about to retry
author Adam Chlipala <adam@chlipala.net>
date Sat, 04 Dec 2010 11:15:20 -0500
parents 6c2e565adca6
children 02fc16faecf3
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))
adamc@387 203 | EBinop (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' =>
adamc@387 208 (EBinop (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
adamc@26 470 end
adamc@26 471
adamc@26 472 structure Decl = struct
adamc@26 473
adamc@26 474 datatype binder = datatype Exp.binder
adamc@26 475
adamc@26 476 fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
adamc@26 477 let
adamc@26 478 val mft = Typ.mapfold fc
adamc@26 479
adamc@26 480 val mfe = Exp.mapfoldB {typ = fc, exp = fe, bind = bind}
adamc@26 481
adamc@26 482 fun mfd ctx d acc =
adamc@26 483 S.bindP (mfd' ctx d acc, fd ctx)
adamc@26 484
adamc@26 485 and mfd' ctx (dAll as (d, loc)) =
adamc@26 486 case d of
adamc@808 487 DDatatype dts =>
adamc@808 488 S.map2 (ListUtil.mapfold (fn (x, n, xncs) =>
adamc@808 489 S.map2 (ListUtil.mapfold (fn (x, n, c) =>
adamc@808 490 case c of
adamc@808 491 NONE => S.return2 (x, n, c)
adamc@808 492 | SOME c =>
adamc@808 493 S.map2 (mft c,
adamc@808 494 fn c' => (x, n, SOME c'))) xncs,
adamc@808 495 fn xncs' => (x, n, xncs'))) dts,
adamc@808 496 fn dts' =>
adamc@808 497 (DDatatype dts', loc))
adamc@164 498 | DVal vi =>
adamc@126 499 S.map2 (mfvi ctx vi,
adamc@126 500 fn vi' =>
adamc@126 501 (DVal vi', loc))
adamc@126 502 | DValRec vis =>
adamc@196 503 let
adamc@196 504 val ctx' = foldl (fn ((x, n, t, _, s), ctx') => bind (ctx', NamedE (x, n, t, NONE, s))) ctx vis
adamc@196 505 in
adamc@196 506 S.map2 (ListUtil.mapfold (mfvi ctx') vis,
adamc@196 507 fn vis' =>
adamc@196 508 (DValRec vis', loc))
adamc@196 509 end
adamc@1104 510 | DExport (ek, s, n, ts, t, b) =>
adamc@609 511 S.bind2 (ListUtil.mapfold mft ts,
adamc@120 512 fn ts' =>
adamc@609 513 S.map2 (mft t,
adamc@609 514 fn t' =>
adamc@1104 515 (DExport (ek, s, n, ts', t', b), loc)))
adamc@707 516 | DTable (s, xts, pe, ce) =>
adamc@707 517 S.bind2 (mfe ctx pe,
adamc@707 518 fn pe' =>
adamc@707 519 S.map2 (mfe ctx ce,
adamc@707 520 fn ce' =>
adamc@707 521 (DTable (s, xts, pe', ce'), loc)))
adamc@338 522 | DSequence _ => S.return2 dAll
adamc@754 523 | DView (s, xts, e) =>
adamc@754 524 S.map2 (mfe ctx e,
adamc@754 525 fn e' =>
adamc@754 526 (DView (s, xts, e'), loc))
adamc@271 527 | DDatabase _ => S.return2 dAll
adamc@569 528 | DJavaScript _ => S.return2 dAll
adamc@725 529 | DCookie _ => S.return2 dAll
adamc@718 530 | DStyle _ => S.return2 dAll
adamc@1075 531 | DTask (e1, e2) =>
adamc@1075 532 S.bind2 (mfe ctx e1,
adamc@1075 533 fn e1' =>
adamc@1075 534 S.map2 (mfe ctx e2,
adamc@1075 535 fn e2' =>
adamc@1075 536 (DTask (e1', e2'), loc)))
adamc@1199 537 | DPolicy pol =>
adamc@1199 538 S.map2 (mfpol ctx pol,
adamc@1199 539 fn p' =>
adamc@1199 540 (DPolicy p', loc))
adam@1294 541 | DOnError _ => S.return2 dAll
adamc@1199 542
adamc@1199 543 and mfpol ctx pol =
adamc@1199 544 case pol of
adamc@1214 545 PolClient e =>
adamc@1199 546 S.map2 (mfe ctx e,
adamc@1214 547 PolClient)
adamc@1220 548 | PolInsert e =>
adamc@1220 549 S.map2 (mfe ctx e,
adamc@1220 550 PolInsert)
adamc@1221 551 | PolDelete e =>
adamc@1221 552 S.map2 (mfe ctx e,
adamc@1221 553 PolDelete)
adamc@1223 554 | PolUpdate e =>
adamc@1223 555 S.map2 (mfe ctx e,
adamc@1223 556 PolUpdate)
adamc@1229 557 | PolSequence e =>
adamc@1229 558 S.map2 (mfe ctx e,
adamc@1229 559 PolSequence)
adamc@126 560
adamc@126 561 and mfvi ctx (x, n, t, e, s) =
adamc@126 562 S.bind2 (mft t,
adamc@126 563 fn t' =>
adamc@126 564 S.map2 (mfe ctx e,
adamc@126 565 fn e' =>
adamc@126 566 (x, n, t', e', s)))
adamc@26 567 in
adamc@26 568 mfd
adamc@26 569 end
adamc@26 570
adamc@26 571 fun mapfold {typ = fc, exp = fe, decl = fd} =
adamc@26 572 mapfoldB {typ = fc,
adamc@26 573 exp = fn () => fe,
adamc@26 574 decl = fn () => fd,
adamc@26 575 bind = fn ((), _) => ()} ()
adamc@26 576
adamc@26 577 fun fold {typ, exp, decl} s d =
adamc@26 578 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
adamc@26 579 exp = fn e => fn s => S.Continue (e, exp (e, s)),
adamc@26 580 decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
adamc@26 581 S.Continue (_, s) => s
adamc@26 582 | S.Return _ => raise Fail "MonoUtil.Decl.fold: Impossible"
adamc@26 583
adamc@506 584 fun map {typ, exp, decl} e =
adamc@506 585 case mapfold {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@506 586 exp = fn e => fn () => S.Continue (exp e, ()),
adamc@506 587 decl = fn d => fn () => S.Continue (decl d, ())} e () of
adamc@506 588 S.Return () => raise Fail "MonoUtil.Decl.map: Impossible"
adamc@506 589 | S.Continue (e, ()) => e
adamc@506 590
adamc@567 591 fun foldMapB {typ, exp, decl, bind} ctx s d =
adamc@567 592 case mapfoldB {typ = fn c => fn s => S.Continue (typ (c, s)),
adamc@567 593 exp = fn ctx => fn e => fn s => S.Continue (exp (ctx, e, s)),
adamc@567 594 decl = fn ctx => fn d => fn s => S.Continue (decl (ctx, d, s)),
adamc@567 595 bind = bind} ctx d s of
adamc@567 596 S.Continue v => v
adamc@567 597 | S.Return _ => raise Fail "MonoUtil.Decl.foldMapB: Impossible"
adamc@567 598
adamc@26 599 end
adamc@26 600
adamc@26 601 structure File = struct
adamc@26 602
adamc@26 603 datatype binder = datatype Exp.binder
adamc@26 604
adamc@26 605 fun mapfoldB (all as {bind, ...}) =
adamc@26 606 let
adamc@26 607 val mfd = Decl.mapfoldB all
adamc@26 608
adamc@26 609 fun mff ctx ds =
adamc@26 610 case ds of
adamc@26 611 nil => S.return2 nil
adamc@26 612 | d :: ds' =>
adamc@26 613 S.bind2 (mfd ctx d,
adamc@26 614 fn d' =>
adamc@26 615 let
adamc@100 616 val ctx' =
adamc@26 617 case #1 d' of
adamc@808 618 DDatatype dts =>
adamc@808 619 foldl (fn ((x, n, xncs), ctx) =>
adamc@808 620 let
adamc@808 621 val ctx = bind (ctx, Datatype (x, n, xncs))
adamc@808 622 val t = (TDatatype (n, ref (ElabUtil.classifyDatatype xncs, xncs)),
adamc@808 623 #2 d')
adamc@808 624 in
adamc@808 625 foldl (fn ((x, n, to), ctx) =>
adamc@808 626 let
adamc@808 627 val t = case to of
adamc@808 628 NONE => t
adamc@808 629 | SOME t' => (TFun (t', t), #2 d')
adamc@808 630 in
adamc@808 631 bind (ctx, NamedE (x, n, t, NONE, ""))
adamc@808 632 end)
adamc@808 633 ctx xncs
adamc@808 634 end) ctx dts
adamc@164 635 | DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s))
adamc@126 636 | DValRec vis => foldl (fn ((x, n, t, e, s), ctx) =>
adamc@196 637 bind (ctx, NamedE (x, n, t, NONE, s))) ctx vis
adamc@109 638 | DExport _ => ctx
adamc@273 639 | DTable _ => ctx
adamc@338 640 | DSequence _ => ctx
adamc@754 641 | DView _ => ctx
adamc@271 642 | DDatabase _ => ctx
adamc@569 643 | DJavaScript _ => ctx
adamc@725 644 | DCookie _ => ctx
adamc@718 645 | DStyle _ => ctx
adamc@1075 646 | DTask _ => ctx
adamc@1199 647 | DPolicy _ => ctx
adam@1294 648 | DOnError _ => ctx
adamc@26 649 in
adamc@26 650 S.map2 (mff ctx' ds',
adamc@26 651 fn ds' =>
adamc@26 652 d' :: ds')
adamc@26 653 end)
adamc@26 654 in
adamc@26 655 mff
adamc@26 656 end
adamc@26 657
adamc@26 658 fun mapfold {typ = fc, exp = fe, decl = fd} =
adamc@26 659 mapfoldB {typ = fc,
adamc@26 660 exp = fn () => fe,
adamc@26 661 decl = fn () => fd,
adamc@26 662 bind = fn ((), _) => ()} ()
adamc@26 663
adamc@26 664 fun mapB {typ, exp, decl, bind} ctx ds =
adamc@26 665 case mapfoldB {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@26 666 exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()),
adamc@26 667 decl = fn ctx => fn d => fn () => S.Continue (decl ctx d, ()),
adamc@26 668 bind = bind} ctx ds () of
adamc@26 669 S.Continue (ds, ()) => ds
adamc@26 670 | S.Return _ => raise Fail "MonoUtil.File.mapB: Impossible"
adamc@26 671
adamc@96 672 fun map {typ, exp, decl} e =
adamc@96 673 case mapfold {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@96 674 exp = fn e => fn () => S.Continue (exp e, ()),
adamc@96 675 decl = fn d => fn () => S.Continue (decl d, ())} e () of
adamc@506 676 S.Return () => raise Fail "MonoUtil.File.map: Impossible"
adamc@96 677 | S.Continue (e, ()) => e
adamc@96 678
adamc@26 679 fun fold {typ, exp, decl} s d =
adamc@26 680 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
adamc@26 681 exp = fn e => fn s => S.Continue (e, exp (e, s)),
adamc@26 682 decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
adamc@26 683 S.Continue (_, s) => s
adamc@26 684 | S.Return _ => raise Fail "MonoUtil.File.fold: Impossible"
adamc@26 685
adamc@506 686 val maxName = foldl (fn ((d, _) : decl, count) =>
adamc@506 687 case d of
adamc@808 688 DDatatype dts =>
adamc@808 689 foldl (fn ((_, n, ns), count) =>
adamc@808 690 foldl (fn ((_, n', _), m) => Int.max (n', m))
adamc@808 691 (Int.max (n, count)) ns) count dts
adamc@506 692 | DVal (_, n, _, _, _) => Int.max (n, count)
adamc@506 693 | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis
adamc@506 694 | DExport _ => count
adamc@506 695 | DTable _ => count
adamc@506 696 | DSequence _ => count
adamc@754 697 | DView _ => count
adamc@569 698 | DDatabase _ => count
adamc@718 699 | DJavaScript _ => count
adamc@725 700 | DCookie _ => count
adamc@1073 701 | DStyle _ => count
adamc@1199 702 | DTask _ => count
adam@1294 703 | DPolicy _ => count
adam@1294 704 | DOnError _ => count) 0
adamc@506 705
adamc@26 706 end
adamc@26 707
adamc@26 708 end