manual-mod.rkt (13699B)
1 #lang scheme/base 2 (require "../decode.rkt" 3 "../struct.rkt" 4 "../basic.rkt" 5 "../manual-struct.rkt" 6 (only-in "../core.rkt" table-columns) 7 "manual-ex.rkt" 8 "manual-style.rkt" 9 "manual-scheme.rkt" 10 "manual-utils.rkt" 11 setup/main-collects 12 pkg/path 13 racket/list 14 scribble/html-properties 15 (for-syntax scheme/base 16 syntax/parse) 17 (for-label scheme/base)) 18 19 (provide defmodule defmodule* 20 defmodulelang defmodulelang* 21 defmodulereader defmodulereader* 22 defmodule*/no-declare defmodulelang*/no-declare defmodulereader*/no-declare 23 declare-exporting) 24 25 ;; --------------------------------------------------------------------------------------------------- 26 (provide deprecated) 27 28 (require (only-in scribble/core make-style make-background-color-property) 29 (only-in scribble/base para nested)) 30 31 ;; @deprecated[Precontent]{Precontent ... } 32 ;; produces a nested paragraph with a yellow NOTE label to warn readers of deprecated modules 33 (define (deprecated #:what [what "library"] 34 replacement 35 . additional-notes) 36 (apply nested #:style 'inset 37 (yellow (bold "NOTE:")) 38 " This " what 39 " is deprecated; use " 40 replacement 41 ", instead. " 42 additional-notes)) 43 44 (define (yellow . content) 45 (make-element (make-style #f (list (make-background-color-property "yellow"))) content)) 46 ;; --------------------------------------------------------------------------------------------------- 47 48 (define-syntax (defmodule stx) 49 (syntax-parse stx 50 [(_ (~or (~seq #:require-form req) 51 (~seq)) 52 (~or (~seq #:multi (name2 ...)) 53 name) 54 (~or (~optional (~seq #:link-target? link-target-expr) 55 #:defaults ([link-target-expr #'#t])) 56 (~optional (~and #:indirect indirect)) 57 (~optional (~seq #:use-sources (pname ...))) 58 (~optional (~seq #:module-paths (modpath ...))) 59 (~optional (~seq #:packages (pkg ...))) 60 (~optional (~and #:no-declare no-declare)) 61 (~optional (~or (~and #:lang language) 62 (~and #:reader readr)))) 63 ... 64 . content) 65 (with-syntax ([(name2 ...) (if (attribute name) 66 #'(name) 67 #'(name2 ...))] 68 [(pname ...) (if (attribute pname) 69 #'(pname ...) 70 #'())] 71 [(indirect-kw ...) (if (attribute indirect) 72 #'(#:indirect) 73 #'())]) 74 (with-syntax ([(decl-exp ...) 75 (if (attribute no-declare) 76 #'() 77 (with-syntax ([(mod ...) 78 (if (attribute modpath) 79 #'(modpath ...) 80 #'(name2 ...))] 81 [(pkg-decl ...) 82 (if (attribute pkg) 83 #'(#:packages (pkg ...)) 84 #'())]) 85 #'((declare-exporting mod ... pkg-decl ... #:use-sources (pname ...)))))] 86 [kind (cond 87 [(attribute language) #'#t] 88 [(attribute readr) #''reader] 89 [else #'#f])] 90 [modpaths (if (attribute modpath) 91 #'(list (racketmodname modpath indirect-kw ...) ...) 92 #'#f)] 93 [packages (if (attribute pkg) 94 #'(list pkg ...) 95 #'#f)] 96 [module-path (let ([l (syntax->list 97 (if (attribute modpath) 98 #'(modpath ...) 99 #'(name2 ...)))]) 100 (and (pair? l) 101 (car l)))] 102 [req (if (attribute req) 103 #'req 104 #'(racket require))] 105 [(show-name ...) 106 (if (attribute modpath) 107 #'(name2 ...) 108 #'((racketmodname name2 indirect-kw ...) ...))]) 109 #'(begin 110 decl-exp ... 111 (*defmodule (list show-name ...) 112 modpaths 113 'module-path 114 packages 115 link-target-expr 116 kind 117 (list . content) 118 req))))])) 119 120 ;; ---------------------------------------- 121 ;; old forms for backward compatibility: 122 123 (define-syntax defmodule*/no-declare 124 (syntax-rules () 125 [(_ #:require-form req (name ...) . content) 126 (defmodule #:require-form req 127 #:names (name ...) 128 #:no-declare 129 . content)] 130 [(_ (name ...) . content) 131 (defmodule #:multi (name ...) 132 #:no-declare 133 . content)])) 134 135 (define-syntax defmodule* 136 (syntax-rules () 137 [(_ #:require-form req (name ...) . options+content) 138 (defmodule #:require-form req #:multi (name ...) 139 . options+content)] 140 [(_ (name ...) . options+content) 141 (defmodule #:multi (name ...) . options+content)])) 142 143 (define-syntax defmodulelang*/no-declare 144 (syntax-rules () 145 [(_ (lang ...) . options+content) 146 (defmodule #:multi (lang ...) 147 #:lang 148 #:no-declare 149 . options+content)])) 150 151 (define-syntax defmodulelang* 152 (syntax-rules () 153 [(_ (name ...) . options+content) 154 (defmodule #:multi (name ...) 155 #:lang 156 . options+content)])) 157 158 (define-syntax defmodulelang 159 (syntax-rules () 160 [(_ lang #:module-path modpath . options+content) 161 (defmodule lang 162 #:module-paths (modpath) 163 #:lang 164 . options+content)] 165 [(_ lang . options+content) 166 (defmodule lang 167 #:lang 168 . options+content)])) 169 170 (define-syntax-rule (defmodulereader*/no-declare (lang ...) . options+content) 171 (defmodule #:multi (lang ...) 172 #:reader 173 #:no-declare 174 . options+content)) 175 176 (define-syntax defmodulereader* 177 (syntax-rules () 178 [(_ (name ...) . options+content) 179 (defmodule #:multi (name ...) 180 #:reader 181 . options+content)])) 182 183 (define-syntax-rule (defmodulereader lang . options+content) 184 (defmodule lang 185 #:reader 186 . options+content)) 187 188 ;; ---------------------------------------- 189 190 (define (compute-packages module-path) 191 (let* ([path (with-handlers ([exn:missing-module? (lambda (exn) #f)]) 192 (and module-path 193 (resolved-module-path-name 194 (module-path-index-resolve (module-path-index-join module-path #f)))))] 195 [pkg (and path 196 (path? path) 197 (or (path->pkg path) 198 (let ([c (path->main-collects-relative path)]) 199 (and c 200 "base"))))]) 201 (if pkg 202 (list pkg) 203 null))) 204 205 ;; mflatt thinks this should not be exposed 206 (define (racketpkgname pkg) 207 (link 208 ;; XXX Look at (pkg-info-orig-pkg (hash-ref (read-pkgs-db scope) 209 ;; pkg)) and only show link if catalog? Or did mflatt have 210 ;; something else in mind? But I'd have to know the scope and pass 211 ;; that down from compute-packages 212 (format "https://pkgs.racket-lang.org/package/~a" pkg) 213 (tt pkg) 214 #:style (make-style #f 215 (list "plainlink" 216 (hover-property 217 (format "Install this package using `raco pkg install ~a`" 218 pkg)))))) 219 220 (define (*defmodule names modpaths module-path packages link-target? lang content req) 221 (let ([modpaths (or modpaths names)]) 222 (define pkg-spec 223 (let ([pkgs (or packages 224 (compute-packages module-path))]) 225 (and pkgs 226 (pair? pkgs) 227 (make-flow 228 (list 229 (make-omitable-paragraph 230 (list (elem #:style "RpackageSpec" 231 (list* (smaller 'nbsp 232 (format "package~a:" 233 (if (null? (cdr pkgs)) 234 "" 235 "s"))) 236 " " 237 (add-between (map racketpkgname pkgs) 238 ", ")))))))))) 239 (define (flow-width f) (apply max (map block-width f))) 240 (define libs-specs 241 ;; make-desc : element -> flow 242 ;; index-desc : module-path-index-desc 243 (let-values ([(make-desc index-desc) 244 (case lang 245 [(#f) 246 (values (lambda (modname) (list (racket (#,req #,modname)))) 247 the-module-path-index-desc)] 248 [(#t) 249 (values (lambda (modname) (list (hash-lang) spacer modname)) 250 the-language-index-desc)] 251 [(reader) 252 (values (lambda (modname) (list (racketmetafont "#reader") spacer modname)) 253 the-reader-index-desc)] 254 [(just-lang) 255 (values (lambda (modname) (list (hash-lang) spacer modname)) 256 the-language-index-desc)] 257 [else (error 'defmodule "unknown mode: ~e" lang)])]) 258 (map 259 (lambda (name modpath) 260 (define modname (if link-target? 261 (make-defracketmodname name modpath index-desc) 262 name)) 263 (list 264 (make-flow 265 (list 266 (make-omitable-paragraph 267 (cons spacer (make-desc modname))))) 268 'cont)) 269 names 270 modpaths))) 271 272 (make-splice 273 (cons 274 (make-table 275 (make-style "defmodule" 276 (list (table-columns (list 277 (make-style #f '(left)) 278 (make-style #f '(right)))))) 279 (if pkg-spec 280 (if ((+ (flow-width (caar libs-specs)) 281 (flow-width pkg-spec) 282 8) 283 . < . (current-display-width)) 284 (cons 285 (cons (car (car libs-specs)) 286 (list pkg-spec)) 287 (cdr libs-specs)) 288 (append 289 libs-specs 290 (list (list (make-flow (list (make-omitable-paragraph (list 'nbsp)))) 291 pkg-spec)))) 292 libs-specs)) 293 (append (if link-target? 294 (map (lambda (modpath) 295 (make-part-tag-decl 296 (intern-taglet 297 `(mod-path ,(datum-intern-literal 298 (element->string modpath)))))) 299 modpaths) 300 null) 301 (flow-paragraphs (decode-flow content))))))) 302 303 (define the-module-path-index-desc (make-module-path-index-desc)) 304 (define the-language-index-desc (make-language-index-desc)) 305 (define the-reader-index-desc (make-reader-index-desc)) 306 307 (define (make-defracketmodname mn mp index-desc) 308 (let ([name-str (datum-intern-literal (element->string mn))] 309 [path-str (datum-intern-literal (element->string mp))]) 310 (make-index-element #f 311 (list mn) 312 (intern-taglet `(mod-path ,path-str)) 313 (list name-str) 314 (list mn) 315 index-desc))) 316 317 (define-syntax (declare-exporting stx) 318 (syntax-parse stx 319 [(_ lib:expr ... 320 (~optional (~seq #:packages (pkg ...))) 321 (~optional (~seq #:use-sources (plib ...)))) 322 (with-syntax ([(plib ...) (if (attribute plib) 323 #'(plib ...) 324 #'())] 325 [packages (if (attribute pkg) 326 #'(list pkg ...) 327 #'#f)]) 328 (let ([libs (syntax->list #'(lib ... plib ...))]) 329 (for ([l libs]) 330 (unless (or (syntax-case l (unquote) 331 [(unquote _) #t] 332 [_ #f]) 333 (module-path? (syntax->datum l))) 334 (raise-syntax-error #f "not a module path" stx l))) 335 (when (null? libs) 336 (raise-syntax-error #f "need at least one module path" stx)) 337 #'(*declare-exporting `(lib ...) `(plib ...) packages)))])) 338 339 (define (*declare-exporting libs source-libs in-pkgs) 340 (define pkgs (or in-pkgs 341 (if (null? libs) 342 null 343 (compute-packages (car libs))))) 344 (make-splice 345 (list 346 (make-part-collect-decl 347 (make-collect-element 348 #f null 349 (lambda (ri) 350 (collect-put! ri '(exporting-libraries #f) libs) 351 (collect-put! ri '(exporting-packages #f) pkgs)))) 352 (make-part-collect-decl 353 (make-exporting-libraries #f null (and (pair? libs) libs) source-libs pkgs)))))