adamc@607: (* Copyright (c) 2009, Adam Chlipala adamc@607: * All rights reserved. adamc@607: * adamc@607: * Redistribution and use in source and binary forms, with or without adamc@607: * modification, are permitted provided that the following conditions are met: adamc@607: * adamc@607: * - Redistributions of source code must retain the above copyright notice, adamc@607: * this list of conditions and the following disclaimer. adamc@607: * - Redistributions in binary form must reproduce the above copyright notice, adamc@607: * this list of conditions and the following disclaimer in the documentation adamc@607: * and/or other materials provided with the distribution. adamc@607: * - The names of contributors may not be used to endorse or promote products adamc@607: * derived from this software without specific prior written permission. adamc@607: * adamc@607: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@607: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@607: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@607: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@607: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@607: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@607: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@607: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@607: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@607: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@607: * POSSIBILITY OF SUCH DAMAGE. adamc@607: *) adamc@607: adamc@607: structure Rpcify :> RPCIFY = struct adamc@607: adamc@607: open Core adamc@607: adamc@607: structure U = CoreUtil adamc@607: structure E = CoreEnv adamc@607: adamc@607: structure IS = IntBinarySet adamc@607: structure IM = IntBinaryMap adamc@607: adamc@607: structure SS = BinarySetFn(struct adamc@607: type ord_key = string adamc@607: val compare = String.compare adamc@607: end) adamc@607: adamc@607: val ssBasis = SS.addList (SS.empty, adamc@607: ["requestHeader", adamc@607: "query", adamc@607: "dml", adamc@607: "nextval"]) adamc@607: adamc@607: val csBasis = SS.addList (SS.empty, adamc@607: ["source", adamc@607: "get", adamc@607: "set", adamc@607: "alert"]) adamc@607: adamc@607: type state = { adamc@608: cpsed : int IM.map, adamc@608: cps_decls : (string * int * con * exp * string) list, adamc@608: adamc@608: exported : IS.set, adamc@608: export_decls : decl list adamc@607: } adamc@607: adamc@607: fun frob file = adamc@607: let adamc@607: fun sideish (basis, ssids) = adamc@607: U.Exp.exists {kind = fn _ => false, adamc@607: con = fn _ => false, adamc@607: exp = fn ENamed n => IS.member (ssids, n) adamc@607: | EFfi ("Basis", x) => SS.member (basis, x) adamc@607: | EFfiApp ("Basis", x, _) => SS.member (basis, x) adamc@607: | _ => false} adamc@607: adamc@607: fun whichIds basis = adamc@607: let adamc@607: fun decl ((d, _), ssids) = adamc@607: let adamc@607: val impure = sideish (basis, ssids) adamc@607: in adamc@607: case d of adamc@607: DVal (_, n, _, e, _) => if impure e then adamc@607: IS.add (ssids, n) adamc@607: else adamc@607: ssids adamc@607: | DValRec xes => if List.exists (fn (_, _, _, e, _) => impure e) xes then adamc@607: foldl (fn ((_, n, _, _, _), ssids) => IS.add (ssids, n)) adamc@607: ssids xes adamc@607: else adamc@607: ssids adamc@607: | _ => ssids adamc@607: end adamc@607: in adamc@607: foldl decl IS.empty file adamc@607: end adamc@607: adamc@607: val ssids = whichIds ssBasis adamc@607: val csids = whichIds csBasis adamc@607: adamc@607: val serverSide = sideish (ssBasis, ssids) adamc@607: val clientSide = sideish (csBasis, csids) adamc@607: adamc@609: val tfuncs = foldl adamc@609: (fn ((d, _), tfuncs) => adamc@609: let adamc@609: fun doOne ((_, n, t, _, _), tfuncs) = adamc@609: let adamc@613: fun crawl (t, args) = adamc@613: case #1 t of adamc@609: CApp ((CFfi ("Basis", "transaction"), _), ran) => SOME (rev args, ran) adamc@609: | TFun (arg, rest) => crawl (rest, arg :: args) adamc@609: | _ => NONE adamc@609: in adamc@609: case crawl (t, []) of adamc@609: NONE => tfuncs adamc@609: | SOME sg => IM.insert (tfuncs, n, sg) adamc@609: end adamc@609: in adamc@609: case d of adamc@609: DVal vi => doOne (vi, tfuncs) adamc@609: | DValRec vis => foldl doOne tfuncs vis adamc@609: | _ => tfuncs adamc@609: end) adamc@609: IM.empty file adamc@609: adamc@607: fun exp (e, st) = adamc@607: case e of adamc@607: EApp ( adamc@607: (EApp adamc@607: ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _), adamc@607: (EFfi ("Basis", "transaction_monad"), _)), _), adamc@607: trans1), _), adamc@607: trans2) => adamc@607: (case (serverSide trans1, clientSide trans1, serverSide trans2, clientSide trans2) of adamc@613: (true, false, false, true) => adamc@607: let adamc@607: fun getApp (e, args) = adamc@607: case #1 e of adamc@607: ENamed n => (n, args) adamc@607: | EApp (e1, e2) => getApp (e1, e2 :: args) adamc@607: | _ => (ErrorMsg.errorAt loc "Mixed client/server code doesn't use a named function for server part"; adamc@607: (0, [])) adamc@607: adamc@607: val (n, args) = getApp (trans1, []) adamc@608: adamc@608: val (exported, export_decls) = adamc@608: if IS.member (#exported st, n) then adamc@608: (#exported st, #export_decls st) adamc@608: else adamc@608: (IS.add (#exported st, n), adamc@608: (DExport (Rpc, n), loc) :: #export_decls st) adamc@608: adamc@608: val st = {cpsed = #cpsed st, adamc@608: cps_decls = #cps_decls st, adamc@608: adamc@608: exported = exported, adamc@608: export_decls = export_decls} adamc@609: adamc@609: val ran = adamc@609: case IM.find (tfuncs, n) of adamc@613: NONE => (Print.prefaces "BAD" [("e", CorePrint.p_exp CoreEnv.empty (e, loc))]; adamc@613: raise Fail "Rpcify: Undetected transaction function") adamc@609: | SOME (_, ran) => ran adamc@607: in adamc@609: (EServerCall (n, args, trans2, ran), st) adamc@607: end adamc@607: | _ => (e, st)) adamc@607: | _ => (e, st) adamc@607: adamc@607: fun decl (d, st : state) = adamc@607: let adamc@607: val (d, st) = U.Decl.foldMap {kind = fn x => x, adamc@607: con = fn x => x, adamc@607: exp = exp, adamc@607: decl = fn x => x} adamc@607: st d adamc@607: in adamc@608: (List.revAppend (case #cps_decls st of adamc@608: [] => [d] adamc@608: | ds => adamc@608: case d of adamc@608: (DValRec vis, loc) => [(DValRec (ds @ vis), loc)] adamc@608: | (_, loc) => [d, (DValRec ds, loc)], adamc@608: #export_decls st), adamc@608: {cpsed = #cpsed st, adamc@608: cps_decls = [], adamc@608: adamc@608: exported = #exported st, adamc@608: export_decls = []}) adamc@607: end adamc@607: adamc@607: val (file, _) = ListUtil.foldlMapConcat decl adamc@608: {cpsed = IM.empty, adamc@608: cps_decls = [], adamc@608: adamc@608: exported = IS.empty, adamc@608: export_decls = []} adamc@607: file adamc@607: in adamc@607: file adamc@607: end adamc@607: adamc@607: end