Commit d54d4250 authored by hayeah's avatar hayeah

Clean Up

darcs-hash:c2b597debaece59be195e2f9d5593889490376e5
parent 5a1ab5fd
;;; Copyright (c) 2006 Howard Yeh
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;;
;; - Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;;
;; - Redistributions in binary form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in the
;; documentation and/or other materials provided with the distribution.
;;
;; - Neither the name of Howard Yeh, nor the names of its
;; contributors may be used to endorse or promote products derived
;; from this software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :wisp.util)
;;; rkr lambda-list
(defun parse/rkr/fnlist (args)
"Parse a specialized lambda list that has required args, key args, then rest args. No optional args.
......@@ -68,19 +100,22 @@
(list '&key keyarg)))
;;; fmt macro
;;;; Issues
;; problem: (:<op> ...) and (fmt-<op> ...) don't mix well.
;; (eval-when (:compile-toplevel :load-toplevel :execute)
;; (defparameter *fmt-stream* *standard-output*)
;; (defparameter *fmt-context* (cons nil nil))
;; (defparameter *fmt-ops* nil))
;;;; fmt global
(defparameter *fmt-stream* *standard-output*)
(defparameter *fmt-context* (cons nil nil))
(defparameter *fmt-ops* nil)
(defparameter *fmt-indent-em* 0)
;;;; fmt interface
(defmacro defmt-op (name args &body body)
"Defines a new format operation macro that may be used within the fmt macro. The names has to be a keyword."
(if (keywordp name)
......@@ -89,13 +124,6 @@
(def/rkr/macro ,(symcat 'fmt- name) ,args ,@body))
(error "Invalid (keyword) name for format op: ~S" name)))
;; Not sure how to pass reirections (:>) around. Implicitly with let through defmt-op or explicitly as now?
;; ;; I am not very clear how it works yet. Wait later to decide.
;; ;; I think this is right. Passed as :> is used for local redirect. 'Let' establishes global redirect.
;; ;; ;; In particular, :a takes local redirect, and fmt takes global redirect.
(defun valid-fmt-op? (fmt-op)
(aif (member fmt-op *fmt-ops*)
(car it)
......@@ -122,7 +150,7 @@
(pprint-logical-block (*fmt-stream* nil) ,body)))
(t `(pprint-logical-block (,> nil) ,body)))))
;;;; fmt-ops
(defmt-op :fmt (&rest rest)
`(fmt ,@rest))
......@@ -153,9 +181,7 @@
;; (:a :mincol 15 1 2 3))
;; (fmt-a :mincol (+ 5 5) 10) ;; incorrect. fix.
;; More often than not, it is ridiculous to specify as fmt-control arguments anything but constants.
;; ;; The only case where this might be useful is indent. But if I provide an indenting facility...
;; ;; Let this be it. Let other people fix it up, if they need it.
;; (with-char-collector col
;; (loop with upflag = t
......@@ -179,6 +205,17 @@
;; ;; `(with-fmt-context (,#?"~${opt}(" "~)")
;; ;; (fmt ,@rest))))
;; (fmt (:cap :o :words
;; (:a "how the fuck are you?"))
;; (:%)
;; (:cap :o :all
;; (:a "how the fuck are you?"))
;; (:%))
;; (format nil "~:(~A~)~%~:@(~A~)~%" "how the fuck are you?" "how the fuck are you?")
(defmt-op :if (test true false)
`(if ,test ,true ,false))
......@@ -223,19 +260,10 @@
;; 1)
;; (fmt (:cap :o :words
;; (:a "how the fuck are you?"))
;; (:%)
;; (:cap :o :all
;; (:a "how the fuck are you?"))
;; (:%))
;; (format nil "~:(~A~)~%~:@(~A~)~%" "how the fuck are you?" "how the fuck are you?")
;; What escape has to do is probably to turn pretty-print off so pprint-logical-block is ineffective.
(defmt-op :esc (&rest rest) ;
`(with-new-fmt-context (fmt ,@rest)))
;; ;; What escape has to do is probably to turn pretty-print off so pprint-logical-block is ineffective.
;; (defmt-op :esc (&rest rest) ;
;; `(with-new-fmt-context (fmt ,@rest)))
;; (deformatop :evl (&rest rest)
;; `(progn ,@rest))
......@@ -248,67 +276,7 @@
;; (pprint-logical-block (nil '(1 2 3 4 5 6 7 8) :per-line-prefix "##" :suffix ";")
;; (princ (pprint-pop))
;; (pprint-indent :block 10)
;; (pprint-newline :mandatory)
;; (princ (pprint-pop))
;; (pprint-indent :current 5)
;; (pprint-newline :mandatory)
;; (princ (pprint-pop))
;; (pprint-indent :current 5)
;; (pprint-newline :mandatory)
;; (princ (pprint-pop))
;; (pprint-indent :block 5)
;; (pprint-newline :mandatory)
;; (princ (pprint-pop)))
;; (defparameter foo
;; '(a000000000000000000000000000
;; 11 111111111 111111 111111111
;; 22 222
;; 333 3333
;; 44444444444444 44444))
;; (time (format t "~<~;~@{~W ~}~;~:@>" foo))
;; (pprint-logical-block (nil foo)
;; (princ (pprint-pop))
;; (pprint-indent :block 3)
;; (pprint-newline :mandatory)
;; (princ (pprint-pop))
;; (princ " ")
;; (until (pprint-exit-if-list-exhausted)
;; (pprint-indent :current 0)
;; (princ (pprint-pop))
;; (princ " ")
;; (pprint-newline :fill)))
;; (with-output-to-string (*standard-output*)
;; (pprint-logical-block (*standard-output* nil :prefix "{" :suffix "};")
;; (pprint-tab :line 3 1)
;; (princ 1)
;; (pprint-newline :mandatory)
;; (pprint-tab :line 3 1)
;; (princ 2)
;; (pprint-tab :line-relative 3 1)
;; (princ 3))
;; )
;; (pprint-logical-block (t '(1 2 3 4 5 6 7 8))
;; (princ (pprint-pop))
;; (pprint-indent :block 10)
;; (terpri)
;; (princ (pprint-pop))
;; (pprint-tab :section-relative 5 1)
;; (terpri)
;; (princ (pprint-pop)))
;;;; Case stream from sbcl
;; ;; :esc binds fresh context
;; (def-complex-format-interpreter #\( (colonp atsignp params directives)
......@@ -332,71 +300,13 @@
;; after))))
;; (princ "shit head you!" (sb-ext::make-case-frob-stream *standard-output* :capitalize))
;; (fboundp 'sb-ext::make-case-frob-stream)
;; forget about doing the pprinting stuff in format string. Use sexp.
;;;; Because I want to include normal lisp in a fmt-op, it's impossible to do everything in fmt-control.
;;;;;; Which leads to the problem that a global effect like ~< doesn't work properly using the current fmt-context scheme.
;; no destructuring macro for defmt-op
;; Just bind to standard stream for now.
;;(defmacro fmt (&key (> t)))
;; (princ "how about this?" (sb-ext::make-case-frob-stream *standard-output* :capitalize))
;; There are operations that influence all formatings nested inside.
;; ;; ~( and ~{ for example.
;; This is very very hairy.
;; ;; I think the trick I can use is to make a macro for format.
;; ;; During expansion, the context is kept within which control strings expand.
;; I need to think through how control strings and forms interact.
;; There needs to be a way to ignore the context too.
;; (:cap (:a :mincol 20 :padchar #\. 30 400000 nil))
;; (:cap (:lst (obj lst)
;; (:if (> (car obj) (cdr obj))
;; (:a :mincol 20 :padchar #\. (car obj) (cdr obj))
;; (:esc (:a :mincol 20 :padchar #\. (car obj) (con obj))))))
;; ;; <===>
;; (:cap (:lst (obj lst)
;; (:evl (if (> (car obj) (cdr obj))
;; (fmt (:a :mincol 20 :padchar #\. (car obj) (cdr obj)))
;; (fmt (:esc (:a :mincol 20 :padchar #\. (car obj) (con obj))))))))
;; under evl fmt inherits the dynamic context from outside, unless otherwise specified.
;; ;; fmt-context is consisted of 1) surruonding control-strings, 2) stream
;; ;; define bind-fmt-flag
;; ;; ;; It's good to take keyword as format-op name
;; problem: (:<op> ...) and (fmt-<op> ...) don't mix well.
;; I can in princple do everything with formatter and the pretty print macros
;;; Copyright (c) 2006 Howard Yeh
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;;
;; - Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;;
;; - Redistributions in binary form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in the
;; documentation and/or other materials provided with the distribution.
;;
;; - Neither the name of Howard Yeh, nor the names of its
;; contributors may be used to endorse or promote products derived
;; from this software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(defpackage :wisp.schema
(:use :cl :clsql-sys :clsql
:wisp.util))
......@@ -56,7 +86,7 @@
;; );
(def-schemas *example*
;; (def-schemas *example*
((products (product-no integer :primary :autoinc)
((name "ACME generic") (string 77) :unique)
(price numeric (> price 0)))
......@@ -80,9 +110,9 @@
;; (: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))))
;; (time time))));;
(def-schema *foo*
;; (def-schema *foo*
((member ((first-name "Joe") (string 32))
((last-name "Schmoe") (string 32))
((age 35) integer
......@@ -103,13 +133,16 @@
;; (b (string 40))
;; (:many foo))
;; (baz (:one foo)
;; (:one bar))))
;; (: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
(defclass schema ()
((name :initarg :name)
(tables :initarg :tables :initform nil)))
......@@ -154,6 +187,7 @@
;; Parse schema sexp into a schema object.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Schema parsing
(defun parse-schema (name data-schema)
(let ((*table-names* (mapcar #'car data-schema)))
(declare (special *table-names*))
......@@ -197,6 +231,7 @@
;;;;; Constraints
(defparameter special-constraint-keys '(:required :unique :primary :autoinc))
(defun special-constraint? (clause)
......@@ -237,6 +272,7 @@
;; Unparse a schema object back into sexp.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Schema parsetree back to sexp
(defgeneric unparse (obj))
(defmethod unparse ((schema schema))
......@@ -273,6 +309,7 @@
;;; Schema Loading
(defmacro load-schema (schema &key force)
"CAUTION!! 'force-create' is in the lexical scope."
`(let ((force-create ,force))
......@@ -285,6 +322,7 @@
(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))
......@@ -292,6 +330,7 @@
,@insts))
(defmethod gen-insts ((table table))
(with-slots (name fields) table
(let* ((relation-fields (filter #'(lambda (field) (when (typep field 'relation-field) field))
......
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