;;;; symbol-environment-access.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18

(declare
  (bound-to-procedure
    ##sys#macro-environment
    ##sys#current-environment
    ##sys#macro?))

#|
##sys namespace

;alist
module-table (list-of (pair module-identifier module))
module-name (module --> symbol)

(for-each (lambda (e) (assert (eq? (car e) (##sys#module-name (cdr e)))))
          ##sys#module-table)

module-alias-environment ???
module-exports ???
|#

(include-relative "symbol-table-access")

(module symbol-environment-access

(;export
  ;
  system-current-environment
  system-macro-environment
  ;
  macro-symbol-in-environment?
  ;
  search-macro-environment-symbols
  search-system-environment-symbols
  #; ;UNUSED
  search-environments-symbols
  ;
  search-interaction-environment-symbols
  search-list-environment-symbols)

(import scheme)
(import (chicken base))
(import (chicken type))
#; ;UNUSED
(import (only (srfi 1) append!))
(import (prefix symbol-table-access symbol-table-))

;opaque
(define-type macro-environment list)

(: system-current-environment (-> list))
(: system-macro-environment (-> list))
(: macro-symbol-in-environment? (symbol macro-environment -> boolean))
(: search-list-environment-symbols ((* -> boolean) (list-of (pair symbol *)) #!optional (pair -> *) --> list))
(: search-interaction-environment-symbols ((* -> boolean) -> list))
(: search-macro-environment-symbols ((* -> boolean) (list-of (pair symbol *)) --> list))
(: search-system-environment-symbols ((* -> boolean) #!optional (or (list-of (pair symbol *)) boolean) -> list))
(: search-environments-symbols ((* -> boolean) -> list))

;;

(define-inline (cons-if test? x xs) (if (test? x) (cons x xs) xs))

;;

(define system-current-environment ##sys#current-environment)
(define system-macro-environment ##sys#macro-environment)

(define macro-symbol-in-environment? ##sys#macro?)

;;

(define (search-list-environment-symbols test? env #!optional (elmref car))
  (define (cons-if-symbol syms cell) (cons-if test? (elmref cell) syms))
  (foldl cons-if-symbol '() env) )

(define (search-interaction-environment-symbols test?)
  (symbol-table-cursor-foldl (lambda (syms sym) (cons-if test? sym syms)) '()) )

;;

(define (search-macro-environment-symbols test? env)
  (search-list-environment-symbols test? env) )

(define (search-system-environment-symbols test? #!optional env)
  (if (list? env)
      (search-list-environment-symbols test? env)
      (search-interaction-environment-symbols test?) ) )

;;

#; ;UNUSED
(define (search-environments-symbols test?)
  (append! (search-macro-environment-symbols test? (system-macro-environment))
           (search-system-environment-symbols test? (system-current-environment))
           (search-system-environment-symbols test?)) )

) ;module symbol-environment-access