adamc@110: (* Copyright (c) 2008, Adam Chlipala adamc@110: * All rights reserved. adamc@110: * adamc@110: * Redistribution and use in source and binary forms, with or without adamc@110: * modification, are permitted provided that the following conditions are met: adamc@110: * adamc@110: * - Redistributions of source code must retain the above copyright notice, adamc@110: * this list of conditions and the following disclaimer. adamc@110: * - Redistributions in binary form must reproduce the above copyright notice, adamc@110: * this list of conditions and the following disclaimer in the documentation adamc@110: * and/or other materials provided with the distribution. adamc@110: * - The names of contributors may not be used to endorse or promote products adamc@110: * derived from this software without specific prior written permission. adamc@110: * adamc@110: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@110: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@110: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@110: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@110: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@110: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@110: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@110: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@110: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@110: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@110: * POSSIBILITY OF SUCH DAMAGE. adamc@110: *) adamc@110: adamc@110: structure Tag :> TAG = struct adamc@110: adamc@110: open Core adamc@110: adamc@110: structure U = CoreUtil adamc@110: structure E = CoreEnv adamc@110: adamc@110: structure IM = IntBinaryMap adamc@112: structure SM = BinaryMapFn(struct adamc@112: type ord_key = string adamc@112: val compare = String.compare adamc@112: end) adamc@110: adamc@110: fun kind (k, s) = (k, s) adamc@110: fun con (c, s) = (c, s) adamc@110: adamc@1046: fun both (loc, f) = (ErrorMsg.errorAt loc ("Function " ^ f ^ " needed for both a link and a form"); adamc@1046: TextIO.output (TextIO.stdErr, adamc@1046: "Make sure that the signature of the containing module hides any form handlers.\n")) adamc@1046: adamc@112: fun exp env (e, s) = adamc@110: case e of adamc@110: EApp ( adamc@110: (EApp ( adamc@110: (EApp ( adamc@721: (EApp ( adamc@110: (ECApp ( adamc@110: (ECApp ( adamc@110: (ECApp ( adamc@140: (ECApp ( adamc@140: (ECApp ( adamc@140: (ECApp ( adamc@140: (ECApp ( adamc@721: (ECApp ( adamc@721: (EFfi ("Basis", "tag"), adamc@721: loc), given), _), absent), _), outer), _), inner), _), adamc@721: useOuter), _), useInner), _), bindOuter), _), bindInner), _), adamc@721: class), _), adamc@110: attrs), _), adamc@110: tag), _), adamc@110: xml) => adamc@110: (case attrs of adamc@110: (ERecord xets, _) => adamc@110: let adamc@110: val (xets, s) = adamc@112: ListUtil.foldlMap (fn ((x, e, t), (count, tags, byTag, newTags)) => adamc@143: let adamc@144: fun tagIt (ek, newAttr) = adamc@143: let adamc@1062: val eOrig = e adamc@1062: adamc@143: fun unravel (e, _) = adamc@143: case e of adamc@143: ENamed n => (n, []) adamc@143: | EApp (e1, e2) => adamc@143: let adamc@143: val (n, es) = unravel e1 adamc@143: in adamc@143: (n, es @ [e2]) adamc@143: end adamc@1062: | _ => (ErrorMsg.errorAt loc ("Invalid " ^ newAttr adamc@1062: ^ " expression"); adamc@1062: Print.epreface ("Expression", adamc@1062: CorePrint.p_exp CoreEnv.empty eOrig); adamc@143: (0, [])) adamc@110: adamc@143: val (f, args) = unravel e adamc@112: adamc@143: val (cn, count, tags, newTags) = adamc@143: case IM.find (tags, f) of adamc@143: NONE => adamc@143: (count, count + 1, IM.insert (tags, f, count), adamc@144: (ek, f, count) :: newTags) adamc@143: | SOME cn => (cn, count, tags, newTags) adamc@143: adamc@143: val (_, _, _, s) = E.lookupENamed env f adamc@112: adamc@143: val byTag = case SM.find (byTag, s) of adamc@144: NONE => SM.insert (byTag, s, (ek, f)) adamc@144: | SOME (ek', f') => adamc@143: (if f = f' then adamc@143: () adamc@143: else adamc@143: ErrorMsg.errorAt loc adamc@143: ("Duplicate HTTP tag " adamc@143: ^ s); adamc@144: if ek = ek' then adamc@144: () adamc@144: else adamc@1046: both (loc, s); adamc@143: byTag) adamc@143: adamc@143: val e = (EClosure (cn, args), loc) adamc@143: val t = (CFfi ("Basis", "string"), loc) adamc@143: in adamc@143: (((CName newAttr, loc), e, t), adamc@143: (count, tags, byTag, newTags)) adamc@143: end adamc@143: in adamc@143: case x of adamc@907: (CName "Link", _) => tagIt (Link, "Link") adamc@731: | (CName "Action", _) => tagIt (Action ReadWrite, "Action") adamc@143: | _ => ((x, e, t), (count, tags, byTag, newTags)) adamc@143: end) adamc@110: s xets adamc@110: in adamc@110: (EApp ( adamc@110: (EApp ( adamc@110: (EApp ( adamc@721: (EApp ( adamc@110: (ECApp ( adamc@110: (ECApp ( adamc@110: (ECApp ( adamc@140: (ECApp ( adamc@140: (ECApp ( adamc@140: (ECApp ( adamc@140: (ECApp ( adamc@721: (ECApp ( adamc@721: (EFfi ("Basis", "tag"), adamc@721: loc), given), loc), absent), loc), outer), loc), inner), loc), adamc@721: useOuter), loc), useInner), loc), bindOuter), loc), bindInner), loc), adamc@721: class), loc), adamc@110: (ERecord xets, loc)), loc), adamc@110: tag), loc), adamc@110: xml), s) adamc@110: end adamc@110: | _ => (ErrorMsg.errorAt loc "Attribute record is too complex"; adamc@110: (e, s))) adamc@110: adamc@110: | _ => (e, s) adamc@110: adamc@110: fun decl (d, s) = (d, s) adamc@110: adamc@110: fun tag file = adamc@110: let adamc@179: val count = U.File.maxName file adamc@110: adamc@112: fun doDecl (d as (d', loc), (env, count, tags, byTag)) = adamc@112: case d' of adamc@144: DExport (ek, n) => adamc@112: let adamc@112: val (_, _, _, s) = E.lookupENamed env n adamc@112: in adamc@112: case SM.find (byTag, s) of adamc@112: NONE => ([d], (env, count, tags, byTag)) adamc@144: | SOME (ek', n') => adamc@144: (if ek = ek' then adamc@144: () adamc@144: else adamc@1046: both (loc, s); adamc@144: ([], (env, count, tags, byTag))) adamc@112: end adamc@112: | _ => adamc@112: let adamc@126: val env' = E.declBinds env d adamc@126: val env'' = case d' of adamc@126: DValRec _ => env' adamc@126: | _ => env adamc@126: adamc@112: val (d, (count, tags, byTag, newTags)) = adamc@112: U.Decl.foldMap {kind = kind, adamc@112: con = con, adamc@126: exp = exp env'', adamc@112: decl = decl} adamc@112: (count, tags, byTag, []) d adamc@110: adamc@126: val env = env' adamc@110: adamc@126: val newDs = map adamc@144: (fn (ek, f, cn) => adamc@112: let adamc@492: val unit = (TRecord (CRecord ((KType, loc), []), loc), loc) adamc@492: adamc@112: fun unravel (all as (t, _)) = adamc@112: case t of adamc@112: TFun (dom, ran) => adamc@112: let adamc@112: val (args, result) = unravel ran adamc@112: in adamc@112: (dom :: args, result) adamc@112: end adamc@112: | _ => ([], all) adamc@110: adamc@112: val (fnam, t, _, tag) = E.lookupENamed env f adamc@112: val (args, result) = unravel t adamc@110: adamc@119: val (abs, t) = adamc@119: case args of adamc@119: [] => adamc@119: let adamc@492: val app = (EApp ((ENamed f, loc), (ERecord [], loc)), loc) adamc@492: val body = (EWrite app, loc) adamc@119: in adamc@492: (body, adamc@119: (TFun (unit, unit), loc)) adamc@119: end adamc@119: | _ => adamc@119: let adamc@119: val (app, _) = foldl (fn (t, (app, n)) => adamc@119: ((EApp (app, (ERel n, loc)), loc), adamc@119: n - 1)) adamc@119: ((ENamed f, loc), length args - 1) args adamc@280: val app = (EApp (app, (ERecord [], loc)), loc) adamc@119: val body = (EWrite app, loc) adamc@280: val t = (TFun (unit, unit), loc) adamc@119: val (abs, _, t) = foldr (fn (t, (abs, n, rest)) => adamc@119: ((EAbs ("x" ^ Int.toString n, adamc@119: t, adamc@119: rest, adamc@119: abs), loc), adamc@119: n + 1, adamc@119: (TFun (t, rest), loc))) adamc@280: (body, 0, t) args adamc@119: in adamc@119: (abs, t) adamc@119: end adamc@112: in adamc@126: (("wrap_" ^ fnam, cn, t, abs, tag), adamc@144: (DExport (ek, cn), loc)) adamc@112: end) newTags adamc@126: adamc@126: val (newVals, newExports) = ListPair.unzip newDs adamc@126: adamc@126: val ds = case d of adamc@126: (DValRec vis, _) => [(DValRec (vis @ newVals), loc)] adamc@126: | _ => map (fn vi => (DVal vi, loc)) newVals @ [d] adamc@112: in adamc@126: (ds @ newExports, (env, count, tags, byTag)) adamc@112: end adamc@110: adamc@112: val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count+1, IM.empty, SM.empty) file adamc@110: in adamc@110: file adamc@110: end adamc@110: adamc@110: end