0. #lang racket
1.  
2. (require (for-syntax syntax/parse))
3.  
4. ; now, with derivations!
5.  
6. (begin-for-syntax
7.   (define-splicing-syntax-class node
8.     #:datum-literals (-- = $)
9.  
10.     (pattern {~seq lhs*:id --}
11.       #:with rhs #'lhs*
12.       #:with lhs #''lhs*)
13.  
14.     (pattern {~seq lhs*:id (~optional {~seq = rhs*:expr})}
15.       #:with rhs #'(~? rhs* _)
16.       #:with lhs #''lhs*)
17.  
18.     (pattern {~seq $ lhs*:expr (~optional {~seq = rhs*:expr})}
19.       #:with rhs #'(~? rhs* _)
20.       #:with lhs #'lhs*))
21.  
22.   (define-splicing-syntax-class nest
23.     #:datum-literals (:)
24.     (pattern {~seq node:node}
25.       #:with norm #'(node.lhs node.rhs))
26.  
27.     (pattern {~seq node:node : nodes-or-conj:nest->hash}
28.       #:with norm #'(node.lhs (and node.rhs nodes-or-conj.norm))))
29.  
30.   (define-splicing-syntax-class nest->hash
31.     (pattern nest:nest
32.       #:with ooo  #'(... ...)
33.       #:with norm #'(hash-table nest.norm _ ooo))
34.  
35.     (pattern nest:conj
36.       #:with norm #'(extract (~@ . nest))))
37.  
38.   ; not being used yet
39.   (define-splicing-syntax-class ellipsis
40.     #:datum-literals (each some with))
41.  
42.   (define-splicing-syntax-class conj
43.     #:datum-literals (× @)
44.     (pattern {~seq [nest0:nest {~seq × nest:nest} ... (~optional {~seq @ rest*:expr})]
45.                    (~optional {~seq #:derive [pat* exp*] ...})}
46.       #:with norm             #'(nest0.norm nest.norm  ...)
47.       #:with rest             #'(~? rest* _)
48.       #:with (derive-pat ...) #'(~? (pat* ...) ())
49.       #:with (derive-exp ...) #'(~? (exp* ...) ()))))
50.  
51. (define-match-expander filter*
52.   (lambda (stx)
53.     (syntax-parse stx
54.       [(_ pattern* (~optional {~seq #:rest rest}))
55.        #:with ooo      #'(... ...)
56.        #'(app (lambda (lst)
57.                 (for/fold ([matched (list)]
58.                            [ignored (list)]
59.                            #:result (values (reverse matched) (reverse ignored)))
60.                           ([element (in-list lst)])
61.                   (match element
62.                     [pattern*
63.                      (values (cons element matched) ignored)]
64.                     [_
65.                      (values matched (cons element ignored))])))
66.               (list pattern* ooo) (~? rest _))])))
67.  
68. (define-match-expander extract
69.   (lambda (stx)
70.     (syntax-parse stx
71.       [(_ conj*:conj)
72.        #:with ooo       #'(... ...)
73.        #:with (exp ...) #'(conj*.derive-exp ...)
74.        #:with (pat ...) #'(conj*.derive-pat ...)
75.        #:with (ph  ...) (generate-temporaries #'(exp ...))
76.        #'(app (match-lambda
77.                 [(and hash (hash-table (~@ . conj*.norm) (k v) ooo))
78.                  (match-let* ([(and ph pat) exp] ...)
79.                    (list hash (make-hash (map cons k v)) ph ...))] [_ #f])
80.               (list (hash-table (~@ . conj*.norm) _ ooo) conj*.rest pat ...))])))
81.  
82. (define-match-expander replace
83.   (lambda (stx)
84.     (syntax-parse stx
85.       [(_)
86.        #'(list)])))
87.  
88. (define T 'h)
89.  
90. (match (list #hash((windows . #hash((wash  . #hash((john . #hash((4 . h)))
91.                                                    (mary . #hash((1 . h)))))))
92.                    (veranda . #hash((scrub . #hash((john . #hash((3 . h)))))))
93.                    (cellars . #hash((scrub . #hash((john . #hash((3 . h)))))))
94.                    (day     . (#hash((date . "1896-02-03"))
95.                                #hash((date . "1896-02-04"))
96.                                #hash((date . "1896-02-05")))))
97.  
98.              #hash((windows . #hash((wash  . #hash((jill . #hash((3   . h)))
99.                                                    (jack . #hash((2   . h)))))))
100.                    (veranda . #hash((scrub . #hash((jess . #hash((1   . h)))))))
101.                    (cellars . #hash((scrub . #hash((jess . #hash((0.5 . h)))))))
102.                    (day     . (#hash((date . "1896-02-10")))))
103.  
104.              #hash((windows . #hash((wash  . #hash((jill . #hash((3 . h)))
105.                                                    (jack . #hash((2 . h)))))))
106.                    (veranda . #hash((scrub . #hash((jess . #hash((5 . h)))))))
107.                    (cellars . #hash((scrub . #hash((jess . #hash((2 . h)))))))
108.                    (day     . (#hash((date . "1896-02-17"))))))
109.   [(filter*
110.     (extract
111.      [ windows
112.      : wash --
113.      : [ $ (or 'jill 'mary)
114.        : $ time-jill+mary = (== T)
115.  
116.        × $ (or 'jack 'john)
117.        : $ time-jack+john = 'h]
118.        #:derive
119.        [time-jill+mary-minutes (* 60 time-jill+mary)]
120.        [time-jack+john-minutes (* 60 time-jack+john)]
121.     × veranda = (and veranda (extract [scrub = veranda-scrub]))
122.     × cellars
123.     : scrub   = cellars-scrub
124.     × day     = (list (extract [date = "1896-02-10"]) ...)
125.     @ hash-rest])
126.     #:rest list-rest)
127.    ;---
128.    (displayln wash)
129.    (displayln time-jill+mary)
130.    (displayln time-jill+mary-minutes)
131.  
132.    (displayln time-jack+john)
133.    (displayln time-jack+john-minutes)
134.  
135.    (displayln veranda-scrub)
136.    (displayln cellars-scrub)
137.    (displayln veranda)]
138.   [_ #f])

=>