;;;; symbol-utils.scm
;;;; Kon Lovett, Aug '10
;;;; Kon Lovett, Aug '17

(module symbol-utils

(;export
  unbound-value unbound-value? unbound?
  symbol-value
  unspecified-value unspecified-value? unspecified?
  symbol->keyword
  symbol-printname-details
  symbol-printname=? symbol-printname<?
  symbol-printname-length
  max-symbol-printname-length
  interned-symbol?
  symbol->qualified-string
  make-qualified-uninterned-symbol
  make-qualified-symbol
  qualified-symbol? )

(import scheme chicken)
(use
  (only data-structures
    ->string)
  (only type-checks
    check-symbol check-list) )

(declare
  (always-bound
    ##sys#arbitrary-unbound-symbol)
  (bound-to-procedure
    ##sys#symbol->string
    ##sys#interned-symbol?
    ##sys#make-symbol
    ##sys#symbol->qualified-string
    ##sys#qualified-symbol-prefix
    ##sys#intern-symbol ) )

;;;

(define (->boolean obj)
  (and
    obj
    #t ) )

;;; Special Values

;; Unbound

(define-syntax unbound-value
	(syntax-rules ()
		((_)
			(##sys#slot '##sys#arbitrary-unbound-symbol 0) ) ) )

(define-syntax unbound-value?
	(syntax-rules ()
		((_ ?val)
			(eq? (unbound-value) ?val) ) ) )

(define-syntax unbound?
	(syntax-rules ()
		((_ ?sym)
			(unbound-value? (##sys#slot ?sym 0)) ) ) )

(define-syntax symbol-value
	(syntax-rules ()
    ;
    ((_ ?sym ?def)
      (let ((val (##sys#slot ?sym 0)))
        (if (unbound-value? val) ?def val) ) )
    ;
    ((_ ?sym)
      (symbol-value ?sym #f) ) ) )

;; Undefined

(define unspecified-value void)

(define-syntax unspecified-value?
	(syntax-rules ()
		((_ ?val)
			(eq? (unspecified-value) ?val) ) ) )

(define-syntax unspecified?
	(syntax-rules ()
		((_ ?obj)
			(unspecified-value? ?obj) ) ) )

;;

;symbol->string drops namespace qualification!
;which means a keyword and a symbol of the same name have the same printname.

(: symbol->keyword (symbol --> symbol))
(define (symbol->keyword sym)
  (if (keyword? sym)
    sym
    (string->keyword (symbol->string (check-symbol 'symbol->keyword sym))) ) )

;;

(: *symbol-printname-details (symbol --> string string))
(define (*symbol-printname-details sym)
  (let ((p (##sys#qualified-symbol-prefix sym)) )
    (values
      (##sys#symbol->string sym)
      (cond
        ((not p)                      "" )
        ((eq? #\x0 (string-ref p 0))  ":")
        (else                         (substring p 1) ) ) ) ) )

(: symbol-printname-details (symbol --> string string))
(define (symbol-printname-details sym)
  (let-values (
    ((s p) (*symbol-printname-details (check-symbol 'symbol-printname-details sym))))
    ;do not expose the symbol's "raw" printname
    (values (string-copy s) p) ) )

;;

(: qualified=? (string string string string --> boolean))
(define (qualified=? px sx py sy)
  (and (string=? px py) (string=? sx sy)) )

(: qualified<? (string string string string --> boolean))
(define (qualified<? px sx py sy)
  (or
    (and (string=? px py) (string<? sx sy))
    (string<? px py)) )

(: symbol-printname=? (symbol symbol --> boolean))
(define (symbol-printname=? x y)
  (let-values (
    ((sx px) (*symbol-printname-details (check-symbol 'symbol-printname=? x)))
    ((sy py) (*symbol-printname-details (check-symbol 'symbol-printname=? y))) )
    (qualified=? px sx py sy) ) )

(: symbol-printname<? (symbol symbol --> boolean))
(define (symbol-printname<? x y)
  (let-values (
    ((sx px) (*symbol-printname-details (check-symbol 'symbol-printname<? x)))
    ((sy py) (*symbol-printname-details (check-symbol 'symbol-printname<? y))) )
    (qualified<? px sx py sy) ) )

;;

#; ;Easier to read but more overhead
(define (symbol-printname-length sym)
  (cond
    ((keyword? sym)
      (+ 1 (string-length (##sys#symbol->string sym))) )
    ((##sys#qualified-symbol? sym)
      (string-length (##sys#symbol->qualified-string sym)) )
    (else
      (string-length (##sys#symbol->string sym)) ) ) )

(: symbol-printname-length (symbol --> fixnum))
(define (symbol-printname-length sym)
  (let (
    (len
      (string-length
        (##sys#symbol->qualified-string
          (check-symbol 'symbol-printname-length sym)))) )
    (if (keyword? sym)
      (fx- len 2) ;compensate for leading '###' when only a ':' is printed
      len ) ) )

(: max-symbol-printname-length ((list-of symbol) --> fixnum))
(define (max-symbol-printname-length syms)
  (if (null? (check-list 'max-symbol-printname-length syms))
    '()
    (apply max (map symbol-printname-length syms)) ) )

;;

(define-constant NAMESPACE-MAX-ID-LEN 31)

(define (valid-prefix-length? len)
  (and (fx<= 1 len) (fx<= len NAMESPACE-MAX-ID-LEN)) )

(define (%fixnum->char n)
  (##core#inline "C_make_character" (##core#inline "C_unfix" n)) )

;Note keywords are in the null namespace!

(: make-qualified-string (symbol * * --> string))
(define (make-qualified-string loc prefix name)
  (let* (
    (name       (->string name))
    (prefix     (->string prefix))
    (prefix-len (##sys#size prefix)) )
    (unless (valid-prefix-length? prefix-len)
      (error loc "invalid namespace identifier length" prefix) )
    (let (
      (length-prefix (##sys#make-string 1 (%fixnum->char prefix-len))) )
      (##sys#fragments->string
        (fx+ 1 (fx+ prefix-len (##sys#size name)))
        `(,length-prefix ,prefix ,name)) ) ) )

;; Chicken namespace qualified symbol.

(: make-qualified-symbol (* * --> symbol))
(define (make-qualified-symbol prefix name)
  (##sys#intern-symbol
    (make-qualified-string 'make-qualified-symbol prefix name)) )

(: make-qualified-uninterned-symbol (* * --> symbol))
(define (make-qualified-uninterned-symbol prefix name)
  (##sys#make-symbol
    (make-qualified-string 'make-qualified-symbol prefix name)) )

(: qualified-symbol? (symbol --> boolean))
(define (qualified-symbol? sym)
  (->boolean
    (##sys#qualified-symbol-prefix (check-symbol 'qualified-symbol? sym))) )

(: symbol->qualified-string (symbol --> string))
(define (symbol->qualified-string sym)
  (##sys#symbol->qualified-string (check-symbol 'symbol->qualified-string sym)) )

(: interned-symbol? (symbol --> boolean))
(define (interned-symbol? sym)
  (##sys#interned-symbol? (check-symbol 'interned-symbol? sym)) )

) ;module symbol-utils