adam@1847: (* Copyright (c) 2008, 2013, Adam Chlipala adamc@26: * All rights reserved. adamc@26: * adamc@26: * Redistribution and use in source and binary forms, with or without adamc@26: * modification, are permitted provided that the following conditions are met: adamc@26: * adamc@26: * - Redistributions of source code must retain the above copyright notice, adamc@26: * this list of conditions and the following disclaimer. adamc@26: * - Redistributions in binary form must reproduce the above copyright notice, adamc@26: * this list of conditions and the following disclaimer in the documentation adamc@26: * and/or other materials provided with the distribution. adamc@26: * - The names of contributors may not be used to endorse or promote products adamc@26: * derived from this software without specific prior written permission. adamc@26: * adamc@26: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@26: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@26: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@26: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@26: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@26: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@26: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@26: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@26: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@26: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@26: * POSSIBILITY OF SUCH DAMAGE. adamc@26: *) adamc@26: adamc@26: structure MonoUtil :> MONO_UTIL = struct adamc@26: adamc@26: open Mono adamc@26: adamc@26: structure S = Search adamc@26: adamc@267: val dummyt = (TRecord [], ErrorMsg.dummySpan) adamc@267: adamc@26: structure Typ = struct adamc@26: adamc@193: open Order adamc@109: adamc@109: fun compare ((t1, _), (t2, _)) = adamc@109: case (t1, t2) of adamc@109: (TFun (d1, r1), TFun (d2, r2)) => adamc@109: join (compare (d1, d2), fn () => compare (r1, r2)) adamc@109: | (TRecord xts1, TRecord xts2) => adamc@109: let adamc@109: val xts1 = sortFields xts1 adamc@109: val xts2 = sortFields xts2 adamc@109: in adamc@109: joinL compareFields (xts1, xts2) adamc@109: end adamc@196: | (TDatatype (n1, _), TDatatype (n2, _)) => Int.compare (n1, n2) adamc@109: | (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2)) adamc@288: | (TOption t1, TOption t2) => compare (t1, t2) adamc@757: | (TList t1, TList t2) => compare (t1, t2) adamc@577: | (TSource, TSource) => EQUAL adamc@568: | (TSignal t1, TSignal t2) => compare (t1, t2) adamc@109: adamc@109: | (TFun _, _) => LESS adamc@109: | (_, TFun _) => GREATER adamc@109: adamc@109: | (TRecord _, _) => LESS adamc@109: | (_, TRecord _) => GREATER adamc@109: adamc@168: | (TDatatype _, _) => LESS adamc@168: | (_, TDatatype _) => GREATER adamc@109: adamc@288: | (TFfi _, _) => LESS adamc@288: | (_, TFfi _) => GREATER adamc@288: adamc@568: | (TOption _, _) => LESS adamc@568: | (_, TOption _) => GREATER adamc@568: adamc@757: | (TList _, _) => LESS adamc@757: | (_, TList _) => GREATER adamc@757: adamc@577: | (TSource, _) => LESS adamc@577: | (_, TSource) => GREATER adamc@577: adamc@109: and compareFields ((x1, t1), (x2, t2)) = adamc@109: join (String.compare (x1, x2), adamc@109: fn () => compare (t1, t2)) adamc@109: adam@1314: and sortFields xts = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) xts adamc@109: adamc@26: fun mapfold fc = adamc@26: let adamc@26: fun mft c acc = adamc@26: S.bindP (mft' c acc, fc) adamc@26: adamc@26: and mft' (cAll as (c, loc)) = adamc@26: case c of adamc@26: TFun (t1, t2) => adamc@26: S.bind2 (mft t1, adamc@26: fn t1' => adamc@26: S.map2 (mft t2, adamc@26: fn t2' => adamc@26: (TFun (t1', t2'), loc))) adamc@26: | TRecord xts => adamc@26: S.map2 (ListUtil.mapfold (fn (x, t) => adamc@26: S.map2 (mft t, adamc@26: fn t' => adamc@26: (x, t'))) adamc@26: xts, adamc@26: fn xts' => (TRecord xts', loc)) adamc@168: | TDatatype _ => S.return2 cAll adamc@51: | TFfi _ => S.return2 cAll adamc@288: | TOption t => adamc@288: S.map2 (mft t, adamc@288: fn t' => adamc@288: (TOption t, loc)) adamc@757: | TList t => adamc@757: S.map2 (mft t, adamc@757: fn t' => adamc@757: (TList t, loc)) adamc@577: | TSource => S.return2 cAll adamc@568: | TSignal t => adamc@568: S.map2 (mft t, adamc@568: fn t' => adamc@568: (TSignal t, loc)) adamc@26: in adamc@26: mft adamc@26: end adamc@26: adamc@26: fun map typ c = adamc@26: case mapfold (fn c => fn () => S.Continue (typ c, ())) c () of adamc@26: S.Return () => raise Fail "Mono_util.Typ.map" adamc@26: | S.Continue (c, ()) => c adamc@26: adamc@26: fun fold typ s c = adamc@26: case mapfold (fn c => fn s => S.Continue (c, typ (c, s))) c s of adamc@26: S.Continue (_, s) => s adamc@26: | S.Return _ => raise Fail "MonoUtil.Typ.fold: Impossible" adamc@26: adamc@26: fun exists typ k = adamc@26: case mapfold (fn c => fn () => adamc@26: if typ c then adamc@26: S.Return () adamc@26: else adamc@26: S.Continue (c, ())) k () of adamc@26: S.Return _ => true adamc@26: | S.Continue _ => false adamc@26: adamc@26: end adamc@26: adamc@26: structure Exp = struct adamc@26: adamc@26: datatype binder = adamc@168: Datatype of string * int * (string * int * typ option) list adamc@26: | RelE of string * typ adamc@109: | NamedE of string * int * typ * exp option * string adamc@26: adamc@26: fun mapfoldB {typ = fc, exp = fe, bind} = adamc@26: let adamc@26: val mft = Typ.mapfold fc adamc@26: adamc@26: fun mfe ctx e acc = adamc@26: S.bindP (mfe' ctx e acc, fe ctx) adamc@26: adam@1663: and mfet ctx (e, t) = adam@1663: S.bind2 (mfe ctx e, adam@1663: fn e' => adam@1663: S.map2 (mft t, adam@1663: fn t' => (e', t'))) adam@1663: adamc@26: and mfe' ctx (eAll as (e, loc)) = adamc@26: case e of adamc@26: EPrim _ => S.return2 eAll adamc@26: | ERel _ => S.return2 eAll adamc@26: | ENamed _ => S.return2 eAll adamc@188: | ECon (_, _, NONE) => S.return2 eAll adamc@188: | ECon (dk, n, SOME e) => adamc@178: S.map2 (mfe ctx e, adamc@178: fn e' => adamc@188: (ECon (dk, n, SOME e'), loc)) adamc@297: | ENone t => adamc@297: S.map2 (mft t, adamc@297: fn t' => adamc@297: (ENone t', loc)) adamc@290: | ESome (t, e) => adamc@290: S.bind2 (mft t, adamc@290: fn t' => adamc@290: S.map2 (mfe ctx e, adamc@290: fn e' => adamc@290: (ESome (t', e'), loc))) adamc@51: | EFfi _ => S.return2 eAll adamc@51: | EFfiApp (m, x, es) => adam@1663: S.map2 (ListUtil.mapfold (fn e => mfet ctx e) es, adamc@51: fn es' => adamc@51: (EFfiApp (m, x, es'), loc)) adamc@26: | EApp (e1, e2) => adamc@26: S.bind2 (mfe ctx e1, adamc@26: fn e1' => adamc@26: S.map2 (mfe ctx e2, adamc@26: fn e2' => adamc@26: (EApp (e1', e2'), loc))) adamc@26: | EAbs (x, dom, ran, e) => adamc@26: S.bind2 (mft dom, adamc@26: fn dom' => adamc@26: S.bind2 (mft ran, adamc@26: fn ran' => adamc@26: S.map2 (mfe (bind (ctx, RelE (x, dom'))) e, adamc@26: fn e' => adamc@26: (EAbs (x, dom', ran', e'), loc)))) adamc@26: adamc@387: | EUnop (s, e) => adamc@387: S.map2 (mfe ctx e, adamc@387: fn e' => adamc@387: (EUnop (s, e'), loc)) adam@1360: | EBinop (bi, s, e1, e2) => adamc@387: S.bind2 (mfe ctx e1, adamc@387: fn e1' => adamc@387: S.map2 (mfe ctx e2, adamc@387: fn e2' => adam@1360: (EBinop (bi, s, e1', e2'), loc))) adamc@387: adamc@26: | ERecord xes => adamc@29: S.map2 (ListUtil.mapfold (fn (x, e, t) => adamc@29: S.bind2 (mfe ctx e, adamc@26: fn e' => adamc@29: S.map2 (mft t, adamc@29: fn t' => adamc@29: (x, e', t')))) adamc@26: xes, adamc@26: fn xes' => adamc@26: (ERecord xes', loc)) adamc@26: | EField (e, x) => adamc@26: S.map2 (mfe ctx e, adamc@26: fn e' => adamc@26: (EField (e', x), loc)) adamc@94: adamc@182: | ECase (e, pes, {disc, result}) => adamc@178: S.bind2 (mfe ctx e, adamc@178: fn e' => adamc@178: S.bind2 (ListUtil.mapfold (fn (p, e) => adamc@179: let adamc@179: fun pb ((p, _), ctx) = adamc@179: case p of adamc@179: PWild => ctx adamc@182: | PVar (x, t) => bind (ctx, RelE (x, t)) adamc@179: | PPrim _ => ctx adamc@188: | PCon (_, _, NONE) => ctx adamc@188: | PCon (_, _, SOME p) => pb (p, ctx) adamc@182: | PRecord xps => foldl (fn ((_, p, _), ctx) => adamc@179: pb (p, ctx)) ctx xps adamc@288: | PNone _ => ctx adamc@288: | PSome (_, p) => pb (p, ctx) adamc@179: in adamc@179: S.map2 (mfe (pb (p, ctx)) e, adamc@179: fn e' => (p, e')) adamc@179: end) pes, adamc@178: fn pes' => adamc@182: S.bind2 (mft disc, adamc@182: fn disc' => adamc@182: S.map2 (mft result, adamc@182: fn result' => adamc@182: (ECase (e', pes', {disc = disc', result = result'}), loc))))) adamc@178: adamc@283: | EError (e, t) => adamc@283: S.bind2 (mfe ctx e, adamc@283: fn e' => adamc@283: S.map2 (mft t, adamc@283: fn t' => adamc@283: (EError (e', t'), loc))) adam@1932: | EReturnBlob {blob = NONE, mimeType, t} => adam@1932: S.bind2 (mfe ctx mimeType, adam@1932: fn mimeType' => adam@1932: S.map2 (mft t, adam@1932: fn t' => adam@1932: (EReturnBlob {blob = NONE, mimeType = mimeType', t = t'}, loc))) adam@1932: | EReturnBlob {blob = SOME blob, mimeType, t} => adamc@741: S.bind2 (mfe ctx blob, adamc@741: fn blob' => adamc@741: S.bind2 (mfe ctx mimeType, adamc@741: fn mimeType' => adamc@741: S.map2 (mft t, adamc@741: fn t' => adam@1932: (EReturnBlob {blob = SOME blob', mimeType = mimeType', t = t'}, loc)))) adamc@1065: | ERedirect (e, t) => adamc@1065: S.bind2 (mfe ctx e, adamc@1065: fn e' => adamc@1065: S.map2 (mft t, adamc@1065: fn t' => adamc@1065: (ERedirect (e', t'), loc))) adamc@741: adamc@94: | EStrcat (e1, e2) => adamc@94: S.bind2 (mfe ctx e1, adamc@94: fn e1' => adamc@94: S.map2 (mfe ctx e2, adamc@94: fn e2' => adamc@94: (EStrcat (e1', e2'), loc))) adamc@102: adamc@102: | EWrite e => adamc@102: S.map2 (mfe ctx e, adamc@102: fn e' => adamc@102: (EWrite e', loc)) adamc@106: adamc@106: | ESeq (e1, e2) => adamc@106: S.bind2 (mfe ctx e1, adamc@106: fn e1' => adamc@106: S.map2 (mfe ctx e2, adamc@106: fn e2' => adamc@106: (ESeq (e1', e2'), loc))) adamc@251: | ELet (x, t, e1, e2) => adamc@251: S.bind2 (mft t, adamc@251: fn t' => adamc@251: S.bind2 (mfe ctx e1, adamc@251: fn e1' => adamc@252: S.map2 (mfe (bind (ctx, RelE (x, t'))) e2, adamc@251: fn e2' => adamc@251: (ELet (x, t', e1', e2'), loc)))) adamc@111: adamc@111: | EClosure (n, es) => adamc@111: S.map2 (ListUtil.mapfold (mfe ctx) es, adamc@111: fn es' => adamc@111: (EClosure (n, es'), loc)) adamc@252: adamc@252: | EQuery {exps, tables, state, query, body, initial} => adamc@252: S.bind2 (ListUtil.mapfold (fn (x, t) => adamc@252: S.map2 (mft t, adamc@252: fn t' => (x, t'))) exps, adamc@252: fn exps' => adamc@252: S.bind2 (ListUtil.mapfold (fn (x, xts) => adamc@252: S.map2 (ListUtil.mapfold adamc@252: (fn (x, t) => adamc@252: S.map2 (mft t, adamc@252: fn t' => (x, t'))) xts, adamc@252: fn xts' => (x, xts'))) tables, adamc@252: fn tables' => adamc@252: S.bind2 (mft state, adamc@252: fn state' => adamc@252: S.bind2 (mfe ctx query, adamc@252: fn query' => adamc@267: S.bind2 (mfe (bind (bind (ctx, RelE ("r", dummyt)), adamc@267: RelE ("acc", dummyt))) adamc@267: body, adamc@267: fn body' => adamc@267: S.map2 (mfe ctx initial, adamc@267: fn initial' => adamc@267: (EQuery {exps = exps', adamc@267: tables = tables', adamc@267: state = state', adamc@267: query = query', adamc@267: body = body', adamc@267: initial = initial'}, adamc@267: loc))))))) adamc@307: adam@1293: | EDml (e, fm) => adamc@307: S.map2 (mfe ctx e, adamc@307: fn e' => adam@1293: (EDml (e', fm), loc)) adamc@338: | ENextval e => adamc@338: S.map2 (mfe ctx e, adamc@338: fn e' => adamc@338: (ENextval e', loc)) adamc@1073: | ESetval (e1, e2) => adamc@1073: S.bind2 (mfe ctx e1, adamc@1073: fn e1' => adamc@1073: S.map2 (mfe ctx e2, adamc@1073: fn e2' => adamc@1073: (ESetval (e1', e2'), loc))) adamc@1112: | EUnurlify (e, t, b) => adamc@463: S.bind2 (mfe ctx e, adamc@463: fn e' => adamc@463: S.map2 (mft t, adamc@463: fn t' => adamc@1112: (EUnurlify (e', t', b), loc))) adamc@815: | EJavaScript (m, e) => adamc@729: S.bind2 (mfmode ctx m, adamc@729: fn m' => adamc@729: S.map2 (mfe ctx e, adamc@729: fn e' => adamc@815: (EJavaScript (m', e'), loc))) adamc@569: adamc@568: | ESignalReturn e => adamc@568: S.map2 (mfe ctx e, adamc@568: fn e' => adamc@568: (ESignalReturn e', loc)) adamc@572: | ESignalBind (e1, e2) => adamc@572: S.bind2 (mfe ctx e1, adamc@572: fn e1' => adamc@572: S.map2 (mfe ctx e2, adamc@572: fn e2' => adamc@572: (ESignalBind (e1', e2'), loc))) adamc@574: | ESignalSource e => adamc@574: S.map2 (mfe ctx e, adamc@574: fn e' => adamc@574: (ESignalSource e', loc)) adamc@608: adam@1848: | EServerCall (s, t, eff, fm) => adamc@642: S.bind2 (mfe ctx s, adamc@642: fn s' => adamc@1020: S.map2 (mft t, adamc@1020: fn t' => adam@1848: (EServerCall (s', t', eff, fm), loc))) adamc@1021: | ERecv (s, t) => adamc@670: S.bind2 (mfe ctx s, adamc@695: fn s' => adamc@1021: S.map2 (mft t, adamc@1021: fn t' => adamc@1021: (ERecv (s', t'), loc))) adamc@1021: | ESleep s => adamc@1021: S.map2 (mfe ctx s, adamc@695: fn s' => adamc@1021: (ESleep s', loc)) adamc@1021: adamc@1021: | ESpawn s => adamc@1021: S.map2 (mfe ctx s, adamc@1021: fn s' => adamc@1021: (ESpawn s', loc)) adamc@729: adamc@729: and mfmode ctx mode = adamc@729: case mode of adamc@729: Attribute => S.return2 mode adamc@729: | Script => S.return2 mode adamc@729: | Source t => adamc@729: S.map2 (mft t, adamc@729: fn t' => Source t') adamc@26: in adamc@26: mfe adamc@26: end adamc@26: adamc@26: fun mapfold {typ = fc, exp = fe} = adamc@26: mapfoldB {typ = fc, adamc@26: exp = fn () => fe, adamc@26: bind = fn ((), _) => ()} () adamc@26: adamc@26: fun mapB {typ, exp, bind} ctx e = adamc@26: case mapfoldB {typ = fn c => fn () => S.Continue (typ c, ()), adamc@26: exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()), adamc@26: bind = bind} ctx e () of adamc@26: S.Continue (e, ()) => e adamc@26: | S.Return _ => raise Fail "MonoUtil.Exp.mapB: Impossible" adamc@26: adamc@26: fun map {typ, exp} e = adamc@26: case mapfold {typ = fn c => fn () => S.Continue (typ c, ()), adamc@26: exp = fn e => fn () => S.Continue (exp e, ())} e () of adamc@26: S.Return () => raise Fail "Mono_util.Exp.map" adamc@26: | S.Continue (e, ()) => e adamc@26: adamc@26: fun fold {typ, exp} s e = adamc@26: case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)), adamc@26: exp = fn e => fn s => S.Continue (e, exp (e, s))} e s of adamc@26: S.Continue (_, s) => s adamc@26: | S.Return _ => raise Fail "MonoUtil.Exp.fold: Impossible" adamc@26: adamc@26: fun exists {typ, exp} k = adamc@26: case mapfold {typ = fn c => fn () => adamc@26: if typ c then adamc@26: S.Return () adamc@26: else adamc@26: S.Continue (c, ()), adamc@26: exp = fn e => fn () => adamc@26: if exp e then adamc@26: S.Return () adamc@26: else adamc@26: S.Continue (e, ())} k () of adamc@26: S.Return _ => true adamc@26: | S.Continue _ => false adamc@26: adamc@919: fun existsB {typ, exp, bind} ctx e = adamc@919: case mapfoldB {typ = fn t => fn () => adamc@919: if typ t then adamc@919: S.Return () adamc@919: else adamc@919: S.Continue (t, ()), adamc@919: exp = fn ctx => fn e => fn () => adamc@919: if exp (ctx, e) then adamc@919: S.Return () adamc@919: else adamc@919: S.Continue (e, ()), adamc@919: bind = bind} ctx e () of adamc@919: S.Return _ => true adamc@919: | S.Continue _ => false adamc@919: adamc@567: fun foldB {typ, exp, bind} ctx s e = adamc@567: case mapfoldB {typ = fn t => fn s => S.Continue (t, typ (t, s)), adamc@567: exp = fn ctx => fn e => fn s => S.Continue (e, exp (ctx, e, s)), adamc@567: bind = bind} ctx e s of adamc@567: S.Continue (_, s) => s adamc@567: | S.Return _ => raise Fail "MonoUtil.Exp.foldB: Impossible" adamc@567: adam@1612: fun appLoc f = adam@1612: let adam@1612: fun appl e = adam@1612: (f e; adam@1612: case #1 e of adam@1612: EPrim _ => () adam@1612: | ERel _ => () adam@1612: | ENamed _ => () adam@1612: | ECon (_, _, eo) => Option.app appl eo adam@1612: | ENone _ => () adam@1612: | ESome (_, e) => appl e adam@1612: | EFfi _ => () adam@1663: | EFfiApp (_, _, es) => app (appl o #1) es adam@1612: | EApp (e1, e2) => (appl e1; appl e2) adam@1612: | EAbs (_, _, _, e1) => appl e1 adam@1612: | EUnop (_, e1) => appl e1 adam@1612: | EBinop (_, _, e1, e2) => (appl e1; appl e2) adam@1612: | ERecord xets => app (appl o #2) xets adam@1612: | EField (e1, _) => appl e1 adam@1612: | ECase (e1, pes, _) => (appl e1; app (appl o #2) pes) adam@1612: | EStrcat (e1, e2) => (appl e1; appl e2) adam@1612: | EError (e1, _) => appl e1 adam@1932: | EReturnBlob {blob = NONE, mimeType = e2, ...} => appl e2 adam@1932: | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => (appl e1; appl e2) adam@1612: | ERedirect (e1, _) => appl e1 adam@1612: | EWrite e1 => appl e1 adam@1612: | ESeq (e1, e2) => (appl e1; appl e2) adam@1612: | ELet (_, _, e1, e2) => (appl e1; appl e2) adam@1612: | EClosure (_, es) => app appl es adam@1612: | EQuery {query = e1, body = e2, initial = e3, ...} => (appl e1; appl e2; appl e3) adam@1612: | EDml (e1, _) => appl e1 adam@1612: | ENextval e1 => appl e1 adam@1612: | ESetval (e1, e2) => (appl e1; appl e2) adam@1612: | EUnurlify (e1, _, _) => appl e1 adam@1612: | EJavaScript (_, e1) => appl e1 adam@1612: | ESignalReturn e1 => appl e1 adam@1612: | ESignalBind (e1, e2) => (appl e1; appl e2) adam@1612: | ESignalSource e1 => appl e1 adam@1848: | EServerCall (e1, _, _, _) => appl e1 adam@1612: | ERecv (e1, _) => appl e1 adam@1612: | ESleep e1 => appl e1 adam@1612: | ESpawn e1 => appl e1) adam@1612: in adam@1612: appl adam@1612: end adam@1612: adamc@26: end adamc@26: adamc@26: structure Decl = struct adamc@26: adamc@26: datatype binder = datatype Exp.binder adamc@26: adamc@26: fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = adamc@26: let adamc@26: val mft = Typ.mapfold fc adamc@26: adamc@26: val mfe = Exp.mapfoldB {typ = fc, exp = fe, bind = bind} adamc@26: adamc@26: fun mfd ctx d acc = adamc@26: S.bindP (mfd' ctx d acc, fd ctx) adamc@26: adamc@26: and mfd' ctx (dAll as (d, loc)) = adamc@26: case d of adamc@808: DDatatype dts => adamc@808: S.map2 (ListUtil.mapfold (fn (x, n, xncs) => adamc@808: S.map2 (ListUtil.mapfold (fn (x, n, c) => adamc@808: case c of adamc@808: NONE => S.return2 (x, n, c) adamc@808: | SOME c => adamc@808: S.map2 (mft c, adamc@808: fn c' => (x, n, SOME c'))) xncs, adamc@808: fn xncs' => (x, n, xncs'))) dts, adamc@808: fn dts' => adamc@808: (DDatatype dts', loc)) adamc@164: | DVal vi => adamc@126: S.map2 (mfvi ctx vi, adamc@126: fn vi' => adamc@126: (DVal vi', loc)) adamc@126: | DValRec vis => adamc@196: let adamc@196: val ctx' = foldl (fn ((x, n, t, _, s), ctx') => bind (ctx', NamedE (x, n, t, NONE, s))) ctx vis adamc@196: in adamc@196: S.map2 (ListUtil.mapfold (mfvi ctx') vis, adamc@196: fn vis' => adamc@196: (DValRec vis', loc)) adamc@196: end adamc@1104: | DExport (ek, s, n, ts, t, b) => adamc@609: S.bind2 (ListUtil.mapfold mft ts, adamc@120: fn ts' => adamc@609: S.map2 (mft t, adamc@609: fn t' => adamc@1104: (DExport (ek, s, n, ts', t', b), loc))) adamc@707: | DTable (s, xts, pe, ce) => adamc@707: S.bind2 (mfe ctx pe, adamc@707: fn pe' => adamc@707: S.map2 (mfe ctx ce, adamc@707: fn ce' => adamc@707: (DTable (s, xts, pe', ce'), loc))) adamc@338: | DSequence _ => S.return2 dAll adamc@754: | DView (s, xts, e) => adamc@754: S.map2 (mfe ctx e, adamc@754: fn e' => adamc@754: (DView (s, xts, e'), loc)) adamc@271: | DDatabase _ => S.return2 dAll adamc@569: | DJavaScript _ => S.return2 dAll adamc@725: | DCookie _ => S.return2 dAll adamc@718: | DStyle _ => S.return2 dAll adamc@1075: | DTask (e1, e2) => adamc@1075: S.bind2 (mfe ctx e1, adamc@1075: fn e1' => adamc@1075: S.map2 (mfe ctx e2, adamc@1075: fn e2' => adamc@1075: (DTask (e1', e2'), loc))) adamc@1199: | DPolicy pol => adamc@1199: S.map2 (mfpol ctx pol, adamc@1199: fn p' => adamc@1199: (DPolicy p', loc)) adam@1294: | DOnError _ => S.return2 dAll adamc@1199: adamc@1199: and mfpol ctx pol = adamc@1199: case pol of adamc@1214: PolClient e => adamc@1199: S.map2 (mfe ctx e, adamc@1214: PolClient) adamc@1220: | PolInsert e => adamc@1220: S.map2 (mfe ctx e, adamc@1220: PolInsert) adamc@1221: | PolDelete e => adamc@1221: S.map2 (mfe ctx e, adamc@1221: PolDelete) adamc@1223: | PolUpdate e => adamc@1223: S.map2 (mfe ctx e, adamc@1223: PolUpdate) adamc@1229: | PolSequence e => adamc@1229: S.map2 (mfe ctx e, adamc@1229: PolSequence) adamc@126: adamc@126: and mfvi ctx (x, n, t, e, s) = adamc@126: S.bind2 (mft t, adamc@126: fn t' => adamc@126: S.map2 (mfe ctx e, adamc@126: fn e' => adamc@126: (x, n, t', e', s))) adamc@26: in adamc@26: mfd adamc@26: end adamc@26: adamc@26: fun mapfold {typ = fc, exp = fe, decl = fd} = adamc@26: mapfoldB {typ = fc, adamc@26: exp = fn () => fe, adamc@26: decl = fn () => fd, adamc@26: bind = fn ((), _) => ()} () adamc@26: adamc@26: fun fold {typ, exp, decl} s d = adamc@26: case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)), adamc@26: exp = fn e => fn s => S.Continue (e, exp (e, s)), adamc@26: decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of adamc@26: S.Continue (_, s) => s adamc@26: | S.Return _ => raise Fail "MonoUtil.Decl.fold: Impossible" adamc@26: adamc@506: fun map {typ, exp, decl} e = adamc@506: case mapfold {typ = fn c => fn () => S.Continue (typ c, ()), adamc@506: exp = fn e => fn () => S.Continue (exp e, ()), adamc@506: decl = fn d => fn () => S.Continue (decl d, ())} e () of adamc@506: S.Return () => raise Fail "MonoUtil.Decl.map: Impossible" adamc@506: | S.Continue (e, ()) => e adamc@506: adam@1800: fun foldMap {typ, exp, decl} s d = adam@1800: case mapfold {typ = fn c => fn s => S.Continue (typ (c, s)), adam@1800: exp = fn e => fn s => S.Continue (exp (e, s)), adam@1800: decl = fn d => fn s => S.Continue (decl (d, s))} d s of adam@1800: S.Continue v => v adam@1800: | S.Return _ => raise Fail "MonoUtil.Decl.foldMap: Impossible" adam@1800: adamc@567: fun foldMapB {typ, exp, decl, bind} ctx s d = adamc@567: case mapfoldB {typ = fn c => fn s => S.Continue (typ (c, s)), adamc@567: exp = fn ctx => fn e => fn s => S.Continue (exp (ctx, e, s)), adamc@567: decl = fn ctx => fn d => fn s => S.Continue (decl (ctx, d, s)), adamc@567: bind = bind} ctx d s of adamc@567: S.Continue v => v adamc@567: | S.Return _ => raise Fail "MonoUtil.Decl.foldMapB: Impossible" adamc@567: adam@1847: fun exists {typ, exp, decl} k = adam@1847: case mapfold {typ = fn c => fn () => adam@1847: if typ c then adam@1847: S.Return () adam@1847: else adam@1847: S.Continue (c, ()), adam@1847: exp = fn e => fn () => adam@1847: if exp e then adam@1847: S.Return () adam@1847: else adam@1847: S.Continue (e, ()), adam@1847: decl = fn d => fn () => adam@1847: if decl d then adam@1847: S.Return () adam@1847: else adam@1847: S.Continue (d, ())} k () of adam@1847: S.Return _ => true adam@1847: | S.Continue _ => false adam@1847: adamc@26: end adamc@26: adamc@26: structure File = struct adamc@26: adamc@26: datatype binder = datatype Exp.binder adamc@26: adamc@26: fun mapfoldB (all as {bind, ...}) = adamc@26: let adamc@26: val mfd = Decl.mapfoldB all adamc@26: adam@1845: fun mff ctx (ds, ps) = adamc@26: case ds of adam@1845: nil => S.return2 (nil, ps) adamc@26: | d :: ds' => adamc@26: S.bind2 (mfd ctx d, adamc@26: fn d' => adamc@26: let adamc@100: val ctx' = adamc@26: case #1 d' of adamc@808: DDatatype dts => adamc@808: foldl (fn ((x, n, xncs), ctx) => adamc@808: let adamc@808: val ctx = bind (ctx, Datatype (x, n, xncs)) adamc@808: val t = (TDatatype (n, ref (ElabUtil.classifyDatatype xncs, xncs)), adamc@808: #2 d') adamc@808: in adamc@808: foldl (fn ((x, n, to), ctx) => adamc@808: let adamc@808: val t = case to of adamc@808: NONE => t adamc@808: | SOME t' => (TFun (t', t), #2 d') adamc@808: in adamc@808: bind (ctx, NamedE (x, n, t, NONE, "")) adamc@808: end) adamc@808: ctx xncs adamc@808: end) ctx dts adamc@164: | DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s)) adamc@126: | DValRec vis => foldl (fn ((x, n, t, e, s), ctx) => adamc@196: bind (ctx, NamedE (x, n, t, NONE, s))) ctx vis adamc@109: | DExport _ => ctx adamc@273: | DTable _ => ctx adamc@338: | DSequence _ => ctx adamc@754: | DView _ => ctx adamc@271: | DDatabase _ => ctx adamc@569: | DJavaScript _ => ctx adamc@725: | DCookie _ => ctx adamc@718: | DStyle _ => ctx adamc@1075: | DTask _ => ctx adamc@1199: | DPolicy _ => ctx adam@1294: | DOnError _ => ctx adamc@26: in adam@1845: S.map2 (mff ctx' (ds', ps), adam@1845: fn (ds', _) => adam@1845: (d' :: ds', ps)) adamc@26: end) adamc@26: in adamc@26: mff adamc@26: end adamc@26: adamc@26: fun mapfold {typ = fc, exp = fe, decl = fd} = adamc@26: mapfoldB {typ = fc, adamc@26: exp = fn () => fe, adamc@26: decl = fn () => fd, adamc@26: bind = fn ((), _) => ()} () adamc@26: adamc@26: fun mapB {typ, exp, decl, bind} ctx ds = adamc@26: case mapfoldB {typ = fn c => fn () => S.Continue (typ c, ()), adamc@26: exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()), adamc@26: decl = fn ctx => fn d => fn () => S.Continue (decl ctx d, ()), adamc@26: bind = bind} ctx ds () of adamc@26: S.Continue (ds, ()) => ds adamc@26: | S.Return _ => raise Fail "MonoUtil.File.mapB: Impossible" adamc@26: adamc@96: fun map {typ, exp, decl} e = adamc@96: case mapfold {typ = fn c => fn () => S.Continue (typ c, ()), adamc@96: exp = fn e => fn () => S.Continue (exp e, ()), adamc@96: decl = fn d => fn () => S.Continue (decl d, ())} e () of adamc@506: S.Return () => raise Fail "MonoUtil.File.map: Impossible" adamc@96: | S.Continue (e, ()) => e adamc@96: adamc@26: fun fold {typ, exp, decl} s d = adamc@26: case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)), adamc@26: exp = fn e => fn s => S.Continue (e, exp (e, s)), adamc@26: decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of adamc@26: S.Continue (_, s) => s adamc@26: | S.Return _ => raise Fail "MonoUtil.File.fold: Impossible" adamc@26: adam@1845: fun maxName (f : file) = adam@1845: foldl (fn ((d, _) : decl, count) => adam@1845: case d of adam@1845: DDatatype dts => adam@1845: foldl (fn ((_, n, ns), count) => adam@1845: foldl (fn ((_, n', _), m) => Int.max (n', m)) adam@1845: (Int.max (n, count)) ns) count dts adam@1845: | DVal (_, n, _, _, _) => Int.max (n, count) adam@1845: | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis adam@1845: | DExport _ => count adam@1845: | DTable _ => count adam@1845: | DSequence _ => count adam@1845: | DView _ => count adam@1845: | DDatabase _ => count adam@1845: | DJavaScript _ => count adam@1845: | DCookie _ => count adam@1845: | DStyle _ => count adam@1845: | DTask _ => count adam@1845: | DPolicy _ => count adam@1845: | DOnError _ => count) 0 (#1 f) adamc@506: adam@1845: fun appLoc f (fl : file) = adam@1612: let adam@1612: val eal = Exp.appLoc f adam@1612: adam@1612: fun appl (d : decl) = adam@1612: case #1 d of adam@1612: DDatatype _ => () adam@1612: | DVal (_, _, _, e1, _) => eal e1 adam@1612: | DValRec vis => app (eal o #4) vis adam@1612: | DExport _ => () adam@1612: | DTable (_, _, e1, e2) => (eal e1; eal e2) adam@1612: | DSequence _ => () adam@1612: | DView (_, _, e1) => eal e1 adam@1612: | DDatabase _ => () adam@1612: | DJavaScript _ => () adam@1612: | DCookie _ => () adam@1612: | DStyle _ => () adam@1612: | DTask (e1, e2) => (eal e1; eal e2) adam@1612: | DPolicy pol => applPolicy pol adam@1612: | DOnError _ => () adam@1612: adam@1612: and applPolicy p = adam@1612: case p of adam@1612: PolClient e1 => eal e1 adam@1612: | PolInsert e1 => eal e1 adam@1612: | PolDelete e1 => eal e1 adam@1612: | PolUpdate e1 => eal e1 adam@1612: | PolSequence e1 => eal e1 adam@1612: in adam@1845: app appl (#1 fl) adam@1612: end adam@1612: adamc@26: end adamc@26: adamc@26: end