Skip to content

Commit

Permalink
Comment code temporarily to archive a clean compilation.
Browse files Browse the repository at this point in the history
  • Loading branch information
@davazp
davazp committed Feb 8, 2010
1 parent 8fb7fc5 commit ecb15f0
Show file tree
Hide file tree
Showing 3 changed files with 169 additions and 170 deletions.
3 changes: 1 addition & 2 deletions cl-icalendar.asd
View file
Expand Up @@ -30,7 +30,6 @@
(:file "package")
(:file "utils")
(:file "datetime")
(:file "cl-icalendar")
(:file "components")))
(:file "cl-icalendar")))

;; cl-icalendar.asd ends here
332 changes: 166 additions & 166 deletions cl-icalendar.lisp
View file
Expand Up @@ -223,176 +223,176 @@
:params (read-params stream)
:value (read-line stream)))

(defun parse-date (string &optional (date (make-date)) &key (offset 0))
(flet ((~ (x) (+ offset x)))
(setf
(date-year date) (parse-integer string :start (~ 0) :end (~ 4))
(date-month date) (parse-integer string :start (~ 4) :end (~ 6))
(date-day date) (parse-integer (subseq string 6 8))))
date)

(defun parse-time (string &optional (date (make-date)) &key (offset 0))
(flet ((~ (x) (+ offset x)))
(setf
(date-hour date) (parse-integer string :start (~ 0) :end (~ 2))
(date-minute date) (parse-integer string :start (~ 2) :end (~ 4))
(date-second date) (parse-integer string :start (~ 4) :end (~ 8))))
date)
;; (defun parse-date (string &optional (date (make-date)) &key (offset 0))
;; (flet ((~ (x) (+ offset x)))
;; (setf
;; (date-year date) (parse-integer string :start (~ 0) :end (~ 4))
;; (date-month date) (parse-integer string :start (~ 4) :end (~ 6))
;; (date-day date) (parse-integer (subseq string 6 8))))
;; date)

;; (defun parse-time (string &optional (date (make-date)) &key (offset 0))
;; (flet ((~ (x) (+ offset x)))
;; (setf
;; (date-hour date) (parse-integer string :start (~ 0) :end (~ 2))
;; (date-minute date) (parse-integer string :start (~ 2) :end (~ 4))
;; (date-second date) (parse-integer string :start (~ 4) :end (~ 8))))
;; date)

;;; Generación del árbol sintáctico

(defstruct icalendar-block
name
items)

(defun read-item (stream)
"Read a content line, if it is a block (BEGIN:...) read and return
the full block, else only that content line"
(let ((first-line (read-content-line stream)))
(if (string= (content-line-name first-line) "BEGIN")
(make-icalendar-block
:name (content-line-value first-line)
:items (loop for item = (read-item stream)
until (and (content-line-p item)
(string= (content-line-name item) "END"))
collect item))
first-line)))

(defun search-content-line (tree name)
"return the first content line with a given name in a sintactic
tree"
(loop for i in (icalendar-block-items tree)
if (string= (content-line-name i) name)
do (return i)))

(defun search-content-lines (tree name)
"return all content lines with a given name"
(with-collecting
(dolist (i (icalendar-block-items tree))
(if (string= (content-line-name i) name)
(collect i)))))

(defun search-content-line-value (tree name)
"return the value of the first content line with a given name in a
sintactic tree"
(aif (search-content-line tree name)
(content-line-value it)))

;; Composition of the sintactic tree in components

