;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; schematic/read.scm
;;;
;;; This is a line-based source reader. It provides a procedure,
;;; `port-fold-source-sections`, that folds over each commented block of
;;; code read from an input port yielding comment/source code pairs.
;;;
;;; See this project's README for more information, or
;;; schematic-markdown.scm for a simple usage example.
;;;
;;; Copyright (c) 2013-2018, 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.
;;;

;; 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)))))

;; Trims all characters in `char` from the start and end of `str`.
(define (string-trim str char)
  (let ((len   (string-length str))
        (chars (if (pair? char) char (list char))))
    (do ((i 0 (+ i 1)))
        ((or (>= i len)
             (not (memv (string-ref str i) chars)))
         (do ((l (- len 1) (- l 1)))
             ((or (>= i l)
                  (not (memv (string-ref str l) chars)))
              (substring str i (+ l 1))))))))

;; Writes `str` and a trailing newline to `port`.
(define (write-line str port)
  (display str port)
  (newline port))

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

;; 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 isn't one.
;;
;; The documentation part of a line comment is the text following a
;; prefix in `prefixes` and a single whitespace character. For example,
;; given the comment prefix list `(";;")`:
;;
;;     "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)))))

;; Strips leading and trailing newlines from the output of `port`.
(define (get-output-string/chomp port)
  (string-trim (get-output-string port) #\newline))

;; Fold over each source section read in turn from the given `port`.
(define (port-fold-source-sections kons knil comment-prefixes port)
  (let ((comment?        (line-comment-predicate comment-prefixes))
        (comment-content (line-comment-content-accessor comment-prefixes)))
    (let next-section ((docs (open-output-string))
                       (code (open-output-string))
                       (knil knil))
      (let next-line ((input docs))
        (let ((line (read-line port)))
          (if (eof-object? line)
              (kons (get-output-string/chomp docs)
                    (get-output-string/chomp code)
                    knil)
              (let ((str (string-trim line '(#\tab #\space))))
                (cond ((not (comment? str))
                       (write-line line code)
                       (next-line code))
                      ((eq? input docs)
                       (write-line (comment-content str) docs)
                       (next-line docs))
                      (else
                       (let ((docs  (get-output-string/chomp docs))
                             (code  (get-output-string/chomp code))
                             (docs* (open-output-string))
                             (code* (open-output-string)))
                         (write-line (comment-content str) docs*)
                         (next-section
                          docs*
                          code*
                          (if (string=? "" docs code)
                              knil
                              (kons docs code knil)))))))))))))