;; TODO: add table, list directives
(import (only chicken.process-context command-line-arguments)
        (only getopt-long getopt-long usage)
        (only chicken.format printf sprintf)
        (only chicken.io read-string read-line)
        (only chicken.port call-with-input-string)
        (only chicken.file file-exists? directory)
        (only chicken.pathname
              make-pathname
              pathname-directory
              pathname-extension
              pathname-file)
        (only chicken.string string-intersperse)
        (only srfi-1
              find
              filter
              first second third fourth fifth sixth)
        (only srfi-13
              string-null?
              string-prefix?
              string-trim
              string-trim-both))

(define grammar
  '((help "Print usage"
          (required #f)
          (single-char #\h))
    (output "Write to file"
            (required #f)
            (single-char #\o)
            (value (required FILE)))
    (ignore-egg "Ignore .egg file"
                (required #f)
                (single-char #\i))
    (ignore-release "Ignore .release-info file"
                    (required #f)
                    (single-char #\r))
    (no-toc "Don't add a toc"
            (required #f)
            (single-char #\n))
    (email "Include EMAIL with author"
           (required #f)
           (single-char #\e)
           (value (required EMAIL)))
    (head "File to add to beginning of documentation"
          (required #f)
          (single-char #\H)
          (value (required FILE)))
    (prologue "File to add after synopsis"
              (required #f)
              (single-char #\P)
              (value (required FILE)))
    (epilogue "File to add before maintainer info"
              (required #f)
              (single-char #\E)
              (value (required FILE)))
    (tail "File to add to end of documentation"
          (required #f)
          (single-char #\T)
          (value (required FILE)))
    (no-license "Don't insert a license file"
                (required #f)
                (single-char #\L))
    (license "File to use as license (defaults to LICENSE if unspecified)"
             (required #f)
             (single-char #\l)
             (value (required FILE)))
    (module-headers "Create === Module-name headers"
                    (required #f)
                    (single-char #\m))))

(define (print-usage #!optional (code 0))
  (printf "Usage: chalk [OPTION]... [FILE]...\n")
  (printf (usage grammar))
  (exit code))

(define pargs
  (getopt-long (command-line-arguments) grammar
               #:unknown-option-handler (lambda (c)
                                          (print-usage 1))))

(define input-files (alist-ref '@ pargs))

(define (find-tag tag doc)
  (find (lambda (i)
          (and (pair? i)
               (not (null? i))
               (equal? (car i) tag)))
        doc))

(define (find-docstr doc)
  (let ((strings (filter string? doc)))
    (and (not (null? strings))
         (string-intersperse strings "\n\n"))))

(define (document-procedure exp #!optional (type 'procedure))
  (let* ((doc (fourth exp))
         (internal (find-tag '@internal doc)))
    (unless internal
      (let* ((sig-tag (find-tag '@sig doc))
             (sig (or (and sig-tag (cadr sig-tag))
                      (second exp)))
             (docstr (find-docstr doc))
             (@to (find-tag '@to doc))
             (@example (find-tag '@example doc))
             (params (filter
                      (lambda (e)
                        (and (pair? e)
                             (not (string-prefix? "@"
                                                  (symbol->string (car e))))))
                      doc)))
        (if @to
            (printf "<~a>~s → ~a</~a>\n" type sig (cadr @to) type)
            (printf "<~a>~s</~a>\n" type sig type))
        (when (and docstr (not (string-null? docstr)))
          (printf "~a\n\n" docstr))
        (when (not (null? params))
          (document-deflist params))
        (when @example
          (document-script (cons '(@highlight "scheme") @example)))))))

(define (document-variable exp #!optional (type 'constant))
  (let* ((name (second exp))
         (doc (fourth exp))
         (internal (find-tag '@internal doc))
         (docstr (find-docstr doc)))
    (unless internal
      (printf "<~a>~s</~a>\n" type name type)
      (when (and docstr (not (string-null? docstr)))
        (printf "~a\n\n" docstr)))))

(define (document-record exp)
  (let* ((type (first exp))
         (name (second exp))
         (rec-doc (fourth exp))
         (internal (find-tag '@internal rec-doc))
         (docstr (find-docstr rec-doc))
         (full (find-tag '@full rec-doc)))
    (unless internal
      (printf "<record>~s</record>\n" name)
      (when full
        (if (eqv? type 'define-record)
            (begin
              (printf "<procedure>~a</procedure>\n" (cons (sprintf "make-~a" name)
                                                          (cddddr exp)))
              (printf "<procedure>~a?</procedure>\n" name)
              (for-each
               (lambda (e)
                 (printf "<procedure>~a-~a</procedure>\n" name e))
               (cddddr exp)))
            (begin
              (printf "<procedure>~a</procedure>\n" (fifth exp))
              (printf "<procedure>~a</procedure>\n" (sixth exp))
              (for-each
               (lambda (e)
                 (printf "<procedure>~a</procedure>\n" (cadr e))
                 (when (not (or (null? (cddr e))
                                (pair? (caddr e))))
                   (printf "<procedure>~a</procedure>\n" (caddr e))))
               (cddr (cddddr exp))))))
      (when (and docstr (not (string-null? docstr)))
        (printf "~a\n\n" docstr)))))

(define procedure-tags
  '(fn proc procedure function))

(define syntax-tags
  '(macro syntax))

(define parameter-tags
  '(param parameter))

(define file-relpath)
(define (document-expr exp)
  (define documentable-expr?
    (and (not (null? (cddr exp)))
         (not (null? (cdddr exp)))
         (eqv? '@ (third exp))))
  (define (tagged exp tags)
    (let ((doc (fourth exp)))
      (and (not (null? doc))
           (member (car doc) tags))))
  (when (and (pair? exp)
             (not (null? (cdr exp))))
    (cond ((and documentable-expr?
                (or (tagged exp syntax-tags)
                    (eqv? 'define-syntax (first exp))))
           (document-procedure exp 'syntax))
          ((and documentable-expr?
                (or (tagged exp procedure-tags)
                    (and (eqv? 'define (first exp))
                         (pair? (second exp)))))
           (document-procedure exp))
          ((and documentable-expr?
                (tagged exp parameter-tags)
                (eqv? 'define (car exp)))
           (document-variable exp 'parameter))
          ((and documentable-expr?
                (eqv? 'define (car exp)))
           (document-variable exp))
          ((and documentable-expr?
                (or (eqv? 'define-record (car exp))
                    (eqv? 'define-record-type (car exp))))
           (document-record exp))
          ((eqv? 'include (car exp))
           (document-file (cadr exp)))
          ((eqv? 'include-relative (car exp))
           (document-file (make-pathname file-relpath (cadr exp)))))))

(define (document-script script-exp)
  (let ((docstr (filter string? script-exp))
        (highlight (find-tag '@highlight script-exp))
        (pre (find-tag '@pre script-exp))
        (post (find-tag '@post script-exp)))
    (unless (null? docstr)
      (when pre
        (printf "~a\n" (cadr pre)))
      (printf "<enscript~a>\n"
              (if highlight
                  (sprintf " highlight=\"~a\"" (cadr highlight))
                  ""))
      (for-each (lambda (s)
                  (printf "~a\n" s))
                docstr)
      (printf "</enscript>\n\n")
      (when post
        (printf "~a\n" (cadr post))))))

(define (document-deflist list-exp)
  (for-each
   (lambda (kv)
     (let ((term (car kv))
           (def (cdr kv)))
       (if (null? def)
           (printf "; ~a :\n" term)
           (printf "; ~a : ~a\n" term (car def)))))
   list-exp)
  (newline))

(define (document-free exp)
  (unless (null? exp)
    (let ((docstr (find-docstr exp)))
      (case (car exp)
        ((script)
         (document-script exp))
        ((heading title ==)
         (printf "== ~a\n\n" docstr))
        ((subheading subtitle ===)
         (printf "=== ~a\n\n" docstr))
        ((subsubheading subsubtitle ====)
         (printf "==== ~a\n\n" docstr))
        ((subsubsubsubheading subsubsubsubtitle =====)
         (printf "===== ~a\n\n" docstr))
        ((deflist)
         (document-deflist (cdr exp)))
        (else
         (printf "~a\n\n" docstr))))))

(define (document-module exp)
  (when (alist-ref 'module-headers pargs)
    (let ((module-name (cadr exp)))
      (printf "=== Module: ~s\n" module-name)))
  (let loop ((exp (cdddr exp)))
    (cond ((null? exp) (void))
          ((eqv? (car exp) '@)
           (document-free (cadr exp))
           (loop (cddr exp)))
          (else
           (document-expr (car exp))
           (loop (cdr exp))))))

(define (document-file file)
  (set! file-relpath (pathname-directory file))
  (call-with-input-file file
    (lambda (in)
      (let loop ((exp (read in)))
        (cond ((eof-object? exp)
               (void))
              ((and (pair? exp)
                    (or (eqv? (car exp) 'module)
                        (eqv? (car exp) 'define-library)))
               (document-module exp)
               (loop (read in)))
              ((eqv? '@ exp)
               (document-free (read in))
               (loop (read in)))
              (else
               (document-expr exp)
               (loop (read in))))))))

(define (generate-docs #!optional (output (current-output-port)))
  (do ((files input-files (cdr files)))
      ((null? files))
    (let ((file (car files)))
      (document-file file))))


(when (alist-ref 'help pargs)
  (print-usage))
(define outfile (alist-ref 'output pargs))
(define license (alist-ref 'license pargs))
(define no-license (alist-ref 'no-license pargs))
(define head (alist-ref 'head pargs))
(define tail (alist-ref 'tail pargs))
(define prologue (alist-ref 'prologue pargs))
(define epilogue (alist-ref 'epilogue pargs))
(define egg-file (find (lambda (f)
                         (equal? (pathname-extension f) "egg"))
                       (directory)))
(define egg-name (if egg-file (pathname-file egg-file) #f))
(define egg-values (if egg-file (call-with-input-file egg-file (cut read <>)) '()))
(define release-file (if egg-name (make-pathname #f egg-name "release-info")))
(define ignore-egg (alist-ref 'ignore-egg pargs))
(define no-toc (alist-ref 'no-toc pargs))
(define ignore-release (alist-ref 'ignore-release pargs))
(define email (alist-ref 'email pargs))

(when outfile
  (current-output-port (open-output-file outfile)))

(when head
  (if (file-exists? head)
      (call-with-input-file head
        (lambda (in)
          (let ((str (read-string #f in)))
            (printf str))))
      (warning "Head file not found, skipping...")))

(unless (or ignore-egg (not egg-file))
  (printf "[[tags: egg]]\n")
  (unless no-toc
    (printf "[[toc:]]\n"))
  (printf "== ~a\n" egg-name)
  (and-let* ((synopsis (alist-ref 'synopsis egg-values)))
    (printf "~a\n\n" (car synopsis))))

(when prologue
  (if (file-exists? prologue)
      (call-with-input-file prologue
        (lambda (in)
          (let ((str (read-string #f in)))
            (printf str))))
      (warning "Prologue file not found, skipping...")))

(generate-docs)

(when epilogue
  (if (file-exists? epilogue)
      (call-with-input-file epilogue
        (lambda (in)
          (let ((str (read-string #f in)))
            (printf str))))
      (warning "Epilogue file not found, skipping...")))

(unless (or ignore-egg (not egg-file))
  (and-let* ((maintainer (alist-ref 'maintainer egg-values)))
    (printf "=== Maintainer\n")
    (printf "~a\n" (car maintainer)))
  (and-let* ((author (alist-ref 'author egg-values)))
    (printf "=== Author\n")
    (printf "~a\n" (car author))
    (when email
      (printf "~a\n" email)))
  (newline))

(unless (or ignore-egg (not egg-file) ignore-release)
  (if (file-exists? release-file)
      (begin
        (printf "=== Version History\n")
        (call-with-input-file release-file
          (lambda (in)
            (let loop ((line (read-line in)))
              (unless (eof-object? line)
                (call-with-input-string
                 line
                 (lambda (line-in)
                   (let ((expr (read line-in)))
                     (when (and (not (eof-object? expr))
                                (eqv? (car expr) 'release))
                       (printf "; ~a :~a\n"
                               (cadr expr)
                               (let ((descr (read-string #f line-in)))
                                 (if (eof-object? descr)
                                     ""
                                     (sprintf
                                      " ~a"
                                      (string-trim
                                       descr
                                       (lambda (c)
                                         (or (char-whitespace? c)
                                             (char=? c #\;))))))))))))
                (loop (read-line in))))))
        (newline))
      (warning "release-info file not found, skipping...")))

(let* ((egg-license (alist-ref 'license egg-values))
       (license-file (or license "LICENSE"))
       (license-exists (file-exists? license-file)))
  (when (or (and (not ignore-egg) egg-license)
            (and (not no-license) license-exists))
    (printf "=== License\n"))
  (unless (or ignore-egg (not egg-file) (not egg-license))
    (printf "~a\n\n" (car egg-license)))
  (unless no-license
    (if license-exists
        (begin
          (call-with-input-file license-file
            (lambda (in)
              (let loop ((line (read-line in)))
                (unless (eof-object? line)
                  (printf " ~a\n" line)
                  (loop (read-line in)))))))
        (warning "License file not found, skipping..."))))

(when tail
  (if (file-exists? tail)
      (call-with-input-file tail
        (lambda (in)
          (let ((str (read-string #f in)))
            (printf str))))
      (warning "Tail file not found, skipping...")))

(close-output-port (current-output-port))