#lang scheme/base
;; Forked from scribble-lib/scribble/private/lp.rkt

(require (for-syntax scheme/base syntax/boundmap)
         scribble/scheme scribble/decode scribble/manual scribble/struct)

(begin-for-syntax
  ;; maps chunk identifiers to a counter, so we can distinguish multiple uses
  ;; of the same name
  (define chunk-numbers (make-free-identifier-mapping))
  (define (get-chunk-number id)
    (free-identifier-mapping-get chunk-numbers id (lambda () #f)))
  (define (inc-chunk-number id)
    (free-identifier-mapping-put! chunk-numbers id (+ 1 (free-identifier-mapping-get chunk-numbers id))))
  (define (init-chunk-number id)
    (free-identifier-mapping-put! chunk-numbers id 2)))

(define-for-syntax ((make-chunk racketblock) stx)
  (syntax-case stx ()
    [(_ name expr ...)
     ;; no need for more error checking, using chunk for the code will do that
     (identifier? #'name)
     (let* ([n (get-chunk-number (syntax-local-introduce #'name))]
            [str (symbol->string (syntax-e #'name))]
            [tag (format "~a:~a" str (or n 1))])
     
       (when n
         (inc-chunk-number (syntax-local-introduce #'name)))
       
       (syntax-local-lift-expression #'(quote-syntax (a-chunk name expr ...)))
       
       (with-syntax ([tag tag]
                     [str str]
                     [((for-label-mod ...) ...)
                      (map (lambda (expr)
                             (syntax-case expr (require)
                               [(require mod ...)
                                (let loop ([mods (syntax->list #'(mod ...))])
                                  (cond
                                    [(null? mods) null]
                                    [else
                                     (syntax-case (car mods)
                                         (for-syntax quote submod)
                                       [(submod ".." . _)
                                        (loop (cdr mods))]
                                       [(submod "." . _)
                                        (loop (cdr mods))]
                                       [(quote x)
                                        (loop (cdr mods))]
                                       [(for-syntax x ...)
                                        (append (loop (syntax->list #'(x ...)))
                                                (loop (cdr mods)))]
                                       [x
                                        (cons #'x (loop (cdr mods)))])]))]
                               [else null]))
                           (syntax->list #'(expr ...)))]
                     
                     [(rest ...) (if n
                                           #`((subscript #,(format "~a" n)))
                                           #`())])
         #`(begin
             (require (for-label for-label-mod ... ...))
             #,@(if n
                    #'()
                    #'((define-syntax name (make-element-id-transformer
                                            (lambda (stx) #'(chunkref name))))
                       (begin-for-syntax (init-chunk-number #'name))))
             (make-splice
              (list (make-toc-element
                     #f
                     (list (elemtag '(chunk (prefixable tag))
                                    (bold (italic (racket name)) " ::=")))
                     (list (smaller (elemref '(chunk (prefixable tag)) #:underline? #f
                                             str
                                             rest ...))))
                    (#,racketblock expr ...))))))]))

(define-syntax chunk (make-chunk #'racketblock))
(define-syntax CHUNK (make-chunk #'RACKETBLOCK))

(define-syntax (chunkref stx)
  (syntax-case stx ()
    [(_ id)
     (identifier? #'id)
     (with-syntax ([tag (format "~a:1" (syntax-e #'id))]
                   [str (format "~a" (syntax-e #'id))])
       #'(elemref '(chunk (prefixable tag)) #:underline? #f str))]))


(provide (all-from-out scheme/base
                       scribble/manual)
         chunk CHUNK)