Commit dfbd913d authored by hayeah via gmail com's avatar hayeah via gmail com

fmt* and schema.lisp refactoring

fmt* is a variant of fmt but doesn't print nil. This is useful for embedding control structure directly within the fmt macro.

darcs-hash:c312d6c8f41e9dbefef70e4e07038979ed0b30e0
parent 9add1039
......@@ -91,9 +91,7 @@ Return:
Where forms before ~ are object path.
Between ~ and @ are arguments to method application.
After @ are array references.
-
Return
((<js-form>*) (~ <js-form>*) (@ <js-form>*)) "
- Return ((<js-form>*) (~ <js-form>*) (@ <js-form>*))"
(let* ((separators '(~ @))
(broken-form (split-by-tests js-form '(~ @))))
(cons (car broken-form)
......@@ -154,8 +152,9 @@ Return
(raw-string processor "]"))))
;;;; Functionl call not dealt with yet
;;;; Irrelevant with the ~ @ syntax.
;; (defun process-function-call (language processor environment name arguments)
;; (let ((function-expression-statement-p
;; (let ((function-expression-statement-p ;; test to see if the function to be applied is the result of a statement.
;; (and (consp name) (eql (car name) 'function) (eql (statement-or-expression environment) :statement))))
;; (when function-expression-statement-p (raw-string processor "("))
;; (process language processor name (new-env 'statement-or-expression :expression environment))
......@@ -266,7 +265,7 @@ statements such as blocks to *not* emit a semicolon."
;;(define-binary-ops << >> >>>)
;;(define-binary-ops < > <= >= instanceof in)
(define-binary-ops instanceof in)
;;(define-binary-ops == != === !===)
;;(define-binary-ops == != === !===)
(define-binary-ops &)
(define-binary-ops ^)
(define-binary-ops \|) ;; hmmm. This may not be the best name. Unless we put the reader into a special mode.
......@@ -543,17 +542,69 @@ statements such as blocks to *not* emit a semicolon."
(body (body)
(process *javascript* processor `(block ,@body) (new-env 'statement-or-expression :statement env))))
(if (and (symbolp (first body)) (not (null (first body))))
(destructuring-bind (name (&rest params) &rest body) body
(destructuring-bind (name (&rest params) &rest body) body
(out "function " (name name) " " (params params) " " (body body)))
(destructuring-bind ((&rest params) &rest body) body
(destructuring-bind ((&rest params) &rest body) body
(when (eql (statement-or-expression env) :expression) (raw-string processor "("))
(out "function " (params params) " " (body body))
(when (eql (statement-or-expression env) :expression) (raw-string processor ")"))))))
(define-javascript-special-operator augment-environment :statement (processor (&rest pairs) &body body &environment env)
(let ((env (append pairs env)))
(loop for form in body do
(process *javascript* processor form env))))
(generate-from-string *lispscript* "(@ (.foo bar))")
(generate-from-string *lispscript* "(.foo bar (.baz maz jo jo))")
(generate-from-string *lispscript* "(@ (.foo bar) baz)")
(generate-from-string *lispscript* "((foo ~ 1 2 3) baz ~ 4 5 6 @ 7 8 9 )")
(generate-from-string *lispscript* "(set (a b c) (+ 1 2 (* (foo @ 4 5) (foo baz @ 3))))")
(generate-from-string *lispscript* "(defvar bah (function (foo) (blah)))")
(generate-from-string *javascript* "(FUNCTION b (a) a b)")
(defmethod process-sexp ((language javascript) processor form environment)
(if (consp form)
(destructuring-bind (name &rest arguments) form
(if (method-name name)
(process-method-call language processor environment
(method-name name)
(first arguments)
(rest arguments))
(process-function-call language processor environment
name
arguments)))
(process-javascript-scalar processor form))
(maybe-semicolon processor environment))
(defun process-function-call (language processor environment name arguments)
(let ((function-expression-statement-p
(and (consp name) (eql (car name) 'function) (eql (statement-or-expression environment) :statement))))
(when function-expression-statement-p (raw-string processor "("))
(process language processor name (new-env 'statement-or-expression :expression environment))
(when function-expression-statement-p (raw-string processor ")"))
(raw-string processor "(")
(loop for (arg . rest) on arguments do
(process language processor arg (new-env 'statement-or-expression :expression environment))
when rest do (raw-string processor ", "))
(raw-string processor ")")))
(process *javascript* (get-pretty-printer) '(function (b c) d) (top-level-environment *javascript*))
(get 'function 'javascript-special-operator)
(symbol-plist 'function)
(with-open-file (out #p"/home/howard/wisp/cl-user-symbols" :direction :output :if-exists :supersede)
(do-symbols (sym (find-package :cl-user))
(print sym out)))
(sleep 3)
......@@ -389,7 +389,7 @@ supports transactions."
(value-consts :initarg :value-consts :initform nil)
(special-consts :initarg :special-consts :initform nil)))
(defclass foreign-key ()
(defclass reference ()
((foreign-table :initarg :foreign-table)
(foreign-field :initarg :foreign-field)
(trigger :initarg :trigger)
......@@ -428,8 +428,8 @@ supports transactions."
(ecase trigger-response
(:restrict (write-string " RESTRICT" *sql-stream*))
(:cascade (write-string " CASCADE" *sql-stream*))
(:cascade (write-string " SET NULL" *sql-stream*))
(:cascade (write-string " SET DEFAULT" *sql-stream*))))))
(:null (write-string " SET NULL" *sql-stream*))
(:default (write-string " SET DEFAULT" *sql-stream*))))))
(dolist (key special-constraints)
(let* ((constraint (assoc key *pg-special-constraint-types*))
(constraint-string (cdr constraint)))
......@@ -441,9 +441,9 @@ supports transactions."
(sql-output (->clsql (cons 'and value-constraints)) database)
(write-char #\) *sql-stream*))))
(sql-output (->clsql '(> 2 3)))
;; (sql-output (->clsql '(> 2 3)))
(create-table 'foo (list (make-instance 'column-spec
;; (create-table 'foo (list (make-instance 'column-spec
(defmethod output-sql ((stmt sql-create-table) (database clsql-postgresql:postgresql-database))
(with-slots (name columns modifiers transactions)
......
......@@ -28,6 +28,20 @@
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;; fmt should have a variant that suppresses printing nil.
;; ;; fmt* this is to facilitate the use of control structure within fmt* directly
;; (fmt (when (= 1 1) 1)
;; (when (> 1 1) 2)
;; (fmt nil)
;; (values)) => "1nilnilnil"
;; (fmt* (when (= 1 1) 1)
;; (when (> 1 1) 2)
;; (fmt nil)
;; (values)) => "1nil"
(in-package :wisp.util)
;;; rkr lambda-list
......@@ -130,26 +144,39 @@
nil))
;; "No destructuring lambda arg"
(defun make-fmt-instructions (fmt-cmds)
(mapcar (fn (fmt-cmd)
(cond
((keywordp fmt-cmd) `(fmt (,fmt-cmd)))
((atom fmt-cmd) `(princ ,fmt-cmd *fmt-stream*))
(t
(aif (valid-fmt-op? (car fmt-cmd))
`(,(symcat 'fmt- it) ,@(cdr fmt-cmd))
(error "Invalid fmt-op in ~S" fmt-cmd)))))
fmt-cmds))
(def/rkr/macro fmt (&key (> '*fmt-stream*) &rest fmt-cmds)
(let* ((body (make-fmt-instructions fmt-cmds))
(body `(macrolet ((fmt (&rest rest) `(progn ,@(make-fmt-instructions rest))))
(defparameter nil-options '(:nil :list :none))
(defun make-fmt-instructions (fmt-cmds &key (nil-option :nil))
(flet ((select-nil-option (fmt-cmd)
(ecase nil-option
(:nil `(princ ,fmt-cmd *fmt-stream*))
(:none `(awhen ,fmt-cmd (princ it *fmt-stream*)))
(:list `(aif ,fmt-cmd
(princ it *fmt-stream*)
(princ "()" *fmt-stream*))))))
(mapcar (fn (fmt-cmd)
(cond
((keywordp fmt-cmd) `(fmt (,fmt-cmd)))
((atom fmt-cmd) (select-nil-option fmt-cmd))
(t
(aif (valid-fmt-op? (car fmt-cmd))
`(,(symcat 'fmt- it) ,@(cdr fmt-cmd))
(select-nil-option fmt-cmd)))))
fmt-cmds)))
(def/rkr/macro fmt (&key (> '*fmt-stream*) (nil-option :nil) &rest fmt-cmds)
(let* ((body (make-fmt-instructions fmt-cmds :nil-option nil-option))
(body `(macrolet ((fmt (&rest rest) `(progn ,@(make-fmt-instructions rest :nil-option ,nil-option))))
,@body))) ;;rebind fmt so no extra logical blocks are created in embedded fmt calls
(case >
((nil) `(with-output-to-string (*fmt-stream*)
(pprint-logical-block (*fmt-stream* nil) ,body)))
(t `(pprint-logical-block (,> nil) ,body)))))
(defmacro fmt* (&rest fnlist)
`(fmt ,@(append '(:nil-option :none) fnlist)))
;;;; fmt-ops
(defmt-op :fmt (&rest rest)
`(fmt ,@rest))
......@@ -248,6 +275,7 @@
`(pprint-newline :mandatory *fmt-stream*))
;; (fmt
;; 1
;; (:idn 2 :tab 22
......
......@@ -66,80 +66,10 @@
;; <data-type> := integer | number | (string <number>) | text | date
;; <relation> := :many | :one
;; CREATE TABLE products (
;; product_no integer PRIMARY KEY,
;; name text,
;; price numeric
;; );
;; CREATE TABLE orders (
;; order_id integer PRIMARY KEY,
;; shipping_address text,
;; ...
;; );
;; CREATE TABLE order_items (
;; product_no integer REFERENCES products,
;; order_id integer REFERENCES orders,
;; quantity integer,
;; PRIMARY KEY (product_no, order_id)
;; );
;; (def-schemas *example*
((products (product-no integer :primary :autoinc)
((name "ACME generic") (string 77) :unique)
(price numeric (> price 0)))
(orders (order-id integer :primary)
(shipping-address text))
(order-items (product-id integer (ref products product-no :on-delete :cascade))
(order-id integer (ref orders))
(quantity integer)
:with (primary-key product-id order-id))))
;; (def-schemas *foo*
;; ((member ((first-name "Joe") (string 32))
;; ((last-name "Schmoe") (string 32))
;; ((age 35) (integer 8)
;; (< age 50) (> age 20) (ref relation age) :required :unique)
;; ((user-name "psileet") (string 16) :unique)
;; (:many relation :on-delete :restrict)
;; :check (unique first-name last-name)) ;; use the keyword :check to specify table constraints.
;; (relation (wish (string 100))
;; (time time))));;
;; (def-schema *foo*
((member ((first-name "Joe") (string 32))
((last-name "Schmoe") (string 32))
((age 35) integer
(< age 50) (> age 20)
(ref relation age :on-delete :cascade) :required :unique)
(user-name (string 16) :unique)
(:many relation :on-delete :restrict))
(relation (wish (string 100))
(time time))))
;; (def-schema *bar*
;; ((foo (a integer)
;; (b (string 30))
;; (:many bar))
;; (bar (a integer)
;; (b (string 40))
;; (:many foo))
;; (baz (:one foo)
;; (:one bar))));;
;;; Schema Definition
(defmacro def-schema (name schema)
`(defparameter ,name (parse-schema ',name ',schema)))
;; Don't check sanity yet. Get it to output stuff first.
;;;; Schema parsetree
......@@ -168,7 +98,7 @@
(value-consts :initarg :value-consts :initform nil)
(special-consts :initarg :special-consts :initform nil)))
(defclass foreign-key ()
(defclass reference ()
((foreign-table :initarg :foreign-table)
(foreign-field :initarg :foreign-field)
(trigger :initarg :trigger)
......@@ -188,28 +118,30 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Schema parsing
(defun parse-schema (name data-schema)
(let ((*table-names* (mapcar #'car data-schema)))
(declare (special *table-names*))
(let ((tables (mapcar #'parse-table data-schema)))
(make-instance 'schema :name name :tables tables))))
(defun parse-table (table-schema)
(let ((table-name (car table-schema))
(fields (cdr table-schema)))
(declare (special name))
(let ((fields (mapcar (fn (field) (parse-field field table-name)) fields)))
(make-instance 'table :name table-name :fields fields))))
(defun parse-schema (schema-name schema)
(let* ((all-table-names (mapcar #'car schema))
(tables (mapcar (fn (table-spec) (parse-table table-spec all-table-names))
schema)))
(make-instance 'schema :name schema-name :tables tables)))
(defun parse-table (table-spec all-table-names)
(let* ((table-name (car table-spec))
(fields (cdr table-spec))
(fields (mapcar (fn (field) (parse-field field table-name all-table-names))
fields)))
(make-instance 'table :name table-name :fields fields)))
(defun relation-field? (field)
(keywordp (car field)))
(defun parse-field (field current-table-name)
(declare (special *table-names*))
(cond ((relation-field? field)
(dbind (type to . constraints) field ;; TODO. Handle relation constraints
(defun parse-field (field current-table-name all-table-names)
(cond ((relation-field? field) (parse-relation field current-table-name all-table-names))
(t (parse-column-spec field))))
(defun parse-relation (relation current-table-name all-table-names)
(dbind (type to . constraints) relation ;; TODO. Handle relation constraints
(declare (ignore constraints))
(if (member to *table-names*)
(if (member to all-table-names)
(make-instance 'relation-field
:name (cat-syms current-table-name '- to)
:from current-table-name
......@@ -217,17 +149,19 @@
:type type)
(error "Relation made from ~s to an unspecified table: ~s"
current-table-name (list type to)))))
(t
(dbind (name type . constraints) field
(let* ((name (mklst name))
(default (cadr name)) ;; either default is specified, or nil (because of mklst)
(name (car name)))
(mvbind (val-consts special-consts ref) (parse-constraints constraints)
(print (list name type default))
(make-instance 'column-spec
:name name :type type
:default default
:value-consts val-consts :special-consts special-consts :reference ref)))))))
(defun parse-column-spec (column)
(dbind (name-spec type . constraints) column
(let* (;; name-spec could be a symbol or a cons depending on whether default is specified.
(name-spec (mklst name-spec))
(name (car name-spec))
(default (cadr name-spec)))
(mvbind (val-consts special-consts reference) (parse-constraints constraints)
(make-instance 'column-spec
:name name :type type
:default default
:value-consts val-consts :special-consts special-consts :reference reference)))))
......@@ -245,28 +179,38 @@
(or (member (car clause) test-ops)
(error "Unrecognized test operator in value constraint: ~S" clause)))))
(defun reference-constraint? (clause)
(eql (car (mklst clause)) 'ref))
(eql (car (mklst clause)) 'ref))
(defparameter *trigger-types* '(:on-delete :on-update))
(defparameter *trigger-actions* '(:cascade :restrict :null :default))
(defun parse-reference (reference-spec)
;; Should probably check to see if the table referenced exists in the schema
(flet ((has-foreign-field? (spec)
(and (symbolp (second spec)) (not (keywordp (second spec)))))
(parse-trigger (trigger)
(if (and (member (car trigger) *trigger-types*)
(member (cadr trigger) *trigger-actions*))
trigger
(error "Unrecognized trigger ~S" trigger))))
(destructuring-bind (foreign-table foreign-field (trigger trigger-response))
(if (has-foreign-field? reference-spec)
(list (first reference-spec) (second reference-spec) (parse-trigger (nthcdr 2 reference-spec)))
(list (first reference-spec) nil (parse-trigger (nthcdr 1 reference-spec))))
(make-instance 'reference
:foreign-table foreign-table :foreign-field foreign-field
:trigger trigger :trigger-response trigger-response))))
(defun parse-constraints (constraints)
(loop for clause in constraints
when (value-constraint? clause) collect clause into val-consts
;;
when (reference-constraint? clause) collect
(dbind (foreign-table &optional foreign-field &rest trigger-spec) (cdr clause)
(let ((trigger (car trigger-spec))
(trigger-response (cadr trigger-spec)))
(make-instance 'foreign-key
:foreign-table foreign-table :foreign-field foreign-field
:trigger trigger :trigger-response trigger-response)))
into ref
;;
when (value-constraint? clause) collect clause into val-consts
when (reference-constraint? clause) collect (parse-reference (cdr clause)) into ref
when (special-constraint? clause) collect clause into special-consts
finally (return (values val-consts
special-consts
(if (> (length ref) 1) ;; multiple references not allowed.
(error "Multiple foreign key in specified column constraints: ~S " constraints)
(car ref))))))
finally (return (progn (when (> (length ref) 1) ;; only one column reference allowed.
(error "Multiple foreign key in specified column constraints: ~S " constraints))
(values val-consts special-consts (car ref))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Unparse a schema object back into sexp.
......@@ -290,26 +234,18 @@
value-consts
special-consts)))
(defmethod unparse ((ref foreign-key))
(defmethod unparse ((ref reference))
(with-slots (foreign-table foreign-field trigger trigger-response) ref
(list 'ref foreign-table foreign-field trigger trigger-response)))
;;(slot-value (make-instance 'column-spec :name 'foo :type 'bar :default 'baz) 'default)
(defmethod unparse ((field relation-field))
(with-slots (name type from to) field
(list type to)))
;; (defmethod unparse ((constraints constraints))
;; (with-slots (specials checks references) constraints
;; (append specials checks references)))
;;; Schema Loading
(defmacro load-schema (schema &key force)
"CAUTION!! 'force-create' is in the lexical scope."
`(let ((force-create ,force))
......@@ -321,8 +257,7 @@
`(progn ,@(mappend #'gen-insts (slot-value schema 'tables))))
(defun force-create? (table-name insts)
(defun force-create? (table-name insts)
"Check if table exists, drop it if doing schema loading by force."
`((and (table-exists-p ',table-name) (not force-create)
(error "~s already exists in database. Either drop, or force create." ',table-name))
......@@ -358,9 +293,6 @@
,@join-insts))))
(defmethod gen-insts ((field column-spec))
(with-slots (name type constraints) field
`(,(->clsql name) ,type ,@constraints)))
......@@ -383,6 +315,7 @@
;; (with-data <var> <query>)
;; <query> := (<query-type>? <table-name> <field>*)
;; <table-name> := (<keyword> <symbol>) | <symbol>
......
(defpackage :wisp.util (:use :cl :cl-interpol :it.bese.fiveam)
(defpackage :wisp.util (:use :cl :cl-interpol); :it.bese.fiveam)
(:export :with-gensyms
;; :while
:until
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment