0. #lang racket
1.  
2. (require (for-syntax racket/set))
3. (require (for-syntax racket/syntax))
4. (require syntax/parse/define (for-syntax syntax/parse))
5.  
6. ;; ;; anything prefixed with "--" is provided out, without the prefix.
7. ;; (require racket/provide) ;; for filtered-out, matching-identifiers-out
8. ;; (provide
9. ;;  (filtered-out (lambda (name) (substring name 2))
10. ;;                (matching-identifiers-out #rx"^--" (all-defined-out))))
11.  
12. ;; TODO: #%top-interaction, and possibly #%top?
13. (provide #%top-interaction)
14.  
15. ;; utility
16. (define-simple-macro (let*/set (for-clause ...) body ...)
17.   (for/set (for-clause ... [x (begin body ...)]) x))
18.  
19. 
20. ;; Our grammar
21.  
22. ;; TOP ::= DECLARE | CLAUSE
23. ;; DECLARE ::= (pred:NAME : arg:NAME ...)
24. ;; CLAUSE ::= (head:POSITIVE-TERM :- body:TERM ...)
25. ;;
26. ;; TERM ::= POSITIVE-TERM | (not POSITIVE-TERM)
27. ;; POSITIVE-TERM ::= (pred:NAME arg:ARG ...)
28. ;;
29. ;; ARG ::= var:VAR | atom:NAME
30. ;;
31. ;; VAR = upper-case identifier
32. ;; NAME = lower-case identifier
33. (begin-for-syntax
34.   (define (first-char pred id)
35.     (define s (symbol->string (syntax->datum id)))
36.     (and (< 0 (string-length s)) (pred (string-ref s 0))))
37.  
38.   (define (name? id) (first-char char-lower-case? id))
39.   (define (var? id) (first-char char-upper-case? id))
40.  
41.   (define-syntax-class declare
42.     #:datum-literals (:)
43.     (pattern (pred:name : arg:name ...)))
44.   (define-syntax-class clause
45.     #:datum-literals (:-)
46.     (pattern (head:positive-term :- body:term ...)
47.              #:attr pred #'head.pred
48.              #:attr (arg 1) (syntax->list #'(head.arg ...))
49.              #:attr (all-preds 1) (syntax->list #'(pred body.pred ...))))
50.  
51.   (define-syntax-class term
52.     #:datum-literals (not)
53.     (pattern t:positive-term
54.              #:attr pred #'t.pred
55.              #:attr (arg 1) (syntax->list #'(t.arg ...)))
56.     (pattern (not t:positive-term)
57.              #:attr pred #'t.pred
58.              #:attr (arg 1) (syntax->list #'(t.arg ...))))
59.  
60.   (define-syntax-class positive-term (pattern (pred:name arg:arg ...)))
61.   (define-syntax-class arg (pattern var) (pattern name))
62.   ;; for some reason, the name of this syntax class seems to matter. when named
63.   ;; var, this file fails to compile for me. when named anything else ("Var" or
64.   ;; "var-"), it works.
65.   (define-syntax-class var (pattern var:id #:when (var? #'var)))
66.   (define-syntax-class name (pattern name:id #:when (name? #'name))))
67.  
68.  
69. 
70. ;; The syntax transformers
71. (provide (rename-out [datalog-module-begin #%module-begin]) )
72. (define-syntax-parser datalog-module-begin
73.   [(_ (~or clause:clause) ...)
74.    ;; Extract the predicate names.
75.    (define id-list (compose set->list list->set syntax->datum))
76.    (define defined-preds (id-list #'(clause.pred ...)))
77.    (define preds (id-list #'(clause.all-preds ... ...)))
78.  
79.    ;; (define used-preds
80.    ;;   (syntax->list #'(clause.body)))
81.  
82.    ;; TODO Check arity: Declarations, definitions, and uses of a given predicate
83.    ;; all have the same arity.
84.  
85.    ;; TODO Check stratification: no mutual definition cycles that go through a
86.    ;; negation
87.  
88.    ;; TODO Check generativity: every variable in the head of a clause occurs in
89.    ;; a positive position in its body.
90.  
91.    (define/with-syntax (pred ...) preds)
92.    #`(#%module-begin
93.       (displayln "hello world")
94.       (printf "- pred: ~a\n" 'pred) ...
95.  
96.       ;; initialize predicate sets.
97.       (define pred (mutable-set)) ...
98.  
99.       ;; the fixed-point loop
100.       (let loop ()
101.         (define changed #f)
102.         (run-clause changed clause) ...
103.         (when changed (loop))))])
104.  
105. (define-syntax-parser run-clause
106.   #:datum-literals (:- not)
107.   [(_ changed:id ((pred:name arg:arg ...)
108.                   :-
109.                   (~or pos-term:positive-term
110.                        ;; (not neg-term:positive-term)
111.                        ) ...))
112.    #`(begin
113.        ;; compute the set of things to add to `pred'
114.        (define tuples (solving (pos-term ...) (list arg ...)))
115.        (unless changed
116.          ;; check whether we added any new elements.
117.          (set! changed (not (subset? tuples pred))))
118.        (set-union! pred tuples))])
119.  
120. ;; (solving (terms ...) body ...)
121. (define-syntax-parser solving
122.   [(_ (term ...) body ...)
123.    (define-values (_ result)
124.     (for/fold ([bound-vars (set)]
125.                [body #'(begin body ...)])
126.               ([term (syntax->list #'(term ...))])
127.       (define/syntax-parse (pred:name arg:arg ...) term)
128.       (define/syntax-parse ((~or var:var (~not _:var)) ...) #'(arg ...))
129.       (define new-vars (list->set (syntax->datum #'(var ...))))
130.       (define tuple-patterns
131.         (for/list ([arg (syntax->list #'(arg ...))])
132.           (syntax-parse arg
133.             [atom:name #''atom]
134.             ;; ----------> this is the offending case. <----------
135.             ;; for some reason it doesn't like this.
136.             [v:var (if (set-member? (syntax->datum #'v) bound-vars)
137.                        #'(== v)
138.                        #'v)]
139.             )))
140.       (values
141.        (set-union bound-vars new-vars)
142.        #`(let*/set ([tuple pred])
143.                    (match tuple
144.                      [(list #,@tuple-patterns) #,body]
145.                      [_ (set)])))))
146.    result])

=>