application/octet-stream
•
8.56 KB
•
176 lines
; Subroutines and macros for formatted text output
[def fmt/format-arg/default @[
:debug #f
:base #f
:precision #nil
:width #nil
:padding-char " "
]]
[defun fmt/find-first-non-digit-from-right [s i]
[if [< i 0]
#f
[do [def char [char-at s i]]
[if [and [>= char #\0] [<= char #\9]]
[fmt/find-first-non-digit-from-right s [- i 1]]
i]]]]
[defun fmt/parse-spec [opts spec]
[if [zero? [string/length spec]]
opts
[case [char-at spec [- [string/length spec] 1]]
[[#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9]
[def next-non-digit [fmt/find-first-non-digit-from-right spec [- [string/length spec] 1]]]
[if next-non-digit
[fmt/parse-spec [tree/set! opts :precision [read/single [substr spec [+ next-non-digit 1] [string/length spec]]]]
[substr spec 0 next-non-digit]]
[-> [if [== #\0 [char-at spec 0]]
[tree/set! opts :padding-char "0"]
opts]
[tree/set! :width [read/single spec]]]]]
[#\? [fmt/parse-spec [tree/set! opts :debug #t]
[substr spec 0 [- [string/length spec] 1]]]]
[#\X [fmt/parse-spec [tree/set! opts :base :HEXADECIMAL]
[substr spec 0 [- [string/length spec] 1]]]]
[#\x [fmt/parse-spec [tree/set! opts :base :hexadecimal]
[substr spec 0 [- [string/length spec] 1]]]]
[#\d [fmt/parse-spec [tree/set! opts :base :decimal]
[substr spec 0 [- [string/length spec] 1]]]]
[#\o [fmt/parse-spec [tree/set! opts :base :octal]
[substr spec 0 [- [string/length spec] 1]]]]
[#\b [fmt/parse-spec [tree/set! opts :base :binary]
[substr spec 0 [- [string/length spec] 1]]]]
[otherwise [throw [list :format-error "Unknown form-spec option" spec [current-closure]]]]]]]
[defun fmt/debug [opts]
[if-not [opts :debug]
opts
[tree/set! opts :argument [list str/write [opts :argument]]]]]
[defun fmt/number-format [opts]
[case [opts :base]
[:binary [tree/set! opts :argument [list int->string/binary [opts :argument]]]]
[:octal [tree/set! opts :argument [list int->string/octal [opts :argument]]]]
[:decimal [tree/set! opts :argument [list int->string/decimal [opts :argument]]]]
[:hexadecimal [tree/set! opts :argument [list int->string/hex [opts :argument]]]]
[:HEXADECIMAL [tree/set! opts :argument [list int->string/HEX [opts :argument]]]]
[otherwise opts]]]
[def fmt/number-format-prefixex @[
:binary "#b"
:octal "#o"
:decimal "#d"
:hexadecimal "#x"
:HEXADECIMAL "#x"
]]
[defun fmt/number-format-prefix [opts]
[if [or [not [opts :debug]] [not [opts :base]]] opts
[-> [if [member '[:binary :octal :decimal :hexadecimal :HEXADECIMAL] [opts :base]]
[tree/set! opts :argument [list cat
[fmt/number-format-prefixex [opts :base]]
[opts :argument]]]
opts]
[tree/set! :debug #f]]]]
[defun fmt/add-padding [opts]
[if-not [opts :width]
opts
[tree/set! opts :argument [list string/pad-start
[opts :argument]
[if [and [opts :debug] [opts :base]]
[- [opts :width] 2]
[opts :width]]
[opts :padding-char]]]]]
[defun fmt/output [opts]
[opts :argument]]
[defun fmt/format-arg [spec argument]
[-> [tree/set! [fmt/parse-spec [tree/dup fmt/format-arg/default] spec] :argument argument]
fmt/number-format
fmt/add-padding
fmt/number-format-prefix
fmt/debug
fmt/output]]
[defun fmt/valid-argument? [argument]
[or [int? argument] [symbol? argument]]]
[def fmt/expr/count 0]
[defun fmt/expr [expr arguments-used]
[when-not [string? expr]
[throw [list :format-error "fmt needs a string literal as a first argument, since it is implemented as a macro" expr [current-lambda]]]]
[def split-expr [split expr ":"]]
[def argument [car split-expr]]
[def format-spec [or [cadr split-expr] ""]]
[if [== "" argument]
[do [array/set! arguments-used [-- fmt/expr/count] #t]
[fmt/format-arg format-spec [str->sym [string fmt/expr/count]]]]
[let [[read-vals [read argument]]]
[when [cdr read-vals]
[throw [list :format-error "Format argument specifier contains more than a single atom" argument [current-lambda]]]]
[when-not [fmt/valid-argument? [car read-vals]]
[throw [list :format-error "Format argument specifier should be either an integer or a symbol" argument [current-lambda]]]]
[when [int? [car read-vals]]
[when [or [< [car read-vals] 0] [>= [car read-vals] [array/length arguments-used]]]
[throw [list :format-error "fmt numbered argument is out of bounds" argument [current-lambda]]]]
[array/set! arguments-used [car read-vals] #t]]
[fmt/format-arg format-spec [str->sym [string [car read-vals]]]]]]]
[def fmt/args/map-fun/count 0]
[defun fmt/args/map-fun [arg]
[def s [str->sym [string fmt/args/map-fun/count]]]
[++ fmt/args/map-fun/count]
[list 'def s arg]]
[defmacro fmt [format-string . args]
"Return a formatted string"
[when-not [string? format-string]
[throw [list :type-error "fmt needs a string literal as a first argument, since it is implemented as a macro" format-string [current-lambda]]]]
[def cuts #nil]
[for [i 0 [string/length format-string]]
[case [char-at format-string i]
[#\{ [do [when [int? [car cuts]] [throw [list :format-error "fmt placeholders can't be nested" format-string [current-lambda]]]]
[set! cuts [cons i cuts]]]]
[#\} [do [when-not [int? [car cuts]] [throw [list :format-error "fmt expects all brackets to be closed" format-string [current-lambda]]]]
[set! cuts [cons [cons [car cuts] i] [cdr cuts]]]]]]]
[when [int? [car cuts]] [throw [list :format-error "fmt placeholders can't be nested" format-string [current-lambda]]]]
[def expr-list #nil]
[def last-pos [string/length format-string]]
[def arguments-used [-> [array/allocate [length args]] [array/fill! #f]]]
[set! fmt/expr/count [array/length arguments-used]]
[for-in [c cuts]
[def lit [substr format-string [+ [cdr c] 1] last-pos]]
[when-not [== "" lit] [set! expr-list [cons lit expr-list]]]
[def expr [fmt/expr [substr format-string [+ 1 [car c]] [cdr c]] arguments-used]]
[set! expr-list [cons expr expr-list]]
[set! last-pos [car c]]]
[when [> last-pos 0]
[def lit [substr format-string 0 last-pos]]
[set! expr-list [cons lit expr-list]]]
[for [i 0 [array/length arguments-used]]
[when-not [array/ref arguments-used i]
[throw [list :format-error "fmt expects all arguments to be used" [list format-string [list/ref args i]] [current-lambda]]]]]
[def expr [if [cdr expr-list]
[cons 'cat expr-list]
[if [string? [car expr-list]]
[car expr-list]
[cons 'string expr-list]]]]
[set! fmt/args/map-fun/count 0]
[if args
`[let* ~@[map args fmt/args/map-fun]
~expr]
expr]]
[defmacro pfmt [format-string . args]
"Print a formatted string"
`[print [fmt ~format-string ~@args]]]
[defmacro efmt [format-string . args]
"Print a formatted string"
`[error [fmt ~format-string ~@args]]]
