;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; schematic-reader.scm
;;;
;;; This is a line-based source reader. It provides a procedure,
;;; `make-source-section-reader`, that, given a line comment prefix and
;;; port, returns a generator that yields documentation and source code
;;; for each commented block of code read from the input.
;;;
;;; It should work in any R7RS-compatible Scheme, given the following
;;; imports:
;;;
;;;     (import (scheme case-lambda)
;;;             (scheme char)
;;;             (scheme write))
;;;
;;; See this project's README for more information, or
;;; schematic-markdown.scm for a simple usage example.
;;;
;;; Copyright (c) 2013, Evan Hanson <evhan@foldling.org>
;;; See LICENSE for details.
;;;

;;;
;;; SRFI-1-ish.
;;;

(define (any pred lst)
  (and (pair? lst)
       (or (pred (car lst))
           (any pred (cdr lst)))))

(define (drop-while pred lst)
  (cond ((null? lst) lst)
        ((pred (car lst))
         (drop-while pred (cdr lst)))
        (else lst)))

;;;
;;; SRFI-13-ish and other string functions.
;;;

(define (string-null? str)
  (zero? (string-length str)))

;; Infix-joins the list of printable objects `lst` with the optional
;; separator `sep` (which may also be any printable object).
(define (string-join lst . sep)
  (let ((str (open-output-string))
        (sep (and (pair? sep) (car sep))))
    (do ((lst lst (cdr lst)))
        ((null? lst)
         (get-output-string str))
      (display (car lst) str)
      (when (and sep (pair? (cdr lst)))
        (display sep str)))))

;; Removes characters satisfying `pred` from the front of `str`.
(define (string-drop-while pred str)
  (let ((len (string-length str)))
    (do ((i 0 (+ i 1)))
        ((or (= i len)
             (not (pred (string-ref str i))))
         (substring str i len)))))

;; Determines whether `str1` is a prefix of `str2`.
(define (string-prefix? str1 str2)
  (let ((len1 (string-length str1))
        (len2 (string-length str2)))
    (do ((i 0 (+ i 1)))
        ((or (= i len1)
             (= i len2)
             (not (char=? (string-ref str1 i)
                          (string-ref str2 i))))
         (= i len1)))))

;;;
;;; Source reader & comment formatting.
;;;

;; Repeats `thunk` indefinitely.
(define (ad-infinitum thunk)
  (do () (#f) (thunk)))

;; Creates a generator from `f`, which should accept a single variadic
;; procedure argument. This procedure, when called, saves its
;; continuation and yields its arguments to the caller. On the
;; generator's next invocation, `f`'s continuation is resumed.
;;
;; It is an error for the generator to end (that is, for `f` to return).
(define (make-generator f)
  (letrec ((g (lambda (resume)
                (f (lambda result
                     (set! resume
                       (call/cc
                        (lambda (pause)
                          (set! g pause)
                          (apply resume result))))))
                (error "end of generator"))))
    (lambda ()
      (call/cc g))))

;; Creates a procedure that determines whether a given string starts
;; with any of the line comment prefixes in the `prefixes` list.
(define (line-comment-predicate prefixes)
  (lambda (str)
    (any (lambda (p) (string-prefix? p str)) prefixes)))

;; Creates a procedure that returns the documentation part of a line
;; comment, or an empty string if there is none.
;;
;; The documentation part of a line comment is the text following a line
;; comment prefix from `prefixes` and a single whitespace character. For
;; example, given the lone comment prefix `(";;")`:
;;
;;     "foo"     => ""
;;     ";;"      => ""
;;     ";;bar"   => ""
;;     ";;;foo"  => ""
;;     ";; foo"  => "foo"
;;     ";;  foo" => " foo"
;;
(define (line-comment-content-accessor prefixes)
  (lambda (str)
    (let ((len (string-length str)))
      (or (any (lambda (p)
                 (let ((l (string-length p)))
                   (cond ((= l len)
                          (string))
                         ((and (<= l len) (char-whitespace? (string-ref str l)))
                          (substring str (+ l 1) len))
                         (else #f))))
               prefixes)
          (string)))))

;; As input is read, source lines are accumulated in reverse order, so
;; before they're returned as strings they're reversed, trimmed of empty
;; lines and joined by newlines.
(define (format-source-section lst)
  (string-join
   (drop-while string-null? (reverse (drop-while string-null? lst)))
   #\newline))

;; Creates an intermediate generator from `f` that performs some
;; formatting on the source sections it produces before yielding them to
;; the caller.
(define (make-source-section-generator f)
  (make-generator
   (let ((g (make-generator f)))
     (lambda (yield)
       (ad-infinitum
        (lambda ()
          (let-values (((docs code) (g)))
            (if (eof-object? docs)
                (yield docs code)
                (yield (format-source-section docs)
                       (format-source-section code))))))))))

;; Creates a source section reader for the given list of line comment
;; prefixes. When invoked, this procedure yields two string values,
;; a comment and code, for each commented section of source code read in
;; turn from the given `port` (or `current-input-port`).
(define make-source-section-reader
  (case-lambda
    ((comment-prefixes)
     (make-source-section-reader comment-prefixes (current-input-port)))
    ((comment-prefixes port)
     (let ((comment?        (line-comment-predicate comment-prefixes))
           (comment-content (line-comment-content-accessor comment-prefixes)))
       (make-source-section-generator
        (lambda (yield)
          (let loop ((docs '())
                     (code '()))
            (let ((line (read-line port)))
              (cond ((eof-object? line)
                     (yield docs code)
                     (loop line line))
                    (else
                     (let ((str (string-drop-while char-whitespace? line)))
                       (if (comment? str)
                           (if (null? code)
                               (loop (cons (comment-content str) docs) code)
                               (begin
                                 (yield docs code)
                                 (loop (list (comment-content str)) (list))))
                           (loop docs (cons line code))))))))))))))