Mercurial > urweb

comparison src/rpcify.sml @ 1848:e15234fbb163

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Basis.tryRpc
author Adam Chlipala <adam@chlipala.net>
date Tue, 16 Apr 2013 10:55:48 -0400
parents 385a1b799a74
children
comparison
equal deleted inserted replaced
1847:8958b580d026 1848:e15234fbb163
1 (* Copyright (c) 2009, 2012, Adam Chlipala 1 (* Copyright (c) 2009, 2012-2013, Adam Chlipala
2 * All rights reserved. 2 * All rights reserved.
3 * 3 *
4 * Redistribution and use in source and binary forms, with or without 4 * Redistribution and use in source and binary forms, with or without
5 * modification, are permitted provided that the following conditions are met: 5 * modification, are permitted provided that the following conditions are met:
6 * 6 *
40 export_decls : decl list 40 export_decls : decl list
41 } 41 }
42 42
43 fun frob file = 43 fun frob file =
44 let 44 let
45 val rpcBaseIds = foldl (fn ((d, _), rpcIds) => 45 val (rpcBaseIds, trpcBaseIds) =
46 case d of 46 foldl (fn ((d, _), (rpcIds, trpcIds)) =>
47 DVal (_, n, _, (EFfi ("Basis", "rpc"), _), _) => IS.add (rpcIds, n) 47 case d of
48 | DVal (_, n, _, (ENamed n', _), _) => if IS.member (rpcIds, n') then 48 DVal (_, n, _, (EFfi ("Basis", "rpc"), _), _) =>
49 IS.add (rpcIds, n) 49 (IS.add (rpcIds, n), trpcIds)
50 else 50 | DVal (_, n, _, (EFfi ("Basis", "tryRpc"), _), _) =>
51 rpcIds 51 (rpcIds, IS.add (trpcIds, n))
52 | _ => rpcIds) 52 | DVal (_, n, _, (ENamed n', _), _) =>
53 IS.empty file 53 if IS.member (rpcIds, n') then
54 (IS.add (rpcIds, n), trpcIds)
55 else if IS.member (trpcIds, n') then
56 (rpcIds, IS.add (trpcIds, n))
57 else
58 (rpcIds, trpcIds)
59 | _ => (rpcIds, trpcIds))
60 (IS.empty, IS.empty) file
54 61
55 val tfuncs = foldl 62 val tfuncs = foldl
56 (fn ((d, _), tfuncs) => 63 (fn ((d, _), tfuncs) =>
57 let 64 let
58 fun doOne ((x, n, t, e, _), tfuncs) = 65 fun doOne ((x, n, t, e, _), tfuncs) =
87 case e' of 94 case e' of
88 ENamed n => SOME (n, args) 95 ENamed n => SOME (n, args)
89 | EApp (e1, e2) => getApp (#1 e1, e2 :: args) 96 | EApp (e1, e2) => getApp (#1 e1, e2 :: args)
90 | _ => NONE 97 | _ => NONE
91 98
92 fun newRpc (trans : exp, st : state) = 99 fun newRpc (trans : exp, st : state, fm) =
93 case getApp (#1 trans, []) of 100 case getApp (#1 trans, []) of
94 NONE => (ErrorMsg.errorAt (#2 trans) 101 NONE => (ErrorMsg.errorAt (#2 trans)
95 "RPC code doesn't use a named function or transaction"; 102 "RPC code doesn't use a named function or transaction";
96 (*Print.preface ("Expression", 103 (*Print.preface ("Expression",
97 CorePrint.p_exp CoreEnv.empty trans);*) 104 CorePrint.p_exp CoreEnv.empty trans);*)
112 (DExport (Rpc ReadWrite, n, false), loc) :: #export_decls st) 119 (DExport (Rpc ReadWrite, n, false), loc) :: #export_decls st)
113 120
114 val st = {exported = exported, 121 val st = {exported = exported,
115 export_decls = export_decls} 122 export_decls = export_decls}
116 123
117 val e' = EServerCall (n, args, ran) 124 val e' = EServerCall (n, args, ran, fm)
118 in 125 in
119 (e', st) 126 (e', st)
120 end 127 end
121 in 128 in
122 case e of 129 case e of
123 EApp ((ECApp ((EFfi ("Basis", "rpc"), _), ran), _), trans) => newRpc (trans, st) 130 EApp ((ECApp ((EFfi ("Basis", "rpc"), _), ran), _), trans) => newRpc (trans, st, None)
131 | EApp ((ECApp ((EFfi ("Basis", "tryRpc"), _), ran), _), trans) => newRpc (trans, st, Error)
124 | EApp ((ECApp ((ENamed n, _), ran), _), trans) => 132 | EApp ((ECApp ((ENamed n, _), ran), _), trans) =>
125 if IS.member (rpcBaseIds, n) then 133 if IS.member (rpcBaseIds, n) then
126 newRpc (trans, st) 134 newRpc (trans, st, None)
135 else if IS.member (trpcBaseIds, n) then
136 newRpc (trans, st, Error)
127 else 137 else
128 (e, st) 138 (e, st)
129 139
130 | _ => (e, st) 140 | _ => (e, st)
131 end 141 end