tekuti/classifier.scm

@@ -114,22 +114,16 @@
      (lambda (feature bogus-count)
        (let ((legit-count (hash-ref legit-features feature 0)))
          (hash-set! log-bogosities feature
-                    (if (and (> total-bogus-features 0)
-                             (> total-legit-features 0))
-                        (log (/ (/ (+ bogus-count 0.001) total-bogus-features)
-                                (/ (+ legit-count 0.001) total-legit-features)))
-                        0))))
+                    (log (/ (/ (+ bogus-count 0.001) total-bogus-features)
+                            (/ (+ legit-count 0.001) total-legit-features))))))
      bogus-features)
     (hash-for-each
      (lambda (feature legit-count)
        (let ((bogus-count (hash-ref bogus-features feature)))
          (unless bogus-count
            (hash-set! log-bogosities feature
-                      (if (and (> total-bogus-features 0)
-                               (> total-legit-features 0))
-                          (log (/ (/ 0.01 total-bogus-features)
-                                  (/ (+ legit-count 0.01) total-legit-features)))
-                          0)))))
+                      (log (/ (/ 0.01 total-bogus-features)
+                              (/ (+ legit-count 0.01) total-legit-features)))))))
      legit-features)
     log-bogosities))
 
@@ -262,9 +256,7 @@
   (with-time-debugging
    (let* ((legit-count (hash-count (const #t) legit-comments))
           (bogus-count (hash-count (const #t) bogus-comments))
-          (legit-prior (if (> legit-count 0)
-                           (/ legit-count (+ legit-count bogus-count 0.0))
-                           0))
+          (legit-prior (/ legit-count (+ legit-count bogus-count 0.0)))
           (legit-features (count-features legit-comments))
           (bogus-features (count-features bogus-comments))
           (bogosities (compute-log-bogosities legit-features bogus-features)))
@@ -291,19 +283,13 @@
                                                (assq-ref index 'master))))
        (let ((removed-features (count-features removed))
              (added-features (count-features added)))
-         ;; If a comment passes the spam filter, it gets added, and is
-         ;; presumed legitimate.  It could then be reverted, in which
-         ;; case we should remove its features from the legitimate count
-         ;; and add them to the bogus count.
          (hash-for-each (lambda (k v)
                           (remove-feature! legit-features k v)
                           (add-feature! bogus-features k v))
                         removed-features)
          (hash-for-each (lambda (k v)
-                          ;; Asymmetry with removed-features; the
-                          ;; comment wasn't previously marked bogus, so
-                          ;; we just add its features to the legit set.
-                          (add-feature! legit-features k v))
+                          (add-feature! legit-features k v)
+                          (remove-feature! bogus-features k v))
                         added-features)
          (update-bogosities! bogosities removed-features
                              legit-features bogus-features)

tekuti/filters.scm

@@ -94,9 +94,6 @@
 (define (marxdown->sxml text)
   (smarxdown->shtml (call-with-input-string text marxdown->smarxdown)))
 
-(define (pre-class? class)
-  (string-prefix? "pre-" class))
-
 (define *allowed-tags*
   `((a (href . ,urlish?) title)
     (abbr title)
@@ -108,10 +105,9 @@
     (em)
     (i)
     (p)
-    (pre (class . ,pre-class?))
+    (pre)
     (strike)
-    (strong)
-    (tt)))
+    (strong)))
 
 (define (compile-sxslt-rules tags)
   (define (ok . body)

tekuti/git.scm

@@ -334,7 +334,7 @@
                    (cons (string->symbol k) v))))))
 
 (define (fold-commits f rev seed)
-  (let lp ((rev (and rev (git-rev-parse rev))) (seed seed))
+  (let lp ((rev (git-rev-parse rev)) (seed seed))
     (if rev
         (let ((commit (parse-commit rev)))
           (lp (assq-ref commit 'parent)

tekuti/marxdown.scm

@@ -132,28 +132,13 @@
        (unget chars))))
 
   (define (next) (get-char port))
-  (define (peek) (peek-char port))
-
   (define (next-not-eof ctx)
     (let ((ch (next)))
       (if (eof-object? ch)
           (error "EOF while reading" ctx)
           ch)))
-  (define (next-line-and-delim)
-    (let lp ((chars '()))
-      (define (finish delim)
-        (cons (reverse-list->string chars) delim))
-      (let ((ch (next)))
-        (cond
-         ((eof-object? ch) (finish ch))
-         ((eqv? ch #\return)
-          (if (eqv? (peek) #\newline)
-              (finish (next))
-              (lp (cons ch chars))))
-         ((eqv? ch #\newline)
-          (finish ch))
-         (else
-          (lp (cons ch chars)))))))
+  (define (next-line-and-delim) (read-line port 'split))
+  (define (peek) (peek-char port))
 
   (define (skip-whitespace k)
     (let lp ((indent 0))
@@ -227,10 +212,7 @@
               (else (kt)))))
           (#\newline
            ;; Sure.  Trailing whitespace can be any indent.
-           (unget1 #\newline)
            (kt))
-          (#\return
-           (lp n))
           (ch
            (unless (eof-object? ch) (unget1 ch))
            (kf)))))))
@@ -365,14 +347,12 @@
     (let lp ((chars '()))
       (match (next-not-eof "backticks")
         (#\` (continue `(code ,(reverse-list->string chars))))
-        (#\return (lp chars))
         (#\newline
          (consume-indent
           indent
           (lambda ()
             (match (next-not-eof "code")
-              ((or #\return #\newline)
-               (error "end of block while reading code"))
+              (#\newline (error "end of block while reading code"))
               (ch (unget1 ch) (lp (cons #\space chars)))))
           (lambda () (error "end of block while reading code"))))
         (ch (lp (cons ch chars))))))
@@ -393,25 +373,14 @@
                   (lp elts (cons (list->string chars) out))))))
             ((elt . elts)
              (lp elts (cons elt out))))))
-      (define (consume-blank-lines-then-finish kdone)
-        (let lp ()
-          (match (next)
-            ((? eof-object?) (finish kdone))
-            (#\return (lp))
-            (#\newline
-             (consume-indent indent lp (lambda () (finish kdone))))
-            (ch
-             (unget1 ch)
-             (finish kdone)))))
       (match (next)
         ((? eof-object?) (finish on-block-end))
-        (#\return (lp elts))
         (#\newline
          (consume-indent
           indent
           (lambda ()
             (cond
-             ((done? #\newline) => consume-blank-lines-then-finish)
+             ((done? #\newline) => finish)
              (else (lp (cons #\newline elts)))))
           (lambda ()
             (finish on-block-end))))
@@ -434,9 +403,7 @@
                              (match link
                                (('link dest . alt)
                                 (continue `(image ,dest . ,alt)))))))
-               (ch
-                (unget1 ch)
-                (lp (cons #\! elts)))))
+               (ch (lp (cons* ch #\! elts)))))
         (ch (lp (cons ch elts))))))
 
   (define (read-para indent kup knext)
@@ -447,7 +414,7 @@
     (define (done? ch)
       (match ch
         (#\newline
-         (let lp ((ch (next)))
+         (let ((ch (next)))
            (match ch
              ((? eof-object?)
               (lambda (para)
@@ -455,13 +422,9 @@
              (ch
               (read-block-type ch #t
                                make-continuation
-                               (if (eqv? ch #\newline)
-                                   (lambda (chars)
-                                     (unget chars)
-                                     (make-continuation read-para))
-                                   (lambda (chars)
-                                     (unget chars)
-                                     #f)))))))
+                               (lambda (chars)
+                                 (unget chars)
+                                 #f))))))
         (_ #f)))
     (read-text 'para indent done? (make-continuation read-block-list)))
 
@@ -469,21 +432,10 @@
     (unget chars)
     (read-para indent kup knext))
 
-  (define (read-heading level indent continue)
-    (let ((continue (lambda (heading)
-                      (match heading
-                        (('heading . body)
-                         (continue `(heading ,level . ,body)))))))
-      (read-text 'heading indent (lambda (ch)
-                                   (and (eqv? ch #\newline) continue))
-                 continue)))
+  (define (read-heading level knext)
+    (error "unimplemented"))
 
   (define (read-li marker marker-indent marker-size kup knext)
-    (define list-tag
-      (match marker
-        ((? number?) 'enumerate)
-        ((? char?) 'itemize)))
-    (define (list-tag? tag) (eq? tag list-tag))
     (read-indent
      (lambda (ch indent)
        (match indent
@@ -494,19 +446,23 @@
                     (append marker-outer
                             (list (+ marker-inner marker-size outer))
                             inner)))
-               (read-block
-                ch body-indent
-                (lambda (blocks ch next-indent)
-                  (read-indented-block
-                   ch marker-indent next-indent kup
-                   (lambda (nodelist)
-                     (knext
-                      (match nodelist
-                        ((((? list-tag?) . items) . nodelist)
-                         `((,list-tag (item . ,blocks) . ,items) . ,nodelist))
-                        (_
-                         `((,list-tag (item . ,blocks)) . ,nodelist)))))))
-                identity)))))))))
+               (pk 'hey marker marker-indent marker-size indent body-indent ch)
+               (read-indented-block
+                ch marker-indent body-indent
+                (lambda (elt ch indent)
+                  (pk ch marker-indent indent elt)
+                  (read-indented-block ch marker-indent indent kup
+                                       (lambda (nodelist)
+                                         (knext (cons elt nodelist)))))
+                (lambda (nodelist)
+                  (cons* 'li marker nodelist)))))))))))
+
+  (define (read-block ch indent kup knext)
+    (define (have-block read-block)
+      (read-block indent kup knext))
+    (define (have-text chars)
+      (read-para* chars indent kup knext))
+    (read-block-type ch #f have-block have-text))
 
   (define (read-block-type ch in-text? kblock ktext)
     (define (make-continue indent kup knext)
@@ -523,8 +479,7 @@
            (#\space
             (kblock
              (lambda (indent kup knext)
-               (read-heading level indent (make-continue indent kup knext)))))
-           (#\return (lp level))
+               (read-heading level (make-continue indent kup knext)))))
            (#\newline
             (kblock
              (lambda (indent kup knext)
@@ -597,8 +552,6 @@
               (match (parse-one-xml-element port)
                 (#f (read-block-list indent kup knext))
                 (elt ((make-continue indent kup knext) `(block-xml ,elt))))))))
-      (#\return
-       (read-block-type (next-not-eof "newline") in-text? kblock ktext))
       (#\newline
        ;; fixme: record loose li
        (kblock read-block-list))
@@ -609,31 +562,16 @@
       (_
        (ktext (list ch)))))
 
-  (define (read-block ch indent kup knext)
-    (define (have-block read-block)
-      (read-block indent kup knext))
-    (define (have-text chars)
-      (read-para* chars indent kup knext))
-    (read-block-type ch #f have-block have-text))
-
-  (define (finish-block-list blocks)
-    (match blocks
-      ((block) block)
-      (_ `(begin . ,blocks))))
-  (define (finish-block-quote blocks)
-    (match blocks
-      ((block) block)
-      (_ `(blockquote . ,blocks))))
-
   (define (read-indented-block ch outer-indent indent kup knext)
-    (define (recurse finish recurse-indent)
+    (define (recurse kind recurse-indent)
       (read-indented-block ch recurse-indent indent
                            (lambda (nested ch indent)
                              (read-indented-block ch outer-indent indent
                                                   kup
                                                   (lambda (nodelist)
                                                     (knext (cons nested nodelist)))))
-                           finish))
+                           (lambda (nodelist)
+                             (cons kind nodelist))))
     (match (compare-indents outer-indent indent)
       ('same
        (read-block ch indent kup knext))
@@ -642,10 +580,9 @@
            'different-blockquote)
        (kup (knext '()) ch indent))
       ('inner
-       (recurse finish-block-list indent))
+       (recurse 'begin indent))
       ('inner-blockquote
-       (recurse finish-block-quote
-                (list-head indent (1+ (length outer-indent)))))))
+       (recurse 'blockquote (list-head indent (1+ (length outer-indent)))))))
 
   (define (parse-error reason)
     (error reason))
@@ -657,7 +594,7 @@
 
   (read-block-list empty-indent
                    (lambda (nodelist ch indent) nodelist)
-                   finish-block-list))
+                   (lambda (nodelist) (cons 'top nodelist))))
 
 (define* (smarxdown->shtml exp #:key
                            (heading-offset 0)
@@ -666,9 +603,9 @@
   (define (transform-inline exp)
     (match exp
       (('inline-xml xml) (handle-inline-xml xml))
-      (('code . body) `(tt . ,body))
-      (('emph . body) `(i . ,(map transform-inline body)))
-      (('strong . body) `(b . ,(map transform-inline body)))
+      (('code . body) exp)
+      (('emph . body) `(emph . ,(map transform-inline body)))
+      (('strong . body) `(strong . ,(map transform-inline body)))
       (('link dest . body) `(a (@ (href ,dest)) . ,(map transform-inline body)))
       ((? string? str) str)))
   (define (transform-block exp)
@@ -676,14 +613,7 @@
       (('block-xml xml) (handle-block-xml xml))
       (('para . body) `(p . ,(map transform-inline body)))
       (('blockquote . body) `(blockquote . ,(map transform-block body)))
-      (('itemize ('item . item) ...)
-       `(ul . ,(map (lambda (blocks)
-                      `(li . ,(map transform-block blocks)))
-                    item)))
-      (('enumerate ('item . item) ...)
-       `(ol . ,(map (lambda (blocks)
-                      `(li . ,(map transform-block blocks)))
-                    item)))
+      (('list-item . body) (error "fixme"))
       (('pre #f . body) `(pre . ,body))
       (('pre info . body) `(pre (@ (class ,(string-append "pre-" info)))
                                 . ,body))
@@ -697,5 +627,5 @@
                          (else 'h6))))
          `(,tag . ,(map transform-inline body))))))
   (match exp
-    (('begin exp ...)
+    (('top exp ...)
      `(div . ,(map transform-block exp)))))

tekuti/page-helpers.scm

@@ -45,7 +45,7 @@
             post-url
             post-editing-form
             sidebar-ul top-tags tag-cloud
-            main-sidebar post-sidebar tag-sidebar related-tag-cloud
+            main-sidebar post-sidebar related-tag-cloud
             post-link admin-post-url admin-post-link
             show-post with-authentication
             find-posts-matching
@@ -540,17 +540,6 @@ present."
                            ,(post-link (car post-and-tags))))
                     (take-max (compute-related-posts post index) 10)))))))
 
-(define (tag-sidebar tag index)
-  (sidebar-ul
-   `((li (h2 (a (@ (href ,(relurl '("feed" "atom")
-                                  #:query `(("with" . ,tag)))))
-                "subscribe "
-                (img (@ (src ,(relurl '("wp-content" "feed-icon-14x14.png")))
-                        (alt "[feed]"))))))
-     (li (h2 "related tags " ,(rellink '("tags") ">>"))
-         (ul (li (@ (style "line-height: 150%"))
-                 ,@(tag-cloud (compute-related-tags tag index))))))))
-
 (define (related-tag-cloud tag index)
   `(div (@ (id "tag-cloud"))
         (h2 "related tags")

tekuti/page.scm

@@ -301,10 +301,13 @@
                        (post-from-key index key))
                      (hash-ref tags tag '()))))
     (if (pair? posts)
-        (respond `(,(tag-sidebar tag index)
-                   (h2 "posts tagged \"" ,tag "\"")
-                   ,@(map (lambda (post) (show-post post #f))
-                          (take-max (reverse posts) 10)))
+        (respond `((h2 "posts tagged \"" ,tag "\" ("
+                       ,(rellink '("feed" "atom") "feed"
+                                 #:query `(("with" . ,tag)))
+                       ")")
+                   ,@(map (lambda (post) `(p ,(post-link post)))
+                          posts)
+                   ,(related-tag-cloud tag index))
                  #:etag (assq-ref index 'master)
                  #:title (string-append "posts tagged \"" tag "\""))
         (respond `((h2 "Unknown tag " ,tag)