Mercurial > urweb

comparison src/sql.sml @ 2203:39faa4a037f4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
ML half of initial prototype. (Doesn't compile because there's no C yet.)
author Ziv Scully <ziv@mit.edu>
date Tue, 25 Mar 2014 02:04:06 -0400
parents 606af2c9b828
children 01c8aceac480
comparison
equal deleted inserted replaced
2202:606af2c9b828 2203:39faa4a037f4
1 structure Sql = struct 1 structure Sql = struct
2 2
3 open Mono 3 open Mono
4 4
5 val debug = ref true (*false*) 5 val debug = ref false
6 6
7 type lvar = int 7 type lvar = int
8 8
9 datatype func = 9 datatype func =
10 DtCon0 of string 10 DtCon0 of string
423 Query of query 423 Query of query
424 | Dml of dml 424 | Dml of dml
425 425
426 val querydml = log "querydml" (altL [wrap dml Dml, wrap query Query]) 426 val querydml = log "querydml" (altL [wrap dml Dml, wrap query Query])
427 427
428 (* New stuff. *)
429
430 fun subExps' (exp' : Mono.exp') =
431 case exp' of
432 ECon (_,_,SOME exp) => [exp]
433 | ESome (_,exp) => [exp]
434 | EFfiApp (_,_,xs) => map #1 xs
435 | EApp (exp1,exp2) => [exp1, exp2]
436 | EAbs (_,_,_,exp) => [exp]
437 | EUnop (_,exp) => [exp]
438 | EBinop (_,_,exp1,exp2) => [exp1, exp2]
439 | ERecord xs => map #2 xs
440 | EField (exp,_) => [exp]
441 | ECase (exp,xs,_) => exp :: map #2 xs
442 | EStrcat (exp1,exp2) => [exp1,exp2]
443 | EError (exp,_) => [exp]
444 | EReturnBlob {blob=NONE, mimeType, ...} => [mimeType]
445 | EReturnBlob {blob=SOME exp, mimeType, ...} => [exp, mimeType]
446 | ERedirect (exp,_) => [exp]
447 | EWrite exp => [exp]
448 | ESeq (exp1,exp2) => [exp1, exp2]
449 | ELet (_,_,exp1,exp2) => [exp1, exp2]
450 | EClosure (_,xs) => xs
451 | EQuery {query, body, initial, ...} => [query, body, initial]
452 | EDml (exp,_) => [exp]
453 | ENextval exp => [exp]
454 | ESetval (exp1,exp2) => [exp1, exp2]
455 | EUnurlify (exp,_,_) => [exp]
456 | EJavaScript (_,exp) => [exp]
457 | ESignalReturn exp => [exp]
458 | ESignalBind (exp1,exp2) => [exp1, exp2]
459 | ESignalSource exp => [exp]
460 | EServerCall (exp,_,_,_) => [exp]
461 | ERecv (exp,_) => [exp]
462 | ESleep exp => [exp]
463 | ESpawn exp => [exp]
464 | _ => []
465
466 val subExps : Mono.exp -> Mono.exp list = subExps' o #1
467
468 fun println str = print (str ^ "\n")
469 fun printlnExp exp = (Print.print (MonoPrint.p_exp MonoEnv.empty exp); println "")
470
471 fun tablesRead (Query1 {From=tablePairs, ...}) = map #1 tablePairs
472 | tablesRead (Union (q1,q2)) = tablesRead q1 @ tablesRead q2
473
474 fun tableTouched (Insert (tab,_)) = tab
475 | tableTouched (Delete (tab,_)) = tab
476 | tableTouched (Update (tab,_,_)) = tab
477
478 fun goExp (exp : Mono.exp) =
479 case #1 exp of
480 EQuery {query=e, ...} => (
481 case parse query e of
482 SOME q => println ("Query reads from " ^ String.concatWith ", " (tablesRead q))
483 | NONE => println "Couldn't parse query";
484 printlnExp exp; println "")
485 | EDml (e,_) => (
486 case parse dml e of
487 SOME d => println ("DML touches " ^ tableTouched d)
488 | NONE => println "Couldn't parse DML";
489 printlnExp exp; println "")
490 | ENextval _ => (printlnExp exp; println "")
491 | ESetval _ => (printlnExp exp; println "")
492 (* Recurse down the syntax tree. *)
493 | _ => app goExp (subExps exp)
494
495 fun goDecl (decl : decl) =
496 case #1 decl of
497 DVal (_,_,_,exp,_) => goExp exp
498 | DValRec xs => app (goExp o #4) xs
499 | _ => ()
500
501 fun goFile (file : file) = app goDecl (#1 file)
502
503 fun go file = (println "Doing SQL analysis.\n"; goFile file; ())
504
505 end 428 end