#lang racket/base

(provide beginner-module-begin vanilla-module-begin advanced-module-begin)

(require deinprogramm/signature/signature
	 deinprogramm/signature/signature-syntax)

(require (for-syntax racket/base)
	 (for-syntax racket/list)
	 (for-syntax syntax/boundmap)
	 (for-syntax syntax/id-table)
	 (for-syntax syntax/kerncase)
	 (for-syntax racket/struct-info)
         (for-syntax stepper/private/syntax-property))

(require (only-in test-engine/syntax test test-display-results!))

(define-syntax (print-results stx)
  (syntax-case stx ()
    ((_ expr)
     (not (or (syntax-property #'expr 'stepper-hide-completed)
	      (syntax-property #'expr 'stepper-skip-completely)
	      (syntax-property #'expr 'test-call)))
     (syntax-property
      (syntax-property
       #'(#%app call-with-values (lambda () expr)
		do-print-results)
       'stepper-skipto 
       '(syntax-e cdr cdr car syntax-e cdr cdr car))
      'certify-mode
      'transparent))
    ((_ expr) #'expr)))

(define (do-print-results . vs)
  (for-each (current-print) vs)
  ;; Returning 0 values avoids any further result printing
  ;; (even if void values are printed)
  (values))
  
(define-syntaxes (beginner-module-begin vanilla-module-begin advanced-module-begin module-continue)
  (let ()
    ;; takes a list of syntax objects (the result of syntax-e) and returns all the syntax objects that correspond to
    ;; a signature declaration. Syntax: (: id signature)
    (define extract-signatures
      (lambda (lostx) 
	(let* ((table (make-free-id-table)) ; bound doesn't work as we need to match signature declarations and definitions
               (ids '())
	       (non-signatures
		(filter-map (lambda (maybe)
			      (syntax-case maybe (:)
				((: ?exp ?sig)
				 (not (identifier? #'?exp))
				 #'(apply-signature/blame (signature ?sig) ?exp))
				((: ?id ?sig)
				 (begin
				   (cond
				    ((free-id-table-ref table #'?id #f)
				     => (lambda (old-sig-stx)
					  (unless (equal? (syntax->datum old-sig-stx)
							  (syntax->datum #'?sig))
					    (raise-syntax-error #f
								"Zweite Signaturdeklaration für denselben Namen."
								maybe))))
				    (else
				     (let ((si (syntax-local-value #'?id (lambda () #f))))
				       (if (and (struct-info? si)
						(procedure? si)) ; record constructor, just a macro
                                           (syntax-case (si #'?id) ()
                                             ; the #%expression is generated by define-singleton and define-record
                                             ((#%expression ?real-id) 
                                              (identifier? #'?real-id)
                                              (free-id-table-set! table #'?real-id #'?sig))
                                             (?real-id
                                              (identifier? #'?real-id)
                                              (free-id-table-set! table #'?real-id #'?sig)))
                                           (free-id-table-set! table #'?id #'?sig)))))
                                   (set! ids (cons #'?id ids))
				   #f))
				((: ?id)
				 (raise-syntax-error #f "Bei dieser Signaturdeklaration fehlt die Signatur" maybe))
				((: ?id ?sig ?stuff0 ?stuff1 ...)
				 (raise-syntax-error #f "In der :-Form werden ein Name und eine Signatur erwartet; da steht noch mehr"
						     (syntax/loc #'?stuff0
								 (?stuff0 ?stuff1 ...))))
				(_ maybe)))
			lostx)))
	  (values table ids non-signatures))))

    (define local-expand-stop-list 
      (append (list #': #'define-contract)
	      (kernel-form-identifier-list)))
	
    (define (expand-signature-expressions signature-table expressions)
      (let ((signature-table signature-table))

        (let loop ((exprs expressions))

          (cond
            ((null? exprs)
             ; check for orphaned signatures
             (free-id-table-for-each signature-table
                                     (lambda (id thing)
                                       (if (identifier-binding id)
                                           (raise-syntax-error #f "Zu einer eingebauten Form kann keine Signatur deklariert werden" id)
                                           (raise-syntax-error #f "Zu dieser Signatur gibt es keine Definition" id))))
             #'(begin))
            (else
             (let ((expanded (car exprs)))

               (syntax-case expanded (begin define-values)
                 ((define-values (?id ...) ?e1)
                  (with-syntax (((?enforced ...)
                                 (map (lambda (id)
                                        (cond
                                          ((free-id-table-ref signature-table id #f)
                                           => (lambda (sig)
                                                (free-id-table-remove! signature-table id) ; enables the check for orphaned signatures
                                                (with-syntax ((?id id)
                                                              (?sig sig))
                                                  #'(?id (signature ?sig)))))
                                          (else id)))
                                      (syntax->list #'(?id ...))))
                                (?rest (loop (cdr exprs))))
                    (with-syntax ((?defn
                                   (syntax-track-origin
                                    #'(define-values/signature (?enforced ...)
                                        ?e1)
                                    (car exprs)
                                    (car (syntax-e expanded)))))

                      (syntax/loc (car exprs)
                        (begin
                          ?defn
                          ?rest)))))
                 ((begin e1 ...)
                  (loop (append (syntax-e (syntax (e1 ...))) (cdr exprs))))
                 (else 
                  (with-syntax ((?first expanded)
                                (?rest (loop (cdr exprs))))
                    (syntax/loc (car exprs)
                      (begin
                        ?first ?rest)))))))))))

    ; these dummy uses are so that DrRacket can display binding arrows correctly
    (define (signature-id-dummy-uses ids)
      #`(begin
          #,@(map (lambda (id)
                    (stepper-syntax-property #`(begin #,id (void))
                                             'stepper-skip-completely 
                                             #t))
                  ids)))

    (define (mk-module-begin options)
      (lambda (stx)
        (syntax-case stx ()
          ((_ e1 ...)
           ;; module-begin-continue takes a sequence of expanded
           ;; exprs and a sequence of to-expand exprs; that way,
           ;; the module-expansion machinery can be used to handle
           ;; requires, etc.:
           #`(#%plain-module-begin
              #,(stepper-syntax-property
                 #`(begin
                     (define repl? #f) ; whether we're in the REPL now
                     (let ((handle (uncaught-exception-handler)))
                       (uncaught-exception-handler
                        (lambda (exn)
                          (begin
                            (unless repl? ; the REPL takes care of printing the results itself
                              (test-display-results!))
                            (set! repl? #t)
                            (handle exn))))))
                 'stepper-skip-completely 
                 #t)
              (module-continue (e1 ...) () ())
              (module configure-runtime racket/base
                (require deinprogramm/sdp/private/runtime)
                (configure '#,options))
              (module+ test
                (test))
              #,(stepper-syntax-property
                 #`(set! repl? #t)
                 'stepper-skip-completely 
                 #t))))))
    
    (values
     (mk-module-begin 'beginner)
     (mk-module-begin 'vanilla)
     (mk-module-begin 'advanced)

     ;; module-continue
     (lambda (stx)
       (syntax-case stx ()
	 ((_ () (e1 ...) (defined-id ...))
	  ;; Local-expanded all body elements, lifted out requires, etc.
	  ;; Now process the result.
	  (begin
	    ;; The expansion for signatures breaks the way that beginner-define, etc.,
	    ;;  check for duplicate definitions, so we have to re-check here.
	    ;; A better strategy might be to turn every define into a define-syntax
	    ;;  to redirect the binding, and then the identifier-binding check in
	    ;;  beginner-define, etc. will work.
	    (let ((defined-ids (make-bound-identifier-mapping)))
	      (for-each (lambda (id)
			  (when (bound-identifier-mapping-get defined-ids id (lambda () #f))
			    (raise-syntax-error
			     #f
			     "Für diesen Namen gibt es schon eine Definition."
			     id))
			  (bound-identifier-mapping-put! defined-ids id #t))
			(reverse (syntax->list #'(defined-id ...)))))
	    ;; Now handle signatures:
	    (let ((top-level (reverse (syntax->list (syntax (e1 ...))))))
	      (let-values (((sig-table ids expr-list)
			    (extract-signatures top-level)))
                #`(begin
                    #,(expand-signature-expressions sig-table expr-list)
                    #,(signature-id-dummy-uses ids))))))
	 ((frm e3s e1s def-ids)
	  (let loop ((e3s #'e3s)
		     (e1s #'e1s)
		     (def-ids #'def-ids))
	    (syntax-case e3s ()
	      (()
	       #`(frm () #,e1s #,def-ids))
	      ((e2 . e3s)
	       (let ((e2 (local-expand #'e2 'module local-expand-stop-list)))
		 ;; Lift out certain forms to make them visible to the module
		 ;;  expander:
		 (syntax-case e2 (#%require #%provide #%declare
				  define-syntaxes begin-for-syntax define-values begin
                                  :)
		   ((#%require . __)
		    #`(begin #,e2 (frm e3s #,e1s #,def-ids)))
		   ((#%provide . __)
		    #`(begin #,e2 (frm e3s #,e1s #,def-ids)))
		   ((#%declare . __)
		    #`(begin #,e2 (frm e3s #,e1s #,def-ids)))
		   ((define-syntaxes (id ...) . _)
		    #`(begin #,e2 (frm e3s #,e1s (id ... . #,def-ids))))
		   ((begin-for-syntax . _)
		    #`(begin #,e2 (frm e3s #,e1s #,def-ids)))
		   ((begin b1 ...)
		    (syntax-track-origin 
		     (loop (append (syntax->list #'(b1 ...)) #'e3s) e1s def-ids)
		     e2
		     (car (syntax-e e2))))
		   ((define-values (id ...) . _)
		    (loop #'e3s (cons e2 e1s) (append (syntax->list #'(id ...)) def-ids)))
		   ((: stuff ...)
		    (loop #'e3s (cons e2 e1s) def-ids))
		   (_
		    (loop #'e3s (cons #`(print-results #,e2) e1s) def-ids)))))))))))))
