1#lang racket/base
2(require (for-syntax racket/base
3                     syntax/stx
4                     racket/syntax
5                     "private/rep-data.rkt"
6                     "private/rep.rkt"
7                     "private/kws.rkt")
8         racket/list
9         racket/pretty
10         "../parse.rkt"
11         (except-in syntax/parse/private/residual
12                    prop:syntax-class
13                    prop:pattern-expander
14                    syntax-local-syntax-parse-pattern-introduce)
15         "private/runtime.rkt"
16         "private/runtime-progress.rkt"
17         "private/runtime-report.rkt"
18         "private/kws.rkt")
19
20;; No lazy loading for this module's dependencies.
21
22(provide syntax-class-parse
23         syntax-class-attributes
24         syntax-class-arity
25         syntax-class-keywords
26
27         debug-rhs
28         debug-pattern
29         debug-parse
30         debug-syntax-parse!)
31
32(define-syntax (syntax-class-parse stx)
33  (syntax-case stx ()
34    [(_ s x arg ...)
35     (parameterize ((current-syntax-context stx))
36       (with-disappeared-uses
37        (let* ([argu (parse-argu (syntax->list #'(arg ...)) #:context stx)]
38               [stxclass
39                (get-stxclass/check-arity #'s stx
40                                          (length (arguments-pargs argu))
41                                          (arguments-kws argu))]
42               [attrs (stxclass-attrs stxclass)])
43          (with-syntax ([parser (stxclass-parser stxclass)]
44                        [argu argu]
45                        [(name ...) (map attr-name attrs)]
46                        [(depth ...) (map attr-depth attrs)])
47            #'(let ([fh (lambda (undos fs) fs)])
48                (app-argu parser x x (ps-empty x x) #f null fh fh #f
49                          (lambda (fh undos . attr-values)
50                            (map vector '(name ...) '(depth ...) attr-values))
51                          argu))))))]))
52
53(define-syntaxes (syntax-class-attributes
54                  syntax-class-arity
55                  syntax-class-keywords)
56  (let ()
57    (define ((mk handler) stx)
58      (syntax-case stx ()
59        [(_ s)
60         (parameterize ((current-syntax-context stx))
61           (with-disappeared-uses
62            (handler (get-stxclass #'s))))]))
63    (values (mk (lambda (s)
64                  (let ([attrs (stxclass-attrs s)])
65                    (with-syntax ([(a ...) (map attr-name attrs)]
66                                  [(d ...) (map attr-depth attrs)])
67                      #'(quote ((a d) ...))))))
68            (mk (lambda (s)
69                  (let ([a (stxclass-arity s)])
70                    #`(to-procedure-arity '#,(arity-minpos a) '#,(arity-maxpos a)))))
71            (mk (lambda (s)
72                  (let ([a (stxclass-arity s)])
73                    #`(values '#,(arity-minkws a) '#,(arity-maxkws a))))))))
74
75(define-syntax (debug-rhs stx)
76  (syntax-case stx ()
77    [(debug-rhs rhs)
78     (let ([rhs (parse-rhs #'rhs #f #:context stx)])
79       #`(quote #,rhs))]))
80
81(define-syntax (debug-pattern stx)
82  (syntax-case stx ()
83    [(debug-pattern p . rest)
84     (let-values ([(rest pattern defs)
85                   (parse-pattern+sides #'p #'rest
86                                        #:splicing? #f
87                                        #:decls (new-declenv null)
88                                        #:context stx)])
89       (unless (stx-null? rest)
90         (raise-syntax-error #f "unexpected terms" stx rest))
91       #`(quote ((definitions . #,defs)
92                 (pattern #,pattern))))]))
93
94(define-syntax-rule (debug-parse x p ...)
95  (let/ec escape
96    (parameterize ((current-failure-handler
97                    (lambda (_ fs)
98                      (define-values (raw-fs-sexpr maximal-fs-sexpr) (fs->sexprs fs))
99                      (escape
100                       `(parse-failure
101                         #:raw-failures
102                         ,raw-fs-sexpr
103                         #:maximal-failures
104                         ,maximal-fs-sexpr)))))
105      (syntax-parse x [p 'success] ...))))
106
107(define (fs->sexprs fs)
108  (let* ([raw-fs (map invert-failure (reverse (flatten fs)))]
109         [selected-groups (maximal-failures raw-fs)])
110    (values (failureset->sexpr raw-fs)
111            (let ([selected (map (lambda (fs)
112                                   (cons 'progress-class
113                                         (map failure->sexpr fs)))
114                                 selected-groups)])
115              (if (= (length selected) 1)
116                  (car selected)
117                  (cons 'union selected))))))
118
119(define (debug-syntax-parse!)
120  (define old-failure-handler (current-failure-handler))
121  (current-failure-handler
122   (lambda (ctx fs)
123     (define-values (raw-fs-sexpr maximal-fs-sexpr) (fs->sexprs fs))
124     (eprintf "*** syntax-parse debug info ***\n")
125     (eprintf "Raw failures:\n")
126     (pretty-write raw-fs-sexpr (current-error-port))
127     (eprintf "Maximal failures:\n")
128     (pretty-write maximal-fs-sexpr (current-error-port))
129     (old-failure-handler ctx fs))))
130