www

runtime-progress.rkt (7304B)

---

 #lang racket/base
 (require racket/list
          syntax/parse/private/minimatch)
 (provide ps-empty
          ps-add-car
          ps-add-cdr
          ps-add-stx
          ps-add-unbox
          ps-add-unvector
          ps-add-unpstruct
          ps-add-opaque
          ps-add-post
          ps-add
          (struct-out ord)
 
          ps-pop-opaque
          ps-pop-ord
          ps-pop-post
          ps-context-syntax
          ps-difference
 
          (struct-out failure)
          failure*
 
          expect?
          (struct-out expect:thing)
          (struct-out expect:atom)
          (struct-out expect:literal)
          (struct-out expect:message)
          (struct-out expect:disj)
          (struct-out expect:proper-pair)
 
          es-add-thing
          es-add-message
          es-add-atom
          es-add-literal
          es-add-proper-pair)
 
 ;; FIXME: add phase to expect:literal
 
 ;; == Failure ==
 
 #|
 A Failure is (failure PS ExpectStack)
 
 A FailureSet is one of
   - Failure
   - (cons FailureSet FailureSet)
 
 A FailFunction = (FailureSet -> Answer)
 |#
 (define-struct failure (progress expectstack) #:prefab)
 
 ;; failure* : PS ExpectStack/#f -> Failure/#t
 (define (failure* ps es) (if es (failure ps es) #t))
 
 ;; == Progress ==
 
 #|
 Progress (PS) is a non-empty list of Progress Frames (PF).
 
 A Progress Frame (PF) is one of
   - stx     ;; "Base" frame, or ~parse/#:with term
   - 'car    ;; car of pair; also vector->list, unbox, struct->list, etc
   - nat     ;; Represents that many repeated cdrs
   - 'post   ;; late/post-traversal check
   - #s(ord group index) ;; ~and subpattern, only comparable w/in group
   - 'opaque
 
 The error-reporting context (ie, syntax-parse #:context arg) is always
 the final frame.
 
 All non-stx frames (eg car, cdr) interpreted as applying to nearest following
 stx frame.
 
 A stx frame is introduced
   - always at base (that is, by syntax-parse)
     - if syntax-parse has #:context arg, then two stx frames at bottom:
       (list to-match-stx context-stx)
   - by #:with/~parse
   - by #:fail-*/#:when/~fail & stx
 
 Interpretation: later frames are applied first.
  eg, (list 'car 1 stx)
       means ( car of ( cdr once of stx ) )
       NOT apply car, then apply cdr once, then stop
 |#
 (define-struct ord (group index) #:prefab)
 
 (define (ps-empty stx ctx)
   (if (eq? stx ctx)
       (list stx)
       (list stx ctx)))
 (define (ps-add-car parent)
   (cons 'car parent))
 (define (ps-add-cdr parent [times 1])
   (if (zero? times)
       parent
       (match (car parent)
         [(? exact-positive-integer? n)
          (cons (+ times n) (cdr parent))]
         [_
          (cons times parent)])))
 (define (ps-add-stx parent stx)
   (cons stx parent))
 (define (ps-add-unbox parent)
   (ps-add-car parent))
 (define (ps-add-unvector parent)
   (ps-add-car parent))
 (define (ps-add-unpstruct parent)
   (ps-add-car parent))
 (define (ps-add-opaque parent)
   (cons 'opaque parent))
 (define (ps-add parent frame)
   (cons frame parent))
 (define (ps-add-post parent)
   (cons 'post parent))
 
 ;; ps-context-syntax : Progress -> syntax
 (define (ps-context-syntax ps)
   ;; Bottom frame is always syntax
   (last ps))
 
 ;; ps-difference : PS PS -> nat
 ;; Returns N s.t. B = (ps-add-cdr^N A)
 (define (ps-difference a b)
   (define-values (a-cdrs a-base)
     (match a
       [(cons (? exact-positive-integer? a-cdrs) a-base)
        (values a-cdrs a-base)]
       [_ (values 0 a)]))
   (define-values (b-cdrs b-base)
     (match b
       [(cons (? exact-positive-integer? b-cdrs) b-base)
        (values b-cdrs b-base)]
       [_ (values 0 b)]))
   (unless (eq? a-base b-base)
     (error 'ps-difference "INTERNAL ERROR: ~e does not extend ~e" b a))
   (- b-cdrs a-cdrs))
 
 ;; ps-pop-opaque : PS -> PS
 ;; Used to continue with progress from opaque head pattern.
 (define (ps-pop-opaque ps)
   (match ps
     [(cons (? exact-positive-integer? n) (cons 'opaque ps*))
      (ps-add-cdr ps* n)]
     [(cons 'opaque ps*)
      ps*]
     [_ (error 'ps-pop-opaque "INTERNAL ERROR: opaque frame not found: ~e" ps)]))
 
 ;; ps-pop-ord : PS -> PS
 (define (ps-pop-ord ps)
   (match ps
     [(cons (? exact-positive-integer? n) (cons (? ord?) ps*))
      (ps-add-cdr ps* n)]
     [(cons (? ord?) ps*)
      ps*]
     [_ (error 'ps-pop-ord "INTERNAL ERROR: ord frame not found: ~e" ps)]))
 
 ;; ps-pop-post : PS -> PS
 (define (ps-pop-post ps)
   (match ps
     [(cons (? exact-positive-integer? n) (cons 'post ps*))
      (ps-add-cdr ps* n)]
     [(cons 'post ps*)
      ps*]
     [_ (error 'ps-pop-post "INTERNAL ERROR: post frame not found: ~e" ps)]))
 
 
 ;; == Expectations ==
 
 #|
 There are multiple types that use the same structures, optimized for
 different purposes.
 
 -- During parsing, the goal is to minimize/consolidate allocations.
 
 An ExpectStack (during parsing) is one of
   - (expect:thing Progress String Boolean String/#f ExpectStack)
   - (expect:thing Progress #f     #f      String/#f ExpectStack)
   * (expect:message String ExpectStack)
   * (expect:atom Datum ExpectStack)
   * (expect:literal Identifier ExpectStack)
   * (expect:proper-pair FirstDesc ExpectStack)
   * #t
 
 The *-marked variants can only occur at the top of the stack (ie, not
 in the next field of another Expect). The top of the stack contains
 the most specific information.
 
 An ExpectStack can also be #f, which means no failure tracking is
 requested (and thus no more ExpectStacks should be allocated).
 
 -- During reporting, the goal is ease of manipulation.
 
 An ExpectList (during reporting) is (listof Expect).
 
 An Expect is one of
   - (expect:thing #f String #t String/#f StxIdx)
   * (expect:message String StxIdx)
   * (expect:atom Datum StxIdx)
   * (expect:literal Identifier StxIdx)
   * (expect:proper-pair FirstDesc StxIdx)
   * (expect:disj (NEListof Expect) StxIdx)
   - '...
 
 A StxIdx is (cons Syntax Nat)
 
 That is, the next link is replaced with the syntax+index of the term
 being complained about. An expect:thing's progress is replaced with #f.
 
 An expect:disj never contains a '... or another expect:disj.
 
 We write ExpectList when the most specific information comes first and
 RExpectList when the most specific information comes last.
 |#
 (struct expect:thing (term description transparent? role next) #:prefab)
 (struct expect:message (message next) #:prefab)
 (struct expect:atom (atom next) #:prefab)
 (struct expect:literal (literal next) #:prefab)
 (struct expect:disj (expects next) #:prefab)
 (struct expect:proper-pair (first-desc next) #:prefab)
 
 (define (expect? x)
   (or (expect:thing? x)
       (expect:message? x)
       (expect:atom? x)
       (expect:literal? x)
       (expect:disj? x)
       (expect:proper-pair? x)))
 
 (define (es-add-thing ps description transparent? role next)
   (if (and next (or description (not transparent?)))
       (expect:thing ps description transparent? role next)
       next))
 
 (define (es-add-message message next)
   (if (and next message)
       (expect:message message next)
       next))
 
 (define (es-add-atom atom next)
   (and next (expect:atom atom next)))
 
 (define (es-add-literal literal next)
   (and next (expect:literal literal next)))
 
 (define (es-add-proper-pair first-desc next)
   (and next (expect:proper-pair first-desc next)))
 
 #|
 A FirstDesc is one of
  - #f                   -- unknown, multiple possible, etc
  - string               -- description
  - (list 'any)
  - (list 'literal symbol)
  - (list 'datum datum)
 |#