runtime-progress.rkt (7215B)
1 #lang racket/base 2 (require racket/list 3 syntax/parse/private/minimatch) 4 (provide ps-empty 5 ps-add-car 6 ps-add-cdr 7 ps-add-stx 8 ps-add-unbox 9 ps-add-unvector 10 ps-add-unpstruct 11 ps-add-opaque 12 ps-add-post 13 ps-add 14 (struct-out ord) 15 16 ps-pop-opaque 17 ps-pop-ord 18 ps-pop-post 19 ps-context-syntax 20 ps-difference 21 22 (struct-out failure) 23 failure* 24 25 expect? 26 (struct-out expect:thing) 27 (struct-out expect:atom) 28 (struct-out expect:literal) 29 (struct-out expect:message) 30 (struct-out expect:disj) 31 (struct-out expect:proper-pair) 32 33 es-add-thing 34 es-add-message 35 es-add-atom 36 es-add-literal 37 es-add-proper-pair) 38 39 ;; FIXME: add phase to expect:literal 40 41 ;; == Failure == 42 43 #| 44 A Failure is (failure PS ExpectStack) 45 46 A FailureSet is one of 47 - Failure 48 - (cons FailureSet FailureSet) 49 50 A FailFunction = (FailureSet -> Answer) 51 |# 52 (define-struct failure (progress expectstack) #:prefab) 53 54 ;; failure* : PS ExpectStack/#f -> Failure/#t 55 (define (failure* ps es) (if es (failure ps es) #t)) 56 57 ;; == Progress == 58 59 #| 60 Progress (PS) is a non-empty list of Progress Frames (PF). 61 62 A Progress Frame (PF) is one of 63 - stx ;; "Base" frame, or ~parse/#:with term 64 - 'car ;; car of pair; also vector->list, unbox, struct->list, etc 65 - nat ;; Represents that many repeated cdrs 66 - 'post ;; late/post-traversal check 67 - #s(ord group index) ;; ~and subpattern, only comparable w/in group 68 - 'opaque 69 70 The error-reporting context (ie, syntax-parse #:context arg) is always 71 the final frame. 72 73 All non-stx frames (eg car, cdr) interpreted as applying to nearest following 74 stx frame. 75 76 A stx frame is introduced 77 - always at base (that is, by syntax-parse) 78 - if syntax-parse has #:context arg, then two stx frames at bottom: 79 (list to-match-stx context-stx) 80 - by #:with/~parse 81 - by #:fail-*/#:when/~fail & stx 82 83 Interpretation: later frames are applied first. 84 eg, (list 'car 1 stx) 85 means ( car of ( cdr once of stx ) ) 86 NOT apply car, then apply cdr once, then stop 87 |# 88 (define-struct ord (group index) #:prefab) 89 90 (define (ps-empty stx ctx) 91 (if (eq? stx ctx) 92 (list stx) 93 (list stx ctx))) 94 (define (ps-add-car parent) 95 (cons 'car parent)) 96 (define (ps-add-cdr parent [times 1]) 97 (if (zero? times) 98 parent 99 (match (car parent) 100 [(? exact-positive-integer? n) 101 (cons (+ times n) (cdr parent))] 102 [_ 103 (cons times parent)]))) 104 (define (ps-add-stx parent stx) 105 (cons stx parent)) 106 (define (ps-add-unbox parent) 107 (ps-add-car parent)) 108 (define (ps-add-unvector parent) 109 (ps-add-car parent)) 110 (define (ps-add-unpstruct parent) 111 (ps-add-car parent)) 112 (define (ps-add-opaque parent) 113 (cons 'opaque parent)) 114 (define (ps-add parent frame) 115 (cons frame parent)) 116 (define (ps-add-post parent) 117 (cons 'post parent)) 118 119 ;; ps-context-syntax : Progress -> syntax 120 (define (ps-context-syntax ps) 121 ;; Bottom frame is always syntax 122 (last ps)) 123 124 ;; ps-difference : PS PS -> nat 125 ;; Returns N s.t. B = (ps-add-cdr^N A) 126 (define (ps-difference a b) 127 (define-values (a-cdrs a-base) 128 (match a 129 [(cons (? exact-positive-integer? a-cdrs) a-base) 130 (values a-cdrs a-base)] 131 [_ (values 0 a)])) 132 (define-values (b-cdrs b-base) 133 (match b 134 [(cons (? exact-positive-integer? b-cdrs) b-base) 135 (values b-cdrs b-base)] 136 [_ (values 0 b)])) 137 (unless (eq? a-base b-base) 138 (error 'ps-difference "INTERNAL ERROR: ~e does not extend ~e" b a)) 139 (- b-cdrs a-cdrs)) 140 141 ;; ps-pop-opaque : PS -> PS 142 ;; Used to continue with progress from opaque head pattern. 143 (define (ps-pop-opaque ps) 144 (match ps 145 [(cons (? exact-positive-integer? n) (cons 'opaque ps*)) 146 (ps-add-cdr ps* n)] 147 [(cons 'opaque ps*) 148 ps*] 149 [_ (error 'ps-pop-opaque "INTERNAL ERROR: opaque frame not found: ~e" ps)])) 150 151 ;; ps-pop-ord : PS -> PS 152 (define (ps-pop-ord ps) 153 (match ps 154 [(cons (? exact-positive-integer? n) (cons (? ord?) ps*)) 155 (ps-add-cdr ps* n)] 156 [(cons (? ord?) ps*) 157 ps*] 158 [_ (error 'ps-pop-ord "INTERNAL ERROR: ord frame not found: ~e" ps)])) 159 160 ;; ps-pop-post : PS -> PS 161 (define (ps-pop-post ps) 162 (match ps 163 [(cons (? exact-positive-integer? n) (cons 'post ps*)) 164 (ps-add-cdr ps* n)] 165 [(cons 'post ps*) 166 ps*] 167 [_ (error 'ps-pop-post "INTERNAL ERROR: post frame not found: ~e" ps)])) 168 169 170 ;; == Expectations == 171 172 #| 173 There are multiple types that use the same structures, optimized for 174 different purposes. 175 176 -- During parsing, the goal is to minimize/consolidate allocations. 177 178 An ExpectStack (during parsing) is one of 179 - (expect:thing Progress String Boolean String/#f ExpectStack) 180 * (expect:message String ExpectStack) 181 * (expect:atom Datum ExpectStack) 182 * (expect:literal Identifier ExpectStack) 183 * (expect:proper-pair FirstDesc ExpectStack) 184 * #t 185 186 The *-marked variants can only occur at the top of the stack (ie, not 187 in the next field of another Expect). The top of the stack contains 188 the most specific information. 189 190 An ExpectStack can also be #f, which means no failure tracking is 191 requested (and thus no more ExpectStacks should be allocated). 192 193 -- During reporting, the goal is ease of manipulation. 194 195 An ExpectList (during reporting) is (listof Expect). 196 197 An Expect is one of 198 - (expect:thing #f String #t String/#f StxIdx) 199 * (expect:message String StxIdx) 200 * (expect:atom Datum StxIdx) 201 * (expect:literal Identifier StxIdx) 202 * (expect:proper-pair FirstDesc StxIdx) 203 * (expect:disj (NEListof Expect) StxIdx) 204 - '... 205 206 A StxIdx is (cons Syntax Nat) 207 208 That is, the next link is replaced with the syntax+index of the term 209 being complained about. An expect:thing's progress is replaced with #f. 210 211 An expect:disj never contains a '... or another expect:disj. 212 213 We write ExpectList when the most specific information comes first and 214 RExpectList when the most specific information comes last. 215 |# 216 (struct expect:thing (term description transparent? role next) #:prefab) 217 (struct expect:message (message next) #:prefab) 218 (struct expect:atom (atom next) #:prefab) 219 (struct expect:literal (literal next) #:prefab) 220 (struct expect:disj (expects next) #:prefab) 221 (struct expect:proper-pair (first-desc next) #:prefab) 222 223 (define (expect? x) 224 (or (expect:thing? x) 225 (expect:message? x) 226 (expect:atom? x) 227 (expect:literal? x) 228 (expect:disj? x) 229 (expect:proper-pair? x))) 230 231 (define (es-add-thing ps description transparent? role next) 232 (if (and next description) 233 (expect:thing ps description transparent? role next) 234 next)) 235 236 (define (es-add-message message next) 237 (if (and next message) 238 (expect:message message next) 239 next)) 240 241 (define (es-add-atom atom next) 242 (and next (expect:atom atom next))) 243 244 (define (es-add-literal literal next) 245 (and next (expect:literal literal next))) 246 247 (define (es-add-proper-pair first-desc next) 248 (and next (expect:proper-pair first-desc next))) 249 250 #| 251 A FirstDesc is one of 252 - #f -- unknown, multiple possible, etc 253 - string -- description 254 - (list 'any) 255 - (list 'literal symbol) 256 - (list 'datum datum) 257 |#