メッセージ。 - Momokaのソースコード、お見せするの恥ずかしいですけど

昨日、hirofummyさんが興味を示してくださったので、現状のMomokaのソースコードを公開します。http://nnri.dip.jp/~yf/source/Momoka-0.36.tar.gz、http://nnri.dip.jp/~yf/source/Momoka-0.35.tar.gz（えーと。まともそうなほうを持ってってくださいm(_ _)m）

一応動くコードなんですが、データがない状態ではテストしてないので、たぶんまだインストールしてもうまく動かないです。コード眺め用ということで、お願いします。あと、main関数に近いところを中心に、コードが汚ないのもご容赦を。動きがありそうなところは、あとでリファクタリングするつもりでした。

パーサ部分はこんな感じです。けっこう手抜きです。

(define-module momoka.kcdp3
  (use srfi-13)  ;; string-prefix?
  (use text.html-lite)
  (export text->kcdp kcdp->html kcdp->text kcdp->t))

(select-module momoka.kcdp3)

(define (with-lines lines proc)
  (string-join (map proc lines) ""))

(define (div istring divider)
  (map (lambda (e) (string-trim-both e)) (string-split istring divider)))

(define (getlines lines pattern)
  (let1 plen (string-length pattern)
    (let loop ((lines lines) (out '()))
      (if (null? lines)
          (values (reverse out) lines)
          (if (string-prefix? pattern (car lines))
              (loop (cdr lines) (cons (string-drop (car lines) plen) out))
              (values (reverse out) lines))))))

(define (text->kcdp istring)
  (let loop ((lines (string-split istring "\n"))
             (out   '()))
    (if (null? lines)
        (reverse out)
        (let1 line1 (car lines)
          (cond ((string-prefix? "*" line1)
                 (loop (cdr lines)
                       (cons (cons 'caption (string-drop line1 1)) out)))
                ((string-prefix? "-" line1)
                 (receive (lis remain) (getlines lines "-")
                   (loop remain
                         (cons (cons 'list lis) out))))
                ((string-prefix? ">" line1)
                 (receive (lis remain) (getlines lines ">")
                   (loop remain
                         (cons (cons 'quote lis) out))))
                ((string-prefix? "|" line1)
                 (receive (lis remain) (getlines lines "|")
                   (loop remain
                         (cons (cons 'table
                                     (cons "|"
                                           (map (lambda (e) (div e "|")) lis)))
                               out))))
                ((string-prefix? "," line1)
                 (receive (lis remain) (getlines lines ",")
                   (loop remain
                         (cons (cons 'table
                                     (cons ","
                                           (map (lambda (e) (div e ",")) lis)))
                               out))))
                (else (loop (cdr lines) (cons (cons 'plain line1) out))))))))

;; (define ecapt (lambda (e) #`"*,|e|"))
;; (define equot (lambda (e) #`">,|e|"))
;; (define elist (lambda (e)
;;                  (with-lines e (lambda (f) #`",|f|\n"))))
;; (define eelse values)

(define (pp-table obj)
  (define (add-pad istring len)
    (string-append istring (make-string (- len (string-size istring)) #\ )))
  (let* ((div  (car obj))
         (body (cdr obj)))
    (let1 nums
        (let loop ((body body) (nums '()))
          (if (null? body)
              nums
              (loop (cdr body)
                    (let l2 ((record (car body)) (nums nums) (out '()))
                      (cond ((null? record)
                             (reverse (append (reverse nums) out)))
                            ((null? nums)
                             (l2 (cdr record)
                                 nums
                                 (cons (string-size (car record)) out)))
                            (else
                             (l2 (cdr record)
                                 (cdr nums)
                                 (cons (max (string-size (car record))
                                            (car nums))
                                       out))))))))
      (string-join
       (map (lambda (r)
              (string-append
               #`",|div| "
               (string-join
                (let loop ((b r) (nums nums) (out '()))
                  (if (null? b)
                      (reverse out)
                      (loop (cdr b)
                            (cdr nums)
                            (cons (add-pad (car b) (car nums)) out))))
                #`" ,|div| ")))
            body)
       "\n"))))

(define (kcdp->t kcdp . opts)
  (let-keywords* opts ((ecapt :capt  (lambda (e) #`"*,|e|"))
                       (equot :quote (lambda (e)
                                       (with-lines e
                                                   (lambda (f) #`">,|f|"))))
                       (elist :list  (lambda (e)
                                       (with-lines e
                                                   (lambda (f) #`"-,|f|\n"))))
                       (etabl :table (lambda (e) (pp-table e)))
                       (eelse  :else  values))
    (string-join
     (let loop ((kcdp kcdp) (out '()))
       (if (null? kcdp)
           (reverse out)
           (let1 kcdpe (car kcdp)
             (cond ((equal? (car kcdpe) 'caption)
                    (loop (cdr kcdp) (cons (ecapt (cdr kcdpe)) out)))
                   ((equal? (car kcdpe) 'list)
                    (loop (cdr kcdp) (cons (elist (cdr kcdpe)) out)))
                   ((equal? (car kcdpe) 'quote)
                    (loop (cdr kcdp) (cons (equot (cdr kcdpe)) out)))
                   ((equal? (car kcdpe) 'table)
                    (loop (cdr kcdp) (cons (etabl (cdr kcdpe)) out)))
                   (else (loop (cdr kcdp) (cons (eelse (cdr kcdpe)) out)))))))
     "\n")))

(define (kcdp->html kcdp linep)
  (kcdp->t kcdp
           :capt  (lambda (e)
                    (format #f "<h3><span class=\"title\">*~a</span></h3>"
                            (linep e)))
           :list  (lambda (e)
                    (format #f "<ul>~a</ul>"
                            (string-join
                             (map (lambda (f) #`"<li>,(linep f)</li>") e)
                             "\n")))
           :quote (lambda (e)
                    (format #f "<blockquote class=\"quote\">~a</blockquote>"
                            (string-join
                             (map (lambda (f)
                                    #`">,(linep f)") e)
                             "<br />\n")))
           :table (lambda (e)
                    (format
                     #f "<table class=\"wiki-table\">~a</table>"
                     (string-join
                      (cons
                       (format #f "<tr class=\"wiki-tr\">~a</tr>\n"
                               (string-join
                                (map (lambda (f) #`"<th class=\"wiki-th\">,(linep f)</th>")
                                     (cadr e))
                                ""))
                       (map (lambda (line)
                              (format
                               #f "<tr class=\"wiki-tr\">~a</tr>\n"
                               (string-join
                                (map (lambda (f) #`"<td class=\"wiki-td\">,(linep f)</td>")
                                     line)
                                "")))
                            (cddr e)))
                      "")))
           :else  (lambda (e) (format #f "~a<br />" (linep e)))))

(define (kcdp->text kcdp linep)
  (kcdp->t kcdp))

(provide "momoka/kcdp3")