application/octet-stream
•
12.02 KB
•
215 lines
;;; Nujel - Copyright (C) 2020-2021 - Benjamin Vincent Schulenburg
;;; This project uses the MIT license, a copy should be included under /LICENSE
;;;
;;; Subroutines and macros for formatted text output
(def fmt (let*
(def fmt/format-arg/default {:align :right
:debug #f
:base #f
:width #nil
:padding-char " "})
(defn fmt/find-non-digit-from-right (s i)
(if (< i 0)
-1
(do (def char (ref s i))
(if (and (>= char #\0) (<= char #\9))
(fmt/find-non-digit-from-right s (- i 1))
i))))
(defn fmt/parse-spec (opts spec)
(if (zero? (:length spec))
opts
(case (ref spec (- (:length spec) 1))
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(def next-non-digit (fmt/find-non-digit-from-right spec (- (:length spec) 1)))
(def number (:cut spec (+ 1 next-non-digit) (:length spec)))
(set! opts :width (read/single number))
(when (= #\0 (ref number 0))
(set! opts :padding-char "0"))
(fmt/parse-spec opts (:cut spec 0 (+ 1 next-non-digit))))
(#\? (fmt/parse-spec (set! opts :debug #t)
(:cut spec 0 (- (:length spec) 1))))
(#\X (fmt/parse-spec (set! opts :base :HEXADECIMAL)
(:cut spec 0 (- (:length spec) 1))))
(#\x (fmt/parse-spec (set! opts :base :hexadecimal)
(:cut spec 0 (- (:length spec) 1))))
(#\d (fmt/parse-spec (set! opts :base :decimal)
(:cut spec 0 (- (:length spec) 1))))
(#\o (fmt/parse-spec (set! opts :base :octal)
(:cut spec 0 (- (:length spec) 1))))
(#\b (fmt/parse-spec (set! opts :base :binary)
(:cut spec 0 (- (:length spec) 1))))
(#\< (fmt/parse-spec (set! opts :align :left)
(:cut spec 0 (- (:length spec) 1))))
(#\^ (fmt/parse-spec (set! opts :align :center)
(:cut spec 0 (- (:length spec) 1))))
(#\> (fmt/parse-spec (set! opts :align :right)
(:cut spec 0 (- (:length spec) 1))))
(#\. (fmt/parse-spec (set! opts :precision (ref opts :width))
(:cut spec 0 (- (:length spec) 1))))
(otherwise (exception :format-error "Unknown form-spec option" spec)))))
(defn fmt/debug (opts)
(if-not (ref opts :debug)
opts
(set! opts :argument (list string/write (ref opts :argument)))))
(defn fmt/number-format (opts)
(case (ref opts :base)
(:binary (set! opts :argument (list int->string/binary (ref opts :argument))))
(:octal (set! opts :argument (list int->string/octal (ref opts :argument))))
(:decimal (set! opts :argument (list int->string/decimal (ref opts :argument))))
(:hexadecimal (set! opts :argument (list int->string/hex (ref opts :argument))))
(:HEXADECIMAL (set! opts :argument (list int->string/HEX (ref opts :argument))))
(otherwise opts)))
(def fmt/number-format-prefixex {:binary "#b"
:octal "#o"
:decimal "#d"
:hexadecimal "#x"
:HEXADECIMAL "#x"})
(defn fmt/number-format-prefix (opts)
(if (or (not (ref opts :debug)) (not (ref opts :base))) opts
(-> (if (ref fmt/number-format-prefixex (ref opts :base))
(set! opts :argument (list cat
(ref fmt/number-format-prefixex (ref opts :base))
(ref opts :argument)))
opts)
(set! :debug #f))))
(defn fmt/add-padding (opts)
(if-not (ref opts :width)
opts
(set! opts :argument (list (case (ref opts :align)
(:right pad-start)
(:center pad-middle)
(:left pad-end))
(ref opts :argument)
(if (and (ref opts :debug) (ref opts :base))
(- (ref opts :width) 2)
(ref opts :width))
(ref opts :padding-char)))))
(defn fmt/precision (opts)
(if-not (ref opts :precision)
opts
(set! opts :argument (list string/round
(ref opts :argument)
(ref opts :precision)))))
(defn fmt/truncate (opts)
(if-not (ref opts :width)
opts
(set! opts :argument (list :cut
(ref opts :argument)
0
(+ 1 (ref opts :width))))))
(defn fmt/output (opts)
(ref opts :argument))
(defn fmt/format-arg (spec argument)
(-> (set! (fmt/parse-spec (:clone fmt/format-arg/default) spec) :argument argument)
fmt/number-format
fmt/precision
fmt/add-padding
fmt/truncate
fmt/number-format-prefix
fmt/debug
fmt/output))
(defn fmt/valid-argument? (argument)
(or (int? argument) (symbol? argument)))
(defn fmt/arg-sym (v)
(case (:type-name v)
(:int (fmt/arg-sym (cat "fmt-arg-" (:string v))))
(:symbol v)
(:string (:symbol v))
(otherwise (exception :type-error "Invalid fmt argument name" v))))
(defn fmt/expr (expr arguments-used opts)
(when-not (string? expr)
(exception :format-error "fmt needs a string literal as a first argument, since it is implemented as a macro" expr))
(def split-expr (split expr ":"))
(def argument (car split-expr))
(def format-spec (or (cadr split-expr) ""))
(if (= "" argument)
(do (tree/-- opts :expr-count)
(set! arguments-used (ref opts :expr-count) #t)
(fmt/format-arg format-spec (fmt/arg-sym (ref opts :expr-count))))
(let ((read-vals (read argument)))
(when (cdr read-vals)
(exception :format-error "Format argument specifier contains more than a single atom" argument))
(when-not (fmt/valid-argument? (car read-vals))
(exception :format-error "Format argument specifier should be either an integer or a symbol" argument))
(when (int? (car read-vals))
(when (or (< (car read-vals) 0) (>= (car read-vals) (:length arguments-used)))
(exception :format-error "fmt numbered argument is out of bounds" argument))
(set! arguments-used (car read-vals) #t))
(fmt/format-arg format-spec (fmt/arg-sym (car read-vals))))))
(defmacro fmt (format-string . args)
"Return a formatted string"
(when-not (string? format-string)
(exception :type-error "fmt needs a string literal as a first argument, since it is implemented as a macro" format-string))
(def cuts #nil)
(dotimes (i (:length format-string))
(case (ref format-string i)
(#\{ (do (when (int? (car cuts)) (exception :format-error "fmt placeholders can't be nested" format-string))
(set! cuts (cons i cuts))))
(#\} (do (when-not (int? (car cuts)) (exception :format-error "fmt expects all brackets to be closed" format-string))
(set! cuts (cons (cons (car cuts) i) (cdr cuts)))))))
(when (int? (car cuts)) (exception :format-error "fmt placeholders can't be nested" format-string))
(def expr-list #nil)
(def last-pos (:length format-string))
(def arguments-used (-> (:alloc Array (:length args)) (array/fill! #f)))
(def opts {:expr-count (:length arguments-used)})
(doseq (c cuts)
(def lit (:cut format-string (+ (cdr c) 1) last-pos))
(when-not (= "" lit) (set! expr-list (cons lit expr-list)))
(def expr (fmt/expr (:cut format-string (+ 1 (car c)) (cdr c)) arguments-used opts))
(set! expr-list (cons expr expr-list))
(set! last-pos (car c)))
(when (> last-pos 0)
(def lit (:cut format-string 0 last-pos))
(set! expr-list (cons lit expr-list)))
(dotimes (i (:length arguments-used))
(when-not (ref arguments-used i)
(exception :format-error "fmt expects all arguments to be used" (list format-string (ref args i)))))
(def expr (if (cdr expr-list)
(cons 'cat expr-list)
(if (string? (car expr-list))
(car expr-list)
(cons 'string/display expr-list))))
(def fmt/args/map-fun/count 0)
(defn fmt/args/map-fun (arg)
(def s (:symbol (cat "fmt-arg-" (:string fmt/args/map-fun/count))))
(inc! fmt/args/map-fun/count)
(list 'def s arg))
(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)))
(defmacro pfmtln (format-string . args)
"Print a formatted string"
`(println (fmt ~format-string ~@args)))
(defmacro efmtln (format-string . args)
"Print a formatted string"
`(errorln (fmt ~format-string ~@args)))
