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

(module symbol-name-utils

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

(import scheme)
(import (chicken base))
(import (chicken type))
(import (chicken keyword))
(import (chicken fixnum))
(import (only (chicken string) ->string))
(import (only type-checks check-symbol check-keyword check-list))

;;

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

;;; Support

(: exploded-qualified-symbol=? (string string string string --> boolean))
(: exploded-qualified-symbol<? (string string string string --> 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-length ((or keyword symbol) --> fixnum))
(: max-symbol-printname-length ((list-of symbol) --> fixnum))

;;

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

(define (exploded-qualified-symbol<? px sx py sy)
  (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)
  (cond
    ((symbol? obj)  (string->uninterned-symbol (symbol->string obj)) )
    ((string? obj)  (string->uninterned-symbol obj) )
    (else           (string->uninterned-symbol (->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)
  (let-values (
    ((s p) (*symbol-printname-details 'symbol-printname-details sym)))
    ;do not expose the symbol's "raw" printname
    (values (string-copy s) 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-length sym)
  (cond
    ((keyword? sym)
      (string-length (keyword->string sym))
      #; ;compensate for leading '###' when only a ':' is printed
      (- (string-length (keyword->string sym)) 2) )
    (else
      (string-length (symbol->string (check-symbol 'symbol-printname-length sym))) ) ) )

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

) ;module symbol-name-utils