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

(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
    (only data-structures
      ->string conc)
    (only type-checks
      define-check+error-type
      check-symbol) )

  (require-library
    data-structures
    type-checks)

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

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

(define (symbol->keyword sym)
  (if (keyword? sym) sym
      (string->keyword (symbol->string sym)) ) )

;;

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

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

;;

(define (symbol-printname=? x y)

 (define (qualified=? px sx py sy)
    (and (string=? px py) (string=? sx sy)) )

  (let-values (((sx px) (*symbol-printname-details x))
               ((sy py) (*symbol-printname-details y)) )
    (qualified=? px sx py sy) ) )

(define (symbol-printname<? x y)

  (define (qualified<? px sx py sy)
    (or (and (string=? px py) (string<? sx sy))
        (string<? px py)) )

  (let-values (((sx px) (*symbol-printname-details x))
               ((sy py) (*symbol-printname-details 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)) ) ) )

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

(define (max-symbol-printname-length syms)
  (if (null? syms) '()
    (apply max (map symbol-printname-length syms)) ) )

;;

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

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

;Note keywords are in the null namespace!

(define (symbol-or-string? obj)
  (or (symbol? obj) (string? obj)) )

(define-check+error-type symbol-or-string)

#; ;UNUSED
(define (make-qualified-string prefix name)
  (let ((str (->string name)))
    (let* ((prefix (->string prefix))
           (prefix-len (##sys#size prefix)) )
      (if (<= 1 prefix-len NAMESPACE-MAX-ID-LEN)
        (##sys#fragments->string
          (+ 1 prefix-len (##sys#size str))
          `(,(##sys#make-string 1 (%fixnum->char prefix-len))
            ,prefix
            ,str))
        (error loc "invalid namespace identifier length" prefix) ) ) ) )

(define (make-qualified-string loc prefix name)
  ; symbol or string
  (check-symbol-or-string loc prefix "qualifier")   ;namespace
  (check-symbol-or-string loc name "qualified")  ;basename
  (let ((str (if (symbol? name) (##sys#symbol->string name) name)))
    (let* ((prefix (if (symbol? prefix) (##sys#symbol->string prefix) prefix))
           (prefix-len (##sys#size prefix)))
      (if (<= 1 prefix-len NAMESPACE-MAX-ID-LEN)
        (##sys#fragments->string
          (+ 1 prefix-len (##sys#size str))
          `(,(##sys#make-string 1 (%fixnum->char prefix-len))
            ,prefix
            ,str))
        (error loc "invalid namespace identifier length" prefix) ) ) ) )

;; Chicken namespace qualified symbol.

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

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

(define (qualified-symbol? sym)
  (check-symbol 'qualified-symbol? sym)
  (and (##sys#qualified-symbol-prefix sym)
       #t ) )

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

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

) ;module symbol-utils