(define-library (scheme-deps)

  (export main)

  (import (except (scheme base) features)
          (scheme file)
          (scheme read)
          (scheme write)
          (only (srfi 1) append-map append-reverse fold any every remove)
          (srfi 193))

  (cond-expand
   (chibi
    (import (chibi show)
            (chibi show pretty)))
   (gauche
    (import (only (gauche base) pprint)))
   (else))

  (cond-expand
   (chibi
    (begin
      (define (pretty-print obj)
        (show #t (pretty obj)))))
   (gauche
    (begin
      (define (pretty-print obj)
        (pprint obj))))
   (else
    (begin
      (define (pretty-print obj)
        (write obj)
        (newline)))))

  (begin

    (define edisp
      (lambda objs
        (for-each (lambda (obj) (display obj (current-error-port)))
                  objs)
        (newline (current-error-port))))

    (define (read-all)
      (let loop ((xs '()))
        (let ((x (read)))
          (if (eof-object? x) (reverse xs) (loop (cons x xs))))))

    ;;

    (define (natural? obj)
      (and (integer? obj) (exact? obj) (not (negative? obj))))

    ;;

    (define first car)
    (define second cadr)

    (define rest cdr)

    (define (list<? < a b)
      (cond ((null? a) (not (null? b)))
            ((null? b) #f)
            ((< (first a) (first b)) #t)
            ((< (first b) (first a)) #f)
            (else (list<? < (rest a) (rest b)))))

    (define (sorted-insert-unique < elem list)
      (let loop ((before '()) (tail list))
        (cond ((or (not (pair? tail))
                   (< elem (first tail)))
               (append-reverse before (cons elem tail)))
              ((< (first tail) elem)
               (loop (cons (first tail) before)
                     (rest tail)))
              (else
               list))))

    (define (sort-unique < list)
      (let loop ((sorted '()) (list list))
        (if (null? list)
            sorted
            (loop (sorted-insert-unique < (first list) sorted)
                  (rest list)))))

    (define (nonnull-list? obj)
      (and (list? obj)
           (not (null? obj))))

    (define (head? form head)
      (and (nonnull-list? form)
           (equal? head (first form))))

    (define (dehead form head)
      (if (head? form head)
          (rest form)
          (error "Mismatch" form head)))

    (define (if-nonnull head tail)
      (if (null? tail) '() `((,head ,@tail))))

    ;;

    (define (string-join parts delim)
      (if (null? parts)
          ""
          (fold (lambda (parts whole) (string-append whole delim parts))
                (first parts)
                (rest parts))))

    ;;

    (define (valid-library-name-part? obj)
      (or (symbol? obj) (natural? obj)))

    (define (valid-library-name? obj)
      (and (nonnull-list? obj)
           (every valid-library-name-part? obj)))

    (define (library-name-part->string part)
      (cond ((symbol? part) (symbol->string part))
            ((number? part) (number->string part))
            (else (error "Bad library name part" part))))

    (define (library-name-part<? a b)
      (string<? (library-name-part->string a)
                (library-name-part->string b)))

    (define (library-name<? a b)
      (list<? library-name-part<? a b))

    (define (format-library-name library-name separator extension)
      (string-append (string-join (map library-name-part->string library-name)
                                  separator)
                     extension))

    (define (library-name->filename library-name)
      (format-library-name library-name "/" ".sld"))

    ;;

    (define (no-consumer value) (error "No consumer"))
    (define (producer consumer) (lambda (value) ((consumer) value)))

    (define consume-name    (make-parameter no-consumer))
    (define consume-import  (make-parameter no-consumer))
    (define consume-include (make-parameter no-consumer))

    (define produce-name    (producer consume-name))
    (define produce-import  (producer consume-import))
    (define produce-include (producer consume-include))

    (define features (make-parameter '()))
    (define libraries (make-parameter '()))

    ;;

    (define (requirement-satisfied? exp)
      (cond ((symbol? exp)
             (not (not (member exp (features)))))
            ((head? exp 'library)
             (if (= 2 (length exp))
                 (not (not (member (second exp) (libraries))))
                 (error "Bad (library ...) requirement")))
            ((head? exp 'not)
             (if (= 2 (length exp))
                 (not (requirement-satisfied? (second exp)))
                 (error "Bad (not ...) requirement" exp)))
            ((head? exp 'and)
             (every requirement-satisfied? exp))
            ((head? exp 'or)
             (any requirement-satisfied? exp))
            (else
             (error "Bad cond-expand requirement" exp))))

    (define (walk-cond-expand form)
      (let loop ((clauses (dehead form 'cond-expand)))
        (if (null? clauses)
            (error "No cond-expand clause matches these features" (features))
            (let ((clause (first clauses)))
              (cond ((not (nonnull-list? clause))
                     (error "Bad cond-expand clause" clause))
                    ((or (equal? 'else (first clause))
                         (requirement-satisfied? (first clause)))
                     (walk-library-declarations (rest clause)))
                    (else
                     (loop (rest clauses))))))))

    (define (walk-include form)
      (if (and (head? form 'include) (= 2 (length form)))
          (produce-include (second form))
          (error "Bad include" form)))

    (define (walk-import-set import-set)
      (cond ((or (head? import-set 'except)
                 (head? import-set 'only)
                 (head? import-set 'prefix)
                 (head? import-set 'rename))
             (walk-import-set (second import-set)))
            ((list? import-set)
             (produce-import import-set))
            (else
             (error "Bad import set" import-set))))

    (define (walk-import form)
      (for-each walk-import-set (dehead form 'import)))

    (define ignored-declarations
      '(begin export))

    (define (walk-library-declaration decl)
      (cond ((head? decl 'cond-expand)
             (walk-cond-expand decl))
            ((head? decl 'include)
             (walk-include decl))
            ((head? decl 'import)
             (walk-import decl))
            ((and (nonnull-list? decl)
                  (member (first decl) ignored-declarations))
             (values))
            (else
             (edisp "warning: ignoring unknown library declaration " decl)
             (values))))

    (define (walk-library-declarations decls)
      (for-each walk-library-declaration decls))

    (define (walk-define-library exp)
      (unless (and (head? exp 'define-library) (>= (length exp) 3))
        (error "Bad define-library" exp))
      (let ((name (second exp))
            (decls (rest (rest exp))))
        (unless (valid-library-name? name)
          (error "Bad library name" name))
        (produce-name name)
        (walk-library-declarations decls)))

    (define (walk-sld-file sld-file)
      (for-each walk-define-library
                (with-input-from-file sld-file read-all)))

    (define-record-type <library>
      (make-library name source-file imports includes)
      library?
      (name library-name)
      (source-file library-source-file)
      (imports library-imports)
      (includes library-includes))

    (define (standard-or-implementation-library? library-name)
      (member (first library-name)
              '(chicken rnrs scheme srfi)))

    (define (library->chicken-extension library)
      (define (library-name->chicken library-name)
        (string->symbol (format-library-name library-name "." "")))
      `(extension
        ,(library-name->chicken (library-name library))
        (source ,(library-source-file library))
        ,@(if-nonnull 'source-dependencies
                      (library-includes library))
        ,@(if-nonnull 'component-dependencies
                      (map library-name->chicken
                           (remove standard-or-implementation-library?
                                   (library-imports library))))
        (csc-options "-R" "r7rs"
                     "-X" "r7rs")))

    (define-syntax add-to
      (syntax-rules ()
        ((add-to lis <)
         (lambda (elem)
           (set! lis (sorted-insert-unique < elem lis))))))

    (define (process-sld-file sld-file)
      (let ((name '())
            (imports '())
            (includes '()))
        (parameterize ((consume-name    (lambda (x) (set! name x)))
                       (consume-import  (add-to imports library-name<?))
                       (consume-include (add-to includes string<?)))
          (walk-sld-file sld-file))
        (make-library name sld-file imports includes)))

    (define (print-chicken libs)
      (for-each
       pretty-print
       `((distribution-files
          ,@(sort-unique
             string<?
             (append-map (lambda (lib)
                           (cons (library-source-file lib)
                                 (library-includes lib)))
                         libs)))
         (components
          ,@(map library->chicken-extension
                 libs)))))

    (define main
      (lambda ignored
        (parameterize ((features '(chicken))
                       (libraries '((srfi 13))))
          (let ((libs (map process-sld-file (command-args))))
            (print-chicken libs)))))))