;; 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 srfi-1
              find
              filter
              first second third fourth fifth sixth)
        (only srfi-13
              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)))
    (license "Whether to insert a license"
             (required #f)
             (single-char #\L)
             (value (optional 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)
  (find string? doc))

(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 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)
  (let* ((name (second exp))
         (doc (fourth exp))
         (internal (find-tag '@internal doc))
         (docstr (find-docstr doc)))
    (unless internal
      (printf "<constant>~s</constant>\n" name)
      (when 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 docstr
        (printf "~a\n\n" docstr)))))

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

(define syntax-tags
  '(macro syntax))

(define file-relpath)
(define (document-expr exp)
  (define documentable-expr?
    (and (not (null? (cddr exp)))
         (not (null? (cdddr exp)))
         (eqv? '@ (third exp))
         (not (null? (fourth exp)))))
  (when (and (pair? exp)
             (not (null? (cdr exp))))
    (cond ((and documentable-expr?
                (or (member (car (fourth exp)) syntax-tags)
                    (eqv? 'define-syntax (first exp))))
           (document-procedure exp 'syntax))
          ((and documentable-expr?
                (or (member (car (fourth exp)) procedure-tags)
                    (and (eqv? 'define (first exp))
                         (pair? (second exp)))))
           (document-procedure exp))
          ((and documentable-expr?
                (eqv? 'define (car exp)))
           ;; (print "VRA")
           (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))
           ;; (print "HEY")
           (document-file (cadr exp)))
          ((eqv? 'include-relative (car exp))
           (document-file (make-pathname file-relpath (cadr exp)))))))

(define (document-script script-exp)
  (let ((docstr (find-docstr script-exp))
        (highlight (find-tag '@highlight script-exp))
        (pre (find-tag '@pre script-exp))
        (post (find-tag '@post script-exp)))
    (unless (not docstr)
      (when pre
        (printf "~a\n" (cadr pre)))
      (printf "<enscript~a>\n"
              (if highlight
                  (sprintf " highlight=\"~a\"" (cadr highlight))
                  ""))
      (printf "~a\n" (string-trim-both 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)
                    (eqv? (car exp) 'module))
               (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 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 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))

;; let* ((outfile (alist-ref 'output pargs))
;;        (license (alist-ref 'license pargs))
;;        (prologue (alist-ref 'prologue pargs))
;;        (epilogue (alist-ref 'epilogue pargs))
;;        (egg-file (find (lambda (f)
;;                          (equal? (pathname-extension f) "egg"))
;;                        (directory)))
;;        (egg-name (if egg-file (pathname-file egg-file) #f)))
(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)
  (call-with-input-file egg-file
    (lambda (in)
      (let* ((values (read in))
             (synopsis (alist-ref 'synopsis values)))
        (when synopsis
          (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))
  (call-with-input-file egg-file
    (lambda (in)
      (let* ((values (read in))
             (author (alist-ref 'author values))
             (maintainer (alist-ref 'maintainer values)))
        (when maintainer
          (printf "=== Maintainer\n")
          (printf "~a\n" (car maintainer)))
        (when author
          (printf "=== Author\n")
          (printf "~a\n" (car author))
          (when email
            (printf "~a\n" email))
          (newline))))))

(when license
  (let ((license-file (or (and (string? license)
                               license)
                          "LICENSE")))
    (if (file-exists? license-file)
        (begin
          (printf "=== License\n")
          (call-with-input-file license-file
            (lambda (in)
              (let ((str (read-string #f in)))
                (printf str)
                (newline)))))
        (warning "License file not found, skipping..."))))

(unless 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)))))))
      (warning "release-info 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))