;;;; 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)

(import scheme)
(import (chicken base))
(import (chicken type))
(import symbol-table-access)

;;;

;opaque
(define-type macro-environment *)

;;

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

;;;

;;

(: system-current-environment ( -> list))
;
(define system-current-environment ##sys#current-environment)

(: system-macro-environment ( -> list))
;
(define system-macro-environment ##sys#macro-environment)

;;

(: macro-symbol-in-environment? (symbol macro-environment -> boolean))
;
(define macro-symbol-in-environment? ##sys#macro?)

;;

(: search-list-environment-symbols ((* -> boolean) (list-of (pair symbol *)) #!optional (pair -> *) --> list))
;
(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) )

(: search-interaction-environment-symbols ((* -> boolean) -> list))
;
(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)) ) ) ) )

;;

(: search-macro-environment-symbols ((* -> boolean) (list-of (pair symbol *)) --> list))
;
(define (search-macro-environment-symbols test? env)
  (search-list-environment-symbols test? env) )

(: search-system-environment-symbols ((* -> boolean) (or (list-of (pair symbol *)) boolean) -> list))
;
(define (search-system-environment-symbols test? #!optional env)
  (if (list? env)
    (search-list-environment-symbols test? env)
    (search-interaction-environment-symbols test?) ) )

) ;module symbol-environment-access