#457

Committed 09 Jul 2026 07:15AM UTC coverage: 94.119% (+0.1%) from 93.976%

Build # #457

Build Type

push

cover

Committed by

web-flow

Commit Message

Merge fde1192da into aa2655136

Coverage Stats

252 of 256 new or added lines in 9 files covered. (98.44%)

16387 of 17411 relevant lines covered (94.12%)

0.94 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

96.44

/grimoire/string-replacement.rkt

#lang racket/base

;; A string replacement is an operation that can be applied to a string which can insert, delete, and
;; move around the contents of the string.


(require racket/contract/base)


(provide
 (contract-out
  [string-replacement? (-> any/c boolean?)]
  [string-replacement
   (->i
    #:chaperone
    (#:start [start natural?]
     #:end [end natural?]
     #:contents [contents (sequence/c string-piece?)])
    #:pre/name (start end) "end cannot be before start" (<= start end)
    [_ string-replacement?])]
  [string-piece? (-> any/c boolean?)]
  [string-piece-span (-> string-piece? exact-nonnegative-integer?)]
  [string-replacement-start (-> string-replacement? natural?)]
  [string-replacement-original-end (-> string-replacement? natural?)]
  [string-replacement-original-span (-> string-replacement? natural?)]
  [string-replacement-new-end (-> string-replacement? natural?)]
  [string-replacement-new-span (-> string-replacement? natural?)]
  [string-replacement-contents (-> string-replacement? (listof string-piece?))]
  [string-replacement-preserved-locations (-> string-replacement? range-set?)]
  [string-replacement-overlaps? (-> string-replacement? string-replacement? boolean?)]
  [string-replacement-focus
   (->* (string-replacement? string?)
        (#:preserve-start (or/c exact-nonnegative-integer? #false)
         #:preserve-end (or/c exact-nonnegative-integer? #false))
        string-replacement?)]
  [string-replacement-union
   (->i ([replacement1 string-replacement?]
         [replacement2 string-replacement?])
        #:pre/name (replacement1 replacement2)
        "replacements must not overlap"
        (not (string-replacement-overlaps? replacement1 replacement2))
        [_ string-replacement?])]
  [union-into-string-replacement (reducer/c string-replacement? string-replacement?)]
  [string-replacement-new-text (-> string-replacement? string? immutable-string?)]
  [string-replacement-apply (-> string-replacement? string? immutable-string?)]
  [string-replacement-apply-to-file! (-> string-replacement? path-string? void?)]
  [inserted-string? (-> any/c boolean?)]
  [inserted-string (-> string? inserted-string?)]
  [inserted-string-contents (-> inserted-string? immutable-string?)]
  [copied-string? (-> any/c boolean?)]
  [copied-string
   (->i
    #:chaperone
    ([start natural?]
     [end natural?])
    #:pre/name (start end) "end cannot be before start" (<= start end)
    [_ copied-string?])]
  [copied-string-start (-> copied-string? natural?)]
  [copied-string-end (-> copied-string? natural?)]))


(require guard
         racket/file
         racket/match
         racket/math
         racket/sequence
         rebellion/base/comparator
         rebellion/base/immutable-string
         rebellion/base/option
         rebellion/base/range
         rebellion/collection/list
         rebellion/collection/range-set
         rebellion/private/static-name
         rebellion/streaming/reducer
         rebellion/streaming/transducer
         rebellion/type/record
         resyntax/grimoire/source)


(module+ test
  (require rackunit
           (submod "..")))


;@----------------------------------------------------------------------------------------------------


(define-record-type string-replacement
  (start original-end original-span new-end new-span required-length contents)
  #:omit-root-binding)


(define (string-replacement #:start start #:end end #:contents contents)
  (define content-list
    (for/fold ([accumulated '()]
               [previous #false]
               #:result
               (reverse (append (if previous (list previous) (list)) accumulated)))
              ([piece contents]
               #:when (positive? (string-piece-span piece)))
      (match (list previous piece)
        [(list #false _) (values accumulated piece)]
        [(list (inserted-string s1) (inserted-string s2))
         (values accumulated (inserted-string (string-append s1 s2)))]
        [(list (copied-string start1 end1) (copied-string start2 end2))
         #:when (equal? end1 start2)
         (values accumulated (copied-string start1 end2))]
        [(list _ _) (values (cons previous accumulated) piece)])))
  (define new-span (transduce content-list (mapping string-piece-span) #:into into-sum))
  (define max-end
    (transduce content-list
               (filtering copied-string?)
               (mapping copied-string-end)
               #:into (into-max)))
  (constructor:string-replacement
   #:start start
   #:original-end end
   #:original-span (- end start)
   #:new-end (+ start new-span)
   #:new-span new-span
   #:required-length (max end (option-get max-end 0))
   #:contents content-list))


(module+ test
  (test-case "string-replacement constructor"

    (test-case "should merge insertions"
      (define initial-pieces
        (list (inserted-string "aaa") (inserted-string "bbb") (inserted-string "ccc")))
      (define expected-pieces (list (inserted-string "aaabbbccc")))
      (define replacement
        (string-replacement
         #:start 0
         #:end 10
         #:contents initial-pieces))
      (check-equal? (string-replacement-contents replacement) expected-pieces))

    (test-case "should merge adjacent copied pieces"
      (define initial-pieces
        (list (copied-string 2 5) (copied-string 5 7) (copied-string 7 9)))
      (define expected-pieces (list (copied-string 2 9)))
      (define replacement
        (string-replacement
         #:start 0
         #:end 10
         #:contents initial-pieces))
      (check-equal? (string-replacement-contents replacement) expected-pieces))

    (test-case "should not merge non-adjacent copied pieces"
      (define initial-pieces
        (list (copied-string 2 5) (copied-string 6 8) (copied-string 10 12)))
      (define replacement
        (string-replacement
         #:start 0
         #:end 10
         #:contents initial-pieces))
      (check-equal? (string-replacement-contents replacement) initial-pieces))

    (test-case "should not merge inserted pieces with copied pieces"
      (define initial-pieces
        (list (inserted-string "aaa") (copied-string 5 7) (inserted-string "bbb")))
      (define replacement
        (string-replacement
         #:start 0
         #:end 10
         #:contents initial-pieces))
      (check-equal? (string-replacement-contents replacement) initial-pieces))

    (test-case "should merge inserted pieces when before copied piece"
      (define initial-pieces
        (list (inserted-string "aaa") (inserted-string "bbb") (copied-string 5 7)))
      (define expected-pieces (list (inserted-string "aaabbb") (copied-string 5 7)))
      (define replacement
        (string-replacement
         #:start 0
         #:end 10
         #:contents initial-pieces))
      (check-equal? (string-replacement-contents replacement) expected-pieces))

    (test-case "should merge inserted pieces when after copied piece"
      (define initial-pieces
        (list (copied-string 5 7) (inserted-string "ccc") (inserted-string "ddd")))
      (define expected-pieces (list (copied-string 5 7) (inserted-string "cccddd")))
      (define replacement
        (string-replacement
         #:start 0
         #:end 10
         #:contents initial-pieces))
      (check-equal? (string-replacement-contents replacement) expected-pieces))))


(define (string-replacement-length-change replacement)
  (- (string-replacement-new-span replacement) (string-replacement-original-span replacement)))


(define (string-replacement-range replacement)
  (closed-open-range
   (string-replacement-start replacement)
   (string-replacement-original-end replacement)
   #:comparator natural<=>))


(define (string-replacement-overlaps? replacement other-replacement)
  (range-overlaps?
   (string-replacement-range replacement) (string-replacement-range other-replacement)))


(struct string-piece () #:transparent)


(struct inserted-string string-piece (contents) #:transparent
  #:guard (λ (contents _) (string->immutable-string contents))
  #:property prop:custom-print-quotable 'never)


(struct copied-string string-piece (start end) #:transparent
  #:property prop:custom-print-quotable 'never)


(define (string-piece-span piece)
  (match piece
    [(inserted-string inserted-string) (string-length inserted-string)]
    [(copied-string start end) (- end start)]))


(define (replacement-string-drop-left piece amount)
  (match piece
    [(inserted-string s)
     (inserted-string (string->immutable-string (substring s amount)))]
    [(copied-string start end) (copied-string (+ start amount) end)]))


(define (replacement-string-drop-right piece amount)
  (match piece
    [(inserted-string s)
     (define new-length (- (string-length s) amount))
     (inserted-string (string->immutable-string (substring s 0 new-length)))]
    [(copied-string start end) (copied-string start (- end amount))]))


(define (string-replacement-new-text replacement original-string)
  (define immutable-original-string (string->immutable-string original-string))
  (define required-length (string-replacement-required-length replacement))
  (define original-length (string-length immutable-original-string))
  (unless (>= original-length required-length)
    (raise-arguments-error
     (name string-replacement-new-text)
     "string is not long enough"
     "string" immutable-original-string
     "string length" original-length
     "required length" required-length))
  (define content-length (string-replacement-new-span replacement))
  (define edited (make-string content-length))
  (for/fold ([start 0] #:result (void))
            ([piece (in-list (string-replacement-contents replacement))])
    (match piece
      [(inserted-string inserted)
       (string-copy! edited start inserted)
       (+ start (string-length inserted))]
      [(copied-string copy-start copy-end)
       (string-copy! edited start immutable-original-string copy-start copy-end)
       (+ start (- copy-end copy-start))]))
  (string->immutable-string edited))


(define (string-replacement-apply replacement string)
  (define immutable-string (string->immutable-string string))
  (define start (string-replacement-start replacement))
  (define end (string-replacement-original-end replacement))
  (define new-end (string-replacement-new-end replacement))
  (define contents (string-replacement-contents replacement))
  (define required-length (string-replacement-required-length replacement))
  (define original-length (string-length immutable-string))
  (unless (>= original-length required-length)
    (raise-arguments-error
     (name string-replacement-apply)
     "string is not long enough"
     "string" immutable-string
     "string length" original-length
     "required length" required-length))
  (define new-length (+ original-length (string-replacement-length-change replacement)))
  (define edited (make-string new-length))
  (string-copy! edited 0 immutable-string 0 start)
  (for/fold ([start start] #:result (void))
            ([piece (in-list contents)])
    (match piece
      [(inserted-string inserted)
       (string-copy! edited start inserted)
       (+ start (string-length inserted))]
      [(copied-string copy-start copy-end)
       (string-copy! edited start immutable-string copy-start copy-end)
       (+ start (- copy-end copy-start))]))
  (string-copy! edited new-end immutable-string end)
  (string->immutable-string edited))


(module+ test
  (test-case (name-string string-replacement-apply)

    (test-case "replace middle part"
      (define s "good morning and hello world")
      (define replacement-pieces
        (list
         (inserted-string "evening")
         (copied-string 12 17)
         (inserted-string "goodbye")))
      (define replacement
        (string-replacement
         #:start 5
         #:end 22
         #:contents replacement-pieces))
      (check-equal? (string-replacement-original-span replacement) 17)
      (check-equal? (string-replacement-new-span replacement) 19)
      (check-equal? (string-replacement-length-change replacement) 2)
      (check-equal? (string-replacement-new-end replacement) 24)
      (check-equal? (string-replacement-new-text replacement s) "evening and goodbye")
      (check-equal? (string-replacement-apply replacement s) "good evening and goodbye world"))

    (test-case "replace entire string"
      (define s "good morning and hello world")
      (define replacement
        (string-replacement #:start 0
                            #:end (string-length s)
                            #:contents (list (inserted-string "hi there"))))
      (check-equal? (string-replacement-apply replacement s) "hi there"))

    (test-case "string shorter than the replaced region"
      (define replacement
        (string-replacement #:start 0 #:end 10 #:contents (list (copied-string 0 2))))
      (check-exn #rx"string-replacement-apply:" (λ () (string-replacement-apply replacement "abc")))
      (check-exn #rx"string is not long enough"
                 (λ () (string-replacement-apply replacement "abc")))))

  (test-case (name-string string-replacement-new-text)
    (test-case "errors are reported under the right name"
      (define replacement
        (string-replacement #:start 0 #:end 2 #:contents (list (copied-string 10 20))))
      (check-exn #rx"string-replacement-new-text:"
                 (λ () (string-replacement-new-text replacement "ab"))))))


(define (string-replacement-apply-to-file! replacement path)
  (define replacement-text (string-replacement-apply replacement (source->string (file-source path))))
  (display-to-file replacement-text path #:mode 'text #:exists 'replace))


(define/guard (string-replacement-focus replacement original-string
                                            #:preserve-start [preserve-start #false]
                                            #:preserve-end [preserve-end #false])
  (define left-normalized
    (string-replacement-left-focus replacement original-string #:preserve-start preserve-start))
  (define left-reversed (string-replacement-reverse left-normalized original-string))
  (define reversed-original-string (string-reverse original-string))
  (define reversed
    (string-replacement-left-focus
     left-reversed
     reversed-original-string
     #:preserve-start (and preserve-end (- (string-length original-string) preserve-end))))
  (string-replacement-reverse reversed reversed-original-string))


(define/guard (string-replacement-left-focus replacement original-string
                                                 #:preserve-start [preserve-start #false])
  (define replaced (string-replacement-apply replacement original-string))
  (guard (not (equal? original-string replaced)) #:else replacement)
  (define actual-start
    (inexact->exact
     (min (or preserve-start +inf.0)
          (string-diff-start original-string replaced)
          (string-replacement-original-end replacement))))
  (define left-trimmed-pieces
    (let loop ([pieces (string-replacement-contents replacement)]
               [pos (string-replacement-start replacement)])
      (guarded-block
        (guard (< pos actual-start) #:else pieces)
        (guard-match (cons next-piece remaining) pieces #:else (list))
        (define piece-span (string-piece-span next-piece))
        (if (< (+ pos piece-span) actual-start)
            (loop remaining (+ pos piece-span))
            (cons (replacement-string-drop-left next-piece (- actual-start pos)) remaining)))))
  (string-replacement #:start actual-start
                      #:end (string-replacement-original-end replacement)
                      #:contents left-trimmed-pieces))


(define (string-replacement-reverse replacement original-string)
  (define new-start (- (string-length original-string) (string-replacement-original-end replacement)))
  (define new-end (+ new-start (string-replacement-original-span replacement)))
  (define new-contents
    (reverse
     (for/list ([piece (in-list (string-replacement-contents replacement))])
       (match piece
         [(inserted-string s) (inserted-string (string-reverse s))]
         [(copied-string start end)
          (define new-start (- (string-length original-string) end))
          (define new-end (+ new-start (- end start)))
          (copied-string new-start new-end)]))))
  (string-replacement #:start new-start #:end new-end #:contents new-contents))


(define (string-reverse s)
  (list->string (reverse (string->list s))))


(define (string-diff-start original new)
  (let loop ([i 0])
    (cond
      [(or (>= i (string-length original)) (>= i (string-length new))) #false]
      [(equal? (string-ref original i) (string-ref new i)) (loop (add1 i))]
      [else i])))


(define (string-diff-end original new)
  (let loop ([i 0])
    (guarded-block
      (guard (and (< i (string-length original)) (< i (string-length new))) #:else #false)
      (define orig-index (- (string-length original) i 1))
      (define new-index (- (string-length new) i 1))
      (if (equal? (string-ref original orig-index) (string-ref new new-index))
          (loop (add1 i))
          (+ orig-index 1)))))


(module+ test

  (test-case "string-diff-start"
    (check-false (string-diff-start "aaaaaa" "aaaaaa"))
    (check-equal? (string-diff-start "aaaaaa" "baaaaa") 0)
    (check-equal? (string-diff-start "aaaaaa" "abaaaa") 1)
    (check-equal? (string-diff-start "aaaaaa" "aabaaa") 2)
    (check-equal? (string-diff-start "aaaaaa" "aaabaa") 3)
    (check-equal? (string-diff-start "aaaaaa" "aaaaba") 4)
    (check-equal? (string-diff-start "aaaaaa" "aaaaab") 5)
    (check-equal? (string-diff-start "aaaaaa" "b") 0)
    (check-equal? (string-diff-start "aaaaaa" "ab") 1)
    (check-equal? (string-diff-start "aaaaaa" "aab") 2)
    (check-equal? (string-diff-start "aaaaaa" "aaab") 3)
    (check-equal? (string-diff-start "aaaaaa" "aaaab") 4)
    (check-equal? (string-diff-start "aaaa" "abaaa") 1)
    (check-equal? (string-diff-start "aaaa" "aaaba") 3)
    (check-equal? (string-diff-start "good morning and hello world"
                                     "good morning friend and hello world")
                  13))

  (test-case "string-diff-end"
    (check-false (string-diff-end "aaaaaa" "aaaaaa"))
    (check-equal? (string-diff-end "aaaaaa" "baaaaa") 1)
    (check-equal? (string-diff-end "aaaaaa" "abaaaa") 2)
    (check-equal? (string-diff-end "aaaaaa" "aabaaa") 3)
    (check-equal? (string-diff-end "aaaaaa" "aaabaa") 4)
    (check-equal? (string-diff-end "aaaaaa" "aaaaba") 5)
    (check-equal? (string-diff-end "aaaaaa" "aaaaab") 6)
    (check-equal? (string-diff-end "aaaaaa" "baaaa") 2)
    (check-equal? (string-diff-end "aaaaaa" "baaa") 3)
    (check-equal? (string-diff-end "aaaaaa" "baa") 4)
    (check-equal? (string-diff-end "aaaaaa" "ba") 5)
    (check-equal? (string-diff-end "aaaaaa" "b") 6)
    (check-equal? (string-diff-end "aaaa" "abaaa") 1)
    (check-equal? (string-diff-end "aaaa" "aaaba") 3)
    (check-equal? (string-diff-end "good morning and hello world"
                                   "good morning friend and hello world")
                  12))

  (test-case "string-replacement-focus"

    (test-case "empty replacement"
      (define s "good morning and hello world")
      (define replacement-pieces (list))
      (define replacement
        (string-replacement
         #:start 5
         #:end 5
         #:contents replacement-pieces))
      (check-equal? (string-replacement-focus replacement s) replacement))

    (test-case "insertion-only replacement"
      (define s "good morning and hello world")
      (define replacement-pieces (list (inserted-string "friend ")))
      (define replacement
        (string-replacement
         #:start 13
         #:end 13
         #:contents replacement-pieces))
      (check-equal? (string-replacement-focus replacement s) replacement))

    (test-case "redundant copied string before insertion"
      (define s "good morning and hello world")
      (define replacement-pieces (list (copied-string 5 13) (inserted-string "friend ")))
      (define replacement
        (string-replacement
         #:start 5
         #:end 13
         #:contents replacement-pieces))
      (check-equal? (string-replacement-focus replacement s)
                    (string-replacement #:start 13
                                        #:end 13
                                        #:contents (list (inserted-string "friend ")))))

    (test-case "redundant inserted string before insertion"
      (define s "good morning and hello world")
      (define replacement-pieces (list (inserted-string "morning ") (inserted-string "friend ")))
      (define replacement
        (string-replacement
         #:start 5
         #:end 13
         #:contents replacement-pieces))
      (check-equal? (string-replacement-focus replacement s)
                    (string-replacement #:start 13
                                        #:end 13
                                        #:contents (list (inserted-string "friend ")))))

    (test-case "redundant copied string after insertion"
      (define s "good morning and hello world")
      (define replacement-pieces (list (inserted-string "friend ") (copied-string 13 16)))
      (define replacement
        (string-replacement
         #:start 13
         #:end 16
         #:contents replacement-pieces))
      (check-equal? (string-replacement-focus replacement s)
                    (string-replacement #:start 13
                                        #:end 13
                                        #:contents (list (inserted-string "friend ")))))

    (test-case "redundant inserted string after insertion"
      (define s "good morning and hello world")
      (define replacement-pieces (list (inserted-string "friend ") (inserted-string "and")))
      (define replacement
        (string-replacement
         #:start 13
         #:end 16
         #:contents replacement-pieces))
      (check-equal? (string-replacement-focus replacement s)
                    (string-replacement #:start 13
                                        #:end 13
                                        #:contents (list (inserted-string "friend ")))))

    (test-case "normalizing by left-trimming a single size-increasing insertion"
      (define s "hello my big friend")
      (define s2 "hello my little friend")
      (define replacement-pieces (list (inserted-string "my little")))
      (define replacement (string-replacement #:start 6 #:end 12 #:contents replacement-pieces))
      (check-equal? (string-replacement-apply replacement s) s2)

      (define normalized (string-replacement-focus replacement s))

      (define expected
        (string-replacement #:start 9 #:end 12 #:contents (list (inserted-string "little"))))
      (check-equal? (string-replacement-apply expected s) s2)
      (check-equal? normalized expected))

    (test-case "normalizing by left-trimming a single size-decreasing insertion"
      (define s "hello my little friend")
      (define s2 "hello my big friend")
      (define replacement-pieces (list (inserted-string "my big")))
      (define replacement (string-replacement #:start 6 #:end 15 #:contents replacement-pieces))
      (check-equal? (string-replacement-apply replacement s) s2)

      (define normalized (string-replacement-focus replacement s))

      (define expected
        (string-replacement #:start 9 #:end 15 #:contents (list (inserted-string "big"))))
      (check-equal? (string-replacement-apply expected s) s2)
      (check-equal? normalized expected))

    (test-case "normalizing by right-trimming a single size-increasing insertion"
      (define s "hello my big friend")
      (define s2 "hello my little friend")
      (define replacement-pieces (list (inserted-string "little friend")))
      (define replacement (string-replacement #:start 9 #:end 19 #:contents replacement-pieces))
      (check-equal? (string-replacement-apply replacement s) s2)

      (define normalized (string-replacement-focus replacement s))

      (define expected
        (string-replacement #:start 9 #:end 12 #:contents (list (inserted-string "little"))))
      (check-equal? (string-replacement-apply expected s) s2)
      (check-equal? normalized expected))

    (test-case "normalizing by right-trimming a single size-decreasing insertion"
      (define s "hello my little friend")
      (define s2 "hello my big friend")
      (define replacement-pieces (list (inserted-string "big friend")))
      (define replacement (string-replacement #:start 9 #:end 22 #:contents replacement-pieces))
      (check-equal? (string-replacement-apply replacement s) s2)

      (define normalized (string-replacement-focus replacement s))

      (define expected
        (string-replacement #:start 9 #:end 15 #:contents (list (inserted-string "big"))))
      (check-equal? (string-replacement-apply expected s) s2)
      (check-equal? normalized expected))))


(define/guard (string-replacement-union replacement1 replacement2)
  (guard (<= (string-replacement-start replacement1) (string-replacement-start replacement2)) #:else
    (string-replacement-union replacement2 replacement1))
  (define piece-between
    (copied-string
     (string-replacement-original-end replacement1) (string-replacement-start replacement2)))
  (string-replacement
   #:start (string-replacement-start replacement1)
   #:end (string-replacement-original-end replacement2)
   #:contents
   (append
    (string-replacement-contents replacement1)
    (list piece-between)
    (string-replacement-contents replacement2))))


(define union-into-string-replacement
  (make-fold-reducer
   string-replacement-union
   (string-replacement #:start 0 #:end 0 #:contents (list))
   #:name (name union-into-string-replacement)))


(module+ test
  (test-case (name-string string-replacement-union)
    (define s "hello world")
    (define r1 (string-replacement #:start 0 #:end 5 #:contents (list (inserted-string "goodbye"))))
    (define r2 (string-replacement #:start 6 #:end 11 #:contents (list (inserted-string "friend"))))
    (check-false (string-replacement-overlaps? r1 r2))
    (define union (string-replacement-union r1 r2))
    (define expected
      (string-replacement
       #:start 0
       #:end 11
       #:contents (list (inserted-string "goodbye") (copied-string 5 6) (inserted-string "friend"))))
    (check-equal? union expected)
    (check-equal? (transduce (list r1 r2) #:into union-into-string-replacement) expected)))


(define (string-replacement-preserved-locations replacement)
  (define before-replacement
    (less-than-range (string-replacement-start replacement) #:comparator natural<=>))
  (define after-replacement
    (at-least-range (string-replacement-original-end replacement) #:comparator natural<=>))
  (for/fold ([ranges (range-set before-replacement after-replacement)])
            ([piece (in-list (string-replacement-contents replacement))]
             #:when (copied-string? piece))
    (match-define (copied-string start end) piece)
    (range-set-add ranges (closed-open-range start end #:comparator natural<=>))))

jackfirth / resyntax / #457

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous