0. #lang racket
1.  
2. (require (for-syntax racket/match
3.                      syntax/parse))
4.  
5. (begin-for-syntax
6.   ; the description of a fact which expands to an implication
7.   (define-splicing-syntax-class fact
8.     #:datum-literals (-- = $)
9.  
10.     ; match some rhs in (hash-table ('rhs rhs) _ ...)
11.     ; written as `rhs --`
12.     (pattern {~seq rhs*:id --}
13.       #:with rhs #'rhs*
14.       #:with lhs #''rhs*)
15.  
16.     ; match some rhs, lhs in (hash-table ('rhs lhs) _ ...)
17.     ; written as `rhs = lhs`
18.     (pattern {~seq rhs*:id (~optional {~seq = lhs*:expr})}
19.       #:with rhs #'(~? lhs* _)
20.       #:with lhs #''rhs*)
21.  
22.     ; match some rhs, lhs in (hash-table (rhs lhs) _ ...)
23.     ; written as `$ rhs = lhs`
24.     (pattern {~seq $ rhs*:expr (~optional {~seq = lhs*:expr})}
25.       #:with rhs #'(~? lhs* _)
26.       #:with lhs #'rhs*))
27.  
28.   ; an implication, i.e. k implies v, in (hash-table (k v) _ ...)
29.   ; in general, (hash-table (f0 (hash-table (f1 (⋯ fn))))) is written
30.   ; `f0 : f1 : ⋯ : fn` for some facts f0, ⋯, fn
31.   (define-splicing-syntax-class impl
32.     #:datum-literals (:)
33.     (pattern {~seq fact:fact}
34.       #:with norm #'(fact.lhs fact.rhs))
35.  
36.     ; we want to keep the "top" of the implication bare, and wrap the deeper facts in (hash-table ...)
37.     (pattern {~seq fact:fact : facts-or-conj:impl->hash}
38.       #:with norm #'(fact.lhs (and fact.rhs facts-or-conj.norm))))
39.  
40.   (define-splicing-syntax-class impl->hash
41.     (pattern impl:impl
42.       #:with ooo  #'(... ...)
43.       #:with norm #'(hash-table impl.norm _ ooo))
44.  
45.     ; a trailing conjunction is allowed
46.     (pattern impl:conj
47.       #:with norm #'(extract impl)))
48.  
49.   ; not being used yet
50.   (define-splicing-syntax-class ellipsis
51.     #:datum-literals (each some with))
52.  
53.   ; the conjunction of implications, eventually expanded to (hash-table (k u) (l v) ⋯ (m w))
54.   ; for some implications p = (k u), q = (l v), ⋯, r = (m w)
55.   ; in general, (hash-table p q ⋯ r) is written
56.   ; `[p × q × ⋯ × r]`, optionally with a trailing `@ z` to capture the rest of the hash-table
57.   (define-syntax-class conj
58.     #:datum-literals (× @)
59.     (pattern [impl0:impl {~seq × impl:impl} ... (~optional {~seq @ rest*:expr})]
60.       #:with norm #'(impl0.norm impl.norm  ...)
61.       #:with rest #'(~? rest* _))))
62.  
63. (define-match-expander extract
64.   (lambda (stx)
65.     (syntax-parse stx
66.       #:datum-literals (list-of)
67.  
68.       ; match a list of similar hash-tables
69.       [(_ list-of conj*:conj)
70.        #:with ooo #'(... ...)
71.        #'(list (extract conj*) ooo)]
72.  
73.       ; match a single hash-table
74.       [(_ conj*:conj)
75.        #:with ooo #'(... ...)
76.        #'(app (match-lambda
77.                 [(and hash (hash-table (~@ . conj*.norm) (k v) ooo))
78.                  (cons hash (make-hash (map cons k v)))] [_ #f])
79.               (cons (hash-table (~@ . conj*.norm)) conj*.rest))])))
80.  
81. (match (list #hash((windows . #hash((wash  . #hash((john . #hash((4 . h)))
82.                                                    (mary . #hash((1 . h)))))))
83.                    (veranda . #hash((scrub . #hash((john . #hash((3 . h)))))))
84.                    (cellars . #hash((scrub . #hash((john . #hash((3 . h)))))))
85.                    (day     . "1896-02-03"))
86.  
87.              #hash((windows . #hash((wash  . #hash((jill . #hash((3   . h)))
88.                                                    (jack . #hash((2   . h)))))))
89.                    (veranda . #hash((scrub . #hash((jess . #hash((1   . h)))))))
90.                    (cellars . #hash((scrub . #hash((jess . #hash((0.5 . h)))))))
91.                    (day     . "1896-02-10"))
92.  
93.              #hash((windows . #hash((wash  . #hash((jill . #hash((3 . h)))
94.                                                    (jack . #hash((2 . h)))))))
95.                    (veranda . #hash((scrub . #hash((jess . #hash((5 . h)))))))
96.                    (cellars . #hash((scrub . #hash((jess . #hash((2 . h)))))))
97.                    (day     . "1896-02-17")))
98.   [(extract list-of
99.     [ windows
100.     : wash --
101.     : [ $ (or 'jill 'mary)
102.       : $ time-jill+mary = 'h
103.  
104.       × $ (or 'jack 'john)
105.       : $ time-jack+john = 'h]
106.     × veranda
107.     : scrub = veranda-scrub
108.     × cellars
109.     : scrub = cellars-scrub
110.     @ rest])
111.    ;---
112.    (displayln wash)
113.    (displayln time-jill+mary)
114.    (displayln time-jack+john)
115.    (displayln veranda-scrub)
116.    (displayln cellars-scrub)
117.    (displayln rest)]
118.   [_ #f])

=>