#lang scheme/base
(require "../decode.rkt"
         "../struct.rkt"
         "../basic.rkt"
         "../manual-struct.rkt"
         (only-in "../core.rkt" table-columns)
         "manual-ex.rkt"
         "manual-style.rkt"
         "manual-scheme.rkt"
         "manual-utils.rkt"
         setup/main-collects
         pkg/path
         racket/list
         (for-syntax scheme/base
                     syntax/parse)
         (for-label scheme/base))

(provide defmodule defmodule* 
         defmodulelang defmodulelang* 
         defmodulereader defmodulereader*
         defmodule*/no-declare defmodulelang*/no-declare defmodulereader*/no-declare
         declare-exporting)

;; ---------------------------------------------------------------------------------------------------
(provide deprecated)

(require (only-in scribble/core make-style make-background-color-property)
         (only-in scribble/base para nested))

;; @deprecated[Precontent]{Precontent ... }
;; produces a nested paragraph with a yellow NOTE label to warn readers of deprecated modules 
(define (deprecated #:what [what "library"]
                    replacement
                    . additional-notes)
  (apply nested #:style 'inset
         (yellow (bold "NOTE:"))
         " This " what
         " is deprecated; use "
         replacement
         ", instead. "
         additional-notes))

(define (yellow . content)
  (make-element (make-style #f (list (make-background-color-property "yellow"))) content))
;; ---------------------------------------------------------------------------------------------------

(define-syntax (defmodule stx)
  (syntax-parse stx
    [(_ (~or (~seq #:require-form req)
             (~seq))
        (~or (~seq #:multi (name2 ...))
             name)
        (~or (~optional (~seq #:link-target? link-target-expr)
                        #:defaults ([link-target-expr #'#t]))
             (~optional (~and #:indirect indirect))
             (~optional (~seq #:use-sources (pname ...)))
             (~optional (~seq #:module-paths (modpath ...)))
             (~optional (~seq #:packages (pkg ...)))
             (~optional (~and #:no-declare no-declare))
             (~optional (~or (~and #:lang language)
                             (~and #:reader readr))))
        ...
        . content)
     (with-syntax ([(name2 ...) (if (attribute name)
                                    #'(name)
                                    #'(name2 ...))]
                   [(pname ...) (if (attribute pname)
                                    #'(pname ...)
                                    #'())]
                   [(indirect-kw ...) (if (attribute indirect)
                                          #'(#:indirect)
                                          #'())])
       (with-syntax ([(decl-exp ...)
                      (if (attribute no-declare)
                          #'()
                          (with-syntax ([(mod ...)
                                         (if (attribute modpath)
                                             #'(modpath ...)
                                             #'(name2 ...))]
                                        [(pkg-decl ...)
                                         (if (attribute pkg)
                                             #'(#:packages (pkg ...))
                                             #'())])
                            #'((declare-exporting mod ... pkg-decl ... #:use-sources (pname ...)))))]
                     [kind (cond
                            [(attribute language) #'#t]
                            [(attribute readr) #''reader]
                            [else #'#f])]
                     [modpaths (if (attribute modpath)
                                   #'(list (racketmodname modpath indirect-kw ...) ...)
                                   #'#f)]
                     [packages (if (attribute pkg)
                                   #'(list pkg ...)
                                   #'#f)]
                     [module-path (let ([l (syntax->list 
                                            (if (attribute modpath)
                                                #'(modpath ...)
                                                #'(name2 ...)))])
                                    (and (pair? l)
                                         (car l)))]
                     [req (if (attribute req)
                              #'req
                              #'(racket require))]
                     [(show-name ...)
                      (if (attribute modpath)
                          #'(name2 ...)
                          #'((racketmodname name2 indirect-kw ...) ...))])
         #'(begin
             decl-exp ...
             (*defmodule (list show-name ...)
                         modpaths
                         'module-path
                         packages
                         link-target-expr
                         kind
                         (list . content)
                         req))))]))

;; ----------------------------------------
;; old forms for backward compatibility:

(define-syntax defmodule*/no-declare
  (syntax-rules ()
    [(_ #:require-form req (name ...) . content)
     (defmodule #:require-form req
       #:names (name ...)
       #:no-declare
       . content)]
    [(_ (name ...) . content)
     (defmodule #:multi (name ...)
       #:no-declare
       . content)]))

(define-syntax defmodule*
  (syntax-rules ()
    [(_ #:require-form req (name ...) . options+content)
     (defmodule #:require-form req #:multi (name ...)
       . options+content)]
    [(_ (name ...) . options+content)
     (defmodule #:multi (name ...) . options+content)]))

(define-syntax defmodulelang*/no-declare
  (syntax-rules ()
    [(_ (lang ...) . options+content)
     (defmodule #:multi (lang ...)
       #:lang
       #:no-declare
       . options+content)]))

(define-syntax defmodulelang*
  (syntax-rules ()
    [(_ (name ...) . options+content)
     (defmodule #:multi (name ...)
       #:lang
       . options+content)]))

(define-syntax defmodulelang
  (syntax-rules ()
    [(_ lang #:module-path modpath . options+content)
     (defmodule lang
       #:module-paths (modpath)
       #:lang
       . options+content)]
    [(_ lang . options+content)
     (defmodule lang
       #:lang
       . options+content)]))

(define-syntax-rule (defmodulereader*/no-declare (lang ...) . options+content)
  (defmodule #:multi (lang ...)
    #:reader
    #:no-declare
    . options+content))

(define-syntax defmodulereader*
  (syntax-rules ()
    [(_ (name ...) . options+content)
     (defmodule #:multi (name ...)
       #:reader
       . options+content)]))

(define-syntax-rule (defmodulereader lang . options+content)
  (defmodule lang
    #:reader
    . options+content))

;; ----------------------------------------

(define (compute-packages module-path)
  (let* ([path (with-handlers ([exn:missing-module? (lambda (exn) #f)])
                 (and module-path
                      (resolved-module-path-name
                       (module-path-index-resolve (module-path-index-join module-path #f)))))]
         [pkg (and path
                   (path? path)
                   (or (path->pkg path)
                       (let ([c (path->main-collects-relative path)])
                         (and c
                              "base"))))])
    (if pkg
        (list pkg)
        null)))

(define (*defmodule names modpaths module-path packages link-target? lang content req)
  (let ([modpaths (or modpaths names)])
    (define pkg-spec
      (let ([pkgs (or packages
                      (compute-packages module-path))])
        (and pkgs
             (pair? pkgs)
             (make-flow
              (list
               (make-omitable-paragraph
                (list (elem #:style "RpackageSpec"
                            (list* (smaller 'nbsp
                                            (format "package~a:" 
                                                    (if (null? (cdr pkgs))
                                                        ""
                                                        "s")))
                                   " "
                                   (add-between (map tt pkgs) ", "))))))))))
    (define (flow-width f) (apply max (map block-width f)))
    (define libs-specs
      ;; make-desc  : element -> flow
      ;; index-desc : module-path-index-desc
      (let-values ([(make-desc index-desc)
                    (case lang
                      [(#f)
                       (values (lambda (modname) (list (racket (#,req #,modname))))
                               the-module-path-index-desc)]
                      [(#t)
                       (values (lambda (modname) (list (hash-lang) spacer modname))
                               the-language-index-desc)]
                      [(reader)
                       (values (lambda (modname) (list (racketmetafont "#reader") spacer modname))
                               the-reader-index-desc)]
                      [(just-lang)
                       (values (lambda (modname) (list (hash-lang) spacer modname))
                               the-language-index-desc)]
                      [else (error 'defmodule "unknown mode: ~e" lang)])])
      (map
       (lambda (name modpath)
         (define modname (if link-target?
                             (make-defracketmodname name modpath index-desc)
                             name))
         (list
          (make-flow
           (list
            (make-omitable-paragraph
             (cons spacer (make-desc modname)))))
          'cont))
       names
       modpaths)))

    (make-splice
     (cons
      (make-table
       (make-style "defmodule"
                   (list (table-columns (list
                                         (make-style #f '(left))
                                         (make-style #f '(right))))))
       (if pkg-spec
           (if ((+ (flow-width (caar libs-specs))
                   (flow-width pkg-spec)
                   8)
                . < . (current-display-width))
               (cons
                (cons (car (car libs-specs))
                      (list pkg-spec))
                (cdr libs-specs))
               (append
                libs-specs
                (list (list (make-flow (list (make-omitable-paragraph (list 'nbsp))))
                            pkg-spec))))
           libs-specs))
      (append (if link-target?
                  (map (lambda (modpath)
                         (make-part-tag-decl 
                          (intern-taglet
                           `(mod-path ,(datum-intern-literal
                                        (element->string modpath))))))
                       modpaths)
                  null)
              (flow-paragraphs (decode-flow content)))))))

(define the-module-path-index-desc (make-module-path-index-desc))
(define the-language-index-desc (make-language-index-desc))
(define the-reader-index-desc (make-reader-index-desc))

(define (make-defracketmodname mn mp index-desc)
  (let ([name-str (datum-intern-literal (element->string mn))]
        [path-str (datum-intern-literal (element->string mp))])
    (make-index-element #f
                        (list mn)
                        (intern-taglet `(mod-path ,path-str))
                        (list name-str)
                        (list mn)
                        index-desc)))

(define-syntax (declare-exporting stx)
  (syntax-parse stx
    [(_ lib:expr ... 
        (~optional (~seq #:packages (pkg ...)))
        (~optional (~seq #:use-sources (plib ...))))
     (with-syntax ([(plib ...) (if (attribute plib)
                                   #'(plib ...)
                                   #'())]
                   [packages (if (attribute pkg)
                                 #'(list pkg ...)
                                 #'#f)])
       (let ([libs (syntax->list #'(lib ... plib ...))])
         (for ([l libs])
           (unless (or (syntax-case l (unquote)
                         [(unquote _) #t]
                         [_ #f])
                       (module-path? (syntax->datum l)))
             (raise-syntax-error #f "not a module path" stx l)))
         (when (null? libs)
           (raise-syntax-error #f "need at least one module path" stx))
         #'(*declare-exporting `(lib ...) `(plib ...) packages)))]))

(define (*declare-exporting libs source-libs in-pkgs)
  (define pkgs (or in-pkgs
                   (if (null? libs)
                       null
                       (compute-packages (car libs)))))
  (make-splice
   (list
    (make-part-collect-decl
     (make-collect-element
      #f null
      (lambda (ri)
        (collect-put! ri '(exporting-libraries #f) libs)
        (collect-put! ri '(exporting-packages #f) pkgs))))
    (make-part-collect-decl
     (make-exporting-libraries #f null (and (pair? libs) libs) source-libs pkgs)))))