Extract Semgrep finding utility helpers
ober
2191eb132d6fdabd9532a46ed20258620ab4b663
--- a/SEMGREP_JERBOA_IMPLEMENTATION.md +++ b/SEMGREP_JERBOA_IMPLEMENTATION.md @@ -457,6 +457,8 @@ Completed in the repo: `src/semgrep/engine/rule-plan.ss` - extracted source offset and line/column conversions into `src/semgrep/source/offsets.ss` + - extracted finding/suppression/binding utility helpers into + `src/semgrep/result/findings.ss` Validation at this checkpoint: new file mode 100644 --- /dev/null +++ b/lib/semgrep/result/findings.sls @@ -0,0 +1,243 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/semgrep/result/findings.ss + +(library (semgrep result findings) + (export source-slice remove-extra-key finding-with-extra + finding-with-message-and-extra finding-with-range + finding-focused-on-binding finding-without-fix + finding-focused-on-binding* finding-range-equal? + finding-same-identity? dedupe-findings source-line + finding-suppressed? finding-range-contains? + finding-has-binding-containing? finding-ranges-overlap? + normalize-metavariable-name lookup-metavariable-binding + finding-metavars finding-metavariable-binding + merge-binding-list bindings-compatible? + finding-on-decorator-line? finding-range-width) + (import + (except (chezscheme) make-hash-table hash-table? sort sort! + printf fprintf format path-extension path-absolute? + with-input-from-string with-output-to-string iota \x31;+ + \x31;- partition make-date make-time meta atom?) + (except (jerboa prelude) meta atom?) (semgrep result) + (semgrep source offsets) (semgrep targeting path-filter) + (semgrep match structural)) + (def (alist-ref/default xs key default) + (let ([found (assoc key xs)]) + (if found (cdr found) default))) + (def (source-slice source start end) + (substring source start end)) + (def (remove-extra-key key extra) + (cond + [(null? extra) '()] + [(eq? key (caar extra)) (remove-extra-key key (cdr extra))] + [else + (cons (car extra) (remove-extra-key key (cdr extra)))])) + (def (finding-with-extra finding extra) + (make-finding (finding-rule-id finding) (finding-path finding) + (finding-start-line finding) (finding-start-col finding) + (finding-end-line finding) (finding-end-col finding) + (finding-start-offset finding) (finding-end-offset finding) + (finding-message finding) (finding-severity finding) extra)) + (def (finding-with-message-and-extra finding message extra) + (make-finding (finding-rule-id finding) (finding-path finding) + (finding-start-line finding) (finding-start-col finding) + (finding-end-line finding) (finding-end-col finding) + (finding-start-offset finding) (finding-end-offset finding) + message (finding-severity finding) extra)) + (def (finding-with-range finding source start end) + (let-values ([(start-line start-col) + (offset->line-col source start)] + [(end-line end-col) (offset->line-col source end)]) + (make-finding (finding-rule-id finding) (finding-path finding) start-line + start-col end-line end-col start end + (finding-message finding) (finding-severity finding) + (finding-extra finding)))) + (def (finding-focused-on-binding finding binding) + (make-finding (finding-rule-id finding) (finding-path finding) + (metavariable-binding-start-line binding) + (metavariable-binding-start-col binding) + (metavariable-binding-end-line binding) + (metavariable-binding-end-col binding) + (metavariable-binding-start-byte binding) + (metavariable-binding-end-byte binding) + (finding-message finding) (finding-severity finding) + (finding-extra finding))) + (def (finding-without-fix finding) + (finding-with-extra + finding + (remove-extra-key 'fix (finding-extra finding)))) + (def (finding-focused-on-binding* finding binding drop-fix?) + (let ([focused (finding-focused-on-binding + finding + binding)]) + (if drop-fix? (finding-without-fix focused) focused))) + (def (finding-range-equal? a b) + (and (= (finding-start-offset a) (finding-start-offset b)) + (= (finding-end-offset a) (finding-end-offset b)))) + (def (finding-same-identity? a b) + (and (string=? (finding-rule-id a) (finding-rule-id b)) + (string=? (finding-path a) (finding-path b)) + (string=? (finding-message a) (finding-message b)) + (finding-range-equal? a b))) + (def (dedupe-findings findings) + (let loop ([remaining findings] [seen '()] [acc '()]) + (cond + [(null? remaining) (reverse acc)] + [(any? + (lambda (finding) + (finding-same-identity? (car remaining) finding)) + seen) + (loop (cdr remaining) seen acc)] + [else + (loop + (cdr remaining) + (cons (car remaining) seen) + (cons (car remaining) acc))]))) + (def (source-line source target-line) + (let ([len (string-length source)]) + (let loop ([i 0] [line 1] [start 0]) + (cond + [(= i len) + (if (= line target-line) (substring source start len) "")] + [(char=? (string-ref source i) #\newline) + (if (= line target-line) + (substring source start i) + (loop (+ i 1) (+ line 1) (+ i 1)))] + [else (loop (+ i 1) line start)])))) + (def (string-find-substring s needle) + (let ([len (string-length s)]) + (let loop ([i 0]) + (cond + [(> i len) #f] + [(and (<= (+ i (string-length needle)) len) + (string=? + (substring s i (+ i (string-length needle))) + needle)) + i] + [else (loop (+ i 1))])))) + (def (line-suppresses-rule? source line rule-id) + (let* ([text (source-line source line)] + [marker (string-find-substring text "nosemgrep")]) + (and marker + (let ([specific (string-find-substring text "nosemgrep:")]) + (if specific + (let ([tail (substring + text + (+ specific (string-length "nosemgrep:")) + (string-length text))]) + (if (string-find-substring tail rule-id) #t #f)) + #t))))) + (def (finding-suppressed? source finding) + (let loop ([line (finding-start-line finding)]) + (and (<= line (finding-end-line finding)) + (or (line-suppresses-rule? + source + line + (finding-rule-id finding)) + (loop (+ line 1)))))) + (def (finding-range-contains? outer inner) + (and (<= (finding-start-offset outer) + (finding-start-offset inner)) + (>= (finding-end-offset outer) (finding-end-offset inner)))) + (def (binding-range-contains-finding? binding finding) + (and (<= (metavariable-binding-start-byte binding) + (finding-start-offset finding)) + (>= (metavariable-binding-end-byte binding) + (finding-end-offset finding)))) + (def (finding-has-binding-containing? candidate finding) + (any? + (lambda (entry) + (binding-range-contains-finding? (cdr entry) finding)) + (finding-metavars candidate))) + (def (finding-ranges-overlap? a b) + (and (< (finding-start-offset a) (finding-end-offset b)) + (< (finding-start-offset b) (finding-end-offset a)))) + (def (string-drop-first s) + (list->string + (let loop ([i 1] [acc '()]) + (if (= i (string-length s)) + (reverse acc) + (loop (+ i 1) (cons (string-ref s i) acc)))))) + (def (string-drop-n s n) (substring s n (string-length s))) + (def (normalize-metavariable-name name) + (if (and (> (string-length name) 0) + (char=? (string-ref name 0) #\$)) + (string-drop-first name) + name)) + (def (ellipsis-normalized-name? name) + (and (>= (string-length name) 3) + (char=? (string-ref name 0) #\.) + (char=? (string-ref name 1) #\.) + (char=? (string-ref name 2) #\.))) + (def (alternate-ellipsis-metavariable-name name) + (if (ellipsis-normalized-name? name) + (string-drop-n name 3) + (string-append "..." name))) + (def (lookup-metavariable-binding name bindings) + (let* ([normalized (normalize-metavariable-name name)] + [found (assoc normalized bindings)]) + (if found + (cdr found) + (let ([alternate (assoc + (alternate-ellipsis-metavariable-name + normalized) + bindings)]) + (and alternate (cdr alternate)))))) + (def (finding-metavars finding) + (alist-ref/default (finding-extra finding) 'metavars '())) + (def (finding-metavariable-binding finding metavariable) + (lookup-metavariable-binding + metavariable + (finding-metavars finding))) + (def (numeric-binding-name? name) + (let ([len (string-length name)]) + (and (> len 0) + (let loop ([i 0]) + (or (= i len) + (and (char-numeric? (string-ref name i)) + (loop (+ i 1)))))))) + (def (merge-binding-list existing additions) + (let loop ([xs additions] [acc existing]) + (cond + [(null? xs) acc] + [else + (let ([found (assoc (caar xs) acc)]) + (cond + [(not found) (loop (cdr xs) (cons (car xs) acc))] + [(string=? + (metavariable-binding-text (cdar xs)) + (metavariable-binding-text (cdr found))) + (loop (cdr xs) acc)] + [(numeric-binding-name? (caar xs)) (loop (cdr xs) acc)] + [else #f]))]))) + (def (bindings-compatible? a b) + (let loop ([xs (finding-metavars a)]) + (cond + [(null? xs) #t] + [else + (let ([other (assoc (caar xs) (finding-metavars b))]) + (and (or (not other) + (numeric-binding-name? (caar xs)) + (string=? + (metavariable-binding-text (cdar xs)) + (metavariable-binding-text (cdr other)))) + (loop (cdr xs))))]))) + (def (line-start-before source offset) + (let loop ([i (- offset 1)]) + (cond + [(< i 0) 0] + [(char=? (string-ref source i) #\newline) (+ i 1)] + [else (loop (- i 1))]))) + (def (finding-on-decorator-line? source finding) + (let* ([start (finding-start-offset finding)] + [line-start (line-start-before source start)]) + (let loop ([i line-start]) + (cond + [(>= i start) #f] + [(char=? (string-ref source i) #\space) (loop (+ i 1))] + [(char=? (string-ref source i) #\tab) (loop (+ i 1))] + [else (char=? (string-ref source i) #\@)])))) + (def (finding-range-width finding) + (- (finding-end-offset finding) + (finding-start-offset finding)))) --- a/lib/semgrep/scan.sls +++ b/lib/semgrep/scan.sls @@ -15,10 +15,10 @@ \x31;- partition make-date make-time meta atom?) (except (jerboa prelude) meta atom?) (std regex) (tree-sitter tree-sitter) (semgrep lang) (semgrep rule) - (semgrep result) (semgrep engine rule-plan) - (semgrep rule parse-rule) (semgrep parse parse-target) - (semgrep source offsets) (semgrep targeting path-filter) - (semgrep match structural)) + (semgrep result) (semgrep result findings) + (semgrep engine rule-plan) (semgrep rule parse-rule) + (semgrep parse parse-target) (semgrep source offsets) + (semgrep targeting path-filter) (semgrep match structural)) (def (alist-ref/default xs key default) (let ([found (assoc key xs)]) (if found (cdr found) default))) @@ -20840,34 +20840,6 @@ (case (car entry) [(pattern-regex pattern pattern-as) #t] [else #f])) - (def (source-slice source start end) - (substring source start end)) - (def (remove-extra-key key extra) - (cond - [(null? extra) '()] - [(eq? key (caar extra)) (remove-extra-key key (cdr extra))] - [else - (cons (car extra) (remove-extra-key key (cdr extra)))])) - (def (finding-with-extra finding extra) - (make-finding (finding-rule-id finding) (finding-path finding) - (finding-start-line finding) (finding-start-col finding) - (finding-end-line finding) (finding-end-col finding) - (finding-start-offset finding) (finding-end-offset finding) - (finding-message finding) (finding-severity finding) extra)) - (def (finding-with-message-and-extra finding message extra) - (make-finding (finding-rule-id finding) (finding-path finding) - (finding-start-line finding) (finding-start-col finding) - (finding-end-line finding) (finding-end-col finding) - (finding-start-offset finding) (finding-end-offset finding) - message (finding-severity finding) extra)) - (def (finding-with-range finding source start end) - (let-values ([(start-line start-col) - (offset->line-col source start)] - [(end-line end-col) (offset->line-col source end)]) - (make-finding (finding-rule-id finding) (finding-path finding) start-line - start-col end-line end-col start end - (finding-message finding) (finding-severity finding) - (finding-extra finding)))) (def (finding-with-bindings rule finding bindings source) (let* ([match-text (source-slice source @@ -20880,25 +20852,6 @@ (finding-end-line finding) (finding-end-col finding) (finding-start-offset finding) (finding-end-offset finding) message (finding-severity finding) extra))) - (def (finding-focused-on-binding finding binding) - (make-finding (finding-rule-id finding) (finding-path finding) - (metavariable-binding-start-line binding) - (metavariable-binding-start-col binding) - (metavariable-binding-end-line binding) - (metavariable-binding-end-col binding) - (metavariable-binding-start-byte binding) - (metavariable-binding-end-byte binding) - (finding-message finding) (finding-severity finding) - (finding-extra finding))) - (def (finding-without-fix finding) - (finding-with-extra - finding - (remove-extra-key 'fix (finding-extra finding)))) - (def (finding-focused-on-binding* finding binding drop-fix?) - (let ([focused (finding-focused-on-binding - finding - binding)]) - (if drop-fix? (finding-without-fix focused) focused))) (def (finding-add-as-binding finding as-var source) (let* ([name (normalize-metavariable-name as-var)] [binding (make-metavariable-binding name @@ -20920,146 +20873,6 @@ (cons (cons 'metavars (cons (cons name binding) metavars)) extra-without-metavars)))) - (def (finding-range-equal? a b) - (and (= (finding-start-offset a) (finding-start-offset b)) - (= (finding-end-offset a) (finding-end-offset b)))) - (def (finding-same-identity? a b) - (and (string=? (finding-rule-id a) (finding-rule-id b)) - (string=? (finding-path a) (finding-path b)) - (string=? (finding-message a) (finding-message b)) - (finding-range-equal? a b))) - (def (dedupe-findings findings) - (let loop ([remaining findings] [seen '()] [acc '()]) - (cond - [(null? remaining) (reverse acc)] - [(any? - (lambda (finding) - (finding-same-identity? (car remaining) finding)) - seen) - (loop (cdr remaining) seen acc)] - [else - (loop - (cdr remaining) - (cons (car remaining) seen) - (cons (car remaining) acc))]))) - (def (source-line source target-line) - (let ([len (string-length source)]) - (let loop ([i 0] [line 1] [start 0]) - (cond - [(= i len) - (if (= line target-line) (substring source start len) "")] - [(char=? (string-ref source i) #\newline) - (if (= line target-line) - (substring source start i) - (loop (+ i 1) (+ line 1) (+ i 1)))] - [else (loop (+ i 1) line start)])))) - (def (line-suppresses-rule? source line rule-id) - (let* ([text (source-line source line)] - [marker (string-find-substring text "nosemgrep")]) - (and marker - (let ([specific (string-find-substring text "nosemgrep:")]) - (if specific - (let ([tail (substring - text - (+ specific (string-length "nosemgrep:")) - (string-length text))]) - (if (string-find-substring tail rule-id) #t #f)) - #t))))) - (def (finding-suppressed? source finding) - (let loop ([line (finding-start-line finding)]) - (and (<= line (finding-end-line finding)) - (or (line-suppresses-rule? - source - line - (finding-rule-id finding)) - (loop (+ line 1)))))) - (def (finding-range-contains? outer inner) - (and (<= (finding-start-offset outer) - (finding-start-offset inner)) - (>= (finding-end-offset outer) (finding-end-offset inner)))) - (def (binding-range-contains-finding? binding finding) - (and (<= (metavariable-binding-start-byte binding) - (finding-start-offset finding)) - (>= (metavariable-binding-end-byte binding) - (finding-end-offset finding)))) - (def (finding-has-binding-containing? candidate finding) - (any? - (lambda (entry) - (binding-range-contains-finding? (cdr entry) finding)) - (finding-metavars candidate))) - (def (finding-ranges-overlap? a b) - (and (< (finding-start-offset a) (finding-end-offset b)) - (< (finding-start-offset b) (finding-end-offset a)))) - (def (string-drop-first s) - (list->string - (let loop ([i 1] [acc '()]) - (if (= i (string-length s)) - (reverse acc) - (loop (+ i 1) (cons (string-ref s i) acc)))))) - (def (string-drop-n s n) (substring s n (string-length s))) - (def (normalize-metavariable-name name) - (if (and (> (string-length name) 0) - (char=? (string-ref name 0) #\$)) - (string-drop-first name) - name)) - (def (ellipsis-normalized-name? name) - (and (>= (string-length name) 3) - (char=? (string-ref name 0) #\.) - (char=? (string-ref name 1) #\.) - (char=? (string-ref name 2) #\.))) - (def (alternate-ellipsis-metavariable-name name) - (if (ellipsis-normalized-name? name) - (string-drop-n name 3) - (string-append "..." name))) - (def (lookup-metavariable-binding name bindings) - (let* ([normalized (normalize-metavariable-name name)] - [found (assoc normalized bindings)]) - (if found - (cdr found) - (let ([alternate (assoc - (alternate-ellipsis-metavariable-name - normalized) - bindings)]) - (and alternate (cdr alternate)))))) - (def (finding-metavars finding) - (alist-ref/default (finding-extra finding) 'metavars '())) - (def (finding-metavariable-binding finding metavariable) - (lookup-metavariable-binding - metavariable - (finding-metavars finding))) - (def (numeric-binding-name? name) - (let ([len (string-length name)]) - (and (> len 0) - (let loop ([i 0]) - (or (= i len) - (and (char-numeric? (string-ref name i)) - (loop (+ i 1)))))))) - (def (merge-binding-list existing additions) - (let loop ([xs additions] [acc existing]) - (cond - [(null? xs) acc] - [else - (let ([found (assoc (caar xs) acc)]) - (cond - [(not found) (loop (cdr xs) (cons (car xs) acc))] - [(string=? - (metavariable-binding-text (cdar xs)) - (metavariable-binding-text (cdr found))) - (loop (cdr xs) acc)] - [(numeric-binding-name? (caar xs)) (loop (cdr xs) acc)] - [else #f]))]))) - (def (bindings-compatible? a b) - (let loop ([xs (finding-metavars a)]) - (cond - [(null? xs) #t] - [else - (let ([other (assoc (caar xs) (finding-metavars b))]) - (and (or (not other) - (numeric-binding-name? (caar xs)) - (string=? - (metavariable-binding-text (cdar xs)) - (metavariable-binding-text (cdr other)))) - (loop (cdr xs))))]))) (def (positive-clause-apply rule candidate findings source) (let loop ([xs findings]) (cond @@ -21120,18 +20933,6 @@ (lambda (finding) (finding-range-contains? finding candidate)) findings)) - (def (finding-on-decorator-line? source finding) - (let* ([start (finding-start-offset finding)] - [line-start (line-start-before source start)]) - (let loop ([i line-start]) - (cond - [(>= i start) #f] - [(char=? (string-ref source i) #\space) (loop (+ i 1))] - [(char=? (string-ref source i) #\tab) (loop (+ i 1))] - [else (char=? (string-ref source i) #\@)])))) - (def (finding-range-width finding) - (- (finding-end-offset finding) - (finding-start-offset finding))) (def (inside-clause-apply rule candidate findings source) (let loop ([xs findings] [best #f] --- a/src/.jerbuild-hashes +++ b/src/.jerbuild-hashes @@ -1,5 +1,6 @@ (("src/semgrep/output/sarif.ss" . "E935456E4B1921FB") ("src/semgrep/result.ss" . "22D23E40B49BA529") ("src/semgrep/engine/rule-plan.ss" . "6631789392AB5F80") + ("src/semgrep/result/findings.ss" . "547811661239D9C7") ("src/semgrep/fix.ss" . "2E5B65B1FEF3B2B1") ("src/semgrep/match/structural.ss" . "5BA4F1566448AF3A") ("src/semgrep/targeting/path-filter.ss" . "9900721941C6B96") @@ -7,7 +8,7 @@ ("src/semgrep/output/json.ss" . "293881CFA2ADB7BC") ("src/semgrep/lang.ss" . "6982E07679D20836") ("src/semgrep/parse/parse-target.ss" . "97AA8FFEB12736DA") - ("src/semgrep/scan.ss" . "70A082557A5C7744") + ("src/semgrep/scan.ss" . "5C81EB3CE9F8F328") ("src/semgrep/rule.ss" . "E12C108153C181FA") ("src/semgrep/schema/lang.ss" . "CAE2CA859C9A9FD0") ("src/semgrep/output/text.ss" . "BE476CB84B807FBA") new file mode 100644 --- /dev/null +++ b/src/semgrep/result/findings.ss @@ -0,0 +1,296 @@ +(export + source-slice + remove-extra-key + finding-with-extra + finding-with-message-and-extra + finding-with-range + finding-focused-on-binding + finding-without-fix + finding-focused-on-binding* + finding-range-equal? + finding-same-identity? + dedupe-findings + source-line + finding-suppressed? + finding-range-contains? + finding-has-binding-containing? + finding-ranges-overlap? + normalize-metavariable-name + lookup-metavariable-binding + finding-metavars + finding-metavariable-binding + merge-binding-list + bindings-compatible? + finding-on-decorator-line? + finding-range-width) + +(import (except (jerboa prelude) meta atom?) + (semgrep result) + (semgrep source offsets) + (semgrep targeting path-filter) + (semgrep match structural)) + +(def (alist-ref/default xs key default) + (let ([found (assoc key xs)]) + (if found (cdr found) default))) + +(def (source-slice source start end) + (substring source start end)) + +(def (remove-extra-key key extra) + (cond + [(null? extra) '()] + [(eq? key (caar extra)) (remove-extra-key key (cdr extra))] + [else (cons (car extra) (remove-extra-key key (cdr extra)))])) + +(def (finding-with-extra finding extra) + (make-finding + (finding-rule-id finding) + (finding-path finding) + (finding-start-line finding) + (finding-start-col finding) + (finding-end-line finding) + (finding-end-col finding) + (finding-start-offset finding) + (finding-end-offset finding) + (finding-message finding) + (finding-severity finding) + extra)) + +(def (finding-with-message-and-extra finding message extra) + (make-finding + (finding-rule-id finding) + (finding-path finding) + (finding-start-line finding) + (finding-start-col finding) + (finding-end-line finding) + (finding-end-col finding) + (finding-start-offset finding) + (finding-end-offset finding) + message + (finding-severity finding) + extra)) + +(def (finding-with-range finding source start end) + (let-values ([(start-line start-col) (offset->line-col source start)] + [(end-line end-col) (offset->line-col source end)]) + (make-finding + (finding-rule-id finding) + (finding-path finding) + start-line + start-col + end-line + end-col + start + end + (finding-message finding) + (finding-severity finding) + (finding-extra finding)))) + +(def (finding-focused-on-binding finding binding) + (make-finding + (finding-rule-id finding) + (finding-path finding) + (metavariable-binding-start-line binding) + (metavariable-binding-start-col binding) + (metavariable-binding-end-line binding) + (metavariable-binding-end-col binding) + (metavariable-binding-start-byte binding) + (metavariable-binding-end-byte binding) + (finding-message finding) + (finding-severity finding) + (finding-extra finding))) + +(def (finding-without-fix finding) + (finding-with-extra + finding + (remove-extra-key 'fix (finding-extra finding)))) + +(def (finding-focused-on-binding* finding binding drop-fix?) + (let ([focused (finding-focused-on-binding finding binding)]) + (if drop-fix? + (finding-without-fix focused) + focused))) + +(def (finding-range-equal? a b) + (and (= (finding-start-offset a) (finding-start-offset b)) + (= (finding-end-offset a) (finding-end-offset b)))) + +(def (finding-same-identity? a b) + (and (string=? (finding-rule-id a) (finding-rule-id b)) + (string=? (finding-path a) (finding-path b)) + (string=? (finding-message a) (finding-message b)) + (finding-range-equal? a b))) + +(def (dedupe-findings findings) + (let loop ([remaining findings] [seen '()] [acc '()]) + (cond + [(null? remaining) (reverse acc)] + [(any? (lambda (finding) + (finding-same-identity? (car remaining) finding)) + seen) + (loop (cdr remaining) seen acc)] + [else + (loop (cdr remaining) + (cons (car remaining) seen) + (cons (car remaining) acc))]))) + +(def (source-line source target-line) + (let ([len (string-length source)]) + (let loop ([i 0] [line 1] [start 0]) + (cond + [(= i len) + (if (= line target-line) + (substring source start len) + "")] + [(char=? (string-ref source i) #\newline) + (if (= line target-line) + (substring source start i) + (loop (+ i 1) (+ line 1) (+ i 1)))] + [else (loop (+ i 1) line start)])))) + +(def (string-find-substring s needle) + (let ([len (string-length s)]) + (let loop ([i 0]) + (cond + [(> i len) #f] + [(and (<= (+ i (string-length needle)) len) + (string=? (substring s i (+ i (string-length needle))) needle)) + i] + [else (loop (+ i 1))])))) + +(def (line-suppresses-rule? source line rule-id) + (let* ([text (source-line source line)] + [marker (string-find-substring text "nosemgrep")]) + (and marker + (let ([specific (string-find-substring text "nosemgrep:")]) + (if specific + (let ([tail (substring text + (+ specific (string-length "nosemgrep:")) + (string-length text))]) + (if (string-find-substring tail rule-id) #t #f)) + #t))))) + +(def (finding-suppressed? source finding) + (let loop ([line (finding-start-line finding)]) + (and (<= line (finding-end-line finding)) + (or (line-suppresses-rule? source line (finding-rule-id finding)) + (loop (+ line 1)))))) + +(def (finding-range-contains? outer inner) + (and (<= (finding-start-offset outer) (finding-start-offset inner)) + (>= (finding-end-offset outer) (finding-end-offset inner)))) + +(def (binding-range-contains-finding? binding finding) + (and (<= (metavariable-binding-start-byte binding) + (finding-start-offset finding)) + (>= (metavariable-binding-end-byte binding) + (finding-end-offset finding)))) + +(def (finding-has-binding-containing? candidate finding) + (any? (lambda (entry) + (binding-range-contains-finding? (cdr entry) finding)) + (finding-metavars candidate))) + +(def (finding-ranges-overlap? a b) + (and (< (finding-start-offset a) (finding-end-offset b)) + (< (finding-start-offset b) (finding-end-offset a)))) + +(def (string-drop-first s) + (list->string + (let loop ([i 1] [acc '()]) + (if (= i (string-length s)) + (reverse acc) + (loop (+ i 1) (cons (string-ref s i) acc)))))) + +(def (string-drop-n s n) + (substring s n (string-length s))) + +(def (normalize-metavariable-name name) + (if (and (> (string-length name) 0) + (char=? (string-ref name 0) #\$)) + (string-drop-first name) + name)) + +(def (ellipsis-normalized-name? name) + (and (>= (string-length name) 3) + (char=? (string-ref name 0) #\.) + (char=? (string-ref name 1) #\.) + (char=? (string-ref name 2) #\.))) + +(def (alternate-ellipsis-metavariable-name name) + (if (ellipsis-normalized-name? name) + (string-drop-n name 3) + (string-append "..." name))) + +(def (lookup-metavariable-binding name bindings) + (let* ([normalized (normalize-metavariable-name name)] + [found (assoc normalized bindings)]) + (if found + (cdr found) + (let ([alternate (assoc (alternate-ellipsis-metavariable-name + normalized) + bindings)]) + (and alternate (cdr alternate)))))) + +(def (finding-metavars finding) + (alist-ref/default (finding-extra finding) 'metavars '())) + +(def (finding-metavariable-binding finding metavariable) + (lookup-metavariable-binding metavariable (finding-metavars finding))) + +(def (numeric-binding-name? name) + (let ([len (string-length name)]) + (and (> len 0) + (let loop ([i 0]) + (or (= i len) + (and (char-numeric? (string-ref name i)) + (loop (+ i 1)))))))) + +(def (merge-binding-list existing additions) + (let loop ([xs additions] [acc existing]) + (cond + [(null? xs) acc] + [else + (let ([found (assoc (caar xs) acc)]) + (cond + [(not found) + (loop (cdr xs) (cons (car xs) acc))] + [(string=? (metavariable-binding-text (cdar xs)) + (metavariable-binding-text (cdr found))) + (loop (cdr xs) acc)] + [(numeric-binding-name? (caar xs)) + (loop (cdr xs) acc)] + [else #f]))]))) + +(def (bindings-compatible? a b) + (let loop ([xs (finding-metavars a)]) + (cond + [(null? xs) #t] + [else + (let ([other (assoc (caar xs) (finding-metavars b))]) + (and (or (not other) + (numeric-binding-name? (caar xs)) + (string=? (metavariable-binding-text (cdar xs)) + (metavariable-binding-text (cdr other)))) + (loop (cdr xs))))]))) + +(def (line-start-before source offset) + (let loop ([i (- offset 1)]) + (cond + [(< i 0) 0] + [(char=? (string-ref source i) #\newline) (+ i 1)] + [else (loop (- i 1))]))) + +(def (finding-on-decorator-line? source finding) + (let* ([start (finding-start-offset finding)] + [line-start (line-start-before source start)]) + (let loop ([i line-start]) + (cond + [(>= i start) #f] + [(char=? (string-ref source i) #\space) (loop (+ i 1))] + [(char=? (string-ref source i) #\tab) (loop (+ i 1))] + [else (char=? (string-ref source i) #\@)])))) + +(def (finding-range-width finding) + (- (finding-end-offset finding) (finding-start-offset finding))) --- a/src/semgrep/scan.ss +++ b/src/semgrep/scan.ss @@ -10,6 +10,7 @@ (semgrep lang) (semgrep rule) (semgrep result) + (semgrep result findings) (semgrep engine rule-plan) (semgrep rule parse-rule) (semgrep parse parse-target) @@ -20882,59 +20883,6 @@ [(pattern-regex pattern pattern-as) #t] [else #f])) -(def (source-slice source start end) - (substring source start end)) - -(def (remove-extra-key key extra) - (cond - [(null? extra) '()] - [(eq? key (caar extra)) (remove-extra-key key (cdr extra))] - [else (cons (car extra) (remove-extra-key key (cdr extra)))])) - -(def (finding-with-extra finding extra) - (make-finding - (finding-rule-id finding) - (finding-path finding) - (finding-start-line finding) - (finding-start-col finding) - (finding-end-line finding) - (finding-end-col finding) - (finding-start-offset finding) - (finding-end-offset finding) - (finding-message finding) - (finding-severity finding) - extra)) - -(def (finding-with-message-and-extra finding message extra) - (make-finding - (finding-rule-id finding) - (finding-path finding) - (finding-start-line finding) - (finding-start-col finding) - (finding-end-line finding) - (finding-end-col finding) - (finding-start-offset finding) - (finding-end-offset finding) - message - (finding-severity finding) - extra)) - -(def (finding-with-range finding source start end) - (let-values ([(start-line start-col) (offset->line-col source start)] - [(end-line end-col) (offset->line-col source end)]) - (make-finding - (finding-rule-id finding) - (finding-path finding) - start-line - start-col - end-line - end-col - start - end - (finding-message finding) - (finding-severity finding) - (finding-extra finding)))) - (def (finding-with-bindings rule finding bindings source) (let* ([match-text (source-slice source (finding-start-offset finding) @@ -20954,31 +20902,6 @@ (finding-severity finding) extra))) -(def (finding-focused-on-binding finding binding) - (make-finding - (finding-rule-id finding) - (finding-path finding) - (metavariable-binding-start-line binding) - (metavariable-binding-start-col binding) - (metavariable-binding-end-line binding) - (metavariable-binding-end-col binding) - (metavariable-binding-start-byte binding) - (metavariable-binding-end-byte binding) - (finding-message finding) - (finding-severity finding) - (finding-extra finding))) - -(def (finding-without-fix finding) - (finding-with-extra - finding - (remove-extra-key 'fix (finding-extra finding)))) - -(def (finding-focused-on-binding* finding binding drop-fix?) - (let ([focused (finding-focused-on-binding finding binding)]) - (if drop-fix? - (finding-without-fix focused) - focused))) - (def (finding-add-as-binding finding as-var source) (let* ([name (normalize-metavariable-name as-var)] [binding @@ -21001,159 +20924,6 @@ (cons (cons 'metavars (cons (cons name binding) metavars)) extra-without-metavars)))) -(def (finding-range-equal? a b) - (and (= (finding-start-offset a) (finding-start-offset b)) - (= (finding-end-offset a) (finding-end-offset b)))) - -(def (finding-same-identity? a b) - (and (string=? (finding-rule-id a) (finding-rule-id b)) - (string=? (finding-path a) (finding-path b)) - (string=? (finding-message a) (finding-message b)) - (finding-range-equal? a b))) - -(def (dedupe-findings findings) - (let loop ([remaining findings] [seen '()] [acc '()]) - (cond - [(null? remaining) (reverse acc)] - [(any? (lambda (finding) - (finding-same-identity? (car remaining) finding)) - seen) - (loop (cdr remaining) seen acc)] - [else - (loop (cdr remaining) - (cons (car remaining) seen) - (cons (car remaining) acc))]))) - -(def (source-line source target-line) - (let ([len (string-length source)]) - (let loop ([i 0] [line 1] [start 0]) - (cond - [(= i len) - (if (= line target-line) - (substring source start len) - "")] - [(char=? (string-ref source i) #\newline) - (if (= line target-line) - (substring source start i) - (loop (+ i 1) (+ line 1) (+ i 1)))] - [else (loop (+ i 1) line start)])))) - -(def (line-suppresses-rule? source line rule-id) - (let* ([text (source-line source line)] - [marker (string-find-substring text "nosemgrep")]) - (and marker - (let ([specific (string-find-substring text "nosemgrep:")]) - (if specific - (let ([tail (substring text - (+ specific (string-length "nosemgrep:")) - (string-length text))]) - (if (string-find-substring tail rule-id) #t #f)) - #t))))) - -(def (finding-suppressed? source finding) - (let loop ([line (finding-start-line finding)]) - (and (<= line (finding-end-line finding)) - (or (line-suppresses-rule? source line (finding-rule-id finding)) - (loop (+ line 1)))))) - -(def (finding-range-contains? outer inner) - (and (<= (finding-start-offset outer) (finding-start-offset inner)) - (>= (finding-end-offset outer) (finding-end-offset inner)))) - -(def (binding-range-contains-finding? binding finding) - (and (<= (metavariable-binding-start-byte binding) - (finding-start-offset finding)) - (>= (metavariable-binding-end-byte binding) - (finding-end-offset finding)))) - -(def (finding-has-binding-containing? candidate finding) - (any? (lambda (entry) - (binding-range-contains-finding? (cdr entry) finding)) - (finding-metavars candidate))) - -(def (finding-ranges-overlap? a b) - (and (< (finding-start-offset a) (finding-end-offset b)) - (< (finding-start-offset b) (finding-end-offset a)))) - -(def (string-drop-first s) - (list->string - (let loop ([i 1] [acc '()]) - (if (= i (string-length s)) - (reverse acc) - (loop (+ i 1) (cons (string-ref s i) acc)))))) -