#lang at-exp racket/base

(require macro-debugger/analysis/check-requires
         racket/contract/base
         racket/contract/region
         racket/format
         racket/function
         racket/list
         racket/match
         racket/path
         racket/port
         racket/pretty
         racket/set
         racket/string
         racket/tcp
         syntax/modresolve
         (only-in xml xexpr->string)
         "channel.rkt"
         "defn.rkt"
         "fresh-line.rkt"
         "help.rkt"
         "instrument.rkt"
         "mod.rkt"
         "scribble.rkt"
         "try-catch.rkt"
         "util.rkt")

(provide start-command-server
         attach-command-server
         make-prompt-read
         display-prompt)

(module+ test
  (require rackunit))

;; Emacs Lisp needs to send us commands and get responses.
;;
;; There are a few ways to do this.
;;
;; 0. Vanilla "inferior-mode" stdin/stdout. Commands are sent to stdin
;;    -- "typed invisibly at the REPL prompt" -- and responses go to
;;    stdout. Mixing command I/O with the user's Racket program I/O
;;    works better than you might expect -- but worse than you want.
;;
;;    Unmixing output is the biggest challenge. Traditionally a comint
;;    filter proc will try to extract everything up to a sentinel like
;;    the next REPL prompt. But it can accidentally match user program
;;    output that resembles the sentinel. (Real example: The ,describe
;;    command returns HTML that happens to contain `\ntag>`.)
;;
;;    Input is also a problem. If the user's program reads from stdin,
;;    it might eat a command. Or if it runs for awhile; commands are
;;    blocked.
;;
;;    TL;DR: Command traffic should be out of band not mixed in stdin
;;    and stdout.
;;
;; 1. Use files. Originally I addressed the mixed-output side by
;;    having commands output responses to a file. (Stdout only
;;    contains regular Racket output and appears directly in REPL
;;    buffer as usual.) This didn't address mixed input. Although
;;    using a command input file could have worked (and did work in
;;    experiments), instead...
;;
;; 2. Use sockets. Now the status quo. Note that this is _not_ a
;;    "network REPL". The socket server is solely for command input
;;    and output. There is no redirection of user's Racket program
;;    I/O, and it is still handled by Emacs' comint-mode in the usual
;;    manner.

