build: remove tracked generated .sls files and ignore them
ober
1f6eb1f13f5b53c2a9db4022175c58deceb02db0
--- a/.gitignore +++ b/.gitignore @@ -22,3 +22,4 @@ dist/ *~ \#* .#* +**/*.sls deleted file mode 100644 --- a/lib/semgrep/cli.sls +++ /dev/null @@ -1,611 +0,0 @@ -#!chezscheme -;;; Generated by jerbuild — DO NOT EDIT -;;; Source: src/semgrep/cli.ss - -(library (semgrep cli) - (export main) - (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?) (std os secure-output) - (std text glob) (semgrep lang) (semgrep scan) - (semgrep result) (semgrep rule) (semgrep rule parse-rule) - (semgrep fix) (semgrep output json) (semgrep output sarif) - (semgrep output text) - (only - (semgrep targeting path-filter) - read-target-file-string - read-target-from-root-with-identity - read-target-port-string)) - (define max-recursive-entries 100000) - (define max-recursive-depth 128) - (define max-recursive-path-chars (* 8 1024 1024)) - (define max-directory-entries 10000) - (define max-directory-list-bytes (* 1024 1024)) - (defstruct cli-root (handle)) - (defstruct cli-target (root relative display)) - (def (target-display target) - (if (cli-target? target) - (cli-target-display target) - target)) - (def (usage) - (display - "usage: semgrep scan --config RULES.yml [--lang LANG] [--severity LEVEL] [--include GLOB] [--exclude GLOB] [--use-semgrepignore] TARGET\n") - (display "\n") - (display - "MVP support: YAML configs with pattern/pattern-regex rules; json/python/javascript/dockerfile/html/xml/yaml/c/terraform/php/java/csharp/swift/dart/move/julia/kotlin/ruby/rust/go/scala/cpp targets.\n") - (display - "Ignore rules from a scanned tree's .semgrepignore are untrusted and only honored with --use-semgrepignore.\n")) - (def (parse-args args) - (let loop ([xs args] - [config #f] - [language #f] - [format 'json] - [severities '()] - [autofix? #f] - [use-ignore? #f] - [includes '()] - [excludes '()] - [targets '()]) - (cond - [(null? xs) - (values config language format (reverse severities) autofix? - use-ignore? (reverse includes) (reverse excludes) - (reverse targets))] - [(string=? (car xs) "--") - (values config language format (reverse severities) autofix? - use-ignore? (reverse includes) (reverse excludes) - (append (reverse targets) (cdr xs)))] - [(string=? (car xs) "--json") - (loop (cdr xs) config language 'json severities autofix? - use-ignore? includes excludes targets)] - [(string=? (car xs) "--sarif") - (loop (cdr xs) config language 'sarif severities autofix? - use-ignore? includes excludes targets)] - [(string=? (car xs) "--text") - (loop (cdr xs) config language 'text severities autofix? - use-ignore? includes excludes targets)] - [(string=? (car xs) "--autofix") - (loop (cdr xs) config language format severities #t - use-ignore? includes excludes targets)] - [(string=? (car xs) "--use-semgrepignore") - (loop (cdr xs) config language format severities autofix? #t - includes excludes targets)] - [(string=? (car xs) "--config") - (when (null? (cdr xs)) - (error 'semgrep-cli "--config needs a value")) - (loop (cddr xs) (cadr xs) language format severities - autofix? use-ignore? includes excludes targets)] - [(string=? (car xs) "-c") - (when (null? (cdr xs)) - (error 'semgrep-cli "-c needs a value")) - (loop (cddr xs) (cadr xs) language format severities - autofix? use-ignore? includes excludes targets)] - [(string=? (car xs) "--lang") - (when (null? (cdr xs)) - (error 'semgrep-cli "--lang needs a value")) - (loop (cddr xs) config (cadr xs) format severities autofix? - use-ignore? includes excludes targets)] - [(string=? (car xs) "--severity") - (when (null? (cdr xs)) - (error 'semgrep-cli "--severity needs a value")) - (loop (cddr xs) config language format - (cons (cadr xs) severities) autofix? use-ignore? includes - excludes targets)] - [(string=? (car xs) "--include") - (when (null? (cdr xs)) - (error 'semgrep-cli "--include needs a value")) - (loop (cddr xs) config language format severities autofix? - use-ignore? (cons (cadr xs) includes) excludes targets)] - [(string=? (car xs) "--exclude") - (when (null? (cdr xs)) - (error 'semgrep-cli "--exclude needs a value")) - (loop (cddr xs) config language format severities autofix? - use-ignore? includes (cons (cadr xs) excludes) targets)] - [(and (> (string-length (car xs)) 0) - (not (string=? (car xs) "-")) - (char=? (string-ref (car xs) 0) #\-)) - (error 'semgrep-cli "unknown option" (car xs))] - [else - (loop (cdr xs) config language format severities autofix? - use-ignore? includes excludes (cons (car xs) targets))]))) - (def (format-findings format findings) - (case format - [(json) (findings->json-string findings)] - [(sarif) (findings->sarif-json-string findings)] - [(text) (findings->text-string findings)] - [else - (error 'semgrep-cli "unsupported output format" format)])) - (def (severity-selected? severities finding) - (or (null? severities) - (let loop ([xs severities]) - (and (not (null? xs)) - (or (string=? (car xs) (finding-severity finding)) - (loop (cdr xs))))))) - (def (filter-findings-by-severity severities findings) - (filter - (lambda (finding) (severity-selected? severities finding)) - findings)) - (def (entry->string entry) - (if (symbol? entry) (symbol->string entry) entry)) - (def (sg-path-join dir name) - (if (string=? dir "/") - (string-append "/" name) - (string-append dir "/" name))) - (def (skip-directory-name? name) - (or (string=? name ".git") - (string=? name ".hg") - (string=? name ".svn") - (string=? name "node_modules") - (string=? name "__pycache__") - (string=? name ".venv") - (string=? name "venv") - (string=? name "_build") - (string=? name "dist") - (string=? name "build"))) - (def (sg-string-contains-char? s ch) - (let ([len (string-length s)]) - (let loop ([i 0]) - (cond - [(= i len) #f] - [(char=? (string-ref s i) ch) #t] - [else (loop (+ i 1))])))) - (def (sg-string-suffix? suffix s) - (let ([suffix-len (string-length suffix)] - [len (string-length s)]) - (and (<= suffix-len len) - (string=? (substring s (- len suffix-len) len) suffix)))) - (def (split-lines source) - (let ([len (string-length source)]) - (let loop ([i 0] [start 0] [acc '()]) - (cond - [(= i len) - (reverse - (if (= start len) - acc - (cons (substring source start len) acc)))] - [(char=? (string-ref source i) #\newline) - (loop - (+ i 1) - (+ i 1) - (cons (substring source start i) acc))] - [else (loop (+ i 1) start acc)])))) - (def (ignore-line? line) - (or (= (string-length line) 0) - (char=? (string-ref line 0) #\#))) - (def (read-semgrepignore dir) - (let ([path (sg-path-join dir ".semgrepignore")]) - (if (file-exists? path) - (let loop ([lines (split-lines - (read-target-file-string path))] - [acc '()]) - (cond - [(null? lines) (reverse acc)] - [(ignore-line? (car lines)) (loop (cdr lines) acc)] - [else (loop (cdr lines) (cons (car lines) acc))])) - '()))) - (def (report-ignored-paths dir paths) - (let ([port (current-error-port)]) - (display "semgrep: .semgrepignore (opt-in) ignored " port) - (display (length paths) port) - (display " path(s) under " port) - (display dir port) - (display ":" port) - (newline port) - (for-each - (lambda (path) - (display " " port) - (display path port) - (newline port)) - paths) - (flush-output-port port))) - (def (ignore-pattern-matches? pattern relative name) - (or (glob-match? pattern relative) - (and (not (sg-string-contains-char? pattern #\/)) - (glob-match? pattern name)) - (and (sg-string-suffix? "/" pattern) - (glob-match? (string-append pattern "**") relative)))) - (def (ignore-negated? pattern) - (and (> (string-length pattern) 0) - (char=? (string-ref pattern 0) #\!))) - (def (ignore-pattern-body pattern) - (if (ignore-negated? pattern) - (substring pattern 1 (string-length pattern)) - pattern)) - (def (ignored-path? patterns relative name) - (let loop ([xs patterns] [ignored? #f]) - (if (null? xs) - ignored? - (let ([pattern (car xs)]) - (if (ignore-pattern-matches? - (ignore-pattern-body pattern) - relative - name) - (loop (cdr xs) (not (ignore-negated? pattern))) - (loop (cdr xs) ignored?)))))) - (def (path-basename path) - (let ([len (string-length path)]) - (let loop ([i (- len 1)]) - (cond - [(< i 0) path] - [(char=? (string-ref path i) #\/) - (substring path (+ i 1) len)] - [else (loop (- i 1))])))) - (def (path-parent-and-name path) - (let ([len (string-length path)]) - (let loop ([i (- len 1)]) - (cond - [(< i 0) (values "." path)] - [(char=? (string-ref path i) #\/) - (when (= i (- len 1)) - (error 'semgrep-cli "target path ends with slash" path)) - (values - (if (= i 0) "/" (substring path 0 i)) - (substring path (+ i 1) len))] - [else (loop (- i 1))])))) - (def (target-pattern-matches? pattern path) - (or (glob-match? pattern path) - (glob-match? pattern (path-basename path)))) - (def (target-selected? includes excludes path) - (and (or (null? includes) - (let loop ([xs includes]) - (and (not (null? xs)) - (or (target-pattern-matches? (car xs) path) - (loop (cdr xs)))))) - (not (let loop ([xs excludes]) - (and (not (null? xs)) - (or (target-pattern-matches? (car xs) path) - (loop (cdr xs)))))))) - (def (scannable-file? language-opt path) - (or language-opt (guess-language-from-path path))) - (def (identity-key info) - (cons (secure-entry-device info) (secure-entry-inode info))) - (def (identity-seen? key seen) (hash-key? seen key)) - (def (expand-open-directory-target - language-opt - dir - root - use-ignore?) - (let ([ignore-patterns (if use-ignore? - (read-semgrepignore dir) - '())] - [entry-count 0] - [path-char-count 0] - [ignored-paths '()] - [seen (make-hash-table)]) - (let ([expanded (let walk ([relative-dir ""] - [depth 0] - [acc '()]) - (when (> depth max-recursive-depth) - (error 'semgrep-cli - "recursive target exceeds depth limit" - max-recursive-depth)) - (let* ([directory-info (secure-entry-info - (cli-root-handle root) - relative-dir)] - [key (identity-key directory-info)]) - (unless (eq? (secure-entry-kind - directory-info) - 'directory) - (error 'semgrep-cli - "recursive target changed type" - relative-dir)) - (when (identity-seen? key seen) - (error 'semgrep-cli - "recursive target contains a directory cycle" - relative-dir)) - (hash-put! seen key #t) - (let loop ([entries (secure-directory-list - (cli-root-handle root) - relative-dir - max-directory-entries - max-directory-list-bytes)] - [current-acc acc]) - (if (null? entries) - current-acc - (let* ([name (car entries)] - [relative (if (string=? - relative-dir - "") - name - (sg-path-join - relative-dir - name))] - [display (sg-path-join - dir - relative)]) - (set! entry-count (+ entry-count 1)) - (set! path-char-count - (+ path-char-count - (string-length relative))) - (when (> entry-count - max-recursive-entries) - (error 'semgrep-cli - "recursive target exceeds entry limit" - max-recursive-entries)) - (when (> path-char-count - max-recursive-path-chars) - (error 'semgrep-cli - "recursive target exceeds path-byte budget" - max-recursive-path-chars)) - (if (ignored-path? - ignore-patterns - relative - name) - (begin - (set! ignored-paths - (cons display ignored-paths)) - (loop - (cdr entries) - current-acc)) - (let ([info (secure-entry-info - (cli-root-handle - root) - relative)]) - (case (secure-entry-kind info) - [(symlink) - (loop - (cdr entries) - current-acc)] - [(directory) - (if (skip-directory-name? - name) - (loop - (cdr entries) - current-acc) - (loop - (cdr entries) - (walk - relative - (+ depth 1) - current-acc)))] - [(file) - (when (> (secure-entry-links - info) - 1) - (error 'semgrep-cli - "recursive target contains a hard-linked file" - display)) - (loop - (cdr entries) - (if (scannable-file? - language-opt - display) - (cons - (make-cli-target - root - relative - display) - current-acc) - current-acc))] - [else - (loop - (cdr entries) - current-acc)]))))))))]) - (when (and use-ignore? (pair? ignored-paths)) - (report-ignored-paths dir (reverse ignored-paths))) - expanded))) - (def (expand-file-target target) - (let-values ([(parent name) (path-parent-and-name target)]) - (let ([handle (secure-directory-open parent #f)]) - (guard (failure - [#t (secure-directory-close handle) (raise failure)]) - (let* ([root (make-cli-root handle)] - [info (secure-entry-info handle name)]) - (unless (eq? (secure-entry-kind info) 'file) - (error 'semgrep-cli - "target is not a regular file" - target)) - (when (> (secure-entry-links info) 1) - (error 'semgrep-cli - "target has multiple hard links" - target)) - (values - (list (make-cli-target root name target)) - (list root))))))) - (def (expand-target language-opt use-ignore? target) - (if (string=? target "-") - (values (list target) '()) - (guard (directory-error [#t (expand-file-target target)]) - (let* ([handle (secure-directory-open-strict target)] - [root (make-cli-root handle)]) - (guard (walk-error - [#t - (secure-directory-close handle) - (raise walk-error)]) - (values - (reverse - (expand-open-directory-target - language-opt - target - root - use-ignore?)) - (list root))))))) - (def (expand-targets language-opt use-ignore? includes - excludes targets) - (let ([opened-roots '()]) - (guard (failure - [#t - (for-each - (lambda (root) - (secure-directory-close (cli-root-handle root))) - opened-roots) - (raise failure)]) - (let loop ([remaining targets] [expanded '()]) - (if (null? remaining) - (values - (filter - (lambda (target) - (target-selected? - includes - excludes - (target-display target))) - (reverse expanded)) - opened-roots) - (let-values ([(next-targets next-roots) - (expand-target - language-opt - use-ignore? - (car remaining))]) - (set! opened-roots (append next-roots opened-roots)) - (loop - (cdr remaining) - (append (reverse next-targets) expanded)))))))) - (def (string-list-member? needle xs) - (and (not (null? xs)) - (or (string=? needle (car xs)) - (string-list-member? needle (cdr xs))))) - (def (unique-rule-languages rules) - (let rule-loop ([remaining rules] [acc '()]) - (if (null? remaining) - (reverse acc) - (let lang-loop ([langs (rule-languages (car remaining))] - [current acc]) - (if (null? langs) - (rule-loop (cdr remaining) current) - (lang-loop - (cdr langs) - (if (string-list-member? (car langs) current) - current - (cons (car langs) current)))))))) - (def (single-config-language rules) - (let ([languages (unique-rule-languages rules)]) - (and (not (null? languages)) - (null? (cdr languages)) - (car languages)))) - (def (single-text-config-language rules) - (let ([language (single-config-language rules)]) - (and language - (let ([canonical (or (canonical-language language) - language)]) - (and (or (string=? canonical "generic") - (string=? canonical "regex")) - language))))) - (def (scan-one rules language-opt target) - (let* ([target-path (target-display target)] - [language (or language-opt - (single-text-config-language rules) - (and (not (string=? target-path "-")) - (guess-language-from-path target-path)) - (single-config-language rules))]) - (unless language - (error 'semgrep-cli - "could not infer target language" - target-path)) - (unless (known-language? language) - (error 'semgrep-cli "unknown target language" language)) - (if (string=? target-path "-") - (scan-string - rules - language - "<stdin>" - (read-target-port-string (current-input-port) "<stdin>")) - (if (cli-target? target) - (call-with-values - (lambda () - (read-target-from-root-with-identity - (cli-root-handle (cli-target-root target)) - (cli-target-relative target) - target-path)) - (lambda (source identity) - (scan-string rules language target-path source))) - (scan-file rules language target-path))))) - (def (report-scan-error path condition) - (let ([port (current-error-port)]) - (display "semgrep: scan-error: skipping " port) - (display path port) - (display ": " port) - (display-condition condition port) - (newline port) - (flush-output-port port))) - (def (findings-for-path path findings) - (filter - (lambda (finding) (string=? (finding-path finding) path)) - findings)) - (def (apply-autofix-to-target! target findings) - (let ([display (target-display target)]) - (unless (string=? display "-") - (let ([target-findings (findings-for-path - display - findings)]) - (unless (null? target-findings) - (if (cli-target? target) - (call-with-values - (lambda () - (read-target-from-root-with-identity - (cli-root-handle (cli-target-root target)) - (cli-target-relative target) - display)) - (lambda (source identity) - (let ([replacement (apply-fixes-to-string - source - target-findings)]) - (call-with-secure-replacement-file - (cli-root-handle (cli-target-root target)) - (cli-target-relative target) - identity - (lambda (port) - (put-bytevector - port - (string->utf8 replacement))))))) - (error 'semgrep-cli - "autofix requires a descriptor-relative target" - display))))))) - (def (apply-autofix! targets findings) - (let loop ([xs targets]) - (unless (null? xs) - (apply-autofix-to-target! (car xs) findings) - (loop (cdr xs))))) - (def (main argv) - (let ([args (if (and (pair? argv) - (string=? (car argv) "scan")) - (cdr argv) - argv)]) - (if (or (null? args) - (member "--help" args) - (member "-h" args)) - (begin (usage) 0) - (let-values ([(config language format severities autofix? use-ignore? includes excludes targets) - (parse-args args)]) - (unless config - (usage) - (error 'semgrep-cli "missing --config")) - (when (null? targets) - (usage) - (error 'semgrep-cli "missing target")) - (let ([rules (parse-config-file config)]) - (let-values ([(expanded-targets roots) - (expand-targets language use-ignore? - includes excludes targets)]) - (dynamic-wind - (lambda () (void)) - (lambda () - (let ([findings (filter-findings-by-severity - severities - (apply - append - (map (lambda (target) - (guard (scan-failure - [#t - (report-scan-error - (target-display - target) - scan-failure) - '()]) - (scan-one - rules - language - target))) - expanded-targets)))]) - (when autofix? - (apply-autofix! expanded-targets findings)) - (display (format-findings format findings)) - (newline) - (if (null? findings) 0 1))) - (lambda () - (for-each - (lambda (root) - (secure-directory-close (cli-root-handle root))) - roots)))))))))) deleted file mode 100644 --- a/lib/semgrep/engine/comparison.sls +++ /dev/null @@ -1,907 +0,0 @@ -#!chezscheme -;;; Generated by jerbuild — DO NOT EDIT -;;; Source: src/semgrep/engine/comparison.ss - -(library (semgrep engine comparison) - (export comparison-missing? comparison-value->string - constant-bindings-before comparison-value - metavariable-comparison-satisfied? skip-whitespace - substring-trim outer-pair? find-top-level-binary-operator) - (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?) (std regex) - (semgrep lang) (semgrep result) (semgrep result findings) - (semgrep engine regex-support) (semgrep util literals) - (semgrep match structural)) - (define missing-comparison-value - (list 'missing-comparison-value)) - (define comparison-max-exponent 1000) - (def (alist-ref/default xs key default) - (let ([found (assoc key xs)]) - (if found (cdr found) default))) - (def (comparison-missing? value) - (eq? value missing-comparison-value)) - (def (any? pred xs) - (and (not (null? xs)) - (or (pred (car xs)) (any? pred (cdr xs))))) - (def (comparison-word-char? ch) - (or (char-alphabetic? ch) - (char-numeric? ch) - (char=? ch #\_) - (char=? ch #\$))) - (def (comparison-identifier-char? ch) - (or (char-alphabetic? ch) - (char-numeric? ch) - (char=? ch #\_))) - (def (identifier-char? ch) - (or (char-alphabetic? ch) - (char-numeric? ch) - (char=? ch #\_) - (char=? ch #\$))) - (def (sg-string-suffix? suffix s) - (let ([suffix-len (string-length suffix)] - [len (string-length s)]) - (and (<= suffix-len len) - (string=? (substring s (- len suffix-len) len) suffix)))) - (def (string-find-substring s needle) - (let ([len (string-length s)]) - (let loop ([i 0]) - (cond - [(> i len) #f] - [(substring-at? s needle i) i] - [else (loop (+ i 1))])))) - (def (string-map-chars proc source) - (let ([len (string-length source)]) - (let loop ([i 0] [acc '()]) - (if (= i len) - (list->string (reverse acc)) - (loop (+ i 1) (cons (proc (string-ref source i)) acc)))))) - (def (source-contains-char? source ch) - (let ([len (string-length source)]) - (let loop ([i 0]) - (cond - [(= i len) #f] - [(char=? (string-ref source i) ch) #t] - [else (loop (+ i 1))])))) - (def (numeric-literal-float-like? source) - (or (source-contains-char? source #\.) - (source-contains-char? source #\e) - (source-contains-char? source #\E) - (source-contains-char? source #\f) - (source-contains-char? source #\F) - (source-contains-char? source #\d) - (source-contains-char? source #\D))) - (def (substring-trim source start end) - (string-trim (substring source start end))) - (def (keyword-at? source index keyword) - (let* ([len (string-length source)] - [keyword-len (string-length keyword)] - [end (+ index keyword-len)]) - (and (<= end len) - (string=? (substring source index end) keyword) - (or (= index 0) - (not (comparison-word-char? - (string-ref source (- index 1))))) - (or (= end len) - (not (comparison-word-char? (string-ref source end))))))) - (def (find-top-level-keyword source keyword) - (let ([len (string-length source)]) - (let loop ([i 0] [depth 0] [state 'normal] [escaped? #f]) - (cond - [(>= i len) #f] - [(eq? state 'normal) - (let ([ch (string-ref source i)]) - (cond - [(char=? ch #\") (loop (+ i 1) depth 'double #f)] - [(char=? ch #\') (loop (+ i 1) depth 'single #f)] - [(char=? ch #\`) (loop (+ i 1) depth 'backtick #f)] - [(or (char=? ch #\() (char=? ch #\[)) - (loop (+ i 1) (+ depth 1) state #f)] - [(or (char=? ch #\)) (char=? ch #\])) - (loop (+ i 1) (max 0 (- depth 1)) state #f)] - [(and (= depth 0) (keyword-at? source i keyword)) i] - [else (loop (+ i 1) depth state #f)]))] - [escaped? (loop (+ i 1) depth state #f)] - [(char=? (string-ref source i) #\\) - (loop (+ i 1) depth state #t)] - [(and (eq? state 'double) - (char=? (string-ref source i) #\")) - (loop (+ i 1) depth 'normal #f)] - [(and (eq? state 'single) - (char=? (string-ref source i) #\')) - (loop (+ i 1) depth 'normal #f)] - [(and (eq? state 'backtick) - (char=? (string-ref source i) #\`)) - (loop (+ i 1) depth 'normal #f)] - [else (loop (+ i 1) depth state #f)])))) - (def (skip-whitespace source index) - (let ([len (string-length source)]) - (let loop ([i index]) - (if (and (< i len) (char-whitespace? (string-ref source i))) - (loop (+ i 1)) - i)))) - (def (find-top-level-not-in source) - (let ([not-index (find-top-level-keyword source "not")]) - (and not-index - (let ([in-index (skip-whitespace source (+ not-index 3))]) - (and (keyword-at? source in-index "in") - (cons not-index (+ in-index 2))))))) - (def (operator-at? source index op) - (let ([end (+ index (string-length op))]) - (and (<= end (string-length source)) - (string=? (substring source index end) op)))) - (def (find-top-level-operator source ops) - (let ([len (string-length source)]) - (let loop ([i 0] [depth 0] [state 'normal] [escaped? #f]) - (cond - [(>= i len) #f] - [(eq? state 'normal) - (let ([ch (string-ref source i)]) - (cond - [(char=? ch #\") (loop (+ i 1) depth 'double #f)] - [(char=? ch #\') (loop (+ i 1) depth 'single #f)] - [(char=? ch #\`) (loop (+ i 1) depth 'backtick #f)] - [(or (char=? ch #\() (char=? ch #\[)) - (loop (+ i 1) (+ depth 1) state #f)] - [(or (char=? ch #\)) (char=? ch #\])) - (loop (+ i 1) (max 0 (- depth 1)) state #f)] - [(= depth 0) - (let find-op ([remaining ops]) - (cond - [(null? remaining) (loop (+ i 1) depth state #f)] - [(operator-at? source i (car remaining)) - (cons (car remaining) i)] - [else (find-op (cdr remaining))]))] - [else (loop (+ i 1) depth state #f)]))] - [escaped? (loop (+ i 1) depth state #f)] - [(char=? (string-ref source i) #\\) - (loop (+ i 1) depth state #t)] - [(and (eq? state 'double) - (char=? (string-ref source i) #\")) - (loop (+ i 1) depth 'normal #f)] - [(and (eq? state 'single) - (char=? (string-ref source i) #\')) - (loop (+ i 1) depth 'normal #f)] - [(and (eq? state 'backtick) - (char=? (string-ref source i) #\`)) - (loop (+ i 1) depth 'normal #f)] - [else (loop (+ i 1) depth state #f)])))) - (def (split-top-level-commas source) - (let ([len (string-length source)]) - (let loop ([i 0] - [start 0] - [depth 0] - [state 'normal] - [escaped? #f] - [acc '()]) - (cond - [(>= i len) - (reverse (cons (substring-trim source start len) acc))] - [(eq? state 'normal) - (let ([ch (string-ref source i)]) - (cond - [(char=? ch #\") - (loop (+ i 1) start depth 'double #f acc)] - [(char=? ch #\') - (loop (+ i 1) start depth 'single #f acc)] - [(char=? ch #\`) - (loop (+ i 1) start depth 'backtick #f acc)] - [(or (char=? ch #\() (char=? ch #\[)) - (loop (+ i 1) start (+ depth 1) state #f acc)] - [(or (char=? ch #\)) (char=? ch #\])) - (loop (+ i 1) start (max 0 (- depth 1)) state #f acc)] - [(and (= depth 0) (char=? ch #\,)) - (loop (+ i 1) (+ i 1) depth state #f - (cons (substring-trim source start i) acc))] - [else (loop (+ i 1) start depth state #f acc)]))] - [escaped? (loop (+ i 1) start depth state #f acc)] - [(char=? (string-ref source i) #\\) - (loop (+ i 1) start depth state #t acc)] - [(and (eq? state 'double) - (char=? (string-ref source i) #\")) - (loop (+ i 1) start depth 'normal #f acc)] - [(and (eq? state 'single) - (char=? (string-ref source i) #\')) - (loop (+ i 1) start depth 'normal #f acc)] - [(and (eq? state 'backtick) - (char=? (string-ref source i) #\`)) - (loop (+ i 1) start depth 'normal #f acc)] - [else (loop (+ i 1) start depth state #f acc)])))) - (def (pair-from-index-to-end? source start open close) - (let ([len (string-length source)]) - (and (< start len) - (char=? (string-ref source start) open) - (let loop ([i start] - [depth 0] - [state 'normal] - [escaped? #f]) - (cond - [(>= i len) #f] - [(eq? state 'normal) - (let ([ch (string-ref source i)]) - (cond - [(char=? ch #\") (loop (+ i 1) depth 'double #f)] - [(char=? ch #\') (loop (+ i 1) depth 'single #f)] - [(char=? ch #\`) (loop (+ i 1) depth 'backtick #f)] - [(char=? ch open) - (loop (+ i 1) (+ depth 1) state #f)] - [(char=? ch close) - (let ([next-depth (- depth 1)]) - (and (>= next-depth 0) - (if (= next-depth 0) - (= (+ i 1) len) - (loop (+ i 1) next-depth state #f))))] - [else (loop (+ i 1) depth state #f)]))] - [escaped? (loop (+ i 1) depth state #f)] - [(char=? (string-ref source i) #\\) - (loop (+ i 1) depth state #t)] - [(and (eq? state 'double) - (char=? (string-ref source i) #\")) - (loop (+ i 1) depth 'normal #f)] - [(and (eq? state 'single) - (char=? (string-ref source i) #\')) - (loop (+ i 1) depth 'normal #f)] - [(and (eq? state 'backtick) - (char=? (string-ref source i) #\`)) - (loop (+ i 1) depth 'normal #f)] - [else (loop (+ i 1) depth state #f)]))))) - (def (outer-pair? source open close) - (and (>= (string-length source) 2) - (pair-from-index-to-end? source 0 open close))) - (def (comparison-function-call expr) - (let ([len (string-length expr)]) - (let loop ([i 0]) - (cond - [(or (= i len) - (not (comparison-identifier-char? (string-ref expr i)))) - (and (> i 0) - (< i len) - (pair-from-index-to-end? expr i #\( #\)) - (cons - (substring expr 0 i) - (substring expr (+ i 1) (- len 1))))] - [else (loop (+ i 1))])))) - (def (comparison-metavariable-reference-name expr) - (let ([len (string-length expr)]) - (and (>= len 1) - (or (char=? (string-ref expr 0) #\$) - (char-alphabetic? (string-ref expr 0)) - (char=? (string-ref expr 0) #\_)) - (let ([start (if (char=? (string-ref expr 0) #\$) 1 0)]) - (and (< start len) - (let loop ([i start]) - (cond - [(= i len) (substring expr start len)] - [(comparison-identifier-char? (string-ref expr i)) - (loop (+ i 1))] - [else #f]))))))) - (def (comparison-value->string value) - (cond - [(comparison-missing? value) ""] - [(string? value) value] - [(number? value) (number->string value)] - [(boolean? value) (if value "true" "false")] - [else ""])) - (def (regex-fold-matches pattern source proc seed) - (let ([rx (re pattern)] [len (string-length source)]) - (let loop ([start 0] [acc seed]) - (if (> start len) - acc - (let ([match (re-search rx source start)]) - (if match - (let ([next (max (+ (re-match-start match) 1) - (re-match-end match))]) - (loop next (proc match acc))) - acc)))))) - (def (comparison-binding-value binding strip? base) - (let* ([text (metavariable-binding-text binding)] - [number (parse-number-literal text base)]) - (cond - [(and strip? number) number] - [number number] - [else (strip-delimiter-pair (string-trim text))]))) - (def python-simple-assignment-regex - "(^|\\n)[ \\t]*([A-Za-z_][A-Za-z0-9_]*)[ \\t]*=[ \\t]*([^\\n#]+)") - (def go-simple-assignment-regex - "(^|\\n)[ \\t]*([A-Za-z_][A-Za-z0-9_]*)[ \\t]*(?::=|=)[ \\t]*([^\\n#=][^\\n#]*)") - (def java-simple-assignment-regex - "(^|\\n)[ \\t]*(?:[A-Za-z_][A-Za-z0-9_<>\\[\\].]*[ \\t]+)*([A-Za-z_][A-Za-z0-9_]*)[ \\t]*=[ \\t]*([^\\n;=][^\\n;]*)") - (def (go-language? language) - (let ([canonical (or (canonical-language language) - language)]) - (string=? canonical "go"))) - (def (java-language? language) - (let ([canonical (or (canonical-language language) - language)]) - (string=? canonical "java"))) - (def (constant-binding-from-value name value source offset) - (make-regex-capture-binding name - (comparison-value->string value) source offset offset)) - (def (constant-bindings-before - source - before-offset - language) - (regex-fold-matches - (cond - [(and language (go-language? language)) - go-simple-assignment-regex] - [(and language (java-language? language)) - java-simple-assignment-regex] - [else python-simple-assignment-regex]) - (substring source 0 before-offset) - (lambda (match acc) - (let* ([name (re-match-group match 2)] - [expr (string-trim (re-match-group match 3))] - [value (comparison-value expr acc #f #f)]) - (if (or (comparison-missing? value) - (string=? (comparison-value->string value) "")) - acc - (let* ([relative (or (string-find-substring-from - (re-match-full match) - name - 0) - 0)] - [binding (constant-binding-from-value - name - value - source - (+ (re-match-start match) relative))] - [without-old (let loop ([xs acc]) - (cond - [(null? xs) '()] - [(string=? (caar xs) name) - (loop (cdr xs))] - [else - (cons - (car xs) - (loop (cdr xs)))]))]) - (cons (cons name binding) without-old))))) - '())) - (def (binding-resolved-for-comparison - binding - constants - source) - (let* ([text (string-trim - (metavariable-binding-text binding))] - [value (comparison-value text constants #f #f)]) - (if (or (comparison-missing? value) (equal? value text)) - binding - (make-metavariable-binding (metavariable-binding-name binding) - (comparison-value->string value) - (metavariable-binding-start-byte binding) - (metavariable-binding-end-byte binding) - (metavariable-binding-start-line binding) - (metavariable-binding-start-col binding) - (metavariable-binding-end-line binding)