source: project/release/5/symbol-utils/trunk/symbol-name-utils.scm @ 37670

Last change on this file since 37670 was 37670, checked in by Kon Lovett, 4 months ago

keyword is disjoint

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