(define command-server-ns (make-base-namespace))
(define command-server-path #f)

(define (attach-command-server ns path)
  (set! command-server-ns ns)
  (set! command-server-path path))

(define (start-command-server port)
  (void
   (thread
    (λ ()
      (define listener (tcp-listen port 4 #t))
      (let connect ()
        (define-values (in out) (tcp-accept listener))
        (parameterize ([current-input-port in]
                       [current-output-port out])
          (define fail (λ _ (elisp-println #f)))
          (let loop ()
            (match (read-syntax)
              [(? eof-object?) (void)]
              [stx (with-handlers ([exn:fail? fail])
                     (parameterize ([current-namespace command-server-ns])
                       (handle-command stx command-server-path fail)))
                   (flush-output)
                   (loop)])))
        (close-input-port in)
        (close-output-port out)
        (connect))))))

(define at-prompt (box 0))
(define (at-prompt?) (positive? (unbox at-prompt)))

(define/contract ((make-prompt-read m))
  (-> (or/c #f mod?) (-> any))
  (display-prompt (maybe-mod->prompt-string m))
  (define in ((current-get-interaction-input-port)))
  (define stx (dynamic-wind
                (λ _ (box-swap! at-prompt add1))
                (λ _ ((current-read-interaction) (object-name in) in))
                (λ _ (box-swap! at-prompt sub1))))
  (syntax-case stx ()
    [(uq cmd)
     (eq? 'unquote (syntax-e #'uq))
     (begin (handle-command #'cmd m usage)
            #'(void))] ;avoid Typed Racket printing a type
    [_ stx]))

(define (display-prompt str)
  (flush-output (current-error-port))
  (fresh-line)
  (display str)
  ;; Use a character unlikely to appear in normal output. Makes it
  ;; easier for Emacs comint-regexp-prompt to avoid matching program
  ;; output by mistake. (This used to be very important: We mixed
  ;; command output with stdout and a comint filter proc had to un-mix
  ;; it. Today it mainly just helps comint-{previous next}-prompt.)
  (display #\uFEFF) ;ZERO WIDTH NON-BREAKING SPACE
  (display "> ")
  (flush-output)
  (zero-column!))

(define (elisp-read)
  ;; Elisp prints '() as 'nil. Reverse that. (Assumption: Although
  ;; some Elisp code puns nil/() also to mean "false" -- _our_ Elisp
  ;; code _won't_ do that when sending us commands.)
  (match (read)
    ['nil '()]
    [x x]))

(define/contract (handle-command cmd-stx m unknown-command)
  (-> syntax? (or/c #f mod?) (-> any) any)
  (define-values (dir file mod-path) (maybe-mod->dir/file/rmp m))
  (define path (and file (build-path dir file)))
  (let ([read elisp-read])
    (case (syntax-e cmd-stx)
      ;; These commands are intended to be used by either the user or
      ;; racket-mode.
      [(run)             (run-or-top 'run)]
      [(top)             (run-or-top 'top)]
      [(doc)             (doc (read-syntax))]
      [(exp)             (exp1 (read))]
      [(exp+)            (exp+)]
      [(exp!)            (exp! (read))]
      [(pwd)             (display-commented (~v (current-directory)))]
      [(cd)              (cd (~a (read)))]
      [(exit)            (exit)]
      [(info)            (info)]
      ;; These remaining commands are intended to be used by
      ;; racket-mode, only.
      [(path)            (elisp-println path)]
      [(prompt)          (elisp-println (and (at-prompt?) (or path 'top)))]
      [(syms)            (syms)]
      [(def)             (def-loc (read))]
      [(describe)        (describe (read-syntax))]
      [(mod)             (mod-loc (read) mod-path)]
      [(type)            (type (read))]
      [(requires/tidy)   (requires/tidy (read))]
      [(requires/trim)   (requires/trim (read) (read))]
      [(requires/base)   (requires/base (read) (read))]
      [(find-collection) (find-collection (read))]
      [(get-profile)     (get-profile)]
      [(get-uncovered)   (get-uncovered path)]
      [(check-syntax)    (check-syntax (string->path (read)))]
      ;; Obsolete
      [(log)             (display-commented "Use M-x racket-logger instead")]
      [else              (unknown-command)])))

(define (usage)
  (display-commented
   @~a{Commands:
       ,run <module> [<mem-limit-MB> [<pretty-print?> [<error-context> [<cmd-line>]]]]
       ,top          [<mem-limit-MB> [<pretty-print?> [<error-context> [<cmd-line>]]]]
         <module> = <file>
                  | (<file> <submodule-id> ...)
         <file> = file.rkt
                | /path/to/file.rkt
                | "file.rkt" | "/path/to/file.rkt"
         <error-context> = low
                         | medium
                         | high
         <cmd-line> = (listof string?) e.g. '("-f" "foo" "--bar" "baz")
       ,exit
       ,doc <identifier>|<string>
       ,exp <stx>
       ,exp+
       ,exp! <stx>
       ,pwd
       ,cd <path>}))

;;; run, top, info

;; Parameter-like interface, but we don't want thread-local. We do
;; want to call collect-garbage IFF the new limit is less than the old
;; one or less than the current actual usage.
(define current-mem
  (let ([old 0])
    (case-lambda
      [() old]
      [(new)
       (and old new
            (or (< new old)
                (< (* new 1024 1024) (current-memory-use)))
            (collect-garbage))
       (set! old new)])))

;; Likewise: Want parameter signature but NOT thread-local.
(define-syntax-rule (make-parameter-ish init)
  (let ([old init])
    (case-lambda
      [() old]
      [(new) (set! old new)])))

(define current-pp? (make-parameter-ish #t))
(define current-ctx-lvl (make-parameter-ish 'low)) ;context-level?
(define current-args (make-parameter-ish (vector)))

(define (run-or-top which)
  ;; Support both the ,run and ,top commands. Latter has no first path
  ;; arg, but otherwise they share subsequent optional args. (Note:
  ;; The complexity here is from the desire to let user type simply
  ;; e.g. ",top" or ",run file" and use the existing values for the
  ;; omitted args. We're intended mainly to be used from Emacs, which
  ;; can/does always supply all the args. But, may as well make it
  ;; convenient for human users, too.)
  (define (go what)
    (define maybe-mod (->mod/existing what))
    (when (or maybe-mod (eq? 'top which))
      (put/stop (rerun maybe-mod
                       (current-mem)
                       (current-pp?)
                       (current-ctx-lvl)
                       (current-args)))))
  (match (match which
           ['run (read-line->reads)]
           ['top (cons #f (read-line->reads))]) ;i.e. what = #f
    [(list what (? number? mem) (? boolean? pp?) (? context-level? ctx)
           (? (or/c #f (listof string?)) args))
     (current-mem mem)
     (current-pp? pp?)
     (current-ctx-lvl ctx)
     (current-args (list->vector (or args (list)))) ;Elisp () = nil => #f
     (go what)]
    [(list what (? number? mem) (? boolean? pp?) (? context-level? ctx))
     (current-mem mem)
     (current-pp? pp?)
     (current-ctx-lvl ctx)
     (go what)]
    [(list what (? number? mem) (? boolean? pp?))
     (current-mem mem)
     (current-pp? pp?)
     (go what)]
    [(list what (? number? mem))
     (current-mem mem)
     (go what)]
    [(list what)
     (go what)]
    [_ (usage)]))

(define (read-line->reads)
  (reads-from-string (read-line)))

(define (reads-from-string s)
  (with-input-from-string s reads))

(define (reads)
  (match (read)
    [(? eof-object?) (list)]
    ['t              (cons #t (reads))] ;in case from elisp
    ['nil            (cons #f (reads))] ;in case from elisp
    [x               (cons x (reads))]))

;; This really just for my own use debugging. Not documented.
(define (info)
  (displayln @~a{Memory Limit:   @(current-mem)
                 Pretty Print:   @(current-pp?)
                 Error Context:  @(current-ctx-lvl)
                 Command Line:   @(current-args)}))

;;; misc other commands

(define (syms)
  (elisp-println (sort (map symbol->string (namespace-mapped-symbols))
                       string<?)))

(define (def-loc sym)
  (elisp-println (find-definition (symbol->string sym))))

(define (mod-loc v rel)
  (define (mod-loc* mod rel)
    (define path (with-handlers ([exn:fail? (λ _ #f)])
                   (resolve-module-path mod rel)))
    (and path
         (file-exists? path)
         (list (path->string path) 1 0)))
  (elisp-println (cond [(module-path? v) (mod-loc* v rel)]
                       [(symbol? v)      (mod-loc* (symbol->string v) rel)]
                       [else             #f])))

(define (type v) ;; the ,type command.  rename this??
  (elisp-println (type-or-sig v)))

(define (type-or-sig v)
  (or (type-or-contract v)
      (sig v)
      ""))

(define (sig v) ;any/c -> (or/c #f string?)
  (and (symbol? v)
       (match (find-signature (symbol->string v))
         [#f #f]
         [x (~a x)])))

(define (type-or-contract v) ;any/c -> (or/c #f string?)
  ;; 1. Try using Typed Racket's REPL simplified type.
  (try (match (with-output-to-string
                (λ ()
                  ((current-eval)
                   (cons '#%top-interaction v))))
         [(pregexp "^- : (.*) \\.\\.\\..*\n" (list _ t)) t]
         [(pregexp "^- : (.*)\n$"            (list _ t)) t])
       #:catch exn:fail? _
       ;; 2. Try to find a contract.
       (try (parameterize ([error-display-handler (λ _ (void))])
              ((current-eval)
               (cons '#%top-interaction
                     `(if (has-contract? ,v)
                       (~a (contract-name (value-contract ,v)))
                       (error "")))))
            #:catch exn:fail? _
            #f)))

(define (sig-and/or-type stx)
  (define dat (syntax->datum stx))
  (define s (sig dat))
  (define t (type-or-contract stx))
  (xexpr->string
   `(div ()
     (h1 () ,(or s (~a dat)))
     ,(cond [(not (or s t))
             `(p ()
               (em ()  "(Found no documentation, signature, type, or contract.)"))]
            [t `(pre () ,t)]
            [else ""])
     (br ()))))

;;; describe

;; If a symbol has installed documentation, display it.
;;
;; Otherwise, walk the source to find the signature of its definition
;; (because the argument names have explanatory value), and also look
;; for Typed Racket type or a contract, if any.

(define (describe stx)
  (write (describe* stx))
  (newline))

(define (describe* _stx)
  (define stx (namespace-syntax-introduce _stx))
  (or (scribble-doc/html stx)
      (sig-and/or-type stx)))

;;; print elisp values

(define (elisp-println v)
  (elisp-print v)
  (newline))

(define (elisp-print v)
  (print (->elisp v)))

(define (->elisp v)
  (match v
    [(or #f (list)) 'nil]
    [#t             't]
    [(? list? xs)   (map ->elisp xs)]
    [(cons x y)     (cons (->elisp x) (->elisp y))]
    [(? path? v)    (path->string v)]
    [v              v]))

(module+ test
  (check-equal? (with-output-to-string
                  (λ () (elisp-print '(1 #t nil () (a . b)))))
                "'(1 t nil nil (a . b))"))

;;; doc / help

(define (doc stx)
  (or (find-help (namespace-syntax-introduce stx))
      (perform-search (~a (syntax->datum stx))))
  ;; Need some command response
  (elisp-println "Sent to web browser"))

;; cd

(define (cd s)
  (let ([old-wd (current-directory)])
    (current-directory s)
    (unless (directory-exists? (current-directory))
      (display-commented (format "~v doesn't exist." (current-directory)))
      (current-directory old-wd))
    (display-commented (format "In ~v" (current-directory)))))

;;; syntax expansion

(define last-stx #f)

(define (exp1 stx)
  (set! last-stx (expand-once stx))
  (pp-stx last-stx))

(define (exp+)
  (when last-stx
    (define this-stx (expand-once last-stx))
    (cond [(equal? (syntax->datum last-stx) (syntax->datum this-stx))
           (display-commented "Already fully expanded.")
           (set! last-stx #f)]
          [else
           (pp-stx this-stx)
           (set! last-stx this-stx)])))

(define (exp! stx)
  (set! last-stx #f)
  (pp-stx (expand stx)))

(define (pp-stx stx)
  (newline)
  (pretty-print (syntax->datum stx)
                (current-output-port)
                1))

;;; requires

;; requires/tidy : (listof require-sexpr) -> require-sexpr
(define (requires/tidy reqs)
  (let* ([reqs (combine-requires reqs)]
         [reqs (group-requires reqs)])
    (elisp-println (require-pretty-format reqs))))

;; requires/trim : path-string? (listof require-sexpr) -> require-sexpr
;;
;; Note: Why pass in a list of the existing require forms -- why not
;; just use the "keep" list from show-requires? Because the keep list
;; only states the module name, not the original form. Therefore if
;; the original require has a subform like `(only-in mod f)` (or
;; rename-in, except-in, &c), we won't know how to preserve that
;; unless we're given it. That's why our strategy must be to look for
;; things to drop, as opposed to things to keep.
(define (requires/trim path-str reqs)
  (let* ([reqs (combine-requires reqs)]
         [sr (show-requires* path-str)]
         [drops (filter-map (λ (x)
                              (match x
                                [(list 'drop mod lvl) (list mod lvl)]
                                [_ #f]))
                            sr)]
         [reqs (filter-map (λ (req)
                             (cond [(member req drops) #f]
                                   [else req]))
                           reqs)]
         [reqs (group-requires reqs)])
    (elisp-println (require-pretty-format reqs))))

;; Use `bypass` to help convert from `#lang racket` to `#lang
;; racket/base` plus explicit requires.
;;
;; Note: Currently this is hardcoded to `#lang racket`, only.
(define (requires/base path-str reqs)
  (let* ([reqs (combine-requires reqs)]
         [sr (show-requires* path-str)]
         [drops (filter-map (λ (x)
                              (match x
                                [(list 'drop mod lvl) (list mod lvl)]
                                [_ #f]))
                            sr)]
         [adds (append*
                (filter-map (λ (x)
                              (match x
                                [(list 'bypass 'racket 0
                                       (list (list mod lvl _) ...))
                                 (filter (λ (x)
                                           (match x
                                             [(list 'racket/base 0) #f]
                                             [_ #t]))
                                         (map list mod lvl))]
                                [_ #f]))
                            sr))]
         [reqs (filter-map (λ (req)
                             (cond [(member req drops) #f]
                                   [else req]))
                           reqs)]
         [reqs (append reqs adds)]
         [reqs (group-requires reqs)])
    (elisp-println (require-pretty-format reqs))))

;; show-requires* : Like show-requires but accepts a path-string? that
;; need not already be a module path.
(define (show-requires* path-str)
  (define-values (base name _) (split-path (string->path path-str)))
  (parameterize ([current-load-relative-directory base]
                 [current-directory base])
    (show-requires name)))

(define (combine-requires reqs)
  (remove-duplicates
   (append* (for/list ([req reqs])
              (match req
                [(list* 'require vs)
                 (append*
                  (for/list ([v vs])
                    ;; Use (list mod level), like `show-requires` uses.
                    (match v
                      [(list* 'for-meta level vs) (map (curryr list level) vs)]
                      [(list* 'for-syntax vs)     (map (curryr list 1) vs)]
                      [(list* 'for-template vs)   (map (curryr list -1) vs)]
                      [(list* 'for-label vs)      (map (curryr list #f) vs)]
                      [v                          (list (list v 0))])))])))))

(module+ test
  (require rackunit)
  (check-equal?
   (combine-requires '((require a b c)
                       (require d e)
                       (require a f)
                       (require (for-syntax s t u) (for-label l0 l1 l2))
                       (require (for-meta 1 m1a m1b)
                                (for-meta 2 m2a m2b))))
   '((a 0) (b 0) (c 0) (d 0) (e 0) (f 0)
     (s 1) (t 1) (u 1)
     (l0 #f) (l1 #f) (l2 #f)
     (m1a 1) (m1b 1) (m2a 2) (m2b 2))))

;; Given a list of requires -- each in the (list module level) form
;; used by `show-requires` -- group them by level and convert them to
;; a Racket `require` form. Also, sort the subforms by phase level:
;; for-syntax, for-template, for-label, for-meta, and plain (0).
;; Within each such group, sort them first by module paths then
;; relative requires. Within each such group, sort alphabetically.
(define (group-requires reqs)
  ;; Put the requires into a hash of sets.
  (define ht (make-hasheq)) ;(hash/c <level> (set <mod>))
  (for ([req reqs]) (match req
                      [(list mod lvl) (hash-update! ht lvl
                                                    (lambda (s) (set-add s mod))
                                                    (set mod))]))
  (define (mod-set->mod-list mod-set)
    (sort (set->list mod-set) mod<?))
  (define (for-level level k)
    (define mods (hash-ref ht level #f))
    (cond [mods (k (mod-set->mod-list mods))]
          [else '()]))
  (define (preface . pres)
    (λ (mods) `((,@pres ,@mods))))
  (define (meta-levels)
    (sort (for/list ([x (hash-keys ht)] #:when (not (member x '(-1 0 1 #f)))) x)
          <))
  `(require
    ,@(for-level  1 (preface 'for-syntax))
    ,@(for-level -1 (preface 'for-template))
    ,@(for-level #f (preface 'for-label))
    ,@(append* (for/list ([level (in-list (meta-levels))])
                 (for-level level (preface 'for-meta level))))
    ,@(for-level 0 values)))

(module+ test
  (check-equal? (group-requires
                 (combine-requires
                  '((require z c b a)
                    (require (for-meta 4 m41 m40))
                    (require (for-meta -4 m-41 m-40))
                    (require (for-label l1 l0))
                    (require (for-template t1 t0))
                    (require (for-syntax s1 s0))
                    (require "a.rkt" "b.rkt" "c.rkt" "z.rkt"
                             (only-in "mod.rkt" oi)
                             (only-in mod oi)))))
                '(require
                  (for-syntax s0 s1)
                  (for-template t0 t1)
                  (for-label l0 l1)
                  (for-meta -4 m-40 m-41)
                  (for-meta 4 m40 m41)
                  a b c (only-in mod oi) z
                  "a.rkt" "b.rkt" "c.rkt" (only-in "mod.rkt" oi) "z.rkt")))

(define (mod<? a b)
  (define (key x)
    (match x
      [(list 'only-in   m _ ...)     (key m)]
      [(list 'except-in m _ ...)     (key m)]
      [(list 'prefix-in _ m)         (key m)]
      [(list 'relative-in _ m _ ...) (key m)]
      [m                             m]))
  (let ([a (key a)]
        [b (key b)])
    (or (and (symbol? a) (not (symbol? b)))
        (and (list? a) (not (list? b)))
        (and (not (string? a)) (string? a))
        (and (string? a) (string? b)
             (string<? a b))
        (and (symbol? a) (symbol? b)
             (string<? (symbol->string a) (symbol->string b))))))

(module+ test
  (check-true (mod<? 'a 'b))
  (check-false (mod<? 'b 'a))
  (check-true (mod<? 'a '(only-in b)))
  (check-true (mod<? '(only-in a) 'b))
  (check-true (mod<? 'a '(except-in b)))
  (check-true (mod<? '(except-in a) 'b))
  (check-true (mod<? 'a '(prefix-in p 'b)))
  (check-true (mod<? '(prefix-in p 'a) 'b))
  (check-true (mod<? 'a '(relative-in p 'b)))
  (check-true (mod<? '(relative-in p 'a) 'b))
  (check-true (mod<? 'a '(prefix-in p (only-in b))))
  (check-true (mod<? '(prefix-in p (only-in a)) 'b)))

;; require-pretty-format : list? -> string?
(define (require-pretty-format x)
  (define out (open-output-string))
  (parameterize ([current-output-port out])
    (require-pretty-print x))
  (get-output-string out))

(module+ test
  (check-equal? (require-pretty-format
                 '(require a))
                @~a{(require a)

                    })
  (check-equal? (require-pretty-format
                 '(require a b))
                @~a{(require a
                             b)

                    })
  (check-equal? (require-pretty-format
                 '(require (for-syntax a b) (for-meta 2 c d) e f))
                @~a{(require (for-syntax a
                                         b)
                             (for-meta 2 c
                                         d)
                             e
                             f)

                    })
  (check-equal? (require-pretty-format
                 `(require (only-in m a b) (except-in m a b)))
                @~a{(require (only-in m
                                      a
                                      b)
                             (except-in m
                                        a
                                        b))

                    }))

;; Pretty print a require form with one module per line and with
;; indentation for the `for-X` subforms. Example:
;;
;; (require (for-syntax racket/base
;;                      syntax/parse)
;;          (for-meta 3 racket/a
;;                      racket/b)
;;          racket/format
;;          racket/string
;;          "a.rkt"
;;          "b.rkt")
(define (require-pretty-print x)
  (define (prn x first? indent)
    (define (indent-string)
      (if first? "" (make-string indent #\space)))
    (define (prn-form pre this more)
      (define new-indent (+ indent (+ 2 (string-length pre))))
      (printf "~a(~a " (indent-string) pre)
      (prn this #t new-indent)
      (for ([x more])
        (newline)
        (prn x #f new-indent))
      (display ")"))
    (match x
      [(list 'require)
       (void)]
      [(list* (and pre (or 'require 'for-syntax 'for-template 'for-label
                           'only-in 'except-in))
              this more)
       (prn-form (format "~s" pre) this more)
       (when (eq? pre 'require)
         (newline))]
      [(list* 'for-meta level this more)
       (prn-form (format "for-meta ~a" level) this more)]
      [this
       (printf "~a~s" (indent-string) this)]))
  (prn x #t 0))

;;; find-collection

(define (do-find-collection str)
  (match (with-handlers ([exn:fail? (λ _ #f)])
           (and ;;#f ;<-- un-comment to exercise fallback path
            (dynamic-require 'find-collection/find-collection
                             'find-collection-dir)))
    [#f 'find-collection-not-installed]
    [f  (map path->string (f str))]))

(define find-collection (compose elisp-println do-find-collection))

;;; profile

(define (get-profile)
  (elisp-println
   ;; TODO: Filter files from racket-mode itself, b/c just noise?
   (for/list ([x (in-list (get-profile-info))])
     (match-define (list count msec name stx _ ...) x)
     (list count
           msec
           (and name (symbol->string name))
           (and (syntax-source stx) (path? (syntax-source stx))
                (path->string (syntax-source stx)))
           (syntax-position stx)
           (and (syntax-position stx) (syntax-span stx)
                (+ (syntax-position stx) (syntax-span stx)))))))

;;; coverage

(define (get-uncovered file)
  (elisp-println
   (consolidate-coverage-ranges
    (for*/list ([x (in-list (get-test-coverage-info))]
                [covered? (in-value (first x))]
                #:when (not covered?)
                [src (in-value (second x))]
                #:when (equal? file src)
                [pos (in-value (third x))]
                [span (in-value (fourth x))])
      (cons pos (+ pos span))))))

(define (consolidate-coverage-ranges xs)
  (remove-duplicates (sort xs < #:key car)
                     same?))

(define (same? x y)
  ;; Is x a subset of y or vice versa?
  (match-define (cons x/beg x/end) x)
  (match-define (cons y/beg y/end) y)
  (or (and (<= x/beg y/beg) (<= y/end x/end))
      (and (<= y/beg x/beg) (<= x/end y/end))))

(module+ test
  (check-true (same? '(0 . 9) '(0 . 9)))
  (check-true (same? '(0 . 9) '(4 . 5)))
  (check-true (same? '(4 . 5) '(0 . 9)))
  (check-false (same? '(0 . 1) '(1 . 2)))
  (check-equal? (consolidate-coverage-ranges
                 '((10 . 20) (10 . 11) (19 . 20) (10 . 20)
                   (20 . 30) (20 . 21) (29 . 30) (20 . 30)))
                '((10 . 20)
                  (20 . 30)))
  ;; This is a test of actual coverage data I got from one example,
  ;; where the maximal subsets were (164 . 197) and (214. 247).
  (check-equal?
   (consolidate-coverage-ranges
    '((164 . 197) (164 . 197) (164 . 197)
      (173 . 180) (173 . 180) (173 . 180) (173 . 180) (173 . 180) (187 . 196)
      (214 . 247) (214 . 247) (214 . 247)
      (223 . 230) (223 . 230) (223 . 230) (223 . 230) (223 . 230) (237 . 246)))
   '((164 . 197) (214 . 247))))

;;; check-syntax

(define check-syntax
  (let ([show-content (try (let ([f (dynamic-require 'drracket/check-syntax
                                                     'show-content)])
                             ;; Ensure correct position info for
                             ;; Unicode like λ. show-content probably
                             ;; ought to do this itself, but work
                             ;; around that.
                             (λ (path)
                               (parameterize ([port-count-lines-enabled #t])
                                 (f path))))
                           #:catch exn:fail? _ (λ _ (elisp-println 'not-supported)))])
    ;; Note: Adjust all positions to 1-based Emacs `point' values.
    (λ (path)
      (parameterize ([current-load-relative-directory (path-only path)])
        ;; Get all the data.
        (define xs (remove-duplicates (show-content path)))
        ;; Extract the add-mouse-over-status items into a list.
        (define infos
          (remove-duplicates
           (filter values
                   (for/list ([x (in-list xs)])
                     (match x
                       [(vector 'syncheck:add-mouse-over-status beg end str)
                        (list 'info (add1 beg) (add1 end) str)]
                       [_ #f])))))
        ;; Consolidate the add-arrow/name-dup items into a hash table
        ;; with one item per definition. The key is the definition
        ;; position. The value is the set of its uses.
        (define ht-defs/uses (make-hash))
        (for ([x (in-list xs)])
          (match x
            [(or (vector 'syncheck:add-arrow/name-dup
                         def-beg def-end
                         use-beg use-end
                         _ _ _ _)
                 (vector 'syncheck:add-arrow/name-dup/pxpy
                         def-beg def-end _ _
                         use-beg use-end _ _
                         _ _ _ _))
             (hash-update! ht-defs/uses
                           (list (add1 def-beg) (add1 def-end))
                           (λ (v) (set-add v (list (add1 use-beg) (add1 use-end))))
                           (set))]
            [_ #f]))
        ;; Convert the hash table into a list, sorting the usage positions.
        (define defs/uses
          (for/list ([(def uses) (in-hash ht-defs/uses)])
            (match-define (list def-beg def-end) def)
            (define tweaked-uses (sort (set->list uses) < #:key car))
            (list 'def/uses def-beg def-end tweaked-uses)))
        ;; Append both lists and print as Elisp values.
        (elisp-println (append infos defs/uses))))))