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

(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?
  ;
  split-prefixed-symbol)

(import scheme utf8)
(import (chicken base))
(import (chicken type))
(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)))

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

;;

(import (chicken syntax))

;miscmacros

(define-syntax define-parameter
  (syntax-rules ()
    ((define-parameter name value guard)
     (define name (make-parameter value guard)))
    ((define-parameter name value)
     (define name (make-parameter value)))
    ((define-parameter name)
     (define name (make-parameter (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) ) ) ) )

;symbol keyed memoized string
(define cached-toplevel-module-string
  (let* ((topstr "")
         (topsym (string->uninterned-symbol topstr)) )
    (lambda ()
      (if (eq? topsym (toplevel-module-symbol)) topstr
          (begin
            (set! topsym (toplevel-module-symbol))
            (set! topstr (symbol->string topsym))
            (cached-toplevel-module-string) ) ) ) ) )

;; 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)
  (any (cut string-prefix? <> str) (excluded-modules)) )

;=> 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 (cached-toplevel-module-string) str) ) ) )

) ;module symbol-access