;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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-2020, Evan Hanson <evhan@foldling.org>
;;; BSD-style license. See LICENSE for details.
;;;

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

(define-inline (append* x . y) (append x y))
(define-inline (list-copy x) (append* x))

(define forms '())
(define module #f)
(define exports '())
(define imports '())
(define imports/syntax '())
(define default-imports (list-copy chicken-default-imports))
(define default-imports/syntax (list-copy chicken-default-syntax-imports))
(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 (for-each-import specs proc)
  (for-each
   (lambda (x)
     (let-values (((name _ spec _ _ _) (##sys#decompose-import x identity eq? 'module)))
       (proc name spec)))
   specs))

(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)
     (for-each-import
      names
      (lambda (name spec)
        (set! imports (append* imports spec))
        (set! default-imports (delete name default-imports))))
     (walk-declaration rest))
    ((('import-for-syntax . names) . rest)
     (for-each-import
      names
      (lambda (name spec)
        (set! imports/syntax (append* imports/syntax spec))
        (set! default-imports/syntax (delete name default-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 ()
                                 ,@(if (null? default-imports) '() `((import ,@default-imports)))
                                 ,@(if (null? default-imports/syntax) '() `((import-for-syntax ,@default-imports/syntax)))
                                 ,@(if (null? imports) '() `((import ,@imports)))
                                 ,@(if (null? imports/syntax) '() `((import-for-syntax ,@imports/syntax)))
                                 ,@(if (null? exports) '() '((import (only chicken.module export))))
                                 ,@(if (null? exports) '() `((export ,@exports)))
                                 ,@(concatenate forms))))
                            (else
                             (concatenate forms)))))
       (when (string? source-line-number)
         (update-line-number-database! body))
       (continue prelude body postlude)))))