;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; schematic/extract.scm
;;;
;;; See this project's README for more information.
;;;
;;; Copyright (c) 2013-2018, Evan Hanson <evhan@foldling.org>
;;; See LICENSE for details.
;;;

(cond-expand
  (chicken
   (import (only (chicken base) symbol-append)))
  (else
   (define (symbol-append . symbols)
     (string->symbol
      (apply string-append (map symbol->string symbols))))))

;;;
;;; Read helpers.
;;;

;; `read`, but returns `#false` on error.
(define (read/guard port)
  (guard (_ (else #false))
    (read port)))

;;
;; Reads the `car` of the pair on `port`, returning `#false` if the read
;; operation signals an error or if no pair is encountered.
;;
;; Does not handle multiline or datum comments.
;;
(define (read-car port)
  ;; Discard whitespace and line comments.
  (do ((c (peek-char port) (peek-char port)))
      ((or (eof-object? c) (not (memq c '(#\; #\space #\tab #\newline)))))
    (case (read-char port)
      ((#\;) (read-line port))))
  ;; Read one datum past a single opening parenthesis.
  (case (read-char port)
    ((#\() (read/guard port))
    (else #false)))

;;;
;;; List helpers.
;;;

;;
;; Splits a list at the first occurence of any member of `xs`, according
;; to `equals?`, returning two sublists.
;;
(define (list-split lst xs)
  (let loop ((a '())
             (b lst))
    (cond ((null? b)
           (values lst b))
          ((member (car b) xs)
           (values (reverse a) (cdr b)))
          (else
           (loop (cons (car b) a) (cdr b))))))

;;;
;;; Basic pattern matching.
;;;

;; Matches `form` against `pattern`, returning a list of all elements
;; from `form` that corresponded to a vector in `pattern`, or `#false`
;; if the two forms didn't otherwise match (in the sense of `equal?`).
(define (match form pattern)
  (let ((env '()))
    (define (extract x p)
      (cond ((vector? p)
             (set! env (cons x env))
             #true)
            ((and (pair? x) (pair? p))
             (and (extract (car x) (car p))
                  (extract (cdr x) (cdr p))))
            (else (equal? x p))))
    (and (extract form pattern)
         (reverse env))))

;; `case`-like syntax for `match`, above.
(define-syntax match-case
  (syntax-rules (else =>)
    ((_ form) (if #false #true))
    ((_ form (else . body)) (begin . body))
    ((_ form (pattern => proc) . clauses)
     (let ((results (match form (quote pattern))))
       (if (not results)
           (match-case form . clauses)
           (apply proc results))))
    ((_ form (pattern . body) . clauses)
     (if (match form (quote pattern))
         (begin . body)
         (match-case form . clauses)))))

;;;
;;; Output.
;;;

(define emit display)

(define (emit-documentation comment)
  (write comment))

(define (emit-specification type form)
  (write (cons type form)))

;;;
;;; Definition extraction.
;;;

;;
;; Extracts commented definitions from the Scheme code on `input`,
;; writing s-expressive specifications for each to `output`.
;;
;; Each of these specifications is of the form:
;;
;;     <specification> = (<comment> (<type> . <form>) ...)
;;     <comment>       = string?
;;     <form>          = any?
;;     <type>          = 'procedure | 'syntax | 'constant
;;                     | 'parameter | 'record | 'string
;;                     | 'type
;;
(define extract-definitions
  (case-lambda
    (()
     (extract-definitions '(";;" ";;;") #f (current-input-port) (current-output-port)))
    ((input)
     (extract-definitions '(";;" ";;;") #f input (current-output-port)))
    ((input output)
     (extract-definitions '(";;" ";;;") #f input output))
    ((types input output)
     (extract-definitions '(";;" ";;;") types input output))
    ((comment-prefixes types input output)
     (parameterize ((current-output-port output))
       (port-fold-source-sections
        (lambda (comment code carry)
          (when (pair? carry)
            (set! comment (car carry))
            (set! code (string-append (cdr carry) code)))
          (let ((in (open-input-string code)))
            (let loop ()
              (cond
                ((string=? comment ""))
                ((read/guard in) =>
                 (lambda (form)
                   (match-case form
                     ((define (#(name) . #(args)) . #(_)) =>
                      (lambda (name args _)
                        (emit #\()
                        (emit-documentation comment)
                        (emit-specification 'procedure (cons name args))
                        (emit #\))))
                     ((define #(name) (lambda #(args) . #(_))) =>
                      (lambda (name args _)
                        (emit #\()
                        (emit-documentation comment)
                        (emit-specification 'procedure (cons name args))
                        (emit #\))))
                     ((define #(name) (case-lambda . #(clauses))) =>
                      (lambda (name clauses)
                        (emit #\()
                        (emit-documentation comment)
                        (for-each (lambda (args)
                                    (emit-specification 'procedure (cons name args)))
                                  (map car clauses))
                        (emit #\))))
                     ((define #(name) (make-parameter . #(_))) =>
                      (lambda (name _)
                        (emit #\()
                        (emit-documentation comment)
                        (emit-specification 'parameter name)
                        (emit #\))))
                     ((define #(name) #(value)) =>
                      (lambda (name value)
                        (cond ((string? value)
                               (emit #\()
                               (emit-documentation comment)
                               (emit-specification 'string name)
                               (emit #\)))
                              ((not (pair? value))
                               (emit #\()
                               (emit-documentation comment)
                               (emit-specification 'constant name)
                               (emit #\))))))
                     ((define-syntax #(name) (syntax-rules #(_) . #(clauses))) =>
                      (lambda (name _ clauses)
                        (emit #\()
                        (emit-documentation comment)
                        (for-each (lambda (args)
                                    (emit-specification 'syntax (cons name args)))
                                  (map cdar clauses))
                        (emit #\))))
                     ((define-syntax #(name) . #(_)) =>
                      (lambda (name _)
                        (emit #\()
                        (emit-documentation comment)
                        (emit-specification 'syntax name)
                        (emit #\))))
                     ((define-record-type #(name) #(make) #(pred) . #(fields)) =>
                      (lambda (name make pred fields)
                        (emit #\()
                        (emit-documentation comment)
                        (emit-specification 'record name)
                        (emit-specification 'procedure make)
                        (emit-specification 'procedure `(,pred object))
                        (for-each (lambda (p)
                                    (emit-specification 'procedure `(,p ,name)))
                                  (map cadr fields))
                        (for-each (lambda (p)
                                    (when (pair? p)
                                      (emit-specification 'procedure `(,(car p) ,name value))))
                                  (map cddr fields))
                        (emit #\))))
                     ;; CHICKEN record shorthand.
                     ((define-record #(name) . #(fields)) =>
                      (lambda (name fields)
                        (emit #\()
                        (emit-documentation comment)
                        (emit-specification 'record name)
                        (emit-specification 'procedure `(,(symbol-append 'make- name) . ,fields))
                        (emit-specification 'procedure `(,(symbol-append name '?) object))
                        (for-each (lambda (f)
                                    (emit-specification 'procedure `(,(symbol-append name '- f) ,name)))
                                  fields)
                        (for-each (lambda (f)
                                    (emit-specification 'procedure `(,(symbol-append name '- f '-set!) ,name value)))
                                  fields)
                        (emit #\))))
                     ;; CHICKEN type syntax.
                     ((define-type #(name) #(type)) =>
                      (lambda (name type)
                        (when (eq? types #f)
                          (emit #\()
                          (emit-documentation comment)
                          (emit-specification 'type `(,name ,type))
                          (emit #\)))))
                     ;; CHICKEN type syntax.
                     ((: #(name) #(type)) =>
                      (lambda (name type)
                        (when (eq? types #f) (loop))
                        (when (eq? types #t)
                          (emit #\()
                          (emit-documentation comment)
                          (if (list? type)
                              (let-values (((arguments _) (list-split type '(-> -->))))
                                (if (eq? type arguments)
                                    (emit-specification type name)
                                    (emit-specification 'procedure `(,name . ,arguments))))
                              (emit-specification type name))
                          (emit #\))))))))
                (else
                 (case (call-with-port (open-input-string code) read-car)
                   ((define-library)) ; R7RS.
                   ((define-module))  ; Gauche.
                   ((module))         ; CHICKEN.
                   (else (cons comment code))))))))
        #false
        comment-prefixes
        input)))))