(defclass component ()
((props-required)
(props-optional-muti)
(props-optional-once)
(properties :initform (make-hash-table :test #'equal :size 16))
(branches :initform nil)))

(defmethod prop-category ((self component) prop)
(declare (type string prop))
(flet ((test (str sym)
(string= (symbol-name sym) str)))
(cond
((find prop (slot-value self 'props-required) :test #'test) 'required)
((find prop (slot-value self 'props-optional-multi) :test #'test) 'optional-multi)
((find prop (slot-value self 'props-optional-once) :test #'test) 'optional-once))))

(defmethod getproperty ((self component) propname)
(gethash propname (slot-value self 'propierties)))

(defmethod parse-content-line ((self component) i)
(let* ((name (content-line-name i))
(value (content-line-value i))
(category (prop-category self name)))
(case category
((required optional-once)
(if (gethash name (slot-value self 'properties))
(error "Property ~a, type ~a appears twice" name category)
(push value (gethash name (slot-value self 'properties)))))
((optional-multi)
(push value (gethash name (slot-value self 'properties))))
(t
(parse-strange-content-line self i)))))

(defmethod parse-strange-content-line ((self component) prop)
"Method meant to be overwritted if there is some special
property expected that &required, &optional-multi or &optional-once
don't cover."
(error "Strange propertiy: ~a" prop))

(defmethod build ((self component) tree &key (recursive-parsing t))
(dolist (i (icalendar-block-items tree))
(case (type-of i)
(content-line
(parse-content-line self i))
(icalendar-block
(when recursive-parsing
(push (build-component i) (slot-value self 'branches))))
(error "Tree item is not a valid type: ~a" (type-of i)))))

(defmacro defcomponent (component props-list &key extra-superclasses)
(labels ((modifier-p (x)
(char= (elt (symbol-name x) 0) #\&))
(select (modifier)
(strip (cdr (member modifier props-list))
#'modifier-p)))
;; (defstruct icalendar-block
;; name
;; items)

;; (defun read-item (stream)
;; "Read a content line, if it is a block (BEGIN:...) read and return
;; the full block, else only that content line"
;; (let ((first-line (read-content-line stream)))
;; (if (string= (content-line-name first-line) "BEGIN")
;; (make-icalendar-block
;; :name (content-line-value first-line)
;; :items (loop for item = (read-item stream)
;; until (and (content-line-p item)
;; (string= (content-line-name item) "END"))
;; collect item))
;; first-line)))

;; (defun search-content-line (tree name)
;; "return the first content line with a given name in a sintactic
;; tree"
;; (loop for i in (icalendar-block-items tree)
;; if (string= (content-line-name i) name)
;; do (return i)))

;; (defun search-content-lines (tree name)
;; "return all content lines with a given name"
;; (with-collecting
;; (dolist (i (icalendar-block-items tree))
;; (if (string= (content-line-name i) name)
;; (collect i)))))

;; (defun search-content-line-value (tree name)
;; "return the value of the first content line with a given name in a
;; sintactic tree"
;; (aif (search-content-line tree name)
;; (content-line-value it)))

;; ;; Composition of the sintactic tree in components

;; (defclass component ()
;; ((props-required)
;; (props-optional-muti)
;; (props-optional-once)
;; (properties :initform (make-hash-table :test #'equal :size 16))
;; (branches :initform nil)))

;; (defmethod prop-category ((self component) prop)
;; (declare (type string prop))
;; (flet ((test (str sym)
;; (string= (symbol-name sym) str)))
;; (cond
;; ((find prop (slot-value self 'props-required) :test #'test) 'required)
;; ((find prop (slot-value self 'props-optional-multi) :test #'test) 'optional-multi)
;; ((find prop (slot-value self 'props-optional-once) :test #'test) 'optional-once))))

;; (defmethod getproperty ((self component) propname)
;; (gethash propname (slot-value self 'propierties)))

;; (defmethod parse-content-line ((self component) i)
;; (let* ((name (content-line-name i))
;; (value (content-line-value i))
;; (category (prop-category self name)))
;; (case category
;; ((required optional-once)
;; (if (gethash name (slot-value self 'properties))
;; (error "Property ~a, type ~a appears twice" name category)
;; (push value (gethash name (slot-value self 'properties)))))
;; ((optional-multi)
;; (push value (gethash name (slot-value self 'properties))))
;; (t
;; (parse-strange-content-line self i)))))

;; (defmethod parse-strange-content-line ((self component) prop)
;; "Method meant to be overwritted if there is some special
;; property expected that &required, &optional-multi or &optional-once
;; don't cover."
;; (error "Strange propertiy: ~a" prop))

;; (defmethod build ((self component) tree &key (recursive-parsing t))
;; (dolist (i (icalendar-block-items tree))
;; (case (type-of i)
;; (content-line
;; (parse-content-line self i))
;; (icalendar-block
;; (when recursive-parsing
;; (push (build-component i) (slot-value self 'branches))))
;; (error "Tree item is not a valid type: ~a" (type-of i)))))

;; (defmacro defcomponent (component props-list &key extra-superclasses)
;; (labels ((modifier-p (x)
;; (char= (elt (symbol-name x) 0) #\&))
;; (select (modifier)
;; (strip (cdr (member modifier props-list))
;; #'modifier-p)))

(Let* ((required (select '&required))
;; may appear any times, including 0
(optional-multi (select '&optional-multi))
;; may appear at most one time
(optional-once (select '&optional-once))
(props (append required optional-multi optional-once)))

`(defclass ,component ((cons component extra-superclasses))
((props-required :initform ',required)
(props-optional-multi :initform ',optional-multi)
(props-optional-once :initform ',optional-once))) )))

(defun build-component (tree)
(declare (type icalendar-block tree))
(let* ((component-name (icalendar-block-name tree))
(component (make-instance (intern component-name))))
(build component tree)
component))

(defclass time-bound-component (component)
())

(defmethod begin-date ((self time-bound-component))
(gethash (slot-value self 'properties)))

(defmethod end-date ((self time-bound-component))
"Returns the end date of a time bound if DTEND is defined, or
estimate it from DURATION (Leap seconds not considred)"
(or (getproperty self "dtend")
(date+ (getproperty self "dtstart")
(getproperty self "duration"))))

;;; Iterators TODO

(defmacro do-vcal-body ((vcal
&key
type
begin-after
begin-before
end-after
end-before
&body
body))
`(dolist (item (slot-value vcal 'branches))
(when ,(cons 'and
(with-collecting
(if type
(collect `(eq (type-of) item ,type)))
(if begin-after
(collect `(date>= ,begin-after (begin-date item))))
(if begin-before
(collect `(date< ,begin-before (begin-date item))))
(if end-after
(collect `(date>= ,end-after (end-date item))))
(if end-before
(collect `(date< ,end-before (end-date item))))))
body)))
;; (Let* ((required (select '&required))
;; ;; may appear any times, including 0
;; (optional-multi (select '&optional-multi))
;; ;; may appear at most one time
;; (optional-once (select '&optional-once))
;; (props (append required optional-multi optional-once)))

;; `(defclass ,component ((cons component extra-superclasses))
;; ((props-required :initform ',required)
;; (props-optional-multi :initform ',optional-multi)
;; (props-optional-once :initform ',optional-once))) )))

;; (defun build-component (tree)
;; (declare (type icalendar-block tree))
;; (let* ((component-name (icalendar-block-name tree))
;; (component (make-instance (intern component-name))))
;; (build component tree)
;; component))

;; (defclass time-bound-component (component)
;; ())

;; (defmethod begin-date ((self time-bound-component))
;; (gethash (slot-value self 'properties)))

;; (defmethod end-date ((self time-bound-component))
;; "Returns the end date of a time bound if DTEND is defined, or
;; estimate it from DURATION (Leap seconds not considred)"
;; (or (getproperty self "dtend")
;; (date+ (getproperty self "dtstart")
;; (getproperty self "duration"))))

;; ;;; Iterators TODO

;; (defmacro do-vcal-body ((vcal
;; &key
;; type
;; begin-after
;; begin-before
;; end-after
;; end-before
;; &body
;; body))
;; `(dolist (item (slot-value vcal 'branches))
;; (when ,(cons 'and
;; (with-collecting
;; (if type
;; (collect `(eq (type-of) item ,type)))
;; (if begin-after
;; (collect `(date>= ,begin-after (begin-date item))))
;; (if begin-before
;; (collect `(date< ,begin-before (begin-date item))))
;; (if end-after
;; (collect `(date>= ,end-after (end-date item))))
;; (if end-before
;; (collect `(date< ,end-before (end-date item))))))
;; body)))



Expand Down
4 changes: 2 additions & 2 deletions utils.lisp
View file
Expand Up @@ -64,8 +64,8 @@
((null (cdr ,i)) t)
(let ((,arg1 (first ,i))
(,arg2 (second ,i)))
(unless (block nil ,@body)
(return nil)))))))
(or (block nil ,@body)
(return nil)))))))

(defun strip-if (func seq &rest rest &key &allow-other-keys)
(subseq seq 0 (apply #'position-if func seq rest)))
Expand Down

0 comments on commit ecb15f0

Please sign in to comment.