;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; module-declarations.scm - Extend CHICKEN's built-in (declare ...)
;;; form with syntax for controlling modules.
;;;
;;;     (declare (module alphabet-soup)
;;;              (import abc def ghi)
;;;              (export uvw xyz))
;;;
;;; This file should be loaded as a compiler extension with the
;;; `-extend` flag to `csc`(1):
;;;
;;;     $ csc -extend module-declarations.scm <FILE>
;;;
;;; Copyright (c) 2014-2018, Evan Hanson <evhan@foldling.org>
;;; BSD-style license. See LICENSE for details.
;;;

(import (only (srfi 1) concatenate)
        (only (matchable) match)
        (only (chicken compiler user-pass) user-read-pass)
        (only (chicken io) read-list)
        (only (chicken internal) default-imports default-syntax-imports)
        (only (chicken string) string-split))

(define forms '())
(define module #f)
(define exports '())
(define imports '())
(define imports/syntax '())
(define source-filename #f)
(define source-line-number #f)

(define (set-module-source-info! x)
  (and-let* ((ln (get-line-number x))
             (fn (string-split ln ":")))
    (set! source-filename (car fn))
    (set! source-line-number (cadr fn))))

(define (walk-declaration e)
  (match e
    ((('module name) . rest)
     (set! module name)
     (set-module-source-info! (car e))
     (walk-declaration rest))
    ((('export . names) . rest)
     (set! exports (append names exports))
     (walk-declaration rest))
    ((('import . names) . rest)
     (set! imports (append names imports))
     (walk-declaration rest))
    ((('import-for-syntax . names) . rest)
     (set! imports/syntax (append names imports/syntax))
     (walk-declaration rest))
    ((declaration . rest)
     (cons declaration (walk-declaration rest)))
    (else e)))

(define (walk-expression e)
  (match e
    (('declare . body)
     (let ((rest (walk-declaration body)))
       (cond ((null? rest) '(##core#undefined))
             (else (cons (car e) rest)))))
    ((a . d)
     ;; This oddness is just to preserve line number information.
     (let ((a* (walk-expression a))
           (d* (walk-expression d)))
       (cond ((and (eq? a* a) (eq? d* d)) e)
             (else (cons a* d*)))))
    (else e)))

(define (read-list/source-info f)
  (fluid-let ((##sys#current-source-filename f))
    (call-with-input-file f
     (lambda (p)
       (read-list p chicken.compiler.support#read/source-info)))))

(define (string->expression s)
  (chicken.compiler.support#string->expr s))

(define (update-line-number-database! x)
  (fluid-let ((##sys#current-source-filename source-filename))
    (let loop ((x x))
      (when (pair? x)
        (unless (get-line-number x)
          (chicken.compiler.support#read-info-hook 'list-info x source-line-number))
        (loop (car x))
        (loop (cdr x))))))

(user-read-pass
 (let ((continue (or (user-read-pass) append)))
   (lambda (prelude files postlude)
     (let* ((forms    (map (compose walk-expression read-list/source-info) files))
            (prelude  (map (compose walk-expression string->expression) prelude))
            (postlude (map (compose walk-expression string->expression) postlude))
            (body     (cond (module
                             `((module ,module ()
                                 (import . ,default-imports)
                                 (import-for-syntax . ,default-syntax-imports)
                                 ,@(if (null? exports) '() '((import (only chicken.module export))))
                                 ,@(map (lambda (i) `(import ,i)) imports)
                                 ,@(map (lambda (i) `(import-for-syntax ,i)) imports/syntax)
                                 ,@(map (lambda (e) `(export ,e)) exports)
                                 ,@(concatenate forms))))
                            (else
                             (concatenate forms)))))
       (when (string? source-line-number)
         (update-line-number-database! body))
       (continue prelude body postlude)))))