adamc@26: (* Copyright (c) 2008, 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 FlatUtil :> FLAT_UTIL = struct adamc@26: adamc@26: open Flat adamc@26: adamc@26: structure S = Search adamc@26: adamc@26: structure Typ = struct adamc@26: adamc@28: fun join (o1, o2) = adamc@28: case o1 of adamc@28: EQUAL => o2 () adamc@28: | v => v adamc@28: adamc@28: fun joinL f (os1, os2) = adamc@28: case (os1, os2) of adamc@28: (nil, nil) => EQUAL adamc@28: | (nil, _) => LESS adamc@28: | (h1 :: t1, h2 :: t2) => adamc@28: join (f (h1, h2), fn () => joinL f (t1, t2)) adamc@28: | (_ :: _, nil) => GREATER adamc@28: adamc@28: fun compare ((t1, _), (t2, _)) = adamc@28: case (t1, t2) of adamc@29: (TTop, TTop) => EQUAL adamc@29: | (TFun (d1, r1), TFun (d2, r2)) => adamc@28: join (compare (d1, d2), fn () => compare (r1, r2)) adamc@28: | (TCode (d1, r1), TCode (d2, r2)) => adamc@28: join (compare (d1, d2), fn () => compare (r1, r2)) adamc@28: | (TRecord xts1, TRecord xts2) => adamc@28: let adamc@99: val xts1 = sortFields xts1 adamc@28: val xts2 = sortFields xts2 adamc@28: in adamc@28: joinL compareFields (xts1, xts2) adamc@28: end adamc@28: | (TNamed n1, TNamed n2) => Int.compare (n1, n2) adamc@52: | (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2)) adamc@28: adamc@29: | (TTop, _) => LESS adamc@29: | (_, TTop) => GREATER adamc@29: adamc@28: | (TFun _, _) => LESS adamc@28: | (_, TFun _) => GREATER adamc@28: adamc@28: | (TCode _, _) => LESS adamc@28: | (_, TCode _) => GREATER adamc@28: adamc@28: | (TRecord _, _) => LESS adamc@28: | (_, TRecord _) => GREATER adamc@28: adamc@52: | (TNamed _, _) => LESS adamc@52: | (_, TNamed _) => GREATER adamc@52: adamc@28: and compareFields ((x1, t1), (x2, t2)) = adamc@28: join (String.compare (x1, x2), adamc@28: fn () => compare (t1, t2)) adamc@28: adamc@28: and sortFields xts = ListMergeSort.sort (fn (x, y) => compareFields (x, y) = GREATER) xts adamc@28: 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@29: TTop => S.return2 cAll adamc@29: | 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: | TCode (t1, t2) => adamc@26: S.bind2 (mft t1, adamc@26: fn t1' => adamc@26: S.map2 (mft t2, adamc@26: fn t2' => adamc@26: (TCode (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@26: | TNamed _ => S.return2 cAll adamc@52: | TFfi _ => S.return2 cAll 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 "Flat_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 "FlatUtil.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@26: NamedT of string * int * typ option adamc@26: | RelE of string * typ adamc@26: | NamedE of string * int * typ * exp option 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: 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@52: | EFfi _ => S.return2 eAll adamc@52: | EFfiApp (m, x, es) => adamc@52: S.map2 (ListUtil.mapfold (fn e => mfe ctx e) es, adamc@52: fn es' => adamc@52: (EFfiApp (m, x, es'), loc)) adamc@26: | ECode _ => S.return2 eAll 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: 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@26: adamc@26: | ELet (xes, e) => adamc@29: S.bind2 (ListUtil.mapfold (fn (x, t, e) => adamc@29: S.bind2 (mft t, adamc@29: fn t' => adamc@29: S.map2 (mfe ctx e, adamc@29: fn e' => adamc@29: (x, t', e')))) adamc@26: xes, adamc@26: fn xes' => adamc@26: S.map2 (mfe ctx e, adamc@26: fn e' => adamc@26: (ELet (xes', e'), loc))) 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 "FlatUtil.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 "Flat_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 "FlatUtil.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@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@26: DVal (x, n, t, e) => adamc@26: S.bind2 (mft t, adamc@26: fn t' => adamc@26: S.map2 (mfe ctx e, adamc@26: fn e' => adamc@26: (DVal (x, n, t', e'), loc))) adamc@26: | DFun (n, 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 ctx e, adamc@26: fn e' => adamc@26: (DFun (n, x, dom', ran', e'), loc)))) adamc@101: | DPage (xts, e) => adamc@101: S.bind2 (ListUtil.mapfold (fn (x, t) => adamc@101: S.map2 (mft t, adamc@101: fn t' => adamc@101: (x, t'))) xts, adamc@101: fn xts' => adamc@101: S.map2 (mfe ctx e, adamc@101: fn e' => adamc@101: (DPage (xts', e'), loc))) 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 "FlatUtil.Decl.fold: Impossible" adamc@26: adamc@26: end adamc@26: adamc@26: structure File = struct adamc@26: adamc@26: datatype binder = adamc@26: NamedT of string * int * typ option adamc@26: | RelE of string * typ adamc@26: | NamedE of string * int * typ * exp option adamc@26: | F of int * string * Flat.typ * Flat.typ * Flat.exp adamc@26: adamc@26: fun mapfoldB (all as {bind, ...}) = adamc@26: let adamc@26: val mfd = Decl.mapfoldB all adamc@26: adamc@26: fun mff ctx ds = adamc@26: case ds of adamc@26: nil => S.return2 nil adamc@26: | d :: ds' => adamc@26: S.bind2 (mfd ctx d, adamc@26: fn d' => adamc@26: let adamc@101: val ctx' = adamc@26: case #1 d' of adamc@101: DVal (x, n, t, e) => bind (ctx, NamedE (x, n, t, SOME e)) adamc@101: | DFun v => bind (ctx, F v) adamc@101: | DPage _ => ctx adamc@26: in adamc@26: S.map2 (mff ctx' ds', adamc@26: fn ds' => adamc@26: d' :: ds') 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 "FlatUtil.File.mapB: Impossible" 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 "FlatUtil.File.fold: Impossible" adamc@26: adamc@26: end adamc@26: adamc@26: end