commit e0c3ac776e5f0b18c3b4df8c1529036b2e7b855c
parent a05ce99d9b1cb176eb648753e84bebf4aa1521c9
Author: Robby Findler <robby@racket-lang.org>
Date: Sat, 2 Aug 2014 01:51:03 -0500
add a scribble/blueboxes library to get the content of the
blueboxes in unstyled form
(moved from DrRacket here)
original commit: 24ecd045637a60114d51c9e33bf0035b1a9c046c
Diffstat:
3 files changed, 120 insertions(+), 0 deletions(-)
diff --git a/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/blueboxes.scrbl b/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/blueboxes.scrbl
@@ -0,0 +1,39 @@
+#lang scribble/doc
+@(require scribble/manual "utils.rkt"
+ (for-label scribble/core
+ scribble/blueboxes
+ racket/contract))
+
+@title[#:tag "blueboxes"]{Blue Boxes Utilities}
+
+@defmodule[scribble/blueboxes]{
+ The @racketmodname[scribble/blueboxes] provides access
+ to the content of the ``blue boxes'' that describe
+ some module's export (but without any styling).}
+
+@defproc[(fetch-blueboxes-strs [tag tag?]
+ [#:blueboxes-cache blueboxes-cache
+ blueboxes-cache?
+ (make-blueboxes-cache)])
+ (or/c #f (non-empty-listof string?))]{
+ Returns a list of strings that show the content of the blue box
+ (without any styling information) for the documentation referenced
+ by @racket[tag].
+
+ The first string in the list describes the export (e.g. @racket["procedure"]
+ when @racket[defproc] is used, or @racket["syntax"] when @racket[defform]
+ was used to document the export).
+}
+
+@defproc[(make-blueboxes-cache [populate? boolean?]) blueboxes-cache?]{
+ Constructs a new (mutable) blueboxes cache.
+
+ If @racket[populate?] is @racket[#f], the cache is initially
+ unpopulated, in which case it is filled in the first time the cache
+ is passed to @racket[fetch-bluebxoes-strs]. Otherwise, the cache is
+ initially populated.
+}
+
+@defproc[(blueboxes-cache? [v any/c]) boolean?]{
+ Determines if @racket[v] is a blueboxes cache.
+}
diff --git a/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/internals.scrbl b/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/internals.scrbl
@@ -14,5 +14,6 @@
@include-section["docreader.scrbl"]
@include-section["xref.scrbl"]
@include-section["tag.scrbl"]
+@include-section["blueboxes.scrbl"]
@include-section["config.scrbl"]
diff --git a/pkgs/scribble-pkgs/scribble-lib/scribble/blueboxes.rkt b/pkgs/scribble-pkgs/scribble-lib/scribble/blueboxes.rkt
@@ -0,0 +1,80 @@
+#lang racket/base
+(require setup/dirs
+ racket/serialize
+ racket/contract
+ scribble/core)
+
+(provide
+ (contract-out
+ [fetch-blueboxes-strs (->* (tag?) (#:blueboxes-cache blueboxes-cache?)
+ (or/c #f (non-empty-listof string?)))]
+ [make-blueboxes-cache (-> boolean? blueboxes-cache?)]
+ [blueboxes-cache? (-> any/c boolean?)]))
+
+(struct blueboxes-cache (info) #:mutable)
+(define (make-blueboxes-cache populate?)
+ (blueboxes-cache (and populate? (build-blueboxes-cache))))
+
+(define (fetch-blueboxes-strs tag #:blueboxes-cache [cache (make-blueboxes-cache #f)])
+ (define plain-strs (fetch-strs-for-single-tag tag cache))
+ (cond
+ [(and plain-strs
+ (pair? tag)
+ (eq? (car tag) 'def))
+ (define constructor-strs
+ (fetch-strs-for-single-tag (cons 'construtor (cdr tag)) cache))
+ (if constructor-strs
+ (append plain-strs
+ '("")
+ ;; cdr drops the "white label" line (constructor, presumably)
+ (cdr constructor-strs))
+ plain-strs)]
+ [else
+ plain-strs]))
+
+(define (fetch-strs-for-single-tag tag cache)
+ (unless (blueboxes-cache-info cache)
+ (set-blueboxes-cache-info! cache (build-blueboxes-cache)))
+ (for/or ([ent (in-list (blueboxes-cache-info cache))])
+ (define offset+lens (hash-ref (list-ref ent 2) tag #f))
+ (cond
+ [offset+lens
+ (apply
+ append
+ (for/list ([offset+len (in-list offset+lens)])
+ (define fn (list-ref ent 0))
+ (define offset (list-ref ent 1))
+ (call-with-input-file fn
+ (λ (port)
+ (port-count-lines! port)
+ (file-position port (+ (car offset+len) offset))
+ (for/list ([i (in-range (cdr offset+len))])
+ (read-line port))))))]
+ [else #f])))
+
+;; build-blueboxes-cache : (listof (list file-path int hash[tag -o> (cons int int)]))
+(define (build-blueboxes-cache)
+ (filter
+ values
+ (for*/list ([doc-search-dir (in-list (get-doc-search-dirs))]
+ [doc-dir-name (in-list (if (directory-exists? doc-search-dir)
+ (directory-list doc-search-dir)
+ '()))])
+ (define x (build-path doc-search-dir doc-dir-name "blueboxes.rktd"))
+ (and (file-exists? x)
+ (call-with-input-file x
+ (λ (port)
+ (port-count-lines! port)
+ (define first-line (read-line port))
+ (define pos (file-position port))
+ (define desed
+ (with-handlers ([exn:fail? (λ (x)
+ (log-warning "Failed to deserialize ~a: ~a"
+ x
+ (exn-message x))
+ #f)])
+ (deserialize (read port))))
+ (and desed
+ (list x
+ (+ (string->number first-line) pos)
+ desed))))))))
