1#lang racket/base
2
3(provide beginner-module-begin vanilla-module-begin advanced-module-begin)
4
5(require deinprogramm/signature/signature
6	 deinprogramm/signature/signature-syntax)
7
8(require (for-syntax racket/base)
9	 (for-syntax racket/list)
10	 (for-syntax syntax/boundmap)
11	 (for-syntax syntax/id-table)
12	 (for-syntax syntax/kerncase)
13	 (for-syntax racket/struct-info))
14
15(require (only-in test-engine/syntax test))
16
17(define-syntax (print-results stx)
18  (syntax-case stx ()
19    ((_ expr)
20     (not (or (syntax-property #'expr 'stepper-hide-completed)
21	      (syntax-property #'expr 'stepper-skip-completely)
22	      (syntax-property #'expr 'test-call)))
23     (syntax-property
24      (syntax-property
25       #'(#%app call-with-values (lambda () expr)
26		do-print-results)
27       'stepper-skipto
28       '(syntax-e cdr cdr car syntax-e cdr cdr car))
29      'certify-mode
30      'transparent))
31    ((_ expr) #'expr)))
32
33(define (do-print-results . vs)
34  (for-each (current-print) vs)
35  ;; Returning 0 values avoids any further result printing
36  ;; (even if void values are printed)
37  (values))
38
39(define-syntaxes (beginner-module-begin vanilla-module-begin advanced-module-begin module-continue)
40  (let ()
41    ;; takes a list of syntax objects (the result of syntax-e) and returns all the syntax objects that correspond to
42    ;; a signature declaration. Syntax: (: id signature)
43    (define extract-signatures
44      (lambda (lostx)
45	(let* ((table (make-free-id-table)) ; bound doesn't work as we need to match signature declarations and definitions
46	       (non-signatures
47		(filter-map (lambda (maybe)
48			      (syntax-case maybe (:)
49				((: ?exp ?sig)
50				 (not (identifier? #'?exp))
51				 #'(apply-signature/blame (signature ?sig) ?exp))
52				((: ?id ?sig)
53				 (begin
54				   (cond
55				    ((free-id-table-ref table #'?id #f)
56				     => (lambda (old-sig-stx)
57					  (unless (equal? (syntax->datum old-sig-stx)
58							  (syntax->datum #'?sig))
59					    (raise-syntax-error #f
60								"Zweite Signaturdeklaration für denselben Namen."
61								maybe))))
62				    (else
63				     (let ((si (syntax-local-value #'?id (lambda () #f))))
64				       (if (and (struct-info? si)
65						(procedure? si)) ; record constructor, just a macro
66					   (free-id-table-set! table (si #'?id) #'?sig)
67					   (free-id-table-set! table #'?id #'?sig)))))
68				   #f))
69				((: ?id)
70				 (raise-syntax-error #f "Bei dieser Signaturdeklaration fehlt die Signatur" maybe))
71				((: ?id ?sig ?stuff0 ?stuff1 ...)
72				 (raise-syntax-error #f "In der :-Form werden ein Name und eine Signatur erwartet; da steht noch mehr"
73						     (syntax/loc #'?stuff0
74								 (?stuff0 ?stuff1 ...))))
75				(_ maybe)))
76			lostx)))
77	  (values table non-signatures))))
78
79    (define local-expand-stop-list
80      (append (list #': #'define-contract)
81	      (kernel-form-identifier-list)))
82
83    (define (expand-signature-expressions signature-table expressions)
84
85      (let loop ((exprs expressions))
86
87	(cond
88	 ((null? exprs)
89	  ; check for orphaned signatures
90	  (free-id-table-for-each signature-table
91				  (lambda (id thing)
92				    (if (identifier-binding id)
93					(raise-syntax-error #f "Zu einer eingebauten Form kann keine Signatur deklariert werden" id)
94					(raise-syntax-error #f "Zu dieser Signatur gibt es keine Definition" id))))
95	  #'(begin))
96	 (else
97	  (let ((expanded (car exprs)))
98
99	    (syntax-case expanded (begin define-values)
100	      ((define-values (?id ...) ?e1)
101	       (with-syntax (((?enforced ...)
102			      (map (lambda (id)
103				     (cond
104				      ((free-id-table-ref signature-table id #f)
105				       => (lambda (sig)
106					    (free-id-table-remove! signature-table id) ; enables the check for orphaned signatures
107					    (with-syntax ((?id id)
108							  (?sig sig))
109					      #'(?id (signature ?sig)))))
110				      (else id)))
111				   (syntax->list #'(?id ...))))
112			     (?rest (loop (cdr exprs))))
113		 (with-syntax ((?defn
114				(syntax-track-origin
115				 #'(define-values/signature (?enforced ...)
116				     ?e1)
117				 (car exprs)
118				 (car (syntax-e expanded)))))
119
120		   (syntax/loc (car exprs)
121			       (begin
122				 ?defn
123				 ?rest)))))
124	      ((begin e1 ...)
125	       (loop (append (syntax-e (syntax (e1 ...))) (cdr exprs))))
126	      (else
127	       (with-syntax ((?first expanded)
128			     (?rest (loop (cdr exprs))))
129		 (syntax/loc (car exprs)
130			     (begin
131			       ?first ?rest))))))))))
132
133    (define (mk-module-begin options)
134      (lambda (stx)
135        (syntax-case stx ()
136          ((_ e1 ...)
137           ;; module-begin-continue takes a sequence of expanded
138           ;; exprs and a sequence of to-expand exprs; that way,
139           ;; the module-expansion machinery can be used to handle
140           ;; requires, etc.:
141           #`(#%plain-module-begin
142              (module-continue (e1 ...) () ())
143              (module configure-runtime racket/base
144                (require deinprogramm/sdp/private/runtime)
145                (configure '#,options))
146              (module+ test (test)))))))
147
148    (values
149     (mk-module-begin 'beginner)
150     (mk-module-begin 'vanilla)
151     (mk-module-begin 'advanced)
152
153     ;; module-continue
154     (lambda (stx)
155       (syntax-case stx ()
156	 ((_ () (e1 ...) (defined-id ...))
157	  ;; Local-expanded all body elements, lifted out requires, etc.
158	  ;; Now process the result.
159	  (begin
160	    ;; The expansion for signatures breaks the way that beginner-define, etc.,
161	    ;;  check for duplicate definitions, so we have to re-check here.
162	    ;; A better strategy might be to turn every define into a define-syntax
163	    ;;  to redirect the binding, and then the identifier-binding check in
164	    ;;  beginner-define, etc. will work.
165	    (let ((defined-ids (make-bound-identifier-mapping)))
166	      (for-each (lambda (id)
167			  (when (bound-identifier-mapping-get defined-ids id (lambda () #f))
168			    (raise-syntax-error
169			     #f
170			     "Für diesen Namen gibt es schon eine Definition."
171			     id))
172			  (bound-identifier-mapping-put! defined-ids id #t))
173			(reverse (syntax->list #'(defined-id ...)))))
174	    ;; Now handle signatures:
175	    (let ((top-level (reverse (syntax->list (syntax (e1 ...))))))
176	      (let-values (((sig-table expr-list)
177			    (extract-signatures top-level)))
178		(expand-signature-expressions sig-table expr-list)))))
179	 ((frm e3s e1s def-ids)
180	  (let loop ((e3s #'e3s)
181		     (e1s #'e1s)
182		     (def-ids #'def-ids))
183	    (syntax-case e3s ()
184	      (()
185	       #`(frm () #,e1s #,def-ids))
186	      ((e2 . e3s)
187	       (let ((e2 (local-expand #'e2 'module local-expand-stop-list)))
188		 ;; Lift out certain forms to make them visible to the module
189		 ;;  expander:
190		 (syntax-case e2 (#%require #%provide #%declare
191				  define-syntaxes begin-for-syntax define-values begin
192                                  :)
193		   ((#%require . __)
194		    #`(begin #,e2 (frm e3s #,e1s #,def-ids)))
195		   ((#%provide . __)
196		    #`(begin #,e2 (frm e3s #,e1s #,def-ids)))
197		   ((#%declare . __)
198		    #`(begin #,e2 (frm e3s #,e1s #,def-ids)))
199		   ((define-syntaxes (id ...) . _)
200		    #`(begin #,e2 (frm e3s #,e1s (id ... . #,def-ids))))
201		   ((begin-for-syntax . _)
202		    #`(begin #,e2 (frm e3s #,e1s #,def-ids)))
203		   ((begin b1 ...)
204		    (syntax-track-origin
205		     (loop (append (syntax->list #'(b1 ...)) #'e3s) e1s def-ids)
206		     e2
207		     (car (syntax-e e2))))
208		   ((define-values (id ...) . _)
209		    (loop #'e3s (cons e2 e1s) (append (syntax->list #'(id ...)) def-ids)))
210		   ((: stuff ...)
211		    (loop #'e3s (cons e2 e1s) def-ids))
212		   (_
213		    (loop #'e3s (cons #`(print-results #,e2) e1s) def-ids)))))))))))))
214