Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

syntax/parse: change expectstack rep to reduce/consolidate allocations

  • Loading branch information...
commit a564110c084717b1435ff456ec68109885fcade4 1 parent 5db8553
Ryan Culpepper authored March 13, 2012
2  collects/syntax/parse/debug.rkt
@@ -39,7 +39,7 @@
39 39
                        [(name ...) (map attr-name attrs)]
40 40
                        [(depth ...) (map attr-depth attrs)])
41 41
            #'(let ([fh (lambda (fs) fs)])
42  
-               (app-argu parser x x (ps-empty x x) null fh fh #f
  42
+               (app-argu parser x x (ps-empty x x) #f fh fh #f
43 43
                          (lambda (fh . attr-values)
44 44
                            (map vector '(name ...) '(depth ...) attr-values))
45 45
                          argu)))))]))
5  collects/syntax/parse/experimental/splicing.rkt
@@ -49,9 +49,8 @@
49 49
                               (cdr result))))
50 50
                      ((error)
51 51
                       (let ([es
52  
-                             (list* (expect:message (cadr result))
53  
-                                    (expect:thing pr (get-description param ...) #f rl)
54  
-                                    es)])
  52
+                             (es-add-message (cadr result)
  53
+                                             (es-add-thing pr (get-description param ...) #f rl es))])
55 54
                         (fh (failure pr es))))))))))
