⚠️ Warning: This is a draft ⚠️

This means it might contain formatting issues, incorrect code, conceptual problems, or other severe issues.

If you want to help to improve and eventually enable this page, please fork RosettaGit's repository and open a merge request on GitHub.

This code is a small library for dealing with options file, used in [[Update a configuration file]] and [[Read a configuration file]]. It is assumed to be in a file called "options.rkt".


#lang racket

(provide read-options write-options define-options ENABLE)

;; holds the verbatim line, includes empty lines
(struct comment (contents))
;; can gold a string or #t for no specified value
(struct option (name [value #:mutable] [disabled? #:mutable]))

;; a convenient global parameter to hold the current options
(define current-options (make-parameter '()))

;; reads and normalizes an options file
(define (read-options file)
  (define (parse raw-line)
    (define line (string-trim raw-line))
    (match line
      [(regexp #px"^(?:(?:#.*)?)$") (comment line)] ; includes empty lines
      [(regexp #px"^(;+)?\\s*([^;\\s]+)(?:(?:\\s*=\\s*|\\s+)(\\S.*))?$"
               (list _ dis name val))
       (option (string-upcase name)
               (or (not val)
                   (let* ([val (string-split val #px"\\s*,\\s*")]
                          [val (if (null? (cdr val)) (car val) val)])
                     (or (equal? "" val) val))) ; "" same as unspecified
               (and dis #t))]
      [(regexp #px"^;") #f] ; discard these lines
      [_ (error 'read-options "invalid line in options file: ~s" line)]))
  (define (same-option? x y)
    (and (option? x) (option? y) (equal? (option-name x) (option-name y))))
  (current-options (remove-duplicates (filter-map parse (file->lines file))
                                      same-option?)))

(define (write-options file)
  (with-output-to-file file #:exists 'truncate
    (λ() (for ([o (current-options)])
           (if (comment? o)
             (displayln (comment-contents o))
             (let ([v (option-value o)])
               (when (option-disabled? o) (display "; "))
               (display (option-name o))
               (when (string? v) (printf " ~a" v))
               (newline)))))))

;; a special constant that is used with `opt-set!' to just enable an option
(define ENABLE (gensym))

;; convert any value into #t (no specific value), #f (missing/disabled),
;; a string, or a list of these; #t is also for an empty list
(define (->val val)
  (define (-> x) (if (boolean? x) x (~a x)))
  (cond [(list? val) (and (pair? val) (map -> val))]
        [(eq? ENABLE val) #t]
        [else (-> val)]))

;; returns a value, #t for no-value-specified and #f for disabled or missing
(define (opt-ref name)
  (define NAME (string-upcase (~a name)))
  (define opt (for/or ([o (current-options)])
                (and (option? o) (equal? NAME (option-name o)) o)))
  (and opt (not (option-disabled? opt)) (option-value opt)))

;; use #f to disable, #t for a no-value, or a plain string; use a
;; special ENABLE constant to enable a previously disabled value
(define (opt-set! name val)
  (define NAME (string-upcase (~a name)))
  (define opt (for/or ([o (current-options)])
                (and (option? o) (equal? NAME (option-name o)) o)))
  (define (add-option o)
    ;; a separator line, and then the new option
    (current-options `(,@(current-options) ,(comment "") ,o)))
  (cond [(not (or opt val)) (void)] ; disable nonexistent => do nothing
        [(not opt) (add-option (option NAME (->val val) (not val)))]
        [(not val) (set-option-disabled?! opt #t)] ; preserves old value if any
        [else (set-option-disabled?! opt #f)
              (unless (eq? val ENABLE) (set-option-value! opt (->val val)))]))

;; make it possible to treat options as plain variables
(define-syntax-rule (define-options name ...)
  (begin (define-syntax name
           (syntax-id-rules (set!)
             [(set! _ val) (opt-set! 'name val)]
             [(_ . xs)     ((opt-ref 'name) . xs)]
             [_            (opt-ref 'name)]))
         ...))