Intransitive Operator Precedence

custom-operator-stuff.rkt

#lang racket

; Inspired by https://blog.adamant-lang.org/2019/operator-precedence/
;
; This racket file implements grouping infix operators with intransitive operator precedence,
; a task that the above blog post does not attempt to describe. This implementation does not handle
; ternary operators, nor the breifly-mentioned extension that allows the left and right sides of an
; operator to have different precedence relationships.
;
; This implementation observes that using only the intransitive relation rules, it is impossible to
; determine how to group expressions of the form (expr 1 expr 3 expr 2 expr) where 1 <. 2 and
; 2 <. 3 but there is no relationship between 1 and 3. This impementation solves this problem by
; defining a second, transitive, relationship with the property that a <. b implies a < b and
; a =.= b implies a == b. This is possible because the intransitive relationship is acyclic. The
; strategy is then to group expressions using the transitive relationship, then check that the
; resulting grouping also obeys the intransitive relationship. Using this strategy, the expression
; (expr 1 expr 3 expr 2 expr) is grouped as expected: (expr 1 ((expr 3 expr) 2 expr)) and the
; expression (expr 1 expr 3 expr) (which should be rejected) is grouped as (expr 1 (expr 3 expr))
; before being rejected as operators 1 and 3 have no (intransitive) relation.
;
; Examples:
; Evaluating (parse-binops '(a / b + 5 * 6 == 7 or james + 5 == 3 and that))
; Yields '(or (== (+ (/ a b) (* 5 6)) 7) (and (== (+ james 5) 3) that))
;
; Evaluating (parse-binops '(a + 5 and c))
; Yields error: No relationship between + and and operators.
;
; Evaluating (parse-binops '(a xor b or c))
; Yields error: No relationship between xor and or operators.
;
; Evaluating (parse-binops '(a xor (b or c)))
; Yields '(xor a (or b c))
;
; Evaluating (parse-binops '(a ^ b ^ c))
; Yields '(^ a (^ b c))
;
; Each of these are from the above blog post and have the expected result:
; (parse-binops '(x + y * z))
; (parse-binops '((x + y) * z))
; (parse-binops '(x < y < z))
; (parse-binops '(a xor x == y))
; (parse-binops '(a xor b or c))
; (parse-binops '(x / y / z))
; (parse-binops '(x / y * z))
; (parse-binops '(x ^ y ^ z))
;
; Some examples from the blog post are omitted since they use either unary or ternary operators,
; which this implementation does not attempt to implement.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; op-prec is a hashmap from symbols (operators) to a list with the following format:
; (associativity operators-.>-than-this-operator ...)
; OR
; ('eq operator-=.=-this-operator operators-.>-than-this-operator)
; where associativity is one of 'left 'right or 'none.
; If an operator is 'eq another, the associativity of that operator cannot be 'none.
(define op-prec (make-hash))

; Example set of precedences
(hash-set! op-prec '^ (list 'right))

(hash-set! op-prec '* (list 'left '^))
(hash-set! op-prec '/ (list 'none '^))

(hash-set! op-prec '+ (list 'left '* '/ '^))
(hash-set! op-prec '- (list 'eq '+ '* '/ '^))

(hash-set! op-prec '< (list 'none '+ '- '* '/ '^))
(hash-set! op-prec '> (list 'none '+ '- '* '/ '^))
(hash-set! op-prec '<= (list 'none '+ '- '* '/ '^))
(hash-set! op-prec '>= (list 'none '+ '- '* '/ '^))

(hash-set! op-prec '== (list 'none '+ '- '* '/ '^ '< '> '<= '>=))
(hash-set! op-prec '!= (list 'none '+ '- '* '/ '^ '< '> '<= '>=))

(hash-set! op-prec 'and (list 'left '== '!= '< '> '<= '>=))
(hash-set! op-prec 'or (list 'left 'and '== '!= '< '> '<= '>=))
(hash-set! op-prec 'xor (list 'left '== '!= '< '> '<= '>=))

; Extracts the list of operators that are .> op
(define (prec-list op)
  (match (hash-ref op-prec op)
    [(list-rest 'eq _ r) r]
    [(list-rest _ r)     r]))

; Checks a .> b (the intransitive relationship)
(define (is-higher a b)
  (ormap identity (for/list ([greater-op (prec-list b)])
        (equal? greater-op a))))

; Checks a > b (the transitive relationship)
(define (is-higher-ext a b)
  (ormap identity (for/list ([greater-op (prec-list b)])
        (or (equal? greater-op a) (is-higher-ext a greater-op)))))

; Gets the associativity of op ('left 'right or 'none)
(define (assoc op)
  (match (hash-ref op-prec op)
    [(list 'eq eqop _ ...) (assoc eqop)]
    [(list a _ ...)        a]))

; Gets the operator that op is =.= to at the end of the 'eq chain
(define (root-eq-op op)
  (match (hash-ref op-prec op)
    [(list 'eq eqop _ ...) (root-eq-op eqop)]
    [_                     op]))

; Determines if a =.= b
(define (ops-eq a b)
  (equal? (root-eq-op a) (root-eq-op b)))

; Determines if an infix expression with operator inner needs to be surrounded by parenthesis to be
; a subexpression of an infix expression with operator outer. That is, returns true if neither
; inner =.= outer nor inner .> outer.
(define (requires-paren inner outer)
  (not (or (ops-eq inner outer) (is-higher inner outer))))

; Determines the bind direction of the term between the left-side operator lhop and the right-side operator rhop
; If lhop > rhop, returns 'left
; If rhop > lhop, returns 'right
; If lhop =.= rhop, returns the associativity of the operators.
; If lhop and rhop have no relation, raises an error.
(define (bind-direction lhop rhop)
  (cond
    [(is-higher-ext lhop rhop) 'left]
    [(is-higher-ext rhop lhop) 'right]
    [(ops-eq lhop rhop)        (assoc lhop)]
    [else (raise-user-error 'error "No relationship between ~a and ~a operators." lhop rhop)]))

; Takes a list of (term [op term]*) and reduces operators with both terms bound as determined by
; bind-direction, with the extra case that a term with no left-side operator is always bound right
; and a term with no right-side operator is always bound left. The reduced term is written (operator
; lhs rhs), the s-expr format. "term" will typically be a symbol, literal, or s-expr, but it could
; be an unreduced expression (which remains untouched) if called directly.
(define (reduce-step expr)
  (match expr
    [(list e1)                  (list e1)]
    [(list e1 op e2)            (list (list op e1 e2))]
    [(list e1 op1 e2 op2 r ...) (match (bind-direction op1 op2)
                                  ['left  (cons (list op1 e1 e2) (cons op2 r))]
                                  ['right (append (list e1 op1)
                                                  (reduce-step (cons e2 (cons op2 r))))]
                                  ['none  (raise-user-error 'error
                                                            "The ~a operator is not associative"
                                                            op1)])]))

; Repeatedly preforms reduction steps until left with one term, and returns that term parenthesized
; (that is, in the form '(term))
(define (fully-reduce expr)
  (match expr
    [(list e)   (list e)]
    [unfinished (fully-reduce (reduce-step unfinished))]))

; Checks that the inner subexpression can be an unparenthesized subexpression of an infix expression
; with operator outer. Does nothing if inner is a parenthesized expression. Otherwise, raises an
; error if the inner expression requires parenthesis to be a subexpression of outer.
(define (check-proper-parens outer inner)
  (match inner
    [(list e)              (void)]
    [(list inner-op _ ...) (cond
                             [(requires-paren inner-op outer)
                              (raise-user-error 'error
                                                "No relationship between ~a and ~a operators."
                                                inner-op outer)]
                             [else (void)])]
    [value                 value]))

; Checks that the s-expr obeys the intransitive precedence relationship (recursive-reduce builds
; them with the extended transitive relationship) and removes parenthesis around the parenthesized
; terms; that is, takes (list term) to term.
(define (deparenthesize sexpr)
  (match sexpr
    [(list e)             (deparenthesize e)]
    [(list op params ...) (cons op (for/list ([param params])
                                     (check-proper-parens op param)
                                     (deparenthesize param)))]
    [value                value]))

; Fully reduces all subexpressions before reducing the original expression.
; The result will be a parenthesized term that may contain other parenthesized terms.
(define (recursive-reduce expr)
  (cond
    [(list? expr) (fully-reduce (map recursive-reduce expr))]
    [else expr]))

; Parses an arbitrarilly long/nested set of infix expressions into an s-expression with the proper
; grouping.
(define (parse-binops expr) (deparenthesize (recursive-reduce expr)))