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@1065: let adamc@1065: fun tagIt (e, ek : export_kind, newAttr, (count, tags, byTag, newTags)) = adamc@1065: let adamc@1065: val loc = #2 e adamc@1065: adamc@1065: val eOrig = e adamc@1065: adamc@1065: fun unravel (e, _) = adamc@1065: case e of adamc@1065: ENamed n => (n, []) adamc@1065: | EApp (e1, e2) => adamc@1065: let adamc@1065: val (n, es) = unravel e1 adamc@1065: in adamc@1065: (n, es @ [e2]) adamc@1065: end adamc@1065: | _ => (ErrorMsg.errorAt loc ("Invalid " ^ newAttr adamc@1065: ^ " expression"); adamc@1065: Print.epreface ("Expression", adamc@1065: CorePrint.p_exp CoreEnv.empty eOrig); adamc@1065: (0, [])) adamc@1065: adamc@1065: val (f, args) = unravel e adamc@1065: adamc@1065: val (cn, count, tags, newTags) = adamc@1065: case IM.find (tags, f) of adamc@1065: NONE => adamc@1065: (count, count + 1, IM.insert (tags, f, count), adamc@1065: (ek, f, count) :: newTags) adamc@1065: | SOME cn => (cn, count, tags, newTags) adamc@1065: adamc@1065: val (_, _, _, s) = E.lookupENamed env f adamc@1065: adamc@1065: val byTag = case SM.find (byTag, s) of adamc@1065: NONE => SM.insert (byTag, s, (ek, f)) adamc@1065: | SOME (ek', f') => adamc@1065: (if f = f' then adamc@1065: () adamc@1065: else adamc@1065: ErrorMsg.errorAt loc adamc@1065: ("Duplicate HTTP tag " adamc@1065: ^ s); adamc@1065: if ek = ek' then adamc@1065: () adamc@1065: else adamc@1065: both (loc, s); adamc@1065: byTag) adamc@1065: adamc@1065: val e = (EClosure (cn, args), loc) adamc@1065: in adamc@1065: (e, (count, tags, byTag, newTags)) adamc@1065: end adamc@1065: in adamc@1065: case e of adamc@1065: EApp ( adamc@1065: (EApp ( adamc@1065: (EApp ( adamc@1065: (EApp ( adamc@140: (ECApp ( adamc@140: (ECApp ( adamc@140: (ECApp ( adamc@721: (ECApp ( adamc@1065: (ECApp ( adamc@1065: (ECApp ( adamc@110: (ECApp ( adamc@110: (ECApp ( adamc@1065: (EFfi ("Basis", "tag"), adamc@1065: loc), given), _), absent), _), outer), _), inner), _), adamc@1065: useOuter), _), useInner), _), bindOuter), _), bindInner), _), adamc@1065: class), _), adamc@1065: attrs), _), adamc@1065: tag), _), adamc@1065: xml) => adamc@1065: (case attrs of adamc@1065: (ERecord xets, _) => adamc@1065: let adamc@1065: val (xets, s) = adamc@1065: ListUtil.foldlMap (fn ((x, e, t), s) => adamc@1065: let adamc@1065: fun tagIt' (ek, newAttr) = adamc@1065: let adamc@1065: val (e', s) = tagIt (e, ek, newAttr, s) adamc@1065: val t = (CFfi ("Basis", "string"), loc) adamc@1065: in adamc@1065: (((CName newAttr, loc), e', t), s) adamc@1065: end adamc@1065: in adamc@1065: case x of adamc@1065: (CName "Link", _) => tagIt' (Link, "Link") adamc@1065: | (CName "Action", _) => tagIt' (Action ReadWrite, "Action") adamc@1065: | _ => ((x, e, t), s) adamc@1065: end) adamc@1065: s xets adamc@1065: in adamc@1065: (EApp ( adamc@1065: (EApp ( adamc@1065: (EApp ( adamc@1065: (EApp ( adamc@140: (ECApp ( adamc@140: (ECApp ( adamc@140: (ECApp ( adamc@721: (ECApp ( adamc@1065: (ECApp ( adamc@1065: (ECApp ( adamc@1065: (ECApp ( adamc@1065: (ECApp ( adamc@1065: (EFfi ("Basis", "tag"), adamc@1065: loc), given), loc), absent), loc), outer), loc), inner), loc), adamc@1065: useOuter), loc), useInner), loc), bindOuter), loc), bindInner), loc), adamc@1065: class), loc), adamc@1065: (ERecord xets, loc)), loc), adamc@1065: tag), loc), adamc@1065: xml), s) adamc@1065: end adamc@1065: | _ => (ErrorMsg.errorAt loc "Attribute record is too complex"; adamc@1065: (e, s))) adamc@110: adamc@1065: | EFfiApp ("Basis", "url", [(ERel 0, _)]) => (e, s) adamc@1065: adamc@1065: | EFfiApp ("Basis", "url", [e]) => adamc@1065: let adamc@1065: val (e, s) = tagIt (e, Link, "Url", s) adamc@1065: in adamc@1067: (EFfiApp ("Basis", "url", [e]), s) adamc@1065: end adamc@1065: adamc@1065: | EApp ((ENamed n, _), e') => adamc@1065: let adamc@1065: val (_, _, eo, _) = E.lookupENamed env n adamc@1065: in adamc@1065: case eo of adamc@1065: SOME (EAbs (_, _, _, (EFfiApp ("Basis", "url", [(ERel 0, _)]), _)), _) => adamc@1065: let adamc@1065: val (e, s) = tagIt (e', Link, "Url", s) adamc@1065: in adamc@1067: (EFfiApp ("Basis", "url", [e]), s) adamc@1065: end adamc@1065: | _ => (e, s) adamc@1065: end adamc@1065: adamc@1065: | _ => (e, s) adamc@1065: end 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