(module docprovide mzscheme
  (require-for-syntax "private/doctable.ss")

  (define-syntaxes (provide-and-document provide-and-document/wrap)
    (let ()
      (define (add-prefix prefix rows)
	(map (lambda (row)
	       (cons (car row)
		     (map
		      (lambda (x) 
			(cons prefix x))
		      (cdr row))))
	     rows))

      (define (remove-prefixes rows)
	(map (lambda (row)
	       (cons (car row)
		     (map (lambda (proc)
			    (let ([rest (cdr proc)])
			      (if (pair? (car rest))
				  (cons (cadar rest)
					(cdr rest))
				  rest)))
			  (cdr row))))
	     rows))

      (define (remove-docs rows exceptions)
	(map (lambda (row)
	       (cons (car row)
		     (let loop ([l (cdr row)])
		       (cond
			[(null? l) null]
			[(memq (let ([i (cadar l)])
				 (if (symbol? i)
				     i
				     (cadr i)))
			       exceptions)
			 (loop (cdr l))]
			[else (cons (car l) (loop (cdr l)))]))))
	     rows))

      (define (go stx label wrap rows)
	(unless (identifier? label)
		(raise-syntax-error
		 'provide-and-document
		 "label is not an identifier"
		 stx
		 label))
	(when wrap
	      (unless (identifier? wrap)
		      (raise-syntax-error
		       'provide-and-document
		       "wrap is not an identifier"
		       stx
		       wrap)))
	(let ([rows (map (lambda (row)
			   ;; Helper:
			   (define (get-existing tag path label exceptions)
			     (unless (identifier? tag)
				     (raise-syntax-error
				      'provide-and-document
				      "prefix tag is not an identifier"
				      stx
				      tag))
			     (unless (identifier? label)
				     (raise-syntax-error
				      'provide-and-document
				      "label is not an identifier"
				      stx
				      label))
			     (for-each
			      (lambda (except)
				(unless (identifier? except)
					(raise-syntax-error
					 'provide-and-document
					 "exclusion is not an identifier"
					 stx
					 except)))
			      exceptions)
			     (let ([mod ((current-module-name-resolver) path #f #f)])
			       ;; Execute syntax part at top-level:
			       (dynamic-require mod (void))
			       ;; Extract documentation via top-level:
			       (let ([docs ((dynamic-require-for-syntax 
					     '(lib "doctable.ss" "syntax" "private") 
					     'lookup-documentation)
					    mod
					    (syntax-e label))])
				 (unless docs
					 (raise-syntax-error
					  'provide-and-document
					  "could not find provided documentation"
					  stx
					  row))
				 (remove-docs (add-prefix tag docs)
					      (map syntax-e exceptions)))))
			   ;; Parse row:
			   (syntax-case row ()
					[(header proc ...)
					 (string? (syntax-e (syntax header)))
					 (begin
					   ;; check form:
					   (map (lambda (proc)
						  (syntax-case proc ()
							       [(name type-sexpr doc-string ...)
								(and (or (identifier? (syntax name))
									 (let ([l (syntax->list (syntax name))])
									   (and l
										(= (length l) 2)
										(andmap identifier? l))))
								     (andmap (lambda (s) (string? (syntax-e s)))
									     (syntax->list (syntax (doc-string ...)))))
								'ok]))
						(syntax->list (syntax (proc ...))))
					   (add-prefix #f (list (syntax-object->datum row))))]
					[(all-from tag path label)
					 (eq? 'all-from (syntax-e (syntax all-from)))
					 (let ([tag (syntax tag)]
					       [label (syntax label)]
					       [path (syntax-object->datum (syntax path))])
					   (get-existing tag path label null))]
					[(all-from-except tag path label exception ...)
					 (eq? 'all-from-except (syntax-e (syntax all-from-except)))
					 (let ([tag (syntax tag)]
					       [label (syntax label)]
					       [path (syntax-object->datum (syntax path))]
					       [exceptions (syntax->list (syntax (exception ...)))])
					   (get-existing tag path label exceptions))]))
			 rows)]
	      [imports (apply
			append
			(map (lambda (row)
			       (syntax-case row ()
					    [(header . _)
					     (string? (syntax-e (syntax header)))
					     null]
					    [(all-from/-except tag path label except ...)
					     (list (with-syntax ([pf (datum->syntax-object
								      stx
								      (syntax-e
								       (syntax (prefix tag path))))])
						     (syntax (require pf))))]))
			     rows))])
	  ;; Collapse rows for a section name:
	  (let ([rows (let loop ([rows (apply append rows)])
			(if (null? rows)
			    null
			    (let ([rest (loop (cdr rows))])
			      (let ([a (assoc (caar rows) rest)])
				(if a
				    (cons (cons (caar rows)
						(append (cdar rows)
							(cdr a)))
					  (let loop ([l rest])
					    (cond
					     [(null? l) null]
					     [(equal? (caar l) (caar rows))
					      (cdr l)]
					     [else (cons (car l) (loop (cdr l)))])))
				    (cons (car rows) rest))))))])
	    ;; Extract procs and eliminate duplicates
	    (let ([procs (let ([ht (make-hash-table)])
			   (for-each
			    (lambda (proc-line)
			      (let-values ([(loc-name ext-name)
					    (let ([n (cadr proc-line)])
					      (if (pair? n)
						  (values (car n) (cadr n))
						  (values n n)))])
					  (hash-table-put! ht ext-name (list* (car proc-line)
									      loc-name
									      ext-name))))
			    (apply append (map cdr rows)))
			   (hash-table-map ht (lambda (key val) val)))])
	      (let ([names (map (lambda (proc)
				  (cond
				   [(car proc)
				    ;; Source prefixed:
				    `(rename ,(string->symbol (format "~a~a" 
								      (syntax-e (car proc))
								      (cadr proc)))
					     ,(cadr proc))]
				   [(eq? (cadr proc) (cddr proc))
				    ;; Plain
				    (cadr proc)]
				   [else
				    ;; Local renamed:
				    `(rename ,(cadr proc)
					     ,(cddr proc))]))
				procs)]
		    [wrapped-name
		     (lambda (name)
		       (string->symbol (format "~a>>~a" 
					       (syntax-e wrap)
					       (if (pair? name)
						   (cadr name)
						   name))))])
		(with-syntax ([procs (if wrap
					 (map (lambda (name)
						`(rename 
						  ,(wrapped-name name)
						  ,(if (pair? name)
						       (caddr name)
						       name)))
					      names)
					 names)]
			      [(wrap ...) (if wrap
					      (map (lambda (name)
						     `(,wrap ,(datum->syntax-object
							       wrap
							       (wrapped-name name))
							     ,(datum->syntax-object
							       wrap
							       (if (pair? name)
								   (cadr name)
								   name))))
						   names)
					      null)]
			      [(import ...) imports]
			      [src (datum->syntax-object stx 'source)]
			      [rows (remove-prefixes rows)]
			      [label label])
		(syntax/loc stx
			    (begin
			      import ...
			      wrap ...
			      (provide . procs)
			      (define-syntaxes ()
				(begin
				  (register-documentation (quote-syntax src) 'label 'rows)
				  (values)))))))))))

      (values
       (lambda (stx)
	 (syntax-case stx ()
		      [(_ label row ...)
		       (go stx
			   (syntax label)
			   #f
			   (syntax->list (syntax (row ...))))]))
       (lambda (stx)
	 (syntax-case stx ()
		      [(_ label wrap row ...)
		       (go stx
			   (syntax label)
			   (let ([s (syntax wrap)])
			     (and (syntax-e s) s))
			   (syntax->list (syntax (row ...))))])))))


  (define (lookup-documentation path label)
    (let ([mod ((current-module-name-resolver) path #f #f)])
      (dynamic-require mod (void))
      ((dynamic-require-for-syntax 
	'(lib "doctable.ss" "syntax" "private")
	'lookup-documentation)
       mod
       label)))
       
  (provide provide-and-document
	   provide-and-document/wrap
	   lookup-documentation))