#!/bin/sh
#| -*- mode: scheme; geiser-scheme-implementation: chicken -*-
exec csi -R r7rs -ss "$0" "$@"
RUSE --- by case duckworth
Make r7rs library files out of source scheme files
|#

#+chicken (import (r7rs))
(import (scheme base)
        (scheme file)
        (scheme write)
        (chicken pathname)
        (chicken pretty-print)
        (chicken string)
        (utf8))

(define (displayln str)
  (display str)
  (newline))

(define (filter pred xs)
  (let loop ((pred pred)
             (xs xs)
             (acc '()))
    (cond
     ((null? xs)
      (reverse acc))
     ((pred (car xs))
      (loop pred (cdr xs) (cons (car xs) acc)))
     (else
      (loop pred (cdr xs) acc)))))

(define (top-level-defines tree)
  (map (lambda (d)
         (if (pair? (cadr d))
             (caadr d)
             (cadr d)))
       (filter (lambda (x)
                 (memq (car x)
                       '( define
                          define-syntax
                          define-record-type
                          define-values
                          ;; others ?
                          )))
               tree)))

(define (top-level-imports tree)
  (filter (lambda (x) (memq (car x) '(import)))
          tree))

(define (slurp-file file)
  (with-input-from-file file
    (lambda ()
      (let loop ((next (read))
                 (it '()))
        (if (eof-object? next)
            (reverse it)
            (loop (read) (cons next it)))))))

(define (assq-ref x alist)
  (and (assq x alist)
       (cdr (assq x alist))
       #f))

(define (file->library-definition file . args)
  (let* ((tree (slurp-file file))
         (name (file->library-name file))
         (exports (top-level-defines tree))
         (imports (top-level-imports tree))
         ;; Possibly: `include-library-interface' ?
         (includer (or (assq-ref 'includer args) 'include))
         (includes (list file)))
    `(define-library ,name
       (export ,@exports)
       ,@imports
       (,includer ,@includes))))

(define (file->library-name file)
  (map string->symbol
       (string-split (pathname-file file) ".")))

(define cond-expand-form
  '(cond-expand
     (chicken (import (r7rs)))
     (else)))

(define (write-library-definition library-definition . port)
  (parameterize ((current-output-port (if (null? port)
                                          (current-output-port)
                                          port))
                 (pretty-print-width 80))
    (displayln (string-append ";;; " (->string
                                      (cadr library-definition))
                              " --- library definition"))
    (displayln ";; This file was automatically generated by ruse.\n")
    (pretty-print cond-expand-form)
    (newline)
    (pretty-print library-definition)
    (newline)))