;;;; typed modules


(import-for-syntax chicken matchable)

(begin-for-syntax
 (use srfi-1))


(define-for-syntax (exports-and-types sig)
  (append-map
   (match-lambda
     ((and x (or (? symbol?) 
		 ('#:interface . _)
		 ('#:syntax . _)))
      (list (cons x #f)))
     (((? list? expnames) ': . more)
      (exports-and-types
       (map (lambda (expname) `(,expname : ,@more)) expnames)))
     (((? symbol? expname) ': 'syntax)
      (list (cons expname #f)))
     (((? symbol? expname) ': 'syntax iexports ...)
      (list (cons (cons expname iexports) #f)))
     (((? symbol? expname) ': type)
      (list (cons expname type)))
     (exp (syntax-error 'module "invalid export in signature" exp name)))
   sig))


(define-syntax signature
  (er-macro-transformer
   (lambda (x r c)
     (let ((%define-interface (r 'define-interface)))
       (match (strip-syntax x)
	 ((_ (? symbol? name) (sig ...))
	  (put! name 'typed-modules:signature sig)
	  (let ((e/t (exports-and-types sig)))
	    `(,%define-interface ,name ,(map car e/t))))
	 (_ (syntax-error 'signature "invalid `signature' form" x)))))))


(define-syntax module
  (er-macro-transformer
   (lambda (x r c)
     (let ((%module1 (r 'module1)))

       (define (eql? x)
	 (let ((x (r x)))
	   (lambda (y) (c x (r y)))))

       (define (expand-typed-module name sig body) ; expects "sig" to be stripped
	 (let ((e/t (exports-and-types sig)))
	   `(,%module1 
	     ,name
	     ,(map car e/t)
	     ;;XXX we could probably rename ":" on import to avoid nameclash
	     (import (only chicken :))	; no need to rename, it will be stripped anyway
	     ,@(filter-map
		(lambda (x/t)
		  (and-let* ((type (cdr x/t)))
		    `(: ,(car x/t) ,(cdr x/t))))
		e/t)
	     ,@body)))

       (match x
	 ;; retain functor-instantiation and module aliasing and modules that
	 ;; export everything
	 ((_ _ (or (? (eql? '=)) (? (eql? '*))) . _)
	  (cons %module1 (cdr x)))
	 ((_ name (? symbol? signame) body ...)
	  (cond ((get (strip-syntax signame) 'typed-modules:signature) =>
		 (lambda (sig)
		   (expand-typed-module name sig body)))
		(else (cons %module1 (cdr x)))))
	 ((_ name (sig ...) body ...)
	  (expand-typed-module name (strip-syntax sig) body))
	 ;; retain everything else
	 (_ (cons %module1 (cdr x))))))))