(import scheme)
(import (chicken base))
(import (chicken condition))
(import (chicken file))
(import (chicken file posix))
(import (chicken format))
(import (chicken io))
(import (chicken irregex))
(import (chicken keyword))
(import (chicken port))
(import (chicken process-context))
(import (srfi 1))
(import svnwiki-sxml)
(import sxpath)

(define stderr (current-error-port))

(define (code-block? element)
  (and (pair? element) (eqv? (car element) 'pre)))

(define (consecutive-code-blocks? elements)
  (let loop ((elements elements)
             (last-status #f))
    (if (null? elements)
        #f
        (let* ((element (car elements))
               (status (code-block? element)))
          (if (and status last-status)
              element
              (loop (cdr elements) status))))))

(define (lint-consecutive-code-blocks path sxml)
  (let ((elements ((sxpath "//pre/following-sibling::*") sxml)))
    (and-let* ((match (consecutive-code-blocks? elements)))
      (print path ": consecutive code blocks found")
      (write match stderr)
      (newline stderr))))

(define (svnwiki-signature->identifier* sig type)
  (define +rx:ivanism+ (irregex '(: ":" eos)))
  (define (skip-chars pred in)
    (let loop ()
      (let ((char (peek-char in)))
        (when (and (not (eof-object? char))
                   (pred char))
          (read-char in)
          (loop)))))
  (define (safe-read in)
    (condition-case
     (read in)
     ((exn) #f)))
  (if (eq? type 'read)
      sig
      (call-with-input-string sig
        (lambda (in)
          (skip-chars char-whitespace? in)
          (if (eqv? (peek-char in) #\()
              (begin
                (skip-chars (lambda (ch) (eqv? ch #\()) in)
                (safe-read in))
              (let ((id (safe-read in)))
                (cond ((keyword? id)
                       ;; SPECIAL HANDLING: handle e.g. make-space:: -> make-space,
                       ;; only at toplevel of signature (not nested in a pair).
                       ;; Remove this once these signatures are normalized.
                       ;; (Warning: when read as a keyword, keyword->string
                       ;;  will strip one : itself).  We assume keywords are
                       ;; in suffix style.
                       (let ((str (keyword->string id)))
                         (string->symbol
                          (irregex-replace +rx:ivanism+ str ""))))
                      ((symbol? id) id)
                      (else sig))))))))

(define (lint-signatures path sxml)
  (let ((elements ((sxpath "//def/sig/*") sxml)))
    (for-each
     (lambda (element)
       (let* ((type (car element))
              (sig (cadr element))
              (current-identifier (svnwiki-signature->identifier sig type))
              (new-identifier (svnwiki-signature->identifier* sig type)))
         (when (not (equal? current-identifier new-identifier))
           (if (not current-identifier)
               (print path ": new identifier found: " new-identifier)
               (begin
                 (print path ": difference in signature parsing found")
                 (printf "current identifier: ~s\n" current-identifier)
                 (printf "new identifier: ~s\n" new-identifier)
                 (printf "signature: ~s\n" sig))))))
     elements)))

(define enabled-linters
  (list
   ;; lint-consecutive-code-blocks
   lint-signatures))

(define (lint-wiki-file path)
  (let ((sxml (call-with-input-file path svnwiki->sxml)))
    (for-each (lambda (linter) (linter path sxml)) enabled-linters)))

(define (lint-wiki-files directories)
  (for-each
   (lambda (dir)
     (find-files dir
                 action: (lambda (path _)
                           (when (and (not (directory? path))
                                      (not (symbolic-link? path)))
                             (lint-wiki-file path)))))
   directories))

(define main
  (case-lambda
   (()
    (fprintf stderr "usage: ~a <directory> ...\n" (program-name))
    (exit 1))
   (directories
    (lint-wiki-files directories))))

(apply main (command-line-arguments))