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@112: fun exp env (e, s) = adamc@110: case e of adamc@110: EApp ( adamc@110: (EApp ( adamc@110: (EApp ( adamc@110: (ECApp ( adamc@110: (ECApp ( adamc@110: (ECApp ( adamc@110: (ECApp ( adamc@110: (EFfi ("Basis", "tag"), adamc@110: loc), given), _), absent), _), outer), _), inner), _), 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@110: case x of adamc@110: (CName "Link", _) => adamc@110: let adamc@110: fun unravel (e, _) = adamc@110: case e of adamc@110: ENamed n => (n, []) adamc@110: | EApp (e1, e2) => adamc@110: let adamc@110: val (n, es) = unravel e1 adamc@110: in adamc@110: (n, es @ [e2]) adamc@110: end adamc@110: | _ => (ErrorMsg.errorAt loc "Invalid link expression"; adamc@110: (0, [])) adamc@110: adamc@110: val (f, args) = unravel e adamc@110: adamc@110: val (cn, count, tags, newTags) = adamc@110: case IM.find (tags, f) of adamc@110: NONE => adamc@110: (count, count + 1, IM.insert (tags, f, count), adamc@110: (f, count) :: newTags) adamc@110: | SOME cn => (cn, count, tags, newTags) adamc@110: adamc@112: val (_, _, _, s) = E.lookupENamed env f adamc@112: adamc@112: val byTag = case SM.find (byTag, s) of adamc@112: NONE => SM.insert (byTag, s, f) adamc@112: | SOME f' => adamc@112: (if f = f' then adamc@112: () adamc@112: else adamc@112: ErrorMsg.errorAt loc adamc@112: ("Duplicate HTTP tag " adamc@112: ^ s); adamc@112: byTag) adamc@112: adamc@110: val e = (EClosure (cn, args), loc) adamc@110: val t = (CFfi ("Basis", "string"), loc) adamc@110: in adamc@117: (((CName "href", loc), e, t), adamc@112: (count, tags, byTag, newTags)) adamc@110: end adamc@112: | _ => ((x, e, t), (count, tags, byTag, newTags))) adamc@110: s xets adamc@110: in adamc@110: (EApp ( adamc@110: (EApp ( adamc@110: (EApp ( adamc@110: (ECApp ( adamc@110: (ECApp ( adamc@110: (ECApp ( adamc@110: (ECApp ( adamc@110: (EFfi ("Basis", "tag"), adamc@110: loc), given), loc), absent), loc), outer), loc), inner), 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@110: val count = foldl (fn ((d, _), count) => adamc@110: case d of adamc@110: DCon (_, n, _, _) => Int.max (n, count) adamc@110: | DVal (_, n, _, _, _) => Int.max (n, count) adamc@125: | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis adamc@110: | DExport _ => count) 0 file adamc@110: adamc@112: fun doDecl (d as (d', loc), (env, count, tags, byTag)) = adamc@112: case d' of adamc@112: DExport 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@112: | SOME n' => ([], (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@112: (fn (f, cn) => adamc@112: let 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@112: val unit = (TRecord (CRecord ((KType, loc), []), loc), loc) adamc@119: adamc@119: val (abs, t) = adamc@119: case args of adamc@119: [] => adamc@119: let adamc@119: val body = (EWrite (ENamed f, loc), loc) adamc@119: in adamc@119: ((EAbs ("x", unit, unit, body), loc), 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@119: val body = (EWrite app, 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@119: (body, 0, unit) args adamc@119: in adamc@119: (abs, t) adamc@119: end adamc@112: in adamc@126: (("wrap_" ^ fnam, cn, t, abs, tag), adamc@126: (DExport 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