[Common Lisp][UCW] 簡単な TODO リストアプリケーションを作ってみる

UCW で簡単なアプリケーションを作成してみます。
TODO の一覧表示、新規作成と完了ができるアプリケーションです。
あまり継続を活用できいない気がしますが、そのあたりは最初のアプリということで… UCW のサンプルに Wiki アプリがあったので、今度それを見て勉強してみましょう。

まずはいつもどおりの UCW の start.lisp のロードからエントリポイントの作成です。

続いて todo クラスを定義します。
作成した todo を *todo* に保管するために、initialize-instance :after で id の設定と *todo* への push を行っています。
こうしておけば普通に make-instance するだけで、todo のインスタンスは *todo* に保管されるようになります。もっとも、今回は永続化は行っていませんので Lisp を再起動すれば消えてしまいますが。

ビューでは body スロットも持った top-window を定義し、各機能毎に body スロットにリスト表示コンポーネント、新規作成コンポーネントが設定されるようにします。top-window がテンプレート的な役割を果します。初期状態は :component todo-list-view により一覧が表示されます。

ということで、ソースは次のようになりました。

;; ucw がロードされていなければロードする。
(eval-when (:load-toplevel :compile-toplevel :execute)
  (unless (find-package :ucw)
    ;; UCW の start.lisp をロードする。パスは環境にあわせて修正してください。
    (load "/Users/ancient/letter/lisp/ucw/ucw-boxset/start.lisp")))

(in-package :it.bese.ucw-user)

(defvar *todo-list-application*
  (make-instance 'cookie-session-application
                 :url-prefix "/todo/"   ; / で終ること
                 :charset :utf-8        ; 文字コードを UTF-8 に設定
                 :debug-on-error t)     ; エラー時にはデバッガを起動
  "アプリケーションの作成。")

;; アプリケーションをサーバに登録する。
(register-application *default-server* *todo-list-application*)

;; エントリポイントの作成。http://localhost:8080/todo/index.ucw
(defentry-point "index.ucw" (:application *todo-list-application*)
    ()
  (call 'top-window))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; モデル
(defvar *todo* nil "TODO を保管するリスト")

(defvar *todo-id-counter* 0 "TODO の id カウンタ")

(defclass todo ()
  ((id :accessor id)
   (content :initarg :content :accessor content)
   (done :initform nil :accessor done))
  (:documentation "TODO クラス"))

(defmethod initialize-instance :after ((todo todo) &rest initargs)
  "id を設定して *todo* に保存する。"
  (declare (ignore initargs))
  (setf (id todo) (incf *todo-id-counter*))
  (push todo *todo*))

(defmethod print-object ((todo todo) stream)
  "debug のために"
  (print-unreadable-object (todo stream :type t :identity t)
    (format stream "~a: ~a" (id todo) (content todo))))

(defun find-todo (id)
  "id をもとに TODO を取得します。"
  (find id *todo* :key #'id))

(defun delete-todo (id)
  "id をもとに TODO を削除します。"
  (setf *todo* (delete id *todo* :key #'id)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ビュー
(defcomponent top-window (simple-window-component)
  ((body :initarg :body
                  :accessor body
                  :component todo-list-view))
  (:default-initargs :title "TODO リスト")
  (:documentation "トップウィンドウ。
body に一覧や編集のコンポーネントをセットして画面表示を行う。"))

(defmethod render ((top top-window))
  (<:h1 "TODO リスト")
  ;; body の表示
  (render (body top)))

(defcomponent todo-list-view ()
  ()
  (:documentation "TODO の一覧コンポーネント"))

(defmethod render ((self todo-list-view))
  "TODO の一覧を表示する。"
  (<ucw:a :action (call 'todo-create-view) "新規作成")
  (<:table
   :border 1
   (<:tr (<:th "完了") (<:th "TODO") (<:th "削除"))
   (loop for each in *todo*
      do (let* ((todo each)
                (id (id todo)))
           (<:tr
            (<:td (<:as-html
                   (if (done todo)
                       "済"
                       (<ucw:a
                        :action (done-todo-action self todo)
                        "完了する"))))
            (<:td (<:as-html (content todo)))
            (<:td (<ucw:a :action (delete-todo-action self id)
                          "削除する")))))))

(defaction done-todo-action ((self todo-list-view) todo)
  "TODO を完了する。"
  (setf (done todo) t))

(defaction delete-todo-action ((self todo-list-view) id)
  "TODO を1件削除する。"
  (delete-todo id))
  
(defcomponent todo-create-view ()
  ((content
    :accessor content
    :initform (make-instance 'string-field)))
  (:documentation "TODO を新規作成するためのコンポーネント"))

(defmethod render ((self todo-create-view))
  "TODO 新規作成画面"
  (<ucw:form
   :action (create-todo self)
   "TODO" (render (content self))
   (<:submit :value "新規作成"))
  (<ucw:a :action (ok self) "キャンセル"))

(defaction create-todo ((self todo-create-view))
  "画面からの入力により TODO を新規作成する。"
  (make-instance 'todo :content (value (content self)))
  (ok self))