symbol-utils/symbol-name-utils.scm

;;;; symbol-name-utils.scm  -*- Scheme -*-
;;;; Kon Lovett, Mar '20
;;;; Kon Lovett, Jul '18

(declare
  (bound-to-procedure ##sys#check-symbol ##sys#check-keyword ##sys#check-list))

(module symbol-name-utils

(;export
  ;
  ->symbol
  ->uninterned-symbol
  keyword->symbol
  keyword->uninterned-symbol
  symbol->keyword
  ;
  symbol-printname-details
  symbol-printname=? symbol-printname<?
  symbol-printname-ci=? symbol-printname-ci<?
  symbol-printname-length
  max-symbol-printname-length
  ;
  module-printname module-printnames)

(import scheme)
(import (chicken base))
(import (chicken type))
(import (chicken keyword))
(import (chicken fixnum))
(import (chicken string))
(import (srfi 13))

(cond-expand
  (chicken-5.0
    (define-type keyword symbol))
  (chicken-6.0
    (define-type keyword symbol))
  (else))

(: exploded-qualified-symbol=? (string string string string #!optional boolean --> boolean))
(: exploded-qualified-symbol<? (string string string string #!optional boolean --> boolean))

(: *symbol-printname-details (symbol (or keyword symbol) --> string string))
(
: ->symbol (* --> symbol))
(: ->uninterned-symbol (* -> symbol))

(: keyword->symbol (keyword --> symbol))
(: keyword->uninterned-symbol (keyword -> symbol))
(: symbol->keyword ((or keyword symbol) --> keyword))

(: symbol-printname-details ((or keyword symbol) --> string string))

(: symbol-printname=? ((or keyword symbol) (or keyword symbol) --> boolean))
(: symbol-printname<? ((or keyword symbol) (or keyword symbol) --> boolean))
(: symbol-printname-ci=? ((or keyword symbol) (or keyword symbol) --> boolean))
(: symbol-printname-ci<? ((or keyword symbol) (or keyword symbol) --> boolean))

(: symbol-printname-length ((or keyword symbol) #!optional boolean --> fixnum))
(: max-symbol-printname-length ((list-of (or keyword symbol)) #!optional boolean --> fixnum))

(: module-printname (* -> (or false string)))
(: module-printnames (* -> (or false (list-of string))))

;;

(define (check-keyword loc obj) (##sys#check-keyword obj loc) obj)
(define (check-symbol loc obj) (##sys#check-symbol obj loc) obj)
(define (check-list loc obj) (##sys#check-list obj loc) obj)

;;

(define (exploded-qualified-symbol=? px sx py sy #!optional ci)
  (if ci
      (and (string-ci= px py) (string-ci= sx sy))
      (and (string=? px py) (string=? sx sy)) ) )

(define (exploded-qualified-symbol<? px sx py sy #!optional ci)
  (if ci
      (or (and (string-ci= px py) (string-ci< sx sy))
               (string-ci< px py))
      (or (and (string=? px py) (string<? sx sy))
          (string<? px py)) ) )

;;

(define (*symbol-printname-details loc sym)
  (cond ((keyword? sym) (values (keyword->string sym) ":"))
        (else (values (symbol->string (check-symbol loc sym)) ""))) )

;;;

;;

(define (->symbol obj)
  (cond ((symbol? obj) obj )
        ((string? obj) (string->symbol obj) )
        (else (string->symbol (->string obj)) ) ) )

(define (->uninterned-symbol obj)
  (string->uninterned-symbol (cond ((symbol? obj) (symbol->string obj))
                                   ((string? obj) obj)
                                   (else (->string obj)))) )

;;

(define (keyword->symbol kwd)
  (string->symbol (keyword->string (check-keyword 'keyword->symbol kwd))) )

(define (keyword->uninterned-symbol kwd)
  (string->uninterned-symbol (keyword->string (check-keyword 'keyword->uninterned-symbol kwd))) )

;;

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

(define (symbol->keyword sym)
  (cond ((keyword? sym) (the keyword sym))
        (else (string->keyword (symbol->string sym)) ) ) )

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

;FIXME (forall (a ...) (a a --> boolean))

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

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

(define (symbol-printname-ci=? x y)
  (let-values (((sx px) (*symbol-printname-details 'symbol-printname=? x))
               ((sy py) (*symbol-printname-details 'symbol-printname=? y)) )
    (exploded-qualified-symbol=? px sx py sy #t) ) )

(define (symbol-printname-ci<? x y)
  (let-values (((sx px) (*symbol-printname-details 'symbol-printname<? x))
               ((sy py) (*symbol-printname-details 'symbol-printname<? y)) )
    (exploded-qualified-symbol<? px sx py sy #t) ) )

;;

(define (symbol-printname-length sym #!optional (sexp? #f))
  (cond ((keyword? sym)
          (let ((l (string-length (keyword->string sym))))
            (fx+ l (if sexp? 2 1)) ) )
        (else
          (string-length (symbol->string (check-symbol 'symbol-printname-length sym))) ) ) )

(define (max-symbol-printname-length syms #!optional (sexp? #f))
  (foldl (lambda (mx sm) (fxmax mx (symbol-printname-length sm sexp?))) 0 (check-list 'max-symbol-printname-length syms)) )

;;

(define (module-printname obj)
  ;
  (define (norm-module-printname)
    (cond ((string? obj) obj)
          ((symbol? obj) (symbol->string obj))
          ((list? obj)
            (and-let* ((l (foldl
                            (lambda (l s)
                              (and (list? l) (symbol? s) (cons (symbol->string s) l)))
                            '()
                            obj))
                       (l (reverse l)) )
            (string-concatenate (intersperse l ".")) ) )
          (else #f)) )
  ;
  (define (srfi-module-printname)
    (and (list? obj) (= 2 (length obj))
         (eq? 'srfi (car obj))
         (and-let* ((n (cadr obj))
                    ((and (integer? n) (not (negative? n)))) )
           (string-append "srfi-" (number->string n)) ) ) )
  ;
  (or (srfi-module-printname) (norm-module-printname)) )

(define (module-printnames obj)
  (and (list? obj)
       (and-let* ((l (foldl
                       (lambda (l s)
                         (and (list? l)
                              (and-let* ((m (module-printname s))) (cons m l))) )
                       '()
                       obj)) )
         (reverse l) ) ) )

) ;module symbol-name-utils