zilch/lang/rust/src/cfg.sld

;; Procedures to parse `cfg` attributes, as well as match them against
;; conditionals found in crate definitions.
(define-library (zilch lang rust cfg)
 (import
  (scheme base)
  (srfi 152))

 (export cfg-parse cfg-matches)

 (begin
   (define (is-ident-start ch)
     (or
      (char=? ch #\_)
      (and (char>=? ch #\A) (char<=? ch #\Z))
      (and (char>=? ch #\a) (char<=? ch #\z))))

   (define (is-ident-rest ch)
     (or
       (is-ident-start ch)
       (and (char>=? ch #\0) (char<=? ch #\9))))

   (define (tokenize-cfg strval index tail)
     (if (>= index (string-length strval))
       (reverse tail)
       (case (string-ref strval index)
         ((#\space) (tokenize-cfg strval (+ index 1) tail))
         ((#\x28) (tokenize-cfg strval (+ index 1) (cons 'left-paren tail)))
         ((#\x29) (tokenize-cfg strval (+ index 1) (cons 'right-paren tail)))
         ((#\,) (tokenize-cfg strval (+ index 1) (cons 'comma tail)))
         ((#\=) (tokenize-cfg strval (+ index 1) (cons 'equals tail)))
         ((#\")
          (let ((end (string-index strval (lambda (f) (char=? f #\")) (+ index 1))))
            (unless end (error "Unterminated string in cfg() string" strval))
            (tokenize-cfg strval (+ end 1) (cons (string-copy strval (+ index 1) end) tail))))
         (else
          (if (is-ident-start (string-ref strval index))
            (let ((end (or (string-skip strval is-ident-rest (+ index 1)) (string-length strval))))
               (tokenize-cfg strval end (cons (cons 'ident (string-copy strval index end)) tail)))
            (error "Unexpected character in cfg() string" strval))))))

   ;; Parses a configuration string or expression.
   ;;
   ;; - `key="value"` is represented as `('value . (key . value))`, where value can be `#f`.
   ;; - `all` and `any` are represented as `('all/'any . items)`, where `items` is a list of sub-expressions.
   ;; - `not(...)` is represented as `('not . value)`, where `value` is a sub-expression.
   (define (cfg-parse str)
     (define tokens (tokenize-cfg str 0 '()))
     (define (expect token)
       (when (null? tokens)
         (error "Unexpected EOF parsing cfg() string"))
       (unless (equal? token (car tokens))
         (error "Unexpected token" (cons (car tokens) token)))
       (set! tokens (cdr tokens)))
     (define (next)
       (define tok (car tokens))
       (set! tokens (cdr tokens))
       tok)
     (define (parse-cfg)
       (when (null? tokens)
         (error "Unexpected EOF parsing cfg() string"))
       (define token (next))
       (unless (and (pair? token) (equal? (car token) 'ident))
         (error "Unexpected token, expected identifier" token))
       (if (and (not (null? tokens)) (equal? (car tokens) 'equals))
         (begin
           (next)
           (let ((str-token (next)))
             (unless (string? str-token)
               (error "Unexpected token parsing cfg=, expected string" str-token))
             (values (cdr token) str-token)))
         (values (cdr token) #f)))

     ; Also consumes the right paren.
     (define (parse-comma-separated-expr tail)
       (when (null? tokens)
         (error "Unexpected EOF parsing cfg() expression contents"))
       (if (equal? (car tokens) 'right-paren)
         (begin (next) (reverse tail))
         (let ((parsed (parse-expr)))
           (if (or (null? tokens) (equal? (car tokens) 'comma))
             (begin (expect 'comma) (parse-comma-separated-expr (cons parsed tail)))
             (begin (expect 'right-paren) (reverse (cons parsed tail)))))))
     (define (parse-expr)
       (when (null? tokens)
         (error "Unexpected EOF parsing cfg() expression"))
       (define token (car tokens))
       (unless (and (pair? token) (equal? (car token) 'ident))
         (error "Unexpected token, expected identifier" token))
       (cond
         ((string=? (cdr token) "all")
          (next)
          (expect 'left-paren)
          (let ((tokens (parse-comma-separated-expr '())))
            (cons 'all tokens)))
         ((string=? (cdr token) "any")
          (next)
          (expect 'left-paren)
          (let ((tokens (parse-comma-separated-expr '())))
            (cons 'any tokens)))
         ((string=? (cdr token) "not")
          (next)
          (expect 'left-paren)
          (let ((expr (parse-expr)))
            (expect 'right-paren)
            (cons 'not expr)))
         (else
          (let-values (((left right) (parse-cfg)))
           (cons 'value (cons left right))))))
     (parse-expr))

   ;; Checks whether the parsed expression `expr` matches against the list of
   ;; config value pairs in `cfgs`.
   (define (cfg-matches expr cfgs)
     (define (parse-any tail)
       (cond
         ((null? tail) #f)
         ((cfg-matches (car tail) cfgs) #t)
         (else (parse-any (cdr tail)))))
     (define (parse-all tail)
       (cond
         ((null? tail) #t)
         ((not (cfg-matches (car tail) cfgs)) #f)
         (else (parse-all (cdr tail)))))
     (define (has-match-in-cfg pair tail)
       (cond
         ((null? tail) #f)
         ((equal? pair (car tail)) #t)
         (else (has-match-in-cfg pair (cdr tail)))))
     (case (car expr)
      ((value) (has-match-in-cfg (cdr expr) cfgs))
      ((any) (parse-any (cdr expr)))
      ((all) (parse-all (cdr expr)))
      ((not) (not (cfg-matches (cdr expr) cfgs)))
      (else (error "unknown cfg expression" expr))))))