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

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

(module symbol-access

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

(import scheme)
(import (chicken base))
(import (chicken type))
(import (only (srfi 13) string-skip string-drop string-take string-index))

;;;

;;

(define-constant TOPLEVEL-MODULE-SYMBOL '||)

;;

(define-inline (namespace-tag-length str)
  ;namespaced identifier begins w/ '##'
  (cond
    ((string-skip str #\#) => identity)
    (else                  0) ) )

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

;;;

;; Toplevel Symbols

(: toplevel-module-symbol (#!optional symbol -> symbol))
;
(define toplevel-module-symbol (make-parameter #f (lambda (x)
  (cond
    ((not x)      TOPLEVEL-MODULE-SYMBOL)
    ((symbol? x)  x)
    (else
      (warning 'toplevel-module-symbol "not a symbol" x)
      (toplevel-module-symbol))))))

(: toplevel-module-string (-> string))
;
;symbol keyed memeoized string
(define toplevel-module-string
  (let ((+symbol+ #f) (+string+ #f))
    (lambda ()
      (if (eq? +symbol+ (toplevel-module-symbol))
        +string+
        (begin
          (set! +symbol+ (toplevel-module-symbol))
          (set! +string+ (symbol->string +symbol+))
          (toplevel-module-string) ) ) ) ) )

;; Raw Access Renames

(: global-symbol-bound? (symbol -> boolean))
;
(define (global-symbol-bound? sym) (##sys#symbol-has-toplevel-binding? sym))

(: global-symbol-ref (symbol -> *))
;
(define (global-symbol-ref sym) (##sys#slot sym 0))

;;

(: internal-module-name? (string -> boolean))
;
(define (internal-module-name? str)
  (not (zero? (namespace-tag-length str))) )

(: split-prefixed-symbol (symbol -> string string))
;
;=> module-name identifier-name
;
(define (split-prefixed-symbol sym)
  (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 (add1 idx)))
      (values (toplevel-module-string) str) ) ) )

) ;module symbol-access