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

;; Issues
;;
;; - "variable" rather than parameter since only 1 symbol-table? seems
;; slightly faster.

(declare
  (bound-to-procedure
    ##sys#symbol-has-toplevel-binding?))

(module symbol-access

(;export
  ;
  toplevel-module-symbol
  excluded-modules
  ;
  global-symbol-bound?
  global-symbol-ref
  ;
  module-names? module-names
  internal-module-name? *internal-module-name?
  ;
  split-prefixed-symbol *split-prefixed-symbol)

(import scheme utf8)
(import (chicken base))
(import (chicken type))
(import (chicken syntax))
(import (chicken fixnum))
(import (only (srfi 1) member any every))
(import (only utf8-srfi-13 string-prefix? string-skip string-drop
                           string-take string-index))

(define-type module-names (list-of string))

(: module-names? (* -> boolean : module-names))
(: module-names ((list-of symbol) --> module-names))

(: toplevel-module-symbol (or (-> symbol)
                              (symbol -> symbol)))
(: excluded-modules (or (-> module-names)
                        (module-names -> module-names)))

(: *internal-module-name? (string module-names --> boolean))
(: *split-prefixed-symbol (symbol string --> string string))

;these depend on a parameter, so cannot be --> but are #:clean
(: internal-module-name? (string #!optional module-names -> boolean))
(: global-symbol-bound? (symbol -> boolean))
(: global-symbol-ref (symbol -> *))
(: split-prefixed-symbol (symbol #!optional string -> string string))

;;

;moremacros (define-guarded-variable)
;NOTE see Issues above
(define-syntax define-parameter
  (syntax-rules ()
    ((define-parameter ?name ?value ?guard)
     (define ?name
       (let* ((guard ?guard)
              (val (guard ?value)))
         (case-lambda
           (() val)
           ((obj)
             (set! val (guard obj))
             val ) ) ) ) )
    ((define-parameter ?name ?value)
     (define-parameter ?name ?value identity))
    ((define-parameter ?name)
     (define-parameter ?name (void)))))

;;

(define TOPLEVEL-MODULE-SYMBOL '||)
;NOTE ##core is inlined & ##compiler isn't runtime
(define DEFAULT-MODULE-EXCLUDES (module-names '(##sys chicken.internal)))

;;

(define-inline (namespace-tag-length str)
  ;namespaced identifier begins w/ '##'
  (or (string-skip str #\#)
      0) )

(define (global-symbol-name-start str)
  ;modulename & namespace identifier has no '#' (?)
  (string-index str #\# (namespace-tag-length str)) )

;; Toplevel Symbols

(define-parameter toplevel-module-symbol #f
  (lambda (obj)
    (cond ((not obj) TOPLEVEL-MODULE-SYMBOL)
          ((symbol? obj) obj)
          (else
            (error 'toplevel-module-symbol "bad argument type - not a symbol or #f" obj) ) ) ) )

;; Raw Access Renames

(define (global-symbol-bound? sym) (##sys#symbol-has-toplevel-binding? sym))

(define (global-symbol-ref sym) (##sys#slot sym 0))

;;

(define (module-names? x)
  (and (list? x)
       (every string? x)) )

(define (module-names x) (map symbol->string x))

(define-parameter excluded-modules #f
  (lambda (obj)
    (cond ((not obj) DEFAULT-MODULE-EXCLUDES)
          ((module-names? obj) obj)
          (else
            (error 'excluded-modules "bad argument type - not a list-of string or #f" obj) ) ) ) )

(define (*internal-module-name? str excld)
  (any (cut string-prefix? <> str) excld) )

(define (internal-module-name? str #!optional (excld (excluded-modules)))
  (*internal-module-name? str excld) )

;=> module-name identifier-name
;
(define (*split-prefixed-symbol sym topstr)
  (let* (;symbol name (keyword w/o print-mark)
         (str (symbol->string sym))
         ;module break char index
         (idx (global-symbol-name-start str)) )
    ;module?
    (if idx
        (values (string-take str idx) (string-drop str (fx+ idx 1)))
        (values topstr str) ) ) )

;=> module-name identifier-name
;
(define (split-prefixed-symbol sym #!optional (topstr (symbol->string (toplevel-module-symbol))))
  (*split-prefixed-symbol sym topstr) )

) ;module symbol-access