<commit_before>#lang racket/base
(require racket/list
         racket/format
         syntax/stx
         racket/struct
         unstable/error
         syntax/srcloc
         "minimatch.rkt"
         syntax/parse/private/residual
         "kws.rkt")
(provide call-current-failure-handler
         current-failure-handler
         maximal-failures
         invert-ps
         ps->stx+index)

#|
TODO: given (expect:thing _ D _ R) and (expect:thing _ D _ #f),
  simplify to (expect:thing _ D _ #f)
  thus, "expected D" rather than "expected D or D for R" (?)
|#

#|
Note: there is a cyclic dependence between residual.rkt and this module,
broken by a lazy-require of this module into residual.rkt
|#

(define (call-current-failure-handler ctx fs)
  (call-with-values (lambda () ((current-failure-handler) ctx fs))
    (lambda vals
      (error 'current-failure-handler
             "current-failure-handler: did not escape, produced ~e"
             (case (length vals)
               ((1) (car vals))
               (else (cons 'values vals)))))))

(define (default-failure-handler ctx fs)
  (report-failureset ctx fs))

(define current-failure-handler
  (make-parameter default-failure-handler))

;; Hack: alternative to new (primitive) phase-crossing exn type is to
;; store extra information in exn continuation marks.

#|
Reporting
---------

First, failures with maximal (normalized) progresses are selected and
grouped into equivalence classes. In principle, each failure in an
equivalence class complains about the same term, but in practice,
special handling of failures like "unexpected term" make things more
complicated.
|#

;; report-failureset : (list Symbol/#f Syntax) FailureSet -> escapes
(define (report-failureset ctx fs)
  (let* ([classes (maximal-failures fs)]
         [reports (apply append (map report/class classes))])
    (error/reports ctx reports)))

;; A Report is
;;   - (report string (listof string) stx stx)
(define-struct report (message context stx within-stx) #:prefab)

;; report/class : (non-empty-listof Failure) -> (listof Report)
(define (report/class fs)
  (let* ([ess (map failure-expectstack fs)]
         [ess (map normalize-expectstack ess)]
         [ess (remove-duplicates ess)]
         [ess (simplify-common-expectstacks ess)])
    (let-values ([(stx index) (ps->stx+index (failure-progress (car fs)))])
      (for/list ([es (in-list ess)])
        (report/expectstack es stx index)))))

;; report/expectstack : ExpectStack syntax nat -> Report
(define (report/expectstack es stx index)
  (let ([frame-expect (and (pair? es) (car es))]
        [context (append* (map context-prose-for-expect (if (pair? es) (cdr es) null)))])
    (cond [(not frame-expect)
           (report "bad syntax" context #f #f)]
          [else
           (let-values ([(frame-stx within-stx)
                         (let-values ([(x cx) (stx-list-drop/cx stx stx index)])
                           (values (datum->syntax cx x cx)
                                   (if (syntax? x) #f cx)))])
             (cond [(equal? frame-expect (expect:atom '() #f))
                    (syntax-case frame-stx ()
                      [(one . more)
                       (report "unexpected term" context #'one #f)]
                      [_
                       (report (prose-for-expect frame-expect) context frame-stx within-stx)])]
                   [(expect:disj? frame-expect)
                    (report (prose-for-expects (expect:disj-expects frame-expect))
                            context frame-stx within-stx)]
                   [else
                    (report (prose-for-expects (list frame-expect))
                            context frame-stx within-stx)]))])))

;; prose-for-expects : (listof Expect) -> string
;; FIXME: partition by role first?
(define (prose-for-expects expects)
  (join-sep (append (for/list ([expect expects]
                               #:when (not (expect:proper-pair? expect)))
                      (prose-for-expect expect))
                    (let ([proper-pair-expects (filter expect:proper-pair? expects)])
                      (if (pair? proper-pair-expects)
                          (list (prose-for-proper-pair-expects proper-pair-expects))
                          null)))
            ";" "or"))

;; prose-for-expect : Expect -> string
(define (prose-for-expect e)
  (match e
    [(expect:thing stx+index description transparent? role _)
     (if role
         (format "expected ~a for ~a" description role)
         (format "expected ~a" description))]
    [(expect:atom atom _)
     (format "expected the literal ~a~s~a"
             (if (symbol? atom) "symbol `" "")
             atom
             (if (symbol? atom) "'" ""))]
    [(expect:literal literal _)
     (format "expected the identifier `~s'" (syntax-e literal))]
    [(expect:message message _)
     (format "~a" message)]
    [(expect:proper-pair '#f _)
     "expected more terms"]))

;; prose-for-proper-pair-expects : (listof expect:proper-pair) -> string
(define (prose-for-proper-pair-expects es)
  (define descs (remove-duplicates (map expect:proper-pair-first-desc es)))
  (cond [(for/or ([desc descs]) (equal? desc #f))
         ;; FIXME: better way to indicate unknown ???
         "expected more terms"]
        [else
         (format "expected more terms starting with ~a"
                 (join-sep (map prose-for-first-desc descs)
                           "," "or"))]))

;; prose-for-first-desc : FirstDesc -> string
(define (prose-for-first-desc desc)
  (match desc
    [(? string?) desc]
    [(list 'any) "any term"] ;; FIXME: maybe should cancel out other descs ???
    [(list 'literal id) (format "the literal symbol `~s'" id)]
    [(list 'datum d) (format "the literal ~s" d)]))

;; context-prose-for-expect : expect:thing -> (listof string)
(define (context-prose-for-expect e)
  (match e
    [(expect:thing stx+index description transparent? role _)
     (let ([stx (stx+index->stx stx+index)])
       (cons (~a "while parsing " description
                 (if role (~a " for " role) ""))
             (if (error-print-source-location)
                 (list (~a " term: "
                           (~s (syntax->datum stx)
                               #:limit-marker "..."
                               #:max-width 50))
                       (~a " location: "
                           (or (source-location->string stx) "not available")))
                 null)))]))

(define (stx+index->stx stx+index)
  (let*-values ([(stx) (car stx+index)]
                [(index) (cdr stx+index)]
                [(x cx) (stx-list-drop/cx stx stx index)])
    (datum->syntax cx x cx)))

;; == Do Report ==

(define (error/reports ctx reports)
  (error/report ctx (car reports) (pair? (cdr reports))))

(define (error/report ctx report more?)
  (let* ([message (report-message report)]
         [context (report-context report)]
         [stx (cadr ctx)]
         [who (or (car ctx) (infer-who stx))]
         [sub-stx (report-stx report)]
         [within-stx (report-within-stx report)]
         [message
          (compose-error-message
           who message
           '("at" maybe) (stx-if-loc sub-stx)
           '("within" maybe) (stx-if-loc within-stx)
           '("in" maybe) (stx-if-loc stx)
           '("parsing context" multi maybe) context
           '("note" maybe) (and more? "additional errors omitted"))]
         [message
          (if (error-print-source-location)
              (let ([source-stx (or stx sub-stx within-stx)])
                (string-append (source-location->prefix source-stx) message))
              message)])
    (raise
     (exn:fail:syntax message (current-continuation-marks)
                      (map syntax-taint
                           (cond [within-stx (list within-stx)]
                                 [sub-stx (list sub-stx)]
                                 [stx (list stx)]
                                 [else null]))))))

(define (stx-if-loc stx)
  (and (syntax? stx)<commit_msg>Remove dependency on unstable/error.<commit_after>#lang racket/base
(require racket/list
         racket/format
         syntax/stx
         racket/struct
         syntax/srcloc
         "minimatch.rkt"
         syntax/parse/private/residual
         "kws.rkt")
(provide call-current-failure-handler
         current-failure-handler
         maximal-failures
         invert-ps
         ps->stx+index)

#|
TODO: given (expect:thing _ D _ R) and (expect:thing _ D _ #f),
  simplify to (expect:thing _ D _ #f)
  thus, "expected D" rather than "expected D or D for R" (?)
|#

#|
Note: there is a cyclic dependence between residual.rkt and this module,
broken by a lazy-require of this module into residual.rkt
|#

(define (call-current-failure-handler ctx fs)
  (call-with-values (lambda () ((current-failure-handler) ctx fs))
    (lambda vals
      (error 'current-failure-handler
             "current-failure-handler: did not escape, produced ~e"
             (case (length vals)
               ((1) (car vals))
               (else (cons 'values vals)))))))

(define (default-failure-handler ctx fs)
  (report-failureset ctx fs))

(define current-failure-handler
  (make-parameter default-failure-handler))

;; Hack: alternative to new (primitive) phase-crossing exn type is to
;; store extra information in exn continuation marks.

#|
Reporting
---------

First, failures with maximal (normalized) progresses are selected and
grouped into equivalence classes. In principle, each failure in an
equivalence class complains about the same term, but in practice,
special handling of failures like "unexpected term" make things more
complicated.
|#

;; report-failureset : (list Symbol/#f Syntax) FailureSet -> escapes
(define (report-failureset ctx fs)
  (let* ([classes (maximal-failures fs)]
         [reports (apply append (map report/class classes))])
    (error/reports ctx reports)))

;; A Report is
;;   - (report string (listof string) stx stx)
(define-struct report (message context stx within-stx) #:prefab)

;; report/class : (non-empty-listof Failure) -> (listof Report)
(define (report/class fs)
  (let* ([ess (map failure-expectstack fs)]
         [ess (map normalize-expectstack ess)]
         [ess (remove-duplicates ess)]
         [ess (simplify-common-expectstacks ess)])
    (let-values ([(stx index) (ps->stx+index (failure-progress (car fs)))])
      (for/list ([es (in-list ess)])
        (report/expectstack es stx index)))))

;; report/expectstack : ExpectStack syntax nat -> Report
(define (report/expectstack es stx index)
  (let ([frame-expect (and (pair? es) (car es))]
        [context (append* (map context-prose-for-expect (if (pair? es) (cdr es) null)))])
    (cond [(not frame-expect)
           (report "bad syntax" context #f #f)]
          [else
           (let-values ([(frame-stx within-stx)
                         (let-values ([(x cx) (stx-list-drop/cx stx stx index)])
                           (values (datum->syntax cx x cx)
                                   (if (syntax? x) #f cx)))])
             (cond [(equal? frame-expect (expect:atom '() #f))
                    (syntax-case frame-stx ()
                      [(one . more)
                       (report "unexpected term" context #'one #f)]
                      [_
                       (report (prose-for-expect frame-expect) context frame-stx within-stx)])]
                   [(expect:disj? frame-expect)
                    (report (prose-for-expects (expect:disj-expects frame-expect))
                            context frame-stx within-stx)]
                   [else
                    (report (prose-for-expects (list frame-expect))
                            context frame-stx within-stx)]))])))

;; prose-for-expects : (listof Expect) -> string
;; FIXME: partition by role first?
(define (prose-for-expects expects)
  (join-sep (append (for/list ([expect expects]
                               #:when (not (expect:proper-pair? expect)))
                      (prose-for-expect expect))
                    (let ([proper-pair-expects (filter expect:proper-pair? expects)])
                      (if (pair? proper-pair-expects)
                          (list (prose-for-proper-pair-expects proper-pair-expects))
                          null)))
            ";" "or"))

;; prose-for-expect : Expect -> string
(define (prose-for-expect e)
  (match e
    [(expect:thing stx+index description transparent? role _)
     (if role
         (format "expected ~a for ~a" description role)
         (format "expected ~a" description))]
    [(expect:atom atom _)
     (format "expected the literal ~a~s~a"
             (if (symbol? atom) "symbol `" "")
             atom
             (if (symbol? atom) "'" ""))]
    [(expect:literal literal _)
     (format "expected the identifier `~s'" (syntax-e literal))]
    [(expect:message message _)
     (format "~a" message)]
    [(expect:proper-pair '#f _)
     "expected more terms"]))

;; prose-for-proper-pair-expects : (listof expect:proper-pair) -> string
(define (prose-for-proper-pair-expects es)
  (define descs (remove-duplicates (map expect:proper-pair-first-desc es)))
  (cond [(for/or ([desc descs]) (equal? desc #f))
         ;; FIXME: better way to indicate unknown ???
         "expected more terms"]
        [else
         (format "expected more terms starting with ~a"
                 (join-sep (map prose-for-first-desc descs)
                           "," "or"))]))

;; prose-for-first-desc : FirstDesc -> string
(define (prose-for-first-desc desc)
  (match desc
    [(? string?) desc]
    [(list 'any) "any term"] ;; FIXME: maybe should cancel out other descs ???
    [(list 'literal id) (format "the literal symbol `~s'" id)]
    [(list 'datum d) (format "the literal ~s" d)]))

;; context-prose-for-expect : expect:thing -> (listof string)
(define (context-prose-for-expect e)
  (match e
    [(expect:thing stx+index description transparent? role _)
     (let ([stx (stx+index->stx stx+index)])
       (cons (~a "while parsing " description
                 (if role (~a " for " role) ""))
             (if (error-print-source-location)
                 (list (~a " term: "
                           (~s (syntax->datum stx)
                               #:limit-marker "..."
                               #:max-width 50))
                       (~a " location: "
                           (or (source-location->string stx) "not available")))
                 null)))]))

(define (stx+index->stx stx+index)
  (let*-values ([(stx) (car stx+index)]
                [(index) (cdr stx+index)]
                [(x cx) (stx-list-drop/cx stx stx index)])
    (datum->syntax cx x cx)))

;; == Do Report ==

(define (error/reports ctx reports)
  (error/report ctx (car reports) (pair? (cdr reports))))

(define (format-if prefix val)
  (if val
      (format "\n  ~a: ~a" prefix val)
      ""))

(define (error/report ctx report more?)
  (let* ([message (report-message report)]
         [context (report-context report)]
         [stx (cadr ctx)]
         [who (or (car ctx) (infer-who stx))]
         [sub-stx (report-stx report)]
         [within-stx (report-within-stx report)]
         [message
          (format "~a: ~a~a~a~a~a~a"
                  who message
                  (format-if "at" (stx-if-loc sub-stx))
                  (format-if "within" (stx-if-loc within-stx))
                  (format-if "in" (stx-if-loc stx))
                  (if (null? context)
                      ""
                      (apply string-append
                             "\n  parsing context: "
                             (for/list ([c (in-list context)])
                               (format "\n   ~a" c))))
                  (format-if "note" (and more? "additional errors omitted")))]
         [message
          (if (error-print-source-location)
              (let ([source-stx (or stx sub-stx within-stx)])
                (string-append (source-location->prefix source-stx) message))
              message)])
    (raise
     (exn:fail:syntax message (current-continuation-marks)
                      (map syntax-taint
                           (cond [within-stx (list within-stx)]
                                 [sub-stx (list sub-stx)]
                                 [stx (list stx)]
                                 [else null]))))))

(define (stx-if-loc stx)
  (and (syntax? stx)
{'fraction_non_alphanumeric': 0.13908741066520067, 'fraction_numerical': 0.0003665017408832692, 'mean_word_length': 1.9767272727272727, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 37, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 9, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3746225', 'n_tokens_mistral': 5055, 'n_tokens_neox': 4835, 'n_words': 1390}