plt-web: improve index-page rendering

pkgs/plt-services/meta/new-web/download/indexes.rkt

@@ -18,4 +18,10 @@
                             #:url "http://download.racket-lang.org/"
                             #:always-abs-url? #t))
 
-(make-indexes download-site)
+(make-indexes download-site
+              #:use-dir? (lambda (d)
+                           (or (not (path? d))
+                               (let-values ([(base name dir) (split-path d)])
+                                 ;; Don't go into documentation "HTML" directories:
+                                 (not (equal? "html" (path->string name)))))))
+

pkgs/plt-web-pkgs/plt-web-doc/plt-web.scrbl

@@ -203,13 +203,16 @@ returning a value that can be used to reference the resource.}
 
 @defproc[(make-indexes [s site?]
                        [dir (or/c 'same relative-path?)]
-                       [#:depth depth (or/c #f exact-nonnegative-integer?)])
+                       [#:depth depth (or/c #f exact-nonnegative-integer?) #f]
+                       [#:use-dir? use-dir? ((or/c 'same relative-path?) . -> . any/c) (lambda (dir) #t)])
          void?]{
 
 Registers an @filepath{index.html} file for every directory within
 @racket[dir] (relative to the current directory) that does not have an
 @filepath{index.html} file already. If @racket[depth] is not @racket[#f],
 then subdirectories are explored at most @racket[depth] layers deep.
+The @racket[use-dir?] predicate is called for each directory to determine
+whether the directory's subdirectories are traversed.
 
 The generated index files are registered for the site @racket[s] at
 destinations that correspond to treating the current directory as the

pkgs/plt-web-pkgs/plt-web-lib/indexes.rkt

@@ -1,11 +1,16 @@
 #lang at-exp racket/base
 (require scribble/html
          racket/format
-         "layout.rkt")
+         racket/runtime-path
+         "layout.rkt"
+         "style.rkt")
 
 (provide make-indexes)
 
-(define (build site p)
+(define-runtime-path file-png "resources/file.png")
+(define-runtime-path folder-png "resources/folder.png")
+
+(define (build site p file-icon folder-icon)
   (let ([dir (current-directory)])
     (unless (file-exists? (build-path dir p "index.html"))
       (page #:site site
@@ -13,22 +18,34 @@
                        "index.html"
                        (path->string (build-path p "index.html")))
             #:title "Index"
+            @columns[10 #:row? #t]{
               @table{@(for/list ([i (in-list
                                      (directory-list (build-path dir p)))])
-                      @tr{@td{@a[href: (path->string i)]{@(path->string i)}}
+                        @tr{@td{@a[href: (path->string i)]{@;
+                                 @img[src: (if (file-exists? (build-path dir p i))
+                                              file-icon
+                                              folder-icon)
+                                     width: "16" height: "16"] @;
+                                 @nbsp @;
+                                 @(path->string i)}}
                             @td{@(let ([i (build-path dir p i)])
                                    (if (file-exists? i)
                                        (let ([s (file-size i)])
                                          (~a (ceiling (/ s 1024)) "k"))
-                                     ""))}})}))))
+                                       ""))}})}}))))
 
 (define (make-indexes site [dir 'same] 
-                      #:depth [depth #f])
-  (build site dir)
-  (when (or (not depth) (positive? depth))
+                      #:depth [depth #f]
+                      #:use-dir? [use-dir? (lambda (p) #t)])
+  (define file-icon (copyfile #:site site file-png))
+  (define folder-icon (copyfile #:site site folder-png))
+  (let loop ([dir dir] [depth depth])
+    (build site dir file-icon folder-icon)
+    (when (and (or (not depth) (positive? depth))
+               (use-dir? dir))
       (for ([d (in-list (directory-list (if (eq? dir 'same)
                                             (current-directory)
                                             dir)))])
         (define p (if (eq? dir 'same) d (build-path dir d)))
         (when (directory-exists? p)
-        (make-indexes site p #:depth (and depth (sub1 depth)))))))
+          (loop p (and depth (sub1 depth))))))))

pkgs/plt-web-pkgs/plt-web-lib/resources/file-icons.rkt

@@ -0,0 +1,64 @@
+#lang racket/base
+#|
+;; This is how "file.png" and "folder.png" were generated, but it's commented
+;; out here to avoid a dependency on `racket/draw`.
+(require racket/class
+         racket/math
+         racket/draw)
+
+(define S 32)
+
+(define (file)
+  (define bm (make-bitmap S S))
+  (define dc (send bm make-dc))
+
+  (define I 3)
+
+  (send dc set-pen "black" 2 'solid)
+  (send dc set-brush (make-color 200 200 200) 'solid)
+  (send dc draw-polygon (list
+                         (cons 6 I)
+                         (cons 6 (- S I))
+                         (cons (- S 6) (- S I))
+                         (cons (- S 6) (+ 8 I))
+                         (cons (- S 14) I))
+        0 1)
+
+  (send dc set-brush (make-color 150 150 150) 'solid)
+  (send dc draw-polygon (list
+                         (cons (- S 14) (+ 8 I))
+                         (cons (- S 6) (+ 8 I))
+                         (cons (- S 14) I))
+        0 1)
+
+  (send bm save-file "/tmp/file.png" 'png #:unscaled? #t))
+
+(define (folder)
+  (define bm (make-bitmap S S))
+  (define dc (send bm make-dc))
+
+  (define D 8)
+  (define H 12)
+  (define T (/ D 2))
+
+   (send dc set-pen "black" 2 'solid)
+  (send dc set-brush (make-color 200 200 200) 'solid)
+
+  (define p (new dc-path%))
+  (send p arc (+ 1 T) (- S D 1 H T) D D 0 (* 1/2 pi) #t)
+  (send p arc 1 (- S D 1 H T) D D (* 1/2 pi) (* 1 pi) #t)
+  (send p line-to 1 (- S 1))
+  ;; (send p arc 1 (- S D 1) D D (* -1 pi) (* -1/2 pi) #t)
+  (send p line-to (- S 1) (- S 1))
+  ;; (send p arc (- S D 1) (- S D 1) D D (* -1/2 pi) 0 #t)
+  (send p arc (- S D 1) (- S D 1 H) D D 0 (* 1/2 pi) #t)
+  (send p close)
+
+  (send dc draw-path p 0 0)
+  
+  (send bm save-file "/tmp/folder.png" 'png #:unscaled? #t))
+
+(file)
+(folder)
+
+|#

pkgs/plt-web-pkgs/plt-web-lib/style.rkt

@@ -1,4 +1,6 @@
-#lang plt-web
+#lang at-exp racket/base
+
+(require (except-in scribble/html/lang #%module-begin))
 
 (provide (all-defined-out))