;; Copyright (c) 2007,2009, Tony Sidaway
;; All rights reserved.
;; 
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following
;; conditions are met:
;;
;; Redistributions of source code must retain the above copyright notice,
;; this list of conditions and the following disclaimer. 
;; Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution. 
;; Neither the name of the author nor the names of its contributors may
;; be used to endorse or promote products derived from this software
;; without specific prior written permission. 
;; 
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS
;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;; POSSIBILITY OF SUCH DAMAGE.
;
; This module provides useful functions for reading and writing Mediawiki's
; version of wiki code.
;
(module mw-format
  (export wiki-list wiki-list->list wiki-list->vector page->user-list
          wiki-clean wiki-username remove-list-preamble wiki-heading
          write-wiki-page canonical-pagename canonical-username userspace-owner
          wiki-unlink wiki-link wiki-external wiki-category interwiki
          wiki-bold wiki-italics)
  
  (import chicken scheme data-structures regex)
;;
;;
;; wiki-list: turn a list or vector of lines into a wiki-list
;;
  (define (wiki-list lst)
    (map
     (lambda(x)(string-append "*" (->string x) "\n"))
     (cond
      ((list? lst) lst)
      ((vector? lst) (vector->list lst))
      (else '()))))
;;
;; wiki-list->list: derive a list of lines from a list of lines comprising a wiki-list
;;
  (define (wiki-list->list lines)
    (reverse
     (let loop ((lst '()) (lines lines) (i 0))
       (if (and
            (not (null? lines))
            (> (string-length (string-chomp (car lines))) 0)
            (string=? (substring (car lines) 0 1) "*"))
           (loop
            (cons (string-chomp (substring (car lines) 1)) lst)
            (cdr lines) (+ i 1))
           lst))))
;;
;; wikilist->vector: derive a vector of lines from a list of lines comprising a wiki-list
;;
  (define (wiki-list->vector lines) (list->vector (wiki-list->list lines)))
;;
;; page->user-list: derive a list of usernames from a wiki-list
;;
  (define (page->user-list wiki-content)
    (and wiki-content
         (map wiki-username
              (wiki-list->list
               (remove-list-preamble
                (string-split
                 (wiki-clean wiki-content) "\n" #t))))))
;;
;; wiki-clean: remove html comments from wiki content
;;
  (define (wiki-clean wiki-content)
    (let ((sx '(: "<!--" (* (or (~ "-") (: "-" (~ "-")) (: "--" (~ ">")))) "-->")))
      (string-substitute* wiki-content `((,sx . "")))))
;;
;; remove-list-preamble: find the start of a wiki-list
;;
  (define (remove-list-preamble wiki-lines)
    (cond
     ((null? wiki-lines) wiki-lines)
     ((string-search '(: bos "*") (car wiki-lines)) wiki-lines)
     (else (remove-list-preamble (cdr wiki-lines)))))
;;
;; wiki-heading: produce a wiki "="-style heading of the requested level
;;
  (define (wiki-heading level title)
    (let ((equals (make-string level #\=)))
      (string-append equals title equals "\n")))
;;
;; write-wiki-page: Write wiki page in s-expression form
;;
  (define (write-wiki-page page content edit-summary)
    (write `(page (,page ,content ,edit-summary))))
;;
;; canonical-pagename: convert "_"s in pagename to spaces.
;;
  (define (canonical-pagename pagename) (string-substitute* pagename '(("_" . " "))))
;;
;; canonical-username: useful alias for canonical-pagename
;;
  (define canonical-username canonical-pagename)
;;
;; userspace-owner: derive the owner of a page in user or user talk namespace.
;;
  (define (userspace-owner page)
    (let ((rx
           '(w/nocase
             (: bos "user"  (? ("_ ") "talk") ":"
                (submatch (* (~ "/")) (* any) eos)))))
      (and (string-search rx page)
           (canonical-username
            (string-substitute rx "\\1" page)))))
;;
;; wiki-unlink: derive the target from a wiki-link
;;
  (define (wiki-unlink link)
    (let ((rx
           '(: bos (* whitespace) "[[" (* whitespace)
               (submatch (*? (~ "]|"))) (* whitespace)
               (? (seq "|" (* (~ "]")))) "]]" (* whitespace) eos)))
      (and (string-search rx link)
           (string-substitute rx "\\1" link))))

;;
;; wiki-link: produce a wiki-link for a target, with optional piped name.
;;
  (define (wiki-link line . opt)
    (let* ((target
            (string-substitute "^\\s([^\\s]*)\\s$" "[[\\1]]" line))
           (piped-name
            (if (null? opt) ""
                (string-append "|" (car opt))))
           (colon
            (if (or
                 (string-search "^[Cc]ategory:" target)
                 (string-search "^[Ii]mage:" target))
                ":" "")))
      (string-append
       "[[" colon target piped-name "]]")))
;;
;; wiki-external: external link
;;
  (define (wiki-external link . opt)
    (let ((name
           (if (null? opt) ""
               (string-append " " (car opt)))))
      (string-append
       "[" (string-substitute "^\\s([^\\s]*)\\s$" "[[\\1]]" link) name "]")))
;;
;; wiki-category: Category with optional piped sort
;;
  (define (wiki-category name . opt)
    (let ((sort (if (null? opt) "" (string-append "|" (car opt)))))
      (string-append "[[Category:" (string-substitute "^\\s([^\\s]*)\\s$" "[[\\1]]" name)
                     sort "]]\n")))
;;
;; interwiki: Interwiki link (eg: [[fr:Londres]])
;;
  (define (interwiki iwiki name) (string-append "[[" iwiki ":" name "]]"))
;;
;; wiki-bold: text in bold
;;
  (define (wiki-bold text) (string-append "'''" text "'''"))
;;
;; wiki-italics: text in italics
;;
  (define (wiki-italics text) (string-append "''" text "''"))
;;
;; wiki-username: derive a username from content containing [[User:username]] or
;; [[User talk:username]].  Also understands piped usernames such as
;; [[User:username|displayed text]]
;;
  (define (wiki-username wiki-content)
    (string-substitute
     '(w/nocase
       (: bos (* whitespace) "[[" (* whitespace) "user" (? (or "_" " ") "talk") ":"
          (submatch (* (~ "|]")))
          (? "|" (* (~ "|]"))) "]]"
          (* any) eos)) "\\1" wiki-content)))