56 55
          (define-syntax name
57 56
            (stxclass 'name (arity (length '(param ...)) (length '(param ...)) '() '())
49  collects/syntax/parse/private/parse.rkt
@@ -76,7 +76,7 @@
76 76
                 (define (parser x cx pr es fh0 cp0 rl success)
77 77
                   (if (predicate x)
78 78
                       (success fh0)
79  
-                      (let ([es (cons (expect:thing pr 'description #t rl) es)])
  79
+                      (let ([es (es-add-thing pr 'description #t rl es)])
80 80
                         (fh0 (failure pr es)))))))]))
81 81
 
82 82
 (define-syntax (parser/rhs stx)
@@ -150,7 +150,7 @@
150 150
                (let* ([x (datum->syntax #f expr)]
151 151
                       [cx x]
152 152
                       [pr (ps-empty x x)]
153  
-                      [es null]
  153
+                      [es #f]
154 154
                       [fh0 (syntax-patterns-fail x)])
155 155
                  (parameterize ((current-syntax-context x))
156 156
                    def ...
@@ -260,7 +260,7 @@ Conventions:
260 260
             (syntax-parameterize ((this-context-syntax
261 261
                                    (syntax-rules ()
262 262
                                      [(tbs) (ps-context-syntax pr)])))
263  
-              (let ([es (cons (expect:thing pr description 'transparent? rl) es)]
  263
+              (let ([es (es-add-thing pr description 'transparent? rl es)]
264 264
                     [pr (if 'transparent? pr (ps-add-opaque pr))])
265 265
                 (with ([fail-handler fh0]
266 266
                        [cut-prompt cp0])
@@ -398,7 +398,7 @@ Conventions:
398 398
                       [(alternative ...) alternatives])
399 399
           #`(let* ([ctx0 #,context]
400 400
                    [pr (ps-empty x ctx0)]
401  
-                   [es null]
  401
+                   [es #f]
402 402
                    [cx x]
403 403
                    [fh0 (syntax-patterns-fail ctx0)])
404 404
               (parameterize ((current-syntax-context ctx0))
@@ -470,12 +470,12 @@ Conventions:
470 470
         #`(let ([d (if (syntax? x) (syntax-e x) x)])
471 471
             (if (equal? d (quote datum))
472 472
                 k
473  
-                (fail (failure pr (cons (expect:atom 'datum) es)))))]
  473
+                (fail (failure pr (es-add-atom 'datum es)))))]
474 474
        [#s(pat:literal attrs literal input-phase lit-phase)
475 475
         #`(if (and (identifier? x)
476 476
                    (free-identifier=? x (quote-syntax literal) input-phase lit-phase))
477 477
               k
478  
-              (fail (failure pr (cons (expect:literal (quote-syntax literal)) es))))]
  478
+              (fail (failure pr (es-add-literal (quote-syntax literal) es))))]
479 479
        [#s(pat:action attrs action subpattern)
480 480
         #'(parse:A x cx action pr es (parse:S x cx subpattern pr es k))]
481 481
        [#s(pat:head attrs head tail)
@@ -549,7 +549,7 @@ Conventions:
549 549
                   (parse:S datum scx subpattern pr es k))
550 550
                 (fail (failure pr es))))]
551 551
        [#s(pat:describe attrs pattern description transparent? role)
552  
-        #`(let ([es (cons (expect:thing pr description transparent? role) es)]
  552
+        #`(let ([es (es-add-thing pr description transparent? role es)]
553 553
                 [pr (if 'transparent? pr (ps-add-opaque pr))])
554 554
             (parse:S x cx pattern pr es k))]
555 555
        [#s(pat:delimit attrs pattern)
@@ -575,7 +575,7 @@ Conventions:
575 575
           #'(let ([x* (datum->syntax cx x cx)])
576 576
               (if (predicate x*)
577 577
                   (let-attributes (name-attr ...) k)
578  
-                  (let ([es (cons (expect:thing pr 'description #t role) es)])
  578
+                  (let ([es (es-add-thing pr 'description #t role es)])
579 579
                     (fail (failure pr es))))))])]))
580 580
 
581 581
 ;; (disjunct ???-pattern success (pre:expr ...) (id:id ...)) : expr[Ans]
@@ -616,7 +616,7 @@ Conventions:
616 616
                 (let ([pr* (if (syntax? c)
617 617
                                (ps-add-stx pr c)
618 618
                                pr)]
619  
-                      [es* (cons (expect:message message) es)])
  619
+                      [es* (es-add-message message es)])
620 620
                   (fail (failure pr* es*)))
621 621
                 k))]
622 622
        [#s(action:parse _ pattern expr)
@@ -669,7 +669,7 @@ Conventions:
669 669
     [(parse:H x cx rest-x rest-cx rest-pr head pr es k)
670 670
      (syntax-case #'head ()
671 671
        [#s(hpat:describe _ pattern description transparent? role)
672  
-        #`(let ([es* (cons (expect:thing pr description transparent? role) es)]
  672
+        #`(let ([es* (es-add-thing pr description transparent? role es)]
673 673
                 [pr (if 'transparent? pr (ps-add-opaque pr))])
674 674
             (parse:H x cx rest-x rest-cx rest-pr pattern pr es*
675 675
                      (let ([rest-pr (if 'transparent? rest-pr (ps-pop-opaque rest-pr))])
@@ -867,7 +867,7 @@ Conventions:
867 867
                                   head es loop-k)
868 868
                         ...)
869 869
                    (cond [(< rel-rep (rep:min-number rel-repc))
870  
-                          (let ([es (cons (expectation-of-reps/too-few rel-rep rel-repc) es)])
  870
+                          (let ([es (expectation-of-reps/too-few es rel-rep rel-repc)])
871 871
                             (fail (failure loop-pr es)))]
872 872
                          ...
873 873
                          [else
@@ -912,7 +912,7 @@ Conventions:
912 912
          [_  #`(parse:H x cx x* cx* pr* head pr es
913 913
                         (if (< rep (rep:max-number repc))
914 914
                             (let ([rep (add1 rep)]) k*)
915  
-                            (let ([es (cons (expectation-of-reps/too-many rep repc) es)])
  915
+                            (let ([es (expectation-of-reps/too-many es rep repc)])
916 916
                               (fail (failure pr* es)))))]))]))
917 917
 
918 918
 ;; (rep:initial-value RepConstraint) : expr
@@ -962,26 +962,23 @@ Conventions:
962 962
 
963 963
 ;; ----
964 964
 
965  
-(define-syntax-rule (expectation-of-message message)
966  
-  (expect:message message))
967  
-
968 965
 (define-syntax expectation-of-reps/too-few
969 966
   (syntax-rules ()
970  
-    [(_ rep #s(rep:once name too-few-msg too-many-msg))
971  
-     (expect:message (or too-few-msg (name->too-few/once name)))]
972  
-    [(_ rep #s(rep:optional name too-many-msg _))
  967
+    [(_ es rep #s(rep:once name too-few-msg too-many-msg))
  968
+     (es-add-message (or too-few-msg (name->too-few/once name)) es)]
  969
+    [(_ es rep #s(rep:optional name too-many-msg _))
973 970
      (error 'syntax-parse "INTERNAL ERROR: impossible (too-few)")]
974  
-    [(_ rep #s(rep:bounds min max name too-few-msg too-many-msg))
975  
-     (expect:message (or too-few-msg (name->too-few name)))]))
  971
+    [(_ es rep #s(rep:bounds min max name too-few-msg too-many-msg))
  972
+     (es-add-message (or too-few-msg (name->too-few name)) es)]))
976 973
 
977 974
 (define-syntax expectation-of-reps/too-many
978 975
   (syntax-rules ()
979  
-    [(_ rep #s(rep:once name too-few-msg too-many-msg))
980  
-     (expect:message (or too-many-msg (name->too-many name)))]
981  
-    [(_ rep #s(rep:optional name too-many-msg _))
982  
-     (expect:message (or too-many-msg (name->too-many name)))]
983  
-    [(_ rep #s(rep:bounds min max name too-few-msg too-many-msg))
984  
-     (expect:message (or too-many-msg (name->too-many name)))]))
  976
+    [(_ es rep #s(rep:once name too-few-msg too-many-msg))
  977
+     (es-add-message (or too-many-msg (name->too-many name)) es)]
  978
+    [(_ es rep #s(rep:optional name too-many-msg _))
  979
+     (es-add-message (or too-many-msg (name->too-many name)) es)]
  980
+    [(_ es rep #s(rep:bounds min max name too-few-msg too-many-msg))
  981
+     (es-add-message (or too-many-msg (name->too-many name)) es)]))
985 982
 
986 983
 ;; ====
987 984
 
3  collects/syntax/parse/private/residual.rkt
@@ -215,13 +215,12 @@
215 215
                      (loop (cdr x) cx (add1 i))
216 216
                      (let* ([pr (ps-add-cdr pr i)]
217 217
                             [pr (ps-add-car pr)]
218  
-                            [es (cons (expect:thing pr desc #t rl) es)])
  218
+                            [es (es-add-thing pr desc #t rl es)])
219 219
                        (values 'fail (failure pr es))))]
220 220
                 [else ;; not null, because stx->list failed
221 221
                  (let ([pr (ps-add-cdr pr i)]
222 222
                        #|
223 223
                        ;; Don't extend es! That way we don't get spurious "expected ()"
224 224
                        ;; that *should* have been cancelled out by ineffable pair failures.
225  
-                       [es (cons (expect:atom '()) es)]
226 225
                        |#)
227 226
                    (values 'fail (failure pr es)))])))))
190  collects/syntax/parse/private/runtime-progress.rkt
... ...
@@ -1,7 +1,5 @@
1 1
 #lang racket/base
2 2
 (require racket/list
3  
-         unstable/struct
4  
-         syntax/stx
5 3
          "minimatch.rkt")
6 4
 (provide ps-empty
7 5
          ps-add-car
@@ -13,9 +11,7 @@
13 11
          ps-add-unpstruct
14 12
          ps-add-opaque
15 13
 
16  
-         invert-ps
17 14
          ps-pop-opaque
18  
-         ps->stx+index
19 15
          ps-context-syntax
20 16
          ps-difference
21 17
 
@@ -25,7 +21,30 @@
25 21
          (struct-out expect:atom)
26 22
          (struct-out expect:literal)
27 23
          (struct-out expect:message)
28  
-         (struct-out expect:disj))
  24
+         (struct-out expect:disj)
  25
+
  26
+         es-add-thing
  27
+         es-add-message
  28
+         es-add-atom
  29
+         es-add-literal)
  30
+
  31
+;; FIXME: add phase to expect:literal
  32
+
  33
+;; == Failure ==
  34
+
  35
+#|
  36
+A Failure is (failure PS ExpectStack)
  37
+
  38
+A FailureSet is one of
  39
+  - Failure
  40
+  - (cons FailureSet FailureSet)
  41
+
  42
+A FailFunction = (FailureSet -> Answer)
  43
+|#
  44
+(define-struct failure (progress expectstack) #:prefab)
  45
+
  46
+
  47
+;; == Progress ==
29 48
 
30 49
 #|
31 50
 Progress (PS) is a non-empty list of Progress Frames (PF).
@@ -86,45 +105,13 @@ Interpretation: later frames are applied first.
86 105
 ;; ps-context-syntax : Progress -> syntax
87 106
 (define (ps-context-syntax ps)
88 107
   ;; Bottom frame is always syntax
89  
-  (car (reverse ps)))
90  
-
91  
-;; ps->stx+index : Progress -> (values stx nat)
92  
-;; Gets the innermost stx that should have a real srcloc, and the offset
93  
-;; (number of cdrs) within that where the progress ends.
94  
-(define (ps->stx+index ps)
95  
-  (define (interp ps)
96  
-    (match ps
97  
-      [(cons (? syntax? stx) _) stx]
98  
-      [(cons 'car parent)
99  
-       (let* ([d (interp parent)]
100  
-              [d (if (syntax? d) (syntax-e d) d)])
101  
-         (cond [(pair? d) (car d)]
102  
-               [(vector? d) (vector->list d)]
103  
-               [(box? d) (unbox d)]
104  
-               [(prefab-struct-key d) (struct->list d)]
105  
-               [else (error 'ps->stx+index "INTERNAL ERROR: unexpected: ~e" d)]))]
106  
-      [(cons (? exact-positive-integer? n) parent)
107  
-       (for/fold ([stx (interp parent)]) ([i (in-range n)])
108  
-         (stx-cdr stx))]
109  
-      [(cons 'post parent)
110  
-       (interp parent)]))
111  
-  (let ([ps (ps-truncate-opaque ps)])
112  
-    (match ps
113  
-      [(cons (? syntax? stx) _)
114  
-       (values stx 0)]
115  
-      [(cons 'car parent)
116  
-       (values (interp ps) 0)]
117  
-      [(cons (? exact-positive-integer? n) parent)
118  
-       (values (interp parent) n)]
119  
-      [(cons 'post parent)
120  
-       (ps->stx+index parent)])))
  108
+  (last ps))
121 109
 
122 110
 ;; ps-difference : PS PS -> nat
123 111
 ;; Returns N s.t. B = (ps-add-cdr^N A)
124 112
 (define (ps-difference a b)
125 113
   (define (whoops)
126  
-    (error 'ps-difference "~e is not an extension of ~e"
127  
-           (progress->sexpr b) (progress->sexpr a)))
  114
+    (error 'ps-difference "~e is not an extension of ~e" a b))
128 115
   (match (list a b)
129 116
     [(list (cons (? exact-positive-integer? na) pa)
130 117
            (cons (? exact-positive-integer? nb) pb))
@@ -137,29 +124,7 @@ Interpretation: later frames are applied first.
137 124
      (unless (equal? a b) (whoops))
138 125
      0]))
139 126
 
140  
-;; ps-truncate-opaque : PS -> PS
141  
-(define (ps-truncate-opaque ps)
142  
-  (let/ec return
143  
-    (let loop ([ps ps])
144  
-      (cond [(null? ps)
145  
-             null]
146  
-            [(eq? (car ps) 'opaque)
147  
-             ;; Tricky! We only jump after loop returns,
148  
-             ;; so jump closest to end wins.
149  
-             (return (loop (cdr ps)))]
150  
-            [else
151  
-             ;; Either (loop _) jumps, or it is identity
152  
-             (loop (cdr ps))
153  
-             ps]))))
154  
-
155  
-;; An Inverted PS (IPS) is a PS inverted for easy comparison.
156  
-;; An IPS may not contain any 'opaque frames.
157  
-
158  
-;; invert-ps : PS -> IPS
159  
-(define (invert-ps ps)
160  
-  (reverse (ps-truncate-opaque ps)))
161  
-
162  
-;; ps-pop-opaque : PS -> IPS
  127
+;; ps-pop-opaque : PS -> PS
163 128
 ;; Used to continue with progress from opaque head pattern.
164 129
 (define (ps-pop-opaque ps)
165 130
   (match ps
@@ -169,43 +134,40 @@ Interpretation: later frames are applied first.
169 134
      ps*]
170 135
     [_ (error 'ps-pop-opaque "opaque marker not found: ~e" ps)]))
171 136
 
172  
-;; ==== Failure ====
173  
-
174  
-;; A Failure is (failure PS ExpectStack)
175 137
 
176  
-;; A FailureSet is one of
177  
-;;   - Failure
178  
-;;   - (cons FailureSet FailureSet)
  138
+;; == Expectations ==
179 139
 
180  
-;; FailFunction = (FailureSet -> Answer)
  140
+#|
  141
+An ExpectStack (during parsing) is one of
  142
+  - (make-expect:thing Progress string boolean string/#f ExpectStack)
  143
+  * (make-expect:message string ExpectStack)
  144
+  * (make-expect:atom atom ExpectStack)
  145
+  * (make-expect:literal identifier ExpectStack)
181 146
 
182  
-(define-struct failure (progress expectstack) #:prefab)
  147
+The *-marked variants can only occur at the top of the stack.
183 148
 
184  
-;; == Expectations
  149
+Goal during parsing is to minimize/consolidate allocations.
185 150
 
186  
-;; FIXME: add phase to expect:literal
187  
-
188  
-#|
189  
-An ExpectStack is (listof Expect)
  151
+During reporting, the representation changes somewhat:
190 152
 
  153
+An ExpectStack (during reporting) is (listof Expect)
191 154
 An Expect is one of
192  
-  - (make-expect:thing ??? string boolean string/#f)
193  
-  * (make-expect:message string)
194  
-  * (make-expect:atom atom)
195  
-  * (make-expect:literal identifier)
196  
-  * (make-expect:disj (non-empty-listof Expect))
  155
+  - (expect:thing (cons syntax nat) string #t string/#f _)
  156
+  * (expect:message string _)
  157
+  * (expect:atom atom _)
  158
+  * (expect:literal identifier _)
  159
+  - (expect:disj (non-empty-listof Expect) _)
197 160
 
198  
-The *-marked variants can only occur at the top of the stack.
  161
+That is, next link always ignored (replace with #f for sake of equal? cmp)
  162
+and expect:thing term represented as syntax with index.
199 163
 
200  
-expect:thing frame contains representation of term:
201  
-  - during parsing, represent as progress
202  
-  - during reporting, convert to stx
  164
+Goal during reporting is ease of manipulation.
203 165
 |#
204  
-(define-struct expect:thing (term description transparent? role) #:prefab)
205  
-(define-struct expect:message (message) #:prefab)
206  
-(define-struct expect:atom (atom) #:prefab)
207  
-(define-struct expect:literal (literal) #:prefab)
208  
-(define-struct expect:disj (expects) #:prefab)
  166
+(struct expect:thing (term description transparent? role next) #:prefab)
  167
+(struct expect:message (message next) #:prefab)
  168
+(struct expect:atom (atom next) #:prefab)
  169
+(struct expect:literal (literal next) #:prefab)
  170
+(struct expect:disj (expects next) #:prefab)
209 171
 
210 172
 (define (expect? x)
211 173
   (or (expect:thing? x)
@@ -214,40 +176,18 @@ expect:thing frame contains representation of term:
214 176
       (expect:literal? x)
215 177
       (expect:disj? x)))
216 178
 
  179
+(define (es-add-thing ps description transparent? role next)
  180
+  (if description
  181
+      (expect:thing ps description transparent? role next)
  182
+      next))
  183
+
  184
+(define (es-add-message message next)
  185
+  (if message
  186
+      (expect:message message next)
  187
+      next))
  188
+
  189
+(define (es-add-atom atom next)
  190
+  (expect:atom atom next))
217 191
 
218  
-;; ==== Debugging
219  
-
220  
-(provide failureset->sexpr
221  
-         failure->sexpr
222  
-         expectstack->sexpr
223  
-         expect->sexpr)
224  
-
225  
-(define (failureset->sexpr fs)
226  
-  (let ([fs (flatten fs)])
227  
-    (case (length fs)
228  
-      ((1) (failure->sexpr (car fs)))
229  
-      (else `(union ,@(map failure->sexpr fs))))))
230  
-
231  
-(define (failure->sexpr f)
232  
-  (match f
233  
-    [(failure progress expectstack)
234  
-     `(failure ,(progress->sexpr progress)
235  
-               #:expected ,(expectstack->sexpr expectstack))]))
236  
-
237  
-(define (expectstack->sexpr es)
238  
-  (map expect->sexpr es))
239  
-
240  
-(define (expect->sexpr e)
241  
-  (match e
242  
-    [(expect:thing term description transparent? role)
243  
-     (expect:thing '<Term> description transparent? role)]
244  
-    [else e]))
245  
-
246  
-(define (progress->sexpr ps)
247  
-  (for/list ([pf (in-list (invert-ps ps))])
248  
-    (match pf
249  
-      [(? syntax? stx) 'stx]
250  
-      ['car 'car]
251  
-      ['post 'post]
252  
-      [(? exact-positive-integer? n) n]
253  
-      ['opaque 'opaque])))
  192
+(define (es-add-literal literal next)
  193
+  (expect:literal literal next))
180  collects/syntax/parse/private/runtime-report.rkt
... ...
@@ -1,5 +1,7 @@
1 1
 #lang racket/base
2 2
 (require racket/list
  3
+         syntax/stx
  4
+         unstable/struct
3 5
          "minimatch.rkt"
4 6
          (except-in syntax/parse/private/residual
5 7
                     syntax-patterns-fail)
@@ -9,7 +11,11 @@
9 11
          maximal-failures
10 12
 
11 13
          exn:syntax-parse?
12  
-         exn:syntax-parse-info)
  14
+         exn:syntax-parse-info
  15
+
  16
+         invert-ps
  17
+         ps->stx+index
  18
+         )
13 19
 
14 20
 #|
15 21
 TODO: given (expect:thing _ D _ R) and (expect:thing _ D _ #f),
@@ -91,7 +97,7 @@ complicated.
91 97
            (let ([frame-stx
92 98
                   (let-values ([(x cx) (stx-list-drop/cx stx stx index)])
93 99
                     (datum->syntax cx x cx))])
94  
-             (cond [(equal? frame-expect (expect:atom '()))
  100
+             (cond [(equal? frame-expect (expect:atom '() #f))
95 101
                     (syntax-case frame-stx ()
96 102
                       [(one . more)
97 103
                        (report "unexpected term" #'one)]
@@ -113,18 +119,18 @@ complicated.
113 119
 ;; prose-for-expect : Expect -> string
114 120
 (define (prose-for-expect e)
115 121
   (match e
116  
-    [(expect:thing ??? description transparent? role)
  122
+    [(expect:thing stx+index description transparent? role _)
117 123
      (if role
118 124
          (format "expected ~a for ~a" description role)
119 125
          (format "expected ~a" description))]
120  
-    [(expect:atom atom)
  126
+    [(expect:atom atom _)
121 127
      (format "expected the literal ~a~s~a"
122 128
              (if (symbol? atom) "symbol `" "")
123 129
              atom
124 130
              (if (symbol? atom) "'" ""))]
125  
-    [(expect:literal literal)
  131
+    [(expect:literal literal _)
126 132
      (format "expected the identifier `~s'" (syntax-e literal))]
127  
-    [(expect:message message)
  133
+    [(expect:message message _)
128 134
      (format "~a" message)]))
129 135
 
130 136
 ;; == Do Report ==
@@ -170,55 +176,32 @@ complicated.
170 176
 
171 177
 ;; == Expectation simplification ==
172 178
 
173  
-;; normalize-expectstack : ExpectStack -> ExpectStack
174  
-(define (normalize-expectstack es)
175  
-  (convert-expectstack
176  
-   (filter-expectstack
177  
-    (truncate-opaque-expectstack es))))
178  
-
179  
-;; truncate-opaque-expectstack : ExpectStack -> ExpectStack
180  
-;; Eliminates expectations on top of opaque (ie, transparent=#f) frames.
181  
-(define (truncate-opaque-expectstack es)
182  
-  (let/ec return
183  
-    (let loop ([es es])
184  
-      (match es
185  
-        ['() '()]
186  
-        [(cons (expect:thing ps description '#f role) rest-es)
187  
-         ;; Tricky! If multiple opaque frames, multiple "returns",
188  
-         ;; but innermost one called first, so jumps past the rest.
189  
-         ;; Also, flip opaque to transparent for sake of equality.
190  
-         (return (cons (expect:thing ps description #t role) (loop rest-es)))]
191  
-        [(cons (expect:thing ps description '#t role) rest-es)
192  
-         (cons (expect:thing ps description #t role) (loop rest-es))]
193  
-        [(cons expect rest-es)
194  
-         (cons expect (loop rest-es))]))))
195  
-
196  
-;; convert-expectstack : ExpectStack -> ExpectStack
197  
-;; Converts expect:thing term rep from progress to (cons stx index).
198  
-(define (convert-expectstack es)
  179
+;; normalize-expectstack : ExpectStack(parsing) -> ExpectStack(reporting)
  180
+;; Converts internal-chaining to list, converts expect:thing term rep,
  181
+;; and truncates expectstack after opaque (ie, transparent=#f) frames.
  182
+(define (normalize-expectstack es [truncate-opaque? #t])
199 183
   (define (convert-ps ps)
200 184
     (let-values ([(stx index) (ps->stx+index ps)])
201 185
       (cons stx index)))
202  
-  (map (lambda (expect)
203  
-         (match expect
204  
-           [(expect:thing ps de tr? rl)
205  
-            (expect:thing (convert-ps ps) de tr? rl)]
206  
-           [_ expect]))
207  
-       es))
208  
-
209  
-;; filter-expectstack : ExpectStack -> ExpectStack
210  
-;; Eliminates missing (ie, #f) messages and descriptions
211  
-;; FIXME: Change parsing code to avoid useless frame allocations?
212  
-;;   Or are they worth retaining for debugging?
213  
-(define (filter-expectstack es)
214  
-  (filter (lambda (expect)
215  
-            (match expect
216  
-              [(expect:thing _ '#f _ _)
217  
-               #f]
218  
-              [(expect:message '#f)
219  
-               #f]
220  
-              [_ #t]))
221  
-          es))
  186
+  (let/ec return
  187
+    (let loop ([es es])
  188
+      (match es
  189
+        ['#f '()]
  190
+        [(expect:thing ps desc tr? role rest-es)
  191
+         (cond [(and truncate-opaque? (not tr?))
  192
+                ;; Tricky! If multiple opaque frames, multiple 'return' calls,
  193
+                ;; but innermost one called first, so jumps past the rest.
  194
+                ;; Also, flip opaque to transparent for sake of equality.
  195
+                (return
  196
+                 (cons (expect:thing (convert-ps ps) desc #t role #f) (loop rest-es)))]
  197
+               [else
  198
+                (cons (expect:thing (convert-ps ps) desc tr? role #f) (loop rest-es))])]
  199
+        [(expect:message message rest-es)
  200
+         (cons (expect:message message #f) (loop rest-es))]
  201
+        [(expect:atom atom rest-es)
  202
+         (cons (expect:atom atom #f) (loop rest-es))]
  203
+        [(expect:literal literal rest-es)
  204
+         (cons (expect:literal literal #f) (loop rest-es))]))))
222 205
 
223 206
 #|
224 207
 Simplification dilemma
@@ -257,7 +240,7 @@ So we go with option 2.
257 240
              (let* ([frames (map car ress)])
258 241
                (list (list (if (singleton? frames)
259 242
                                (car frames)
260  
-                               (expect:disj frames)))))]
  243
+                               (expect:disj frames #f)))))]
261 244
             [else ress])))
262 245
   ;; singleton? : list -> boolean
263 246
   (define (singleton? res)
@@ -303,6 +286,28 @@ If ps1 = ps2 then both must "blame" the same term,
303 286
 ie (ps->stx+index ps1) = (ps->stx+index ps2).
304 287
 |#
305 288
 
  289
+;; An Inverted PS (IPS) is a PS inverted for easy comparison.
  290
+;; An IPS may not contain any 'opaque frames.
  291
+
  292
+;; invert-ps : PS -> IPS
  293
+(define (invert-ps ps)
  294
+  (reverse (ps-truncate-opaque ps)))
  295
+
  296
+;; ps-truncate-opaque : PS -> PS
  297
+(define (ps-truncate-opaque ps)
  298
+  (let/ec return
  299
+    (let loop ([ps ps])
  300
+      (cond [(null? ps)
  301
+             null]
  302
+            [(eq? (car ps) 'opaque)
  303
+             ;; Tricky! We only jump after loop returns,
  304
+             ;; so jump closest to end wins.
  305
+             (return (loop (cdr ps)))]
  306
+            [else
  307
+             ;; Either (loop _) jumps, or it is identity
  308
+             (loop (cdr ps))
  309
+             ps]))))
  310
+
306 311
 ;; maximal/progress : (listof (cons A IPS)) -> (listof (listof A))
307 312
 ;; Returns a list of equivalence sets.
308 313
 (define (maximal/progress items)
@@ -387,9 +392,78 @@ ie (ps->stx+index ps1) = (ps->stx+index ps2).
387 392
         [ips (cdr a+ips)])
388 393
     (cons a (cdr ips))))
389 394
 
  395
+;; ps->stx+index : Progress -> (values stx nat)
  396
+;; Gets the innermost stx that should have a real srcloc, and the offset
  397
+;; (number of cdrs) within that where the progress ends.
  398
+(define (ps->stx+index ps)
  399
+  (define (interp ps)
  400
+    (match ps
  401
+      [(cons (? syntax? stx) _) stx]
  402
+      [(cons 'car parent)
  403
+       (let* ([d (interp parent)]
  404
+              [d (if (syntax? d) (syntax-e d) d)])
  405
+         (cond [(pair? d) (car d)]
  406
+               [(vector? d) (vector->list d)]
  407
+               [(box? d) (unbox d)]
  408
+               [(prefab-struct-key d) (struct->list d)]
  409
+               [else (error 'ps->stx+index "INTERNAL ERROR: unexpected: ~e" d)]))]
  410
+      [(cons (? exact-positive-integer? n) parent)
  411
+       (for/fold ([stx (interp parent)]) ([i (in-range n)])
  412
+         (stx-cdr stx))]
  413
+      [(cons 'post parent)
  414
+       (interp parent)]))
  415
+  (let ([ps (ps-truncate-opaque ps)])
  416
+    (match ps
  417
+      [(cons (? syntax? stx) _)
  418
+       (values stx 0)]
  419
+      [(cons 'car parent)
  420
+       (values (interp ps) 0)]
  421
+      [(cons (? exact-positive-integer? n) parent)
  422
+       (values (interp parent) n)]
  423
+      [(cons 'post parent)
  424
+       (ps->stx+index parent)])))
  425
+
390 426
 (define (rmap f xs)
391 427
   (let rmaploop ([xs xs] [accum null])
392 428
     (cond [(pair? xs)
393 429
            (rmaploop (cdr xs) (cons (f (car xs)) accum))]
394 430
           [else
395 431
            accum])))
  432
+
  433
+
  434
+;; ==== Debugging
  435
+
  436
+(provide failureset->sexpr
  437
+         failure->sexpr
  438
+         expectstack->sexpr
  439
+         expect->sexpr)
  440
+
  441
+(define (failureset->sexpr fs)
  442
+  (let ([fs (flatten fs)])
  443
+    (case (length fs)
  444
+      ((1) (failure->sexpr (car fs)))
  445
+      (else `(union ,@(map failure->sexpr fs))))))
  446
+
  447
+(define (failure->sexpr f)
  448
+  (match f
  449
+    [(failure progress expectstack)
  450
+     `(failure ,(progress->sexpr progress)
  451
+               #:expected ,(expectstack->sexpr expectstack))]))
  452
+
  453
+(define (expectstack->sexpr es)
  454
+  (map expect->sexpr (normalize-expectstack es #f)))
  455
+
  456
+(define (expect->sexpr e)
  457
+  (match e
  458
+    [(expect:thing stx+index description transparent? role _)
  459
+     (expect:thing '<Term> description transparent? role '_)]
  460
+    [else e]))
  461
+
  462
+(define (progress->sexpr ps)
  463
+  (for/list ([pf (in-list (reverse ps))])
  464
+    (match pf
  465
+      [(? syntax? stx) 'stx]
  466
+      ['car 'car]
  467
+      ['post 'post]
  468
+      [(? exact-positive-integer? n) n]
  469
+      ['opaque 'opaque])))

0 notes on commit a564110

Please sign in to comment.
Something went wrong with that request. Please try again.