adamc@2: (* Copyright (c) 2008, Adam Chlipala adamc@2: * All rights reserved. adamc@2: * adamc@2: * Redistribution and use in source and binary forms, with or without adamc@2: * modification, are permitted provided that the following conditions are met: adamc@2: * adamc@2: * - Redistributions of source code must retain the above copyright notice, adamc@2: * this list of conditions and the following disclaimer. adamc@2: * - Redistributions in binary form must reproduce the above copyright notice, adamc@2: * this list of conditions and the following disclaimer in the documentation adamc@2: * and/or other materials provided with the distribution. adamc@2: * - The names of contributors may not be used to endorse or promote products adamc@2: * derived from this software without specific prior written permission. adamc@2: * adamc@2: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@2: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@2: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@2: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@2: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@2: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@2: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@2: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@2: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@2: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@2: * POSSIBILITY OF SUCH DAMAGE. adamc@2: *) adamc@2: adamc@2: structure ElabUtil :> ELAB_UTIL = struct adamc@2: adamc@2: open Elab adamc@2: adamc@2: structure S = Search adamc@2: adamc@2: structure Kind = struct adamc@2: adamc@6: fun mapfold f = adamc@2: let adamc@2: fun mfk k acc = adamc@2: S.bindP (mfk' k acc, f) adamc@2: adamc@2: and mfk' (kAll as (k, loc)) = adamc@2: case k of adamc@2: KType => S.return2 kAll adamc@2: adamc@2: | KArrow (k1, k2) => adamc@2: S.bind2 (mfk k1, adamc@2: fn k1' => adamc@2: S.map2 (mfk k2, adamc@2: fn k2' => adamc@2: (KArrow (k1', k2'), loc))) adamc@2: adamc@2: | KName => S.return2 kAll adamc@2: adamc@2: | KRecord k => adamc@2: S.map2 (mfk k, adamc@2: fn k' => adamc@2: (KRecord k', loc)) adamc@2: adamc@2: | KError => S.return2 kAll adamc@2: adamc@2: | KUnif (_, ref (SOME k)) => mfk' k adamc@2: | KUnif _ => S.return2 kAll adamc@2: in adamc@2: mfk adamc@2: end adamc@2: adamc@2: fun exists f k = adamc@6: case mapfold (fn k => fn () => adamc@6: if f k then adamc@6: S.Return () adamc@6: else adamc@6: S.Continue (k, ())) k () of adamc@6: S.Return _ => true adamc@6: | S.Continue _ => false adamc@6: adamc@6: end adamc@6: adamc@6: structure Con = struct adamc@6: adamc@11: datatype binder = adamc@11: Rel of string * Elab.kind adamc@11: | Named of string * Elab.kind adamc@11: adamc@11: fun mapfoldB {kind = fk, con = fc, bind} = adamc@6: let adamc@6: val mfk = Kind.mapfold fk adamc@6: adamc@11: fun mfc ctx c acc = adamc@11: S.bindP (mfc' ctx c acc, fc ctx) adamc@6: adamc@11: and mfc' ctx (cAll as (c, loc)) = adamc@6: case c of adamc@6: TFun (c1, c2) => adamc@11: S.bind2 (mfc ctx c1, adamc@6: fn c1' => adamc@11: S.map2 (mfc ctx c2, adamc@6: fn c2' => adamc@6: (TFun (c1', c2'), loc))) adamc@6: | TCFun (e, x, k, c) => adamc@6: S.bind2 (mfk k, adamc@6: fn k' => adamc@11: S.map2 (mfc (bind (ctx, Rel (x, k))) c, adamc@6: fn c' => adamc@6: (TCFun (e, x, k', c'), loc))) adamc@6: | TRecord c => adamc@11: S.map2 (mfc ctx c, adamc@6: fn c' => adamc@6: (TRecord c', loc)) adamc@6: adamc@6: | CRel _ => S.return2 cAll adamc@6: | CNamed _ => S.return2 cAll adamc@34: | CModProj _ => S.return2 cAll adamc@6: | CApp (c1, c2) => adamc@11: S.bind2 (mfc ctx c1, adamc@6: fn c1' => adamc@11: S.map2 (mfc ctx c2, adamc@6: fn c2' => adamc@6: (CApp (c1', c2'), loc))) adamc@8: | CAbs (x, k, c) => adamc@6: S.bind2 (mfk k, adamc@6: fn k' => adamc@11: S.map2 (mfc (bind (ctx, Rel (x, k))) c, adamc@6: fn c' => adamc@8: (CAbs (x, k', c'), loc))) adamc@6: adamc@6: | CName _ => S.return2 cAll adamc@6: adamc@6: | CRecord (k, xcs) => adamc@6: S.bind2 (mfk k, adamc@6: fn k' => adamc@6: S.map2 (ListUtil.mapfold (fn (x, c) => adamc@11: S.bind2 (mfc ctx x, adamc@6: fn x' => adamc@11: S.map2 (mfc ctx c, adamc@6: fn c' => adamc@6: (x', c')))) adamc@6: xcs, adamc@6: fn xcs' => adamc@6: (CRecord (k', xcs'), loc))) adamc@6: | CConcat (c1, c2) => adamc@11: S.bind2 (mfc ctx c1, adamc@6: fn c1' => adamc@11: S.map2 (mfc ctx c2, adamc@6: fn c2' => adamc@6: (CConcat (c1', c2'), loc))) adamc@6: adamc@6: | CError => S.return2 cAll adamc@11: | CUnif (_, _, ref (SOME c)) => mfc' ctx c adamc@6: | CUnif _ => S.return2 cAll adamc@6: in adamc@6: mfc adamc@6: end adamc@6: adamc@11: fun mapfold {kind = fk, con = fc} = adamc@11: mapfoldB {kind = fk, adamc@11: con = fn () => fc, adamc@11: bind = fn ((), _) => ()} () adamc@11: adamc@11: fun mapB {kind, con, bind} ctx c = adamc@11: case mapfoldB {kind = fn k => fn () => S.Continue (kind k, ()), adamc@11: con = fn ctx => fn c => fn () => S.Continue (con ctx c, ()), adamc@11: bind = bind} ctx c () of adamc@11: S.Continue (c, ()) => c adamc@34: | S.Return _ => raise Fail "ElabUtil.Con.mapB: Impossible" adamc@34: adamc@34: fun map {kind, con} s = adamc@34: case mapfold {kind = fn k => fn () => S.Continue (kind k, ()), adamc@34: con = fn c => fn () => S.Continue (con c, ())} s () of adamc@34: S.Return () => raise Fail "ElabUtil.Con.map: Impossible" adamc@34: | S.Continue (s, ()) => s adamc@11: adamc@6: fun exists {kind, con} k = adamc@6: case mapfold {kind = fn k => fn () => adamc@6: if kind k then adamc@6: S.Return () adamc@6: else adamc@6: S.Continue (k, ()), adamc@6: con = fn c => fn () => adamc@6: if con c then adamc@6: S.Return () adamc@6: else adamc@6: S.Continue (c, ())} k () of adamc@2: S.Return _ => true adamc@2: | S.Continue _ => false adamc@2: adamc@2: end adamc@2: adamc@10: structure Exp = struct adamc@10: adamc@11: datatype binder = adamc@11: RelC of string * Elab.kind adamc@11: | NamedC of string * Elab.kind adamc@11: | RelE of string * Elab.con adamc@11: | NamedE of string * Elab.con adamc@11: adamc@11: fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = adamc@10: let adamc@10: val mfk = Kind.mapfold fk adamc@10: adamc@11: fun bind' (ctx, b) = adamc@11: let adamc@11: val b' = case b of adamc@11: Con.Rel x => RelC x adamc@11: | Con.Named x => NamedC x adamc@11: in adamc@11: bind (ctx, b') adamc@11: end adamc@11: val mfc = Con.mapfoldB {kind = fk, con = fc, bind = bind'} adamc@10: adamc@11: fun mfe ctx e acc = adamc@11: S.bindP (mfe' ctx e acc, fe ctx) adamc@11: adamc@11: and mfe' ctx (eAll as (e, loc)) = adamc@10: case e of adamc@14: EPrim _ => S.return2 eAll adamc@14: | ERel _ => S.return2 eAll adamc@10: | ENamed _ => S.return2 eAll adamc@34: | EModProj _ => S.return2 eAll adamc@10: | EApp (e1, e2) => adamc@11: S.bind2 (mfe ctx e1, adamc@10: fn e1' => adamc@11: S.map2 (mfe ctx e2, adamc@10: fn e2' => adamc@10: (EApp (e1', e2'), loc))) adamc@26: | EAbs (x, dom, ran, e) => adamc@26: S.bind2 (mfc ctx dom, adamc@26: fn dom' => adamc@26: S.bind2 (mfc ctx 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@10: | ECApp (e, c) => adamc@11: S.bind2 (mfe ctx e, adamc@10: fn e' => adamc@11: S.map2 (mfc ctx c, adamc@10: fn c' => adamc@10: (ECApp (e', c'), loc))) adamc@10: | ECAbs (expl, x, k, e) => adamc@10: S.bind2 (mfk k, adamc@10: fn k' => adamc@11: S.map2 (mfe (bind (ctx, RelC (x, k))) e, adamc@10: fn e' => adamc@10: (ECAbs (expl, x, k', e'), loc))) adamc@10: adamc@12: | ERecord xes => adamc@29: S.map2 (ListUtil.mapfold (fn (x, e, t) => adamc@12: S.bind2 (mfc ctx x, adamc@12: fn x' => adamc@29: S.bind2 (mfe ctx e, adamc@12: fn e' => adamc@29: S.map2 (mfc ctx t, adamc@29: fn t' => adamc@29: (x', e', t'))))) adamc@12: xes, adamc@12: fn xes' => adamc@12: (ERecord xes', loc)) adamc@12: | EField (e, c, {field, rest}) => adamc@12: S.bind2 (mfe ctx e, adamc@12: fn e' => adamc@12: S.bind2 (mfc ctx c, adamc@12: fn c' => adamc@12: S.bind2 (mfc ctx field, adamc@12: fn field' => adamc@12: S.map2 (mfc ctx rest, adamc@12: fn rest' => adamc@12: (EField (e', c', {field = field', rest = rest'}), loc))))) adamc@12: adamc@10: | EError => S.return2 eAll adamc@10: in adamc@10: mfe adamc@10: end adamc@10: adamc@11: fun mapfold {kind = fk, con = fc, exp = fe} = adamc@11: mapfoldB {kind = fk, adamc@11: con = fn () => fc, adamc@11: exp = fn () => fe, adamc@11: bind = fn ((), _) => ()} () adamc@11: adamc@10: fun exists {kind, con, exp} k = adamc@10: case mapfold {kind = fn k => fn () => adamc@10: if kind k then adamc@10: S.Return () adamc@10: else adamc@10: S.Continue (k, ()), adamc@10: con = fn c => fn () => adamc@10: if con c then adamc@10: S.Return () adamc@10: else adamc@10: S.Continue (c, ()), adamc@10: exp = fn e => fn () => adamc@10: if exp e then adamc@10: S.Return () adamc@10: else adamc@10: S.Continue (e, ())} k () of adamc@10: S.Return _ => true adamc@10: | S.Continue _ => false adamc@10: adamc@10: end adamc@10: adamc@34: structure Sgn = struct adamc@34: adamc@34: datatype binder = adamc@34: RelC of string * Elab.kind adamc@34: | NamedC of string * Elab.kind adamc@34: | Str of string * Elab.sgn adamc@34: adamc@34: fun mapfoldB {kind, con, sgn_item, sgn, bind} = adamc@34: let adamc@34: fun bind' (ctx, b) = adamc@34: let adamc@34: val b' = case b of adamc@34: Con.Rel x => RelC x adamc@34: | Con.Named x => NamedC x adamc@34: in adamc@34: bind (ctx, b') adamc@34: end adamc@34: val con = Con.mapfoldB {kind = kind, con = con, bind = bind'} adamc@34: adamc@34: val kind = Kind.mapfold kind adamc@34: adamc@34: fun sgi ctx si acc = adamc@34: S.bindP (sgi' ctx si acc, sgn_item ctx) adamc@34: adamc@34: and sgi' ctx (si, loc) = adamc@34: case si of adamc@34: SgiConAbs (x, n, k) => adamc@34: S.map2 (kind k, adamc@34: fn k' => adamc@34: (SgiConAbs (x, n, k'), loc)) adamc@34: | SgiCon (x, n, k, c) => adamc@34: S.bind2 (kind k, adamc@34: fn k' => adamc@34: S.map2 (con ctx c, adamc@34: fn c' => adamc@34: (SgiCon (x, n, k', c'), loc))) adamc@34: | SgiVal (x, n, c) => adamc@34: S.map2 (con ctx c, adamc@34: fn c' => adamc@34: (SgiVal (x, n, c'), loc)) adamc@34: | SgiStr (x, n, s) => adamc@34: S.map2 (sg ctx s, adamc@34: fn s' => adamc@34: (SgiStr (x, n, s'), loc)) adamc@34: adamc@34: and sg ctx s acc = adamc@34: S.bindP (sg' ctx s acc, sgn ctx) adamc@34: adamc@34: and sg' ctx (sAll as (s, loc)) = adamc@34: case s of adamc@34: SgnConst sgis => adamc@34: S.map2 (ListUtil.mapfoldB (fn (ctx, si) => adamc@34: (case #1 si of adamc@34: SgiConAbs (x, _, k) => adamc@34: bind (ctx, NamedC (x, k)) adamc@34: | SgiCon (x, _, k, _) => adamc@34: bind (ctx, NamedC (x, k)) adamc@34: | SgiVal _ => ctx adamc@34: | SgiStr (x, _, sgn) => adamc@34: bind (ctx, Str (x, sgn)), adamc@34: sgi ctx si)) ctx sgis, adamc@34: fn sgis' => adamc@34: (SgnConst sgis', loc)) adamc@34: adamc@34: | SgnVar _ => S.return2 sAll adamc@41: | SgnFun (m, n, s1, s2) => adamc@41: S.bind2 (sg ctx s1, adamc@41: fn s1' => adamc@41: S.map2 (sg (bind (ctx, Str (m, s1'))) s2, adamc@41: fn s2' => adamc@41: (SgnFun (m, n, s1', s2'), loc))) adamc@42: | SgnWhere (sgn, x, c) => adamc@42: S.bind2 (sg ctx sgn, adamc@42: fn sgn' => adamc@42: S.map2 (con ctx c, adamc@42: fn c' => adamc@42: (SgnWhere (sgn', x, c'), loc))) adamc@34: | SgnError => S.return2 sAll adamc@34: in adamc@34: sg adamc@34: end adamc@34: adamc@34: fun mapfold {kind, con, sgn_item, sgn} = adamc@34: mapfoldB {kind = kind, adamc@34: con = fn () => con, adamc@34: sgn_item = fn () => sgn_item, adamc@34: sgn = fn () => sgn, adamc@34: bind = fn ((), _) => ()} () adamc@34: adamc@34: fun map {kind, con, sgn_item, sgn} s = adamc@34: case mapfold {kind = fn k => fn () => S.Continue (kind k, ()), adamc@34: con = fn c => fn () => S.Continue (con c, ()), adamc@34: sgn_item = fn si => fn () => S.Continue (sgn_item si, ()), adamc@34: sgn = fn s => fn () => S.Continue (sgn s, ())} s () of adamc@34: S.Return () => raise Fail "Elab_util.Sgn.map" adamc@34: | S.Continue (s, ()) => s adamc@34: adamc@2: end adamc@34: adamc@34: end