From e0c3ac776e5f0b18c3b4df8c1529036b2e7b855c Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 2 Aug 2014 01:51:03 -0500 Subject: [PATCH] add a scribble/blueboxes library to get the content of the blueboxes in unstyled form (moved from DrRacket here) original commit: 24ecd045637a60114d51c9e33bf0035b1a9c046c --- .../scribblings/scribble/blueboxes.scrbl | 39 +++++++++ .../scribblings/scribble/internals.scrbl | 1 + .../scribble-lib/scribble/blueboxes.rkt | 80 +++++++++++++++++++ 3 files changed, 120 insertions(+) create mode 100644 pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/blueboxes.scrbl create mode 100644 pkgs/scribble-pkgs/scribble-lib/scribble/blueboxes.rkt diff --git a/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/blueboxes.scrbl b/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/blueboxes.scrbl new file mode 100644 index 00000000..39623511 --- /dev/null +++ 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 index 88a5bc5d..9c8ca238 100644 --- 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 new file mode 100644 index 00000000..c74406e4 --- /dev/null +++ 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))))))))