#|[
This is an attempt, to create modules, their documentation and their
tests from one file, a premodule.

A premodule differs from a module insofar, as there is
- no license
- no export-clause
- no documentation routine
- but internal and external tests

Instead, those texts are inserted automatically into the final module,
as well as into the final documentation, using spezial documentation
clauses.
The exported tests are inserted into the final test file
]|#

(module premodules (
  premodules
  license
  history
  premodule->module
  premodule->tests
  premodule->docs
  )

  (import scheme
          (chicken base)
          (chicken irregex)
          (only (chicken pretty-print) pp)
          (only (chicken io) read-line read-lines write-line)
          (only (chicken port) with-input-from-string)
          (only (chicken string)
                string-translate string-split string-intersperse ->string)
          (only (chicken file posix) file-modification-time)
          (only (chicken time posix) seconds->string)
          )

(define license
  (make-parameter "../license.txt"
                  (lambda (x)
                    (if (string? x)
                      x
                      "../license.txt"))))

(define history
  (make-parameter "../history.txt"
                  (lambda (x)
                    (if (string? x)
                      x
                      "../history.txt"))))

(define dissect-premodule
  ;; to be populated only once
  (let ((head? #t) (main? #f) (tail? #f))
    (let ((head.lst #f) (main.lst #f) (tail.lst #f))
      (lambda (file)
        (with-input-from-file file
          (lambda ()
            ;; with line input
            (when head?
              (let loop ((line (read-line)) (head '()))
                (cond
                  ((module-line? line)
                   (set! head? #f)
                   (set! main? #t)
                   (set! head.lst (reverse head))
                   (set! main.lst (list line)))
                  (else
                    (loop (read-line) (cons line head))))))
            (when main?
              (let loop ((line (read-line)) (main '()))
                (cond
                  ((test-line? line)
                   (set! main? #f)
                   (set! tail? #t)
                   (set! main.lst (append main.lst (reverse main))))
                  (else
                    (loop (read-line) (cons line main))))))
            ;; switch to expression input
            (when tail?
              (let loop ((xpr (read)) (tail '()))
                (cond
                  ((eof-object? xpr)
                   (set! tail.lst (reverse tail)))
                  ((memq (car xpr)
                         '(ppp xpr:val ppp* xpr:val* ppp** check))
                   ; skip internal tests
                   (loop (read) tail))
                  (else
                    (set! tail? #f)
                    (loop (read) (cons xpr tail))))))
            (values head.lst main.lst tail.lst)))))))

(define (module-name module.lst)
  (caddr (string-split (car module.lst))))

(define (module-line? line)
  (and (string? line)
       (irregex-match? '(: bos
                           (* space)
                           ";;;"
                           (* #\;)
                           (+ space)
                           "module"
                           (+ space)
                           (+ (or alnum ("!$%&*+-./:<=>?@^_~")))
                           (+ space)
                           ";;;"
                           (* #\;)
                           (* space)
                           eos)
                       line)))

(define (test-line? line)
  (and (string? line)
       (irregex-match? '(: bos
                           (* space)
                           ";;;"
                           (* #\;)
                           (+ space)
                           "tests"
                           (+ space)
                           ";;;"
                           (* #\;)
                           (* space)
                           eos)
                       line)))

(define (comment-begin? line)
  (and (string? line)
       (irregex-match? '(: bos
                           (* space)
                           "#|["
                           (* space)
                           eos)
                       line)))

(define (comment-end? line)
  (and (string? line)
       (irregex-match? '(: bos
                           (* space)
                           "]|#"
                           (* space)
                           eos)
                       line)))

(define (comment-separator? line)
  (and (string? line)
       (irregex-match? '(: bos
                           (* space)
                           "---"
                           (* #\-)
                           (+ space)
                           (or "macro" "procedure" "parameter")
                           (+ space)
                           "---"
                           (* #\-)
                           (* space)
                           eos)
                       line)))

(define (comment-signature? line)
  (and (string? line)
       (irregex-match? '(: bos
                           (* space)
                           #\(
                           (* space)
                           ;; name
                           (+ (or alnum ("!$%&*+-./:<=>?@^_~")))
                           (+ space)
                           (* any)
                           eos)
                       line)))

(define (check-xpr? xpr)
  (or (eq? (car xpr) 'define-checks)
      (eq? (car xpr) 'do-checks)))

(define (extract-check-name xpr)
  (and (check-xpr? xpr) (caadr xpr)))


(define (destructure-comment comment)
  (let ((sig? #t))
    (let loop ((comment comment)
               (name #f)
               (type #f)
               (signatures '())
               (text '()))
      (if (null? comment)
        (values name type (reverse signatures) (reverse text))
        (let ((first (car comment)) (rest (cdr comment)))
          (cond
            ((comment-signature? first)
             ;(set! sig? #t)
             (loop rest
                   (comment-name first)
                   type
                   (cons first signatures)
                   text))
            ((comment-separator? first)
             (set! sig? #f)
             (loop rest name (comment-type first) signatures text))
            (else
              (if sig?
                (loop rest
                      (comment-name first)
                      type
                      (cons first signatures)
                      text)
                (loop rest
                      name
                      type
                      signatures
                      (cons first text))))
            ))))))

(define (comment-type separator)
  (if (comment-separator? separator)
    (cadr (string-split separator))
    (error 'comment-type "not a comment separator" separator)))

(define (comment-name signature)
  (let* ((lst (string-split signature))
         (nlst (string-split (car lst) "()")))
    (car nlst)))

(define (extract-comments lines)
  (let ((state? #f))
    (let loop ((lines lines) (comment '()) (comments '()))
      (if (null? lines)
        (reverse comments)
        (let ((first (car lines)) (rest (cdr lines)))
          (cond
            ((comment-begin? first)
             (set! state? #t)
             (loop rest '() comments))
            ((comment-end? first)
             (set! state? #f)
             (loop rest '() (cons (reverse comment) comments)))
            (else
              (if state?
                (loop rest (cons first comment) comments)
                (loop rest comment comments)))
            ))))))

(define (module-comments module.lst)
  (append (extract-comments module.lst)
          `((,(string-append "(" (module-name module.lst) ")")
             ,(string-append "(" (module-name module.lst) " sym)")
            "--- procedure ---"
            "with sym: documentation of exported symbol"
            "without sym: list of exported symbols"))))

(define (module-exports module.lst)
  (let* ((export.lst
           (map comment-name
                (map car (module-comments module.lst))))
         (export.str
           (apply string-append
              (map (lambda (s) (string-append "\n  " s))
                   export.lst))))
    (substring export.str 1)))

(define license.lst ;(file->list "license.txt"))
  (with-input-from-file (license "license.txt") ;"license.txt"
    (lambda ()
      (read-lines))))

(define history.lst ;(file->list "history.txt"))
  (with-input-from-file (history "history.txt") ;"history.txt"
    (lambda ()
      (read-lines))))


(define (license-author licens)
  (string-intersperse (string-split (cadr (string-split (car licens) ",")))
                      " "))

(define (doclists comments)
  (let loop ((comments comments) (alist '()) (docs '(("=== API"))))
    (if (null? comments)
      (values (apply append (reverse alist))
              (apply append (reverse docs)))
      (let ((first (car comments)) (rest (cdr comments)))
        (receive (name type signatures text)
          (destructure-comment first)
          (loop rest
                (cons
                  `(,(string-append "      (" name)
                     ,(string-append "        " type ":")
                     ,@(map (lambda (sig)
                              (string-append "        " sig))
                            signatures)
                     ,@(map (lambda (str)
                              (string-append "        \"" str "\""))
                            text)
                     "        )"
                     )
                  alist)
                (cons
                  `(,(string-append "\n==== " name) " "
                    ,@(map (lambda (sig)
                             (string-append "<" type ">" sig "</" type ">\n"))
                           signatures)
                    ,@text)
                  docs)
                ))))))


(define (internal-doc-proc module.lst)
  (let ((name (module-name module.lst))
        (comments (module-comments module.lst)))
`(,(string-append 
      "#|[\n"
      "(" name ")\n"
      "(" name " sym)\n"
      "--- procedure ---\n"
      "documentation procedure\n"
      "]|#\n"
      "(define " name)
      "  (let ("
      "    (alist '("
               ,@(doclists comments)
      "        ))"
      "      )"
      "      (case-lambda"
      "        (() (map car alist))"
      "        ((sym)"
      "         (let ((pair (assq sym alist)))"
      "           (if pair"
      "             (for-each print (cdr pair))"
      "             (print \"Choose one of \" (map car alist))))))))")
      ))

(define (write-doc-examples run.lst)
  (let ((xprs run.lst))
    (for-each (lambda (xpr)
                (if (pair? xpr)
                  (case (car xpr)
                    ((define-checks do-checks)
                     (for-each (lambda (p)
                                 (pp (car p))
                                 (print ";-> " (cadr p) "\n"))
                               (chop (cddr xpr) 2)))
                    (else (pp xpr) (newline)))
                  (print xpr)))
              ;; remove simple-tests line
              (cdr run.lst))
    ))

;; the next two routines are for the Requirements section in the docfile
(define (import-xpr main.lst)
  (let ((str
          (let loop ((lines (cdr main.lst)) (result ""))
            (let ((line (car lines)) (lines (cdr lines)))
              (if (comment-begin? line)
                  result
                  (loop lines (string-append result "\n" line)))))))
    (with-input-from-string str
                            (lambda () (read))) ; read first xpr,
                                                ; i.e. import clause 
    ))

;; remove import, scheme, only etc
(define (strip-mods imp-xpr)
  (let loop ((xprs imp-xpr) (result '()))
    (if (null? xprs)
      result
      (let ((xpr (car xprs)) (xprs (cdr xprs)))
        (cond
          ((pair? xpr)
           (case (car xpr)
             ((only except prefix rename)
              (cond
                ((and (pair? (cadr xpr))
                      (eq? (caadr xpr) 'chicken))
                 (loop xprs result))
                ((eq? (cadr xpr) 'scheme)
                 (loop xprs result))
                (else
                  (loop xprs (cons (cadr xpr) result)))))
             ((chicken)
              (loop xprs result))
             (else
               (loop xprs (cons xpr result)))))
          (else
            (if (or (eq? xpr 'import) (eq? xpr 'scheme))
              (loop xprs result)
              (loop xprs (cons xpr result))))
          )))))

(define (premodule-transform pre-file)
  (receive (head.lst main.lst test.lst)
    (dissect-premodule pre-file)
    (values
      (lambda (module-file)
        (with-output-to-file module-file
          (lambda ()
            (let ((name (module-name main.lst))
                  (exports (module-exports main.lst)))
              (let (
                (main.lst*
                  (append
                    (cons (string-append "(module " name " (")
                          (cons (string-append exports "\n  )")
                                (cdr main.lst)))
                    (internal-doc-proc main.lst)
                    (list ")")))
                )
                (for-each write-line
                          (append ;license.lst
                                  (map (lambda (str)
                                         (string-append "; " str))
                                       license.lst)
                                  (list "\n")
                                  head.lst
                                  main.lst*))))
                )))
      (lambda (test-file)
        (with-output-to-file test-file
          (lambda ()
            (write-line (string-append "(import "
                                       (module-name main.lst)
                                       ")"))
            (let loop ((xprs test.lst) (checks '()))
              (cond
                ((null? xprs)
                 (newline)
                 (write-line
                   (string-append "(check-all "
                   (string-translate (module-name main.lst)
                                     "abcdefghijklmnopqrstuvwxyz"
                                     "ABCDEFGHIJKLMNOPQRSTUVWXYZ")))
                 (for-each (lambda (sym)
                             (write-line
                               (string-append "  ("
                                              (symbol->string sym)
                                              ")")))
                           (reverse checks))
                 (write-line "  )"))
                ((check-xpr? (car xprs))
                 (newline)
                 ;(print (caar xprs) " " (cadar xprs))
                 ;(pp (cddar xprs))
                 (pp (car xprs))
                 (loop (cdr xprs)
                       (cons (extract-check-name (car xprs)) checks)))
                (else
                  (newline)
                  (pp (car xprs))
                  (loop (cdr xprs) checks))))))
        )
      (lambda (doc-file)
        (with-output-to-file doc-file ;"loops"
          (lambda ()
            (receive (internal-doclist external-doclist)
              (doclists (module-comments main.lst))
              (write-line "[[tags: egg]]")
              (write-line "[[toc:]]")
              (write-line "\n== Rationale\n") 
              (let ((comment? #f))
                (let loop ((lines head.lst))
                  (unless (null? lines)
                    (let ((line (car lines)) (lines (cdr lines)))
                      (cond
                        ((comment-begin? line)
                         (set! comment? #t)
                         (loop lines))
                        ((comment-end? line)
                         (set! comment? #f)
                         (loop lines))
                        (else
                          (if comment?
                            (begin (write-line line)
                                   (loop lines))
                            (loop lines))))))))
              (newline)
              (for-each write-line external-doclist)
              (newline)
              (write-line "=== Examples\n")
              (write-line "<enscript highlight=scheme>\n")
              (write-line (string-append "(import "
                                         (module-name main.lst)
                                         ")\n"))
              (write-doc-examples test.lst)
              (write-line "</enscript>\n")
              (write-line "\n== Requirements\n")
              (let ((imports (strip-mods (import-xpr main.lst))))
                (if (null? imports)
                  (write-line "None")
                  (for-each write-line
                            (map ->string imports))))
              (newline)
              (write-line "== Last update\n")
              (write-line
                (let (
                  (lst (string-split
                         (seconds->string
                           (file-modification-time; "preloops.scm"))))
                             pre-file))))
                  )
                  (string-append (list-ref lst 1)
                                 " "
                                 (list-ref lst 2)
                                 ", "
                                 (list-ref lst 4)
                                 "\n")))
              (write-line "== Author\n")
              (write-line (license-author license.lst))
              ;  (string-append (license-author (car license.lst)) "\n"))
              (write-line "\n== License\n")
              (for-each write-line license.lst)
              (newline)
              (write-line "== Version history")
              ;(write-line "; 0.1 : Initial check in")))
              (for-each write-line history.lst)))
        )))))

(define (premodule->module from to)
  (receive (mod-proc run-proc doc-proc)
    (premodule-transform from)
    (mod-proc to)))

(define (premodule->tests from to)
  (receive (mod-proc run-proc doc-proc)
    (premodule-transform from)
    (run-proc to)))

(define (premodule->docs from to)
  (receive (mod-proc run-proc doc-proc)
    (premodule-transform from)
    (doc-proc to)))

(define premodules
  (let (
    (signatures '((premodules
                    procedure:
                    (premodules sym ..)
                    "documentation procedure"
                    "without sym: list of exported symbols"
                    "with sym: docu of exported sym")
                  (license
                    parameter:
                    (license)
                    (license new)
                    "returns or updates the license file")
                  (premodule->module
                    procedure:
                    (premodule->module pre-file module-file)
                    "destructures the pre-file, re-assembles it"
                    "and writes it to the module-file")
                  (premodule->tests
                    procedure:
                    (premodule->tests pre-file test-file)
                    "destructures the pre-file, re-assembles it"
                    "and writes it to the test-file")
                  (premodule->docs
                    procedure:
                    (premodule->docs pre-file doc-file)
                    "destructures the pre-file, re-assembles it"
                    "and writes it to the doc-file")))
    )
    (case-lambda
      (() (map car signatures))
      ((sym)
       (let ((pair (assq sym signatures)))
         (if pair
           (for-each print (cdr pair))
           (print "Choose one of " (map car signatures))))))))

) ; endmodule

;(import premodules simple-tests (chicken port))
;(premodule->module "../dotted-lambdas/dotted-lambdas.pre.scm"
;                  "dl.scm")
;(premodule->tests "../dotted-lambdas/dotted-lambdas.pre.scm"
;                  "dlrun.scm")
;(premodule->docs "../dotted-lambdas/dotted-lambdas.pre.scm"
;                  "dl")