source: project/release/4/symbol-utils/trunk/symbol-name-utils.scm @ 35750

Last change on this file since 35750 was 35750, checked in by Kon Lovett, 2 years ago

add keyword->...

File size: 3.0 KB
Line 
1;;;; symbol-name-utils.scm
2;;;; Kon Lovett, Jul '18
3
4(declare
5  (bound-to-procedure
6    ##sys#symbol->qualified-string
7    ##sys#qualified-symbol-prefix
8    ##sys#symbol->string))
9
10(module symbol-name-utils
11
12(;export
13  keyword->symbol
14  keyword->uninterned-symbol
15  symbol->keyword
16  symbol-printname-details
17  symbol-printname=? symbol-printname<?
18  symbol-printname-length
19  max-symbol-printname-length)
20
21(import scheme chicken)
22(use
23  (only data-structures o)
24  (only symbol-qualified-utils
25    exploded-qualified-symbol=? exploded-qualified-symbol<?)
26  (only type-checks check-symbol check-list))
27
28;;
29
30(: keyword->symbol (symbol --> symbol))
31;
32(define keyword->symbol (o string->symbol keyword->string))
33
34(: keyword->uninterned-symbol (symbol --> symbol))
35;
36(define keyword->uninterned-symbol (o string->uninterned-symbol keyword->string))
37
38;;
39
40;symbol->string drops namespace qualification!
41;which means a keyword and a symbol of the same name have the same printname.
42
43(: symbol->keyword (symbol --> symbol))
44;
45(define (symbol->keyword sym)
46  (if (keyword? sym)
47    sym
48    (string->keyword (symbol->string (check-symbol 'symbol->keyword sym))) ) )
49
50;;
51
52(: *symbol-printname-details (symbol --> string string))
53;
54(define (*symbol-printname-details sym)
55  (let ((p (##sys#qualified-symbol-prefix sym)))
56    (values
57      (##sys#symbol->string sym)
58      (cond
59        ((not p)                      "" )
60        ((eq? #\x0 (string-ref p 0))  ":")
61        (else                         (substring p 1) ) ) ) ) )
62
63(: symbol-printname-details (symbol --> string string))
64;
65(define (symbol-printname-details sym)
66  (let-values (
67    ((s p) (*symbol-printname-details (check-symbol 'symbol-printname-details sym))))
68    ;do not expose the symbol's "raw" printname
69    (values (string-copy s) p) ) )
70
71(: symbol-printname=? (symbol symbol --> boolean))
72;
73(define (symbol-printname=? x y)
74  (let-values (
75    ((sx px) (*symbol-printname-details (check-symbol 'symbol-printname=? x)))
76    ((sy py) (*symbol-printname-details (check-symbol 'symbol-printname=? y))) )
77    (exploded-qualified-symbol=? px sx py sy) ) )
78
79(: symbol-printname<? (symbol symbol --> boolean))
80;
81(define (symbol-printname<? x y)
82  (let-values (
83    ((sx px) (*symbol-printname-details (check-symbol 'symbol-printname<? x)))
84    ((sy py) (*symbol-printname-details (check-symbol 'symbol-printname<? y))) )
85    (exploded-qualified-symbol<? px sx py sy) ) )
86
87;;
88
89(: symbol-printname-length (symbol --> fixnum))
90;
91(define (symbol-printname-length sym)
92  (let (
93    (len
94      (string-length
95        (##sys#symbol->qualified-string
96          (check-symbol 'symbol-printname-length sym)))) )
97    (if (keyword? sym)
98      (fx- len 2) ;compensate for leading '###' when only a ':' is printed
99      len ) ) )
100
101(: max-symbol-printname-length ((list-of symbol) --> fixnum))
102;
103(define (max-symbol-printname-length syms)
104  (if (null? (check-list 'max-symbol-printname-length syms))
105    '()
106    (apply max (map symbol-printname-length syms)) ) )
107
108) ;module symbol-name-utils
Note: See TracBrowser for help on using the repository browser.