Shiro(2007/04/22 20:10:07 PDT): Inspired by an entry of Lisp movies ( http://homepage.mac.com/svc/LispMovies/index.html ) episode 2: (Re)writing Reddit in Lisp is 20 minutes and 100 lines, I tried the same thing in Scheme.

Here I use Kahua, a continuation-based web app framework built on top of a Scheme implementation Gauche.

This is minimal - no style, no input validation, no user registration, no comments. It does have a persistent storage. The class <entry> uses Kahua's persistent object feature. (Inheriting from <kahua-persistent-base> and adding :allocation :persistent makes objects persistent automagically.)

I got an impression that the point comes down to frameworks, not languages, after all.

;; -*- coding: utf-8 ; mode: scheme-*-
(use gauche.collection)

(define-class <entry> (<kahua-persistent-base>)
  ((url   :init-keyword :url   :allocation :persistent)
   (title :init-keyword :title :allocation :persistent)
   (score :init-value 1        :allocation :persistent)))

(define (main-page)

  (define (show-urls)
     (map (lambda (e)
             (td: (a: (@: (href (ref e 'url))) (ref e 'title))
                  (format "(~a points)" (ref e 'score))
                  (a/cont: (@@: (cont (lambda () (inc! (ref e 'score)) (show))))
                  (a/cont: (@@: (cont (lambda () (dec! (ref e 'score)) (show))))
          (sort (coerce-to <list> (make-kahua-collection <entry>))
                (lambda (a b) (> (ref a 'score) (ref b 'score)))))))

  (define commit-url
    (entry-lambda (:keyword url title)
      (make <entry> :url url :title title)

  (define submit-form
    (entry-lambda ()
        (head: (title: "Reddit-modoki"))
        (body: (h1: "Submit URL")
                (@@: (cont commit-url '(url) '(title)))
                 (tr: (th: "URL")
                      (td: (input: (@: (type "text") (name "url") (value "")))))
                 (tr: (th: "Title")
                      (td: (input: (@: (type "text") (name "title") (value "")))))
                 (tr: (th:)
                      (td: (input: (@: (type "submit") (name "submit") (value "submit"))))))

  (define (show)
      (head: (title: "Reddit-modoki"))
       (h1: "Reddit-modoki")
       (div: (@: (style "text-align: right"))
             (a/cont: (@@: (cont submit-form)) "[Submit URL]"))
       (table: (show-urls))))))


(initialize-main-proc main-page)

(2007/05/23 16:40:20 PDT): I rewrote shiro's code in new fashion ;-)

;; -*- coding: utf-8; mode: kahua -*-

(use gauche.collection)

(define page-template
   (kahua-template-path "bookmarks/page.xml")))

(define-class <bookmark-entry> (<kahua-persistent-base>)
  ((url :init-keyword :url :allocation :persistent :index :unique)
   (title :init-keyword :title :allocation :persistent :index :any)
   (score :init-value 1 :allocation :persistent)
   (count :init-value 0 :allocation :persistent)))

(define-entry (index)
  (define (bookmark-list/)
     (tr/ (th/ (a/cont/ (@@/ (cont new)) "[new]")) (th/ "count") (th/ "score"))
     (map/ (lambda (bm)
             (tr/ (th/ (a/cont/ (@@/ (cont (cut go/countup bm))) (ref bm 'title)))
                  (td/ (@/ (class "numeric")) (ref bm 'count))
                  (td/ (@/ (class "numeric")) (ref bm 'score))
                  (td/ (a/cont/ "[up]"
                                (@@/ (cont (lambda ()
                                             (inc! (ref bm 'score))
                                             (redirect/cont (cont index))))))
                       (a/cont/ "[down]"
                                (@@/ (cont (lambda ()
                                             (dec! (ref bm 'score))
                                             (redirect/cont (cont index)))))))))
           (sort! (coerce-to <list> (make-kahua-collection <bookmark-entry>))
                  (lambda (a b) (> (ref a 'score) (ref b 'score)))))))
   :title (title/ "Reddit modoki revised")
   :body (bookmark-list/)))

(define (go/countup bm)
  (inc! (ref bm 'count))
   (extra-header/ (@/ (name "Status") (value "302 Found")))
   (extra-header/ (@/ (name "Location") (value (ref bm 'url))))))

(define-entry (new)
  (define (submit-url-form/)
    (form/cont/ (@@/ (cont (entry-lambda (:keyword url title)
                             (make <bookmark-entry> :title title :url url)
                             (redirect/cont (cont index)))))
                 (tr/ (th/ "Title: ") (td/ (input/ (@/ (name "url")))))
                 (tr/ (th/ "URL: ")   (td/ (input/ (@/ (name "title")))))
                 (tr/ (th/) (td/ (input/ (@/ (type "submit") (value "Submit"))))))))
   :title (title/ "Submit URL")
   :body (submit-url-form/)))
(initialize-main-proc index)

Last modified : 2007/05/23 23:40:20 UTC