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

Last change on this file since 38406 was 38406, checked in by Kon Lovett, 15 months ago

add ->symbol, add type-checks & remove compiler checks, style

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