Mercurial > urweb

annotate src/mono_util.sml @ 1244:1eedc9086e6c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Use key information in more places, and catch cases where one key completion depends on another having happened already
author Adam Chlipala <adamc@hcoop.net>
date Sun, 18 Apr 2010 13:00:36 -0400
parents a2cd6664f57f
children 3d06e0f7a6f3
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
adamc@109 83 and sortFields xts = ListMergeSort.sort (fn (x, y) => compareFields (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
adamc@307 335 | EDml e =>
adamc@307 336 S.map2 (mfe ctx e,
adamc@307 337 fn e' =>
adamc@307 338 (EDml e', 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))
adamc@1199 541
adamc@1199 542 and mfpol ctx pol =
adamc@1199 543 case pol of
adamc@1214 544 PolClient e =>
adamc@1199 545 S.map2 (mfe ctx e,
adamc@1214 546 PolClient)
adamc@1220 547 | PolInsert e =>
adamc@1220 548 S.map2 (mfe ctx e,
adamc@1220 549 PolInsert)
adamc@1221 550 | PolDelete e =>
adamc@1221 551 S.map2 (mfe ctx e,
adamc@1221 552 PolDelete)
adamc@1223 553 | PolUpdate e =>
adamc@1223 554 S.map2 (mfe ctx e,
adamc@1223 555 PolUpdate)
adamc@1229 556 | PolSequence e =>
adamc@1229 557 S.map2 (mfe ctx e,
adamc@1229 558 PolSequence)
adamc@126 559
adamc@126 560 and mfvi ctx (x, n, t, e, s) =
adamc@126 561 S.bind2 (mft t,
adamc@126 562 fn t' =>
adamc@126 563 S.map2 (mfe ctx e,
adamc@126 564 fn e' =>
adamc@126 565 (x, n, t', e', s)))
adamc@26 566 in
adamc@26 567 mfd
adamc@26 568 end
adamc@26 569
adamc@26 570 fun mapfold {typ = fc, exp = fe, decl = fd} =
adamc@26 571 mapfoldB {typ = fc,
adamc@26 572 exp = fn () => fe,
adamc@26 573 decl = fn () => fd,
adamc@26 574 bind = fn ((), _) => ()} ()
adamc@26 575
adamc@26 576 fun fold {typ, exp, decl} s d =
adamc@26 577 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
adamc@26 578 exp = fn e => fn s => S.Continue (e, exp (e, s)),
adamc@26 579 decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
adamc@26 580 S.Continue (_, s) => s
adamc@26 581 | S.Return _ => raise Fail "MonoUtil.Decl.fold: Impossible"
adamc@26 582
adamc@506 583 fun map {typ, exp, decl} e =
adamc@506 584 case mapfold {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@506 585 exp = fn e => fn () => S.Continue (exp e, ()),
adamc@506 586 decl = fn d => fn () => S.Continue (decl d, ())} e () of
adamc@506 587 S.Return () => raise Fail "MonoUtil.Decl.map: Impossible"
adamc@506 588 | S.Continue (e, ()) => e
adamc@506 589
adamc@567 590 fun foldMapB {typ, exp, decl, bind} ctx s d =
adamc@567 591 case mapfoldB {typ = fn c => fn s => S.Continue (typ (c, s)),
adamc@567 592 exp = fn ctx => fn e => fn s => S.Continue (exp (ctx, e, s)),
adamc@567 593 decl = fn ctx => fn d => fn s => S.Continue (decl (ctx, d, s)),
adamc@567 594 bind = bind} ctx d s of
adamc@567 595 S.Continue v => v
adamc@567 596 | S.Return _ => raise Fail "MonoUtil.Decl.foldMapB: Impossible"
adamc@567 597
adamc@26 598 end
adamc@26 599
adamc@26 600 structure File = struct
adamc@26 601
adamc@26 602 datatype binder = datatype Exp.binder
adamc@26 603
adamc@26 604 fun mapfoldB (all as {bind, ...}) =
adamc@26 605 let
adamc@26 606 val mfd = Decl.mapfoldB all
adamc@26 607
adamc@26 608 fun mff ctx ds =
adamc@26 609 case ds of
adamc@26 610 nil => S.return2 nil
adamc@26 611 | d :: ds' =>
adamc@26 612 S.bind2 (mfd ctx d,
adamc@26 613 fn d' =>
adamc@26 614 let
adamc@100 615 val ctx' =
adamc@26 616 case #1 d' of
adamc@808 617 DDatatype dts =>
adamc@808 618 foldl (fn ((x, n, xncs), ctx) =>
adamc@808 619 let
adamc@808 620 val ctx = bind (ctx, Datatype (x, n, xncs))
adamc@808 621 val t = (TDatatype (n, ref (ElabUtil.classifyDatatype xncs, xncs)),
adamc@808 622 #2 d')
adamc@808 623 in
adamc@808 624 foldl (fn ((x, n, to), ctx) =>
adamc@808 625 let
adamc@808 626 val t = case to of
adamc@808 627 NONE => t
adamc@808 628 | SOME t' => (TFun (t', t), #2 d')
adamc@808 629 in
adamc@808 630 bind (ctx, NamedE (x, n, t, NONE, ""))
adamc@808 631 end)
adamc@808 632 ctx xncs
adamc@808 633 end) ctx dts
adamc@164 634 | DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s))
adamc@126 635 | DValRec vis => foldl (fn ((x, n, t, e, s), ctx) =>
adamc@196 636 bind (ctx, NamedE (x, n, t, NONE, s))) ctx vis
adamc@109 637 | DExport _ => ctx
adamc@273 638 | DTable _ => ctx
adamc@338 639 | DSequence _ => ctx
adamc@754 640 | DView _ => ctx
adamc@271 641 | DDatabase _ => ctx
adamc@569 642 | DJavaScript _ => ctx
adamc@725 643 | DCookie _ => ctx
adamc@718 644 | DStyle _ => ctx
adamc@1075 645 | DTask _ => ctx
adamc@1199 646 | DPolicy _ => ctx
adamc@26 647 in
adamc@26 648 S.map2 (mff ctx' ds',
adamc@26 649 fn ds' =>
adamc@26 650 d' :: ds')
adamc@26 651 end)
adamc@26 652 in
adamc@26 653 mff
adamc@26 654 end
adamc@26 655
adamc@26 656 fun mapfold {typ = fc, exp = fe, decl = fd} =
adamc@26 657 mapfoldB {typ = fc,
adamc@26 658 exp = fn () => fe,
adamc@26 659 decl = fn () => fd,
adamc@26 660 bind = fn ((), _) => ()} ()
adamc@26 661
adamc@26 662 fun mapB {typ, exp, decl, bind} ctx ds =
adamc@26 663 case mapfoldB {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@26 664 exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()),
adamc@26 665 decl = fn ctx => fn d => fn () => S.Continue (decl ctx d, ()),
adamc@26 666 bind = bind} ctx ds () of
adamc@26 667 S.Continue (ds, ()) => ds
adamc@26 668 | S.Return _ => raise Fail "MonoUtil.File.mapB: Impossible"
adamc@26 669
adamc@96 670 fun map {typ, exp, decl} e =
adamc@96 671 case mapfold {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@96 672 exp = fn e => fn () => S.Continue (exp e, ()),
adamc@96 673 decl = fn d => fn () => S.Continue (decl d, ())} e () of
adamc@506 674 S.Return () => raise Fail "MonoUtil.File.map: Impossible"
adamc@96 675 | S.Continue (e, ()) => e
adamc@96 676
adamc@26 677 fun fold {typ, exp, decl} s d =
adamc@26 678 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
adamc@26 679 exp = fn e => fn s => S.Continue (e, exp (e, s)),
adamc@26 680 decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
adamc@26 681 S.Continue (_, s) => s
adamc@26 682 | S.Return _ => raise Fail "MonoUtil.File.fold: Impossible"
adamc@26 683
adamc@506 684 val maxName = foldl (fn ((d, _) : decl, count) =>
adamc@506 685 case d of
adamc@808 686 DDatatype dts =>
adamc@808 687 foldl (fn ((_, n, ns), count) =>
adamc@808 688 foldl (fn ((_, n', _), m) => Int.max (n', m))
adamc@808 689 (Int.max (n, count)) ns) count dts
adamc@506 690 | DVal (_, n, _, _, _) => Int.max (n, count)
adamc@506 691 | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis
adamc@506 692 | DExport _ => count
adamc@506 693 | DTable _ => count
adamc@506 694 | DSequence _ => count
adamc@754 695 | DView _ => count
adamc@569 696 | DDatabase _ => count
adamc@718 697 | DJavaScript _ => count
adamc@725 698 | DCookie _ => count
adamc@1073 699 | DStyle _ => count
adamc@1199 700 | DTask _ => count
adamc@1199 701 | DPolicy _ => count) 0
adamc@506 702
adamc@26 703 end
adamc@26 704
adamc@26 705 end