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

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

(module symbol-environment-access

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

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

;;;

;opaque
(define-type macro-environment *)

(: 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 (itemref car))
  (define (cons-if-symbol syms cell) (cons-if test? (itemref cell) syms))
  (foldl cons-if-symbol '() env) )

(define (search-interaction-environment-symbols test?)
  (let loop ((cursor (cursor-first)) (syms '()))
    (let ((sym (cursor-current cursor)))
      (if (not sym)
        syms
        (loop (cursor-next cursor) (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?) ) )

;;

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

) ;module symbol-environment-access