343 lines
13 KiB
Common Lisp
343 lines
13 KiB
Common Lisp
(in-package :myoji-accent/entry)
|
|
|
|
(defapp entry
|
|
:prefix "/entry"
|
|
:name "苗字アクセントを入力")
|
|
|
|
(defparameter *entries-per-page* 2
|
|
"The number of entries to be shown per page.")
|
|
|
|
(defwidget myoji-list-entry ()
|
|
((parent :initarg :parent
|
|
:accessor myoji-list-entry-parent
|
|
:documentation "The parent list of this entry.")
|
|
(id :initarg :id
|
|
:type (integer 1)
|
|
:accessor myoji-list-entry-id
|
|
:documentation "The ID of the myoji object for this entry.")
|
|
(myoji :initarg :myoji
|
|
:type myoji
|
|
:accessor myoji-list-entry-myoji
|
|
:documentation "The myoji object for this entry.")
|
|
(edit-mode :initform nil
|
|
:type boolean
|
|
:accessor myoji-list-entry-edit-mode-p
|
|
:documentation "Weather we are in edit mode or not.")
|
|
(err-msg :initform nil
|
|
:type (or null string)
|
|
:accessor myoji-list-entry-error
|
|
:documentation "An error message to show to the user.")))
|
|
|
|
(define-condition accent-error (error)
|
|
((message :initarg :message
|
|
:accessor accent-error-message
|
|
:type string
|
|
:documentation "A description of what went wrong."))
|
|
(:report
|
|
(lambda (err stream)
|
|
(format stream "~a" (accent-error-message err)))))
|
|
|
|
(defmethod update-db-entry ((widget myoji-list-entry) new-kanji new-reading
|
|
new-accent)
|
|
"Update the entry WIDGET with some new values provided by the user."
|
|
(handler-case
|
|
(progn
|
|
(setf (slot-value widget 'edit-mode) nil)
|
|
(let ((obj))
|
|
(handler-case
|
|
(let ((accent-point (parse-integer new-accent)))
|
|
(when (> accent-point (count-word-mora new-reading))
|
|
(signal
|
|
'accent-error
|
|
:message
|
|
(format nil "Accent point too bit for word: ~a" new-accent)))
|
|
(setq obj (make-myoji new-reading new-kanji
|
|
:accent-point accent-point)))
|
|
(parse-error ()
|
|
(if (valid-accent-string-p new-accent)
|
|
(setq obj (make-myoji new-reading new-kanji
|
|
:accent-string new-accent))
|
|
(signal
|
|
'accent-error
|
|
:message
|
|
(format nil "Not a valid accent string or number: ~a" new-accent)))))
|
|
(mito:insert-dao obj)
|
|
(mito:delete-dao (myoji-list-entry-myoji widget))))
|
|
(accent-error (e)
|
|
(setf (slot-value widget 'err-msg) (format nil "~a" e)))
|
|
(error ()
|
|
(setf (slot-value widget 'err-msg) "An internal error occured.")))
|
|
(reblocks/widget:update widget))
|
|
|
|
(defmethod reblocks/widget:render ((widget myoji-list-entry))
|
|
(with-slots (myoji edit-mode err-msg) widget
|
|
(with-html
|
|
(if (or edit-mode err-msg)
|
|
(with-html-form (:POST #'(lambda (&key kanji reading accent
|
|
&allow-other-keys)
|
|
(update-db-entry widget kanji reading accent)))
|
|
(:tr
|
|
(:td (:input :type "text"
|
|
:name "kanji"
|
|
:value (myoji-kanji myoji)))
|
|
(:td (:input :type "text"
|
|
:name "reading"
|
|
:value (myoji-reading myoji)))
|
|
(:td :class "accented"
|
|
(:raw (myoji-accent-html myoji)))
|
|
(:td (:input :type "text"
|
|
:name "accent"
|
|
:value (myoji-accent-point myoji)))
|
|
(:td (myoji-accent-name myoji))
|
|
(:td (:input :type "submit"
|
|
:value "編集")
|
|
(:button "削除")
|
|
(when err-msg
|
|
(:br)
|
|
(:p :class "insert-error"
|
|
err-msg)))))
|
|
(:tr
|
|
(:td (myoji-kanji myoji))
|
|
(:td (myoji-reading myoji))
|
|
(:td :class "accented"
|
|
(:raw (myoji-accent-html myoji)))
|
|
(:td (myoji-accent-point myoji))
|
|
(:td (myoji-accent-name myoji))
|
|
(:td
|
|
(:button :onclick
|
|
(when (boundp 'reblocks/page::*current-page*)
|
|
(reblocks/actions:make-js-action
|
|
(lambda (&key &allow-other-keys)
|
|
(setf (slot-value widget 'edit-mode) t)
|
|
(reblocks/widget:update (myoji-list-entry-parent widget)))))
|
|
"編集")
|
|
(:button :onclick
|
|
(when (boundp 'reblocks/page::*current-page*)
|
|
(reblocks/actions:make-js-action
|
|
(lambda (&key &allow-other-keys)
|
|
())))
|
|
"削除")))))))
|
|
|
|
(defwidget myoji-list ()
|
|
((page-num :initform 0
|
|
:type '(integer 0)
|
|
:accessor entry-page-page-num
|
|
:documentation "The index of the displayed page.")
|
|
(last-low-id :initform 0
|
|
:type '(integer 0)
|
|
:accessor entry-page-last-low-id
|
|
:documentation "The lowest ID from the last SQL query.")
|
|
(last-high-id :initform 0
|
|
:type '(integer 0)
|
|
:accessor entry-page-last-high-id
|
|
:documentation "The highest ID from the last SQL query.")
|
|
(page-entries :initform nil
|
|
:type 'list
|
|
:accessor entry-page-page-entries
|
|
:documentation "The myoji entries for the current page.")))
|
|
|
|
(defmethod initialize-instance :after
|
|
((widget myoji-list) &key &allow-other-keys)
|
|
;; get the first page
|
|
(next-page widget))
|
|
|
|
(defmethod reblocks/dependencies:get-dependencies ((widget myoji-list))
|
|
(append
|
|
(list
|
|
(reblocks-lass:make-dependency
|
|
`(.myoji-list
|
|
:margin-left auto
|
|
:margin-right auto
|
|
:width "90%"
|
|
:border "1px" "black" solid
|
|
(table
|
|
:width "100%"
|
|
:height "100%"
|
|
:font-size larger
|
|
:border-collapse collapse
|
|
:border "1px" "black" solid
|
|
((:or th td)
|
|
:border "1px" "black" solid)
|
|
((:or th td)
|
|
:padding "5px"))
|
|
(|#selector-wrapper|
|
|
:width "100%"
|
|
:display flex
|
|
:justify-content center
|
|
(span
|
|
:margin-left "5px"
|
|
:margin-right "5px")))))
|
|
(call-next-method)))
|
|
|
|
(defmethod has-next-page-p ((widget myoji-list))
|
|
"Return non-nil if WIDGET can be paged forward."
|
|
(with-slots (page-num page-entries last-high-id) widget
|
|
(or (zerop page-num)
|
|
(and (= (length page-entries) *entries-per-page*)
|
|
(mito:retrieve-by-sql
|
|
(sxql:select (:myoji.*)
|
|
(sxql:from :myoji)
|
|
(sxql:where (:> :id last-high-id))))))))
|
|
|
|
(defmethod has-previous-page-p ((widget myoji-list))
|
|
"Return non-nil if WIDGET can be paged back."
|
|
(> (slot-value widget 'page-num) 1))
|
|
|
|
(defmethod reblocks/widget:render ((widget myoji-list))
|
|
(with-slots (page-num page-entries) widget
|
|
(with-html
|
|
(:table
|
|
(:tr (dolist (header '("漢字" "読み方" "アクセント" "アクセントポイント"
|
|
"タイプ" ""))
|
|
(:th header)))
|
|
(dolist (entry page-entries)
|
|
(reblocks/widget:render entry)))
|
|
(:div :id "selector-wrapper"
|
|
(when (boundp 'reblocks/page::*current-page*)
|
|
(if (has-previous-page-p widget)
|
|
(:button :onclick (reblocks/actions:make-js-action
|
|
(lambda (&key &allow-other-keys)
|
|
(next-page widget :previous t)))
|
|
"<")
|
|
(:button :disabled "disabled"
|
|
"<"))
|
|
(:span (format nil "~a" page-num))
|
|
(if (has-next-page-p widget)
|
|
(:button :onclick (reblocks/actions:make-js-action
|
|
(lambda (&key &allow-other-keys)
|
|
(next-page widget)))
|
|
">")
|
|
(:button :disabled "disabled"
|
|
">")))))))
|
|
|
|
(defmethod update-page-from-query-results ((widget myoji-list) results)
|
|
"Update the content of the current page of WIDGET with the RESULTS, which are
|
|
SQL query results."
|
|
(with-slots (page-num last-low-id last-high-id page-entries) widget
|
|
(loop for entry in results
|
|
for id = (getf entry :id)
|
|
maximize id into new-high
|
|
minimize id into new-low
|
|
collect
|
|
(make-instance 'myoji-list-entry
|
|
:parent widget
|
|
:id id
|
|
:myoji (apply #'mito:make-dao-instance
|
|
'myoji-accent/accent:myoji
|
|
entry))
|
|
into entry-objects
|
|
finally
|
|
(setf last-low-id new-low
|
|
last-high-id new-high
|
|
page-entries entry-objects))))
|
|
|
|
(defmethod reload-page ((widget myoji-list))
|
|
"Reload the current page for WIDGET."
|
|
(with-slots (last-low-id last-high-id) widget
|
|
(update-page-from-query-results
|
|
widget
|
|
(mito:retrieve-by-sql
|
|
(sxql:select (:myoji.*)
|
|
(sxql:from :myoji)
|
|
(sxql:where (:>= :id last-low-id))
|
|
(sxql:order-by (:asc :id))
|
|
(sxql:limit *entries-per-page*))))
|
|
(reblocks/widget:update widget)))
|
|
|
|
(defmethod next-page ((widget myoji-list) &key previous)
|
|
"Display the next page for WIDGET."
|
|
(if (or (and (has-next-page-p widget) (not previous))
|
|
(and (has-previous-page-p widget) previous))
|
|
(with-slots (page-num last-low-id last-high-id) widget
|
|
(update-page-from-query-results
|
|
widget
|
|
(mito:retrieve-by-sql
|
|
(sxql:select (:myoji.*)
|
|
(sxql:from :myoji)
|
|
(if previous
|
|
(sxql:where (:< :id last-low-id))
|
|
(sxql:where (:> :id last-high-id)))
|
|
(if previous
|
|
(sxql:order-by (:desc :id))
|
|
(sxql:order-by (:asc :id)))
|
|
(sxql:limit *entries-per-page*))))
|
|
(setf page-num (if previous (1- page-num) (1+ page-num)))
|
|
(reblocks/widget:update widget))))
|
|
|
|
(defwidget entry-page ()
|
|
((list :initform (make-instance 'myoji-list)
|
|
:type 'myoji-list
|
|
:documentation "The list of already existing entries.")))
|
|
|
|
(defmethod reblocks/dependencies:get-dependencies ((widget entry-page))
|
|
(append
|
|
(list
|
|
(reblocks-lass:make-dependency
|
|
`(.entry-page
|
|
:width "100%"
|
|
(|#add-form|
|
|
:margin-top "20px"
|
|
:display "flex"
|
|
:justify-content center
|
|
((:or (:and span (:not :first-of-type)) |#submit-button|)
|
|
:margin-left "10px")
|
|
(span
|
|
:margin-right "5px"))
|
|
(.accented
|
|
(span.tone-h
|
|
:border-top "1px" solid ,*pitch-color*)
|
|
(span.tone-l
|
|
:border-bottom "1px" solid ,*pitch-color*)
|
|
(span.tone-h-change
|
|
:border solid ,*pitch-color*
|
|
:border-width "1px" "1px" "0px" "0px")
|
|
(span.tone-l-change
|
|
:border solid ,*pitch-color*
|
|
:border-width "0px" "1px" "1px" "0px")
|
|
(span.tone-end-change
|
|
:border-right "1px")))))
|
|
(call-next-method)))
|
|
|
|
(defun string-integer-p (str)
|
|
"Return non-nil if STR is all digits."
|
|
(every #'digit-char-p str))
|
|
|
|
(defmethod handle-add-myoji ((widget entry-page) reading kanji accent)
|
|
"Add a new myoji to the database."
|
|
(let ((mora (count-word-mora reading)))
|
|
(cond
|
|
((string-integer-p accent)
|
|
(mito:insert-dao (make-myoji reading kanji
|
|
:accent-point (parse-integer accent))))
|
|
((valid-accent-string-p accent mora)
|
|
(mito:insert-dao (make-myoji reading kanji
|
|
:accent-string accent)))
|
|
(t ;; TODO error
|
|
))
|
|
(reblocks/widget:update widget)))
|
|
|
|
(defmethod reblocks/widget:render ((widget entry-page))
|
|
(with-html
|
|
(reblocks/widget:render (slot-value widget 'list))
|
|
(with-html-form (:POST #'(lambda (&key reading kanji accent
|
|
&allow-other-keys)
|
|
(handle-add-myoji widget reading kanji accent))
|
|
:id "add-form")
|
|
(:span "読み方：")
|
|
(:input :type "text"
|
|
:name "reading")
|
|
(:span "漢字：")
|
|
(:input :type "text"
|
|
:name "kanji")
|
|
(:span "アクセント：")
|
|
(:input :type "text"
|
|
:name "accent")
|
|
(:input :id "submit-button"
|
|
:type "submit"
|
|
:value "追加"))))
|
|
|
|
(defmethod reblocks/page:init-page ((app entry) (url-path string) expire-at)
|
|
(declare (ignorable url-path expire-at))
|
|
(setf (reblocks/page:get-title) "苗字アクセントを入力")
|
|
(make-instance 'entry-page))
|