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.   ;; if this is named "var" instead, and all uses are updated, the code does not
63.   ;; compile!
64.   (define-syntax-class var (pattern var:id #:when (var? #'var)))
65.   (define-syntax-class name (pattern name:id #:when (name? #'name))))
66.  
67.  
68. 
69. ;; The syntax transformers
70. (provide (rename-out [datalog-module-begin #%module-begin]) )
71. (define-syntax-parser datalog-module-begin
72.   [(_ (~or clause:clause) ...)
73.    ;; Extract the predicate names.
74.    (define id-list (compose set->list list->set syntax->datum))
75.    (define defined-preds (id-list #'(clause.pred ...)))
76.    (define preds (id-list #'(clause.all-preds ... ...)))
77.  
78.    ;; (define used-preds
79.    ;;   (syntax->list #'(clause.body)))
80.  
81.    ;; TODO Check arity: Declarations, definitions, and uses of a given predicate
82.    ;; all have the same arity.
83.  
84.    ;; TODO Check stratification: no mutual definition cycles that go through a
85.    ;; negation
86.  
87.    ;; TODO Check generativity: every variable in the head of a clause occurs in
88.    ;; a positive position in its body.
89.  
90.    (define/with-syntax (pred ...) preds)
91.    #`(#%module-begin
92.       (displayln "hello world")
93.       (printf "- pred: ~a\n" 'pred) ...
94.  
95.       ;; initialize predicate sets.
96.       (define pred (mutable-set)) ...
97.  
98.       ;; the fixed-point loop
99.       (let loop ()
100.         (define changed #f)
101.         (run-clause changed clause) ...
102.         (when changed (loop))))])
103.  
104. (define-syntax-parser run-clause
105.   #:datum-literals (:- not)
106.   [(_ changed:id ((pred:name arg:arg ...)
107.                   :-
108.                   (~or pos-term:positive-term
109.                        ;; (not neg-term:positive-term)
110.                        ) ...))
111.    #`(begin
112.        ;; compute the set of things to add to `pred'
113.        (define tuples (solving (pos-term ...) (list arg ...)))
114.        (unless changed
115.          ;; check whether we added any new elements.
116.          (set! changed (not (subset? tuples pred))))
117.        (set-union! pred tuples))])
118.  
119. ;; (solving (terms ...) body ...)
120. (define-syntax-parser solving
121.   [(_ (term ...) body ...)
122.    (define-values (_ result)
123.     (for/fold ([bound-vars (set)]
124.                [body #'(begin body ...)])
125.               ([term (syntax->list #'(term ...))])
126.       (define/syntax-parse (pred:name arg:arg ...) term)
127.       (define/syntax-parse ((~or var:var (~not _:var)) ...) #'(arg ...))
128.       (define new-vars (list->set (syntax->datum #'(var ...))))
129.       (define tuple-patterns
130.         (for/list ([arg (syntax->list #'(arg ...))])
131.           (syntax-parse arg
132.             [atom:name #''atom]
133.             [v:var (if (set-member? (syntax->datum #'v) bound-vars)
134.                        #'(== v)
135.                        #'v)]
136.             )))
137.       (values
138.        (set-union bound-vars new-vars)
139.        #`(let*/set ([tuple pred])
140.                    (match tuple
141.                      [(list #,@tuple-patterns) #,body]
142.                      [_ (set)])))))
143.    result])

=>