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@607:      exps : int IM.map,
adamc@607:      decls : (string * int * con * exp * string) 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@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@607:                      (true, false, false, _) =>
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@607:                      in
adamc@607:                          (EServerCall (n, args, trans2), 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@607:                 (case #decls st of
adamc@607:                      [] => [d]
adamc@607:                    | ds =>
adamc@607:                      case d of
adamc@607:                          (DValRec vis, loc) => [(DValRec (ds @ vis), loc)]
adamc@607:                        | (_, loc) => [(DValRec ds, loc), d],
adamc@607:                  {decls = [],
adamc@607:                   exps = #exps st})
adamc@607:             end
adamc@607: 
adamc@607:         val (file, _) = ListUtil.foldlMapConcat decl
adamc@607:                         {decls = [],
adamc@607:                          exps = IM.empty}
adamc@607:                         file
adamc@607:     in
adamc@607:         file
adamc@607:     end
adamc@607: 
adamc@607: end