;;;; symbol-name-utils.scm
;;;; Kon Lovett, Jul '18

(declare
  (bound-to-procedure
    ##sys#symbol->qualified-string
    ##sys#qualified-symbol-prefix
    ##sys#symbol->string))

(module symbol-name-utils

(;export
  symbol->keyword
  symbol-printname-details
  symbol-printname=? symbol-printname<?
  symbol-printname-length
  max-symbol-printname-length)

(import scheme chicken)
(use
  (only symbol-qualified-utils
    exploded-qualified-symbol=? exploded-qualified-symbol<?)
  (only type-checks check-symbol check-list))

;;

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

(: 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))) )
    (exploded-qualified-symbol=? 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))) )
    (exploded-qualified-symbol<? px sx py sy) ) )

;;

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

) ;module symbol-name-utils