Mercurial > urweb

comparison src/mono_fooify.sml @ 2262:34ad83d9b729

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix recording bugs to do with nesting and buffer reallocation. Stop MonoFooify printing spurious errors.
author Ziv Scully <ziv@mit.edu>
date Wed, 07 Oct 2015 08:58:08 -0400
parents f81f1930c5d6
children a647a1560628
comparison
equal deleted inserted replaced
2261:f81f1930c5d6 2262:34ad83d9b729
125 else 125 else
126 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) 126 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
127 127
128 structure E = ErrorMsg 128 structure E = ErrorMsg
129 129
130 exception TypeMismatch of Fm.t * E.span
131 exception CantPass of Fm.t * typ
132 exception DontKnow of Fm.t * typ
133
130 val dummyExp = (EPrim (Prim.Int 0), E.dummySpan) 134 val dummyExp = (EPrim (Prim.Int 0), E.dummySpan)
131 135
132 fun fooifyExp fk lookupENamed lookupDatatype = 136 fun fooifyExpWithExceptions fk lookupENamed lookupDatatype =
133 let 137 let
134 fun fooify fm (e, tAll as (t, loc)) = 138 fun fooify fm (e, tAll as (t, loc)) =
135 case #1 e of 139 case #1 e of
136 EClosure (fnam, [(ERecord [], _)]) => 140 EClosure (fnam, [(ERecord [], _)]) =>
137 let 141 let
153 (EStrcat (e, 157 (EStrcat (e,
154 (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc), 158 (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc),
155 arg'), loc)), loc), 159 arg'), loc)), loc),
156 fm) 160 fm)
157 end 161 end
158 | _ => (E.errorAt loc "Type mismatch encoding attribute"; 162 | _ => raise TypeMismatch (fm, loc)
159 (e, fm))
160 in 163 in
161 attrify (args, ft, (EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm) 164 attrify (args, ft, (EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm)
162 end 165 end
163 | _ => 166 | _ =>
164 case t of 167 case t of
165 TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) 168 TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm)
166 | TFfi (m, x) => (if Settings.mayClientToServer (m, x) 169 | TFfi (m, x) => (if Settings.mayClientToServer (m, x)
167 (* TODO: better error message. (Then again, user should never see this.) *) 170 (* TODO: better error message. (Then again, user should never see this.) *)
168 then () 171 then ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm)
169 else (E.errorAt loc "MonoFooify: can't pass type from client to server"; 172 else raise CantPass (fm, tAll))
170 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]);
171 ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm))
172 173
173 | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) 174 | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm)
174 | TRecord ((x, t) :: xts) => 175 | TRecord ((x, t) :: xts) =>
175 let 176 let
176 val (se, fm) = fooify fm ((EField (e, x), loc), t) 177 val (se, fm) = fooify fm ((EField (e, x), loc), t)
289 val (fm, n) = Fm.lookupList fm fk t makeDecl 290 val (fm, n) = Fm.lookupList fm fk t makeDecl
290 in 291 in
291 ((EApp ((ENamed n, loc), e), loc), fm) 292 ((EApp ((ENamed n, loc), e), loc), fm)
292 end 293 end
293 294
294 | _ => (E.errorAt loc "Don't know how to encode attribute/URL type"; 295 | _ => raise DontKnow (fm, tAll)
295 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
296 (dummyExp, fm))
297 in 296 in
298 fooify 297 fooify
299 end 298 end
299
300 fun fooifyExp fk lookupENamed lookupDatatype fm exp =
301 fooifyExpWithExceptions fk lookupENamed lookupDatatype fm exp
302 handle TypeMismatch (fm, loc) =>
303 (E.errorAt loc "Type mismatch encoding attribute";
304 (dummyExp, fm))
305 | CantPass (fm, typ as (_, loc)) =>
306 (E.errorAt loc "MonoFooify: can't pass type from client to server";
307 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty typ)];
308 (dummyExp, fm))
309 | DontKnow (fm, typ as (_, loc)) =>
310 (E.errorAt loc "Don't know how to encode attribute/URL type";
311 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty typ)];
312 (dummyExp, fm))
313
300 314
301 (* Has to be set at the end of [Monoize]. *) 315 (* Has to be set at the end of [Monoize]. *)
302 val canonicalFm = ref (Fm.empty 0 : Fm.t) 316 val canonicalFm = ref (Fm.empty 0 : Fm.t)
303 317
304 fun urlify env expTyp = 318 fun urlify env expTyp =
305 if ErrorMsg.anyErrors () 319 let
306 then ((* DEBUG *) print "already error"; NONE) 320 val (exp, fm) =
307 else 321 fooifyExpWithExceptions
308 let 322 Url
309 val (exp, fm) = 323 (fn n =>
310 fooifyExp 324 let
311 Url 325 val (_, t, _, s) = MonoEnv.lookupENamed env n
312 (fn n => 326 in
313 let 327 (t, s)
314 val (_, t, _, s) = MonoEnv.lookupENamed env n 328 end)
315 in 329 (fn n => MonoEnv.lookupDatatype env n)
316 (t, s) 330 (!canonicalFm)
317 end) 331 expTyp
318 (fn n => MonoEnv.lookupDatatype env n) 332 in
319 (!canonicalFm) 333 canonicalFm := fm;
320 expTyp 334 SOME exp
321 in 335 end
322 if ErrorMsg.anyErrors () 336 handle TypeMismatch _ => NONE
323 then ((* DEBUG *) print "why"; (ErrorMsg.resetErrors (); NONE)) 337 | CantPass _ => NONE
324 else (canonicalFm := fm; SOME exp) 338 | DontKnow _ => NONE
325 end
326 339
327 fun getNewFmDecls () = 340 fun getNewFmDecls () =
328 let 341 let
329 val fm = !canonicalFm 342 val fm = !canonicalFm
330 in 343 in