suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

Fixes lots of issues. Fixes scribble bug #25 (last commit didn't fix it in the end). Fixes arrows in DrRacket. Fixes some identifier conflicts.

Browse Source
This commit is contained in:
Georges Dupéron 2016-06-23 21:09:35 +02:00
parent dbebe7b60a
commit b9037c3c06
7 changed files with 121 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
info.rkt
View File

@ -10,7 +10,8 @@
"typed-racket-doc")) "typed-racket-doc"))
(define build-deps '("scribble-lib" "racket-doc" "rackunit-doc")) (define build-deps '("scribble-lib" "racket-doc" "rackunit-doc"))
(define scribblings '(("scribblings/hyper-literate.scrbl" ()) (define scribblings '(("scribblings/hyper-literate.scrbl" ())
("test/test.hl.rkt" ()))) ("test/test.hl.rkt" () (omit-start))
("test/test2.hl.rkt" () (omit-start))))
(define pkg-desc "Description Here") (define pkg-desc "Description Here")
(define version "0.0") (define version "0.0")
(define pkg-authors '(|Georges Dupéron|)) (define pkg-authors '(|Georges Dupéron|))

5
lang.rkt
View File

@ -2,7 +2,4 @@
;; Forked from scribble-lib/scribble/lp/lang/lang2.rkt ;; Forked from scribble-lib/scribble/lp/lang/lang2.rkt
(require "private/common.rkt") (require "private/common.rkt")
(provide (except-out (all-from-out "private/common.rkt") (provide (rename-out [module-begin/doc #%module-begin]))
module-begin/plain
module-begin/doc)
(rename-out [module-begin/doc #%module-begin]))

31
lang/meta-first-line.rkt Normal file
View File

@ -0,0 +1,31 @@
#lang racket/base
(require scribble/reader
racket/port)
(provide meta-read-inside
meta-read-syntax-inside)
(define (read-line-length port)
(let* ([peeking (peeking-input-port port)]
[start (file-position peeking)]
[_ (read-line peeking)]
[end (file-position peeking)])
(- end start)))
(define (narrow-to-one-line port)
(make-limited-input-port port (read-line-length port)))
(define (meta-read-inside in . args)
(displayln args)
(apply read-inside args))
(define (meta-read-syntax-inside source-name in . args)
(define in1 (narrow-to-one-line in))
(with-syntax ([rd1 (let loop ([res '()])
(define res+ (read-syntax source-name in1))
(if (eof-object? res+)
(reverse res)
(loop (cons res+ res))))]
[rd (apply read-syntax-inside source-name in args)])
#'(rd1 . rd)))

6
lang/reader.rkt
View File

@ -3,14 +3,14 @@
hyper-literate/lang hyper-literate/lang
#:read read-inside #:read meta-read-inside
#:read-syntax read-syntax-inside #:read-syntax meta-read-syntax-inside
#:whole-body-readers? #t #:whole-body-readers? #t
;; don't use scribble-base-info for the #:info arg, since ;; don't use scribble-base-info for the #:info arg, since
;; scribble/lp files are not directly scribble'able. ;; scribble/lp files are not directly scribble'able.
#:language-info (scribble-base-language-info) #:language-info (scribble-base-language-info)
#:info (scribble-base-reader-info) #:info (scribble-base-reader-info)
(require scribble/reader (require "meta-first-line.rkt"
(only-in scribble/base/reader (only-in scribble/base/reader
scribble-base-reader-info scribble-base-reader-info
scribble-base-language-info)) scribble-base-language-info))

114
private/common.rkt
View File

@ -28,7 +28,7 @@
chunks id chunks id
`(,@(mapping-get chunks id) ,@exprs)))) `(,@(mapping-get chunks id) ,@exprs))))
(define-for-syntax (tangle orig-stx) (define-for-syntax (tangle orig-stx req-lng)
(define chunk-mentions '()) (define chunk-mentions '())
(unless first-id (unless first-id
(raise-syntax-error 'scribble/lp "no chunks")) (raise-syntax-error 'scribble/lp "no chunks"))
@ -37,6 +37,21 @@
(define (shift nstx) (replace-context orig-stx nstx)) (define (shift nstx) (replace-context orig-stx nstx))
(define body (define body
(let ([main-id (or main-id first-id)]) (let ([main-id (or main-id first-id)])
;; HACK to get arrows drawn for built-ins imported by the module language.
;; TODO: it fails with type-expander.lp2.rkt, because it re-requires λ
;; (the new-λ) from 'main.
(when req-lng
(free-identifier-mapping-put!
chunk-groups main-id
(cons main-id (mapping-get chunk-groups main-id)))
(free-identifier-mapping-put!
chunks main-id
`(,#`(require #,(datum->syntax main-id
req-lng
req-lng
req-lng))
,@(mapping-get chunks main-id))))
;;;;;;;;;;;;;;
(restore (restore
main-id main-id
(let loop ([block (get-chunk main-id)]) (let loop ([block (get-chunk main-id)])
@ -63,8 +78,11 @@
(mapping-get chunk-groups m))) (mapping-get chunk-groups m)))
chunk-mentions)]) chunk-mentions)])
;(displayln (dynamic-require 'tyyyyyyyyyyyped/racket '#%module-begin)) ;(displayln (dynamic-require 'tyyyyyyyyyyyped/racket '#%module-begin))
(replace-context #'#%module-begin;modbeg-ty ;; TODO: use disappeared-use and disappeared-binding.
#`(begin body ... (let ([b-id (void)]) b-use) ...)))) ;; TODO: fix srcloc (already fixed?).
#`(begin (let ([b-id (void)]) b-use) ... body ...)
#;(replace-context #'#%module-begin;modbeg-ty
#`(begin (let ([b-id (void)]) b-use) ... body ...))))
(define-for-syntax (strip-comments body) (define-for-syntax (strip-comments body)
(cond (cond
@ -122,51 +140,69 @@
[_ [_
(loop #'exprs)])]))) (loop #'exprs)])])))
(require racket/stxparam) (require (for-syntax racket/syntax
(define-syntax-parameter mbeg #'#%module-begin) syntax/parse))
(require (only-in typed/racket)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; WORKAROUND
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require (only-in typed/racket)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; WORKAROUND ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require (for-syntax racket/pretty))
(define-for-syntax ((make-module-begin submod?) stx) (define-for-syntax ((make-module-begin submod?) stx)
(syntax-case stx () (syntax-parse stx
[(_modbeg lang body0 . body) [(_modbeg (lang:id (~optional (~and no-require-lang #:no-require-lang)))
body0 . body)
(let () (let ()
;; TODO: get the actual symbol, instead of the string returned by (define lang-sym (syntax-e #'lang))
;; scribble's at-reader. Or use the first line as a whole as the #lang,
;; to allow othe meta-languages to be chained.
(define lang-sym
(string->symbol (regexp-replace "^ " (syntax-e #'lang) "")))
(let ([expanded (let ([expanded
(expand `(,#'module scribble-lp-tmp-name hyper-literate/private/lp (expand `(,#'module
(define-syntax-rule (if-preexpanding a b) a) scribble-lp-tmp-name hyper-literate/private/lp
(define-syntax-rule (when-preexpanding . b) (begin . b)) (define-syntax-rule (if-preexpanding a b) a)
(define-syntax-rule (unless-preexpanding . b) (begin)) (define-syntax-rule (when-preexpanding . b) (begin . b))
,@(strip-context #'(body0 . body))))]) (define-syntax-rule (unless-preexpanding . b) (begin))
,@(strip-context #'(body0 . body))))])
(syntax-case expanded () (syntax-case expanded ()
[(module name lang (mb . stuff)) [(module name elang (mb . stuff))
(let () (let ()
(extract-chunks #'stuff) (extract-chunks #'stuff)
(dynamic-require lang-sym #f) (dynamic-require lang-sym #f)
(namespace-require `(for-meta -1 ,lang-sym)) (namespace-require `(for-meta -1 ,lang-sym))
(replace-context #;(begin
(namespace-symbol->identifier '#%module-begin) (define/with-syntax tngl (tangle #'body0))
#`(#%module-begin (define/with-syntax (tngl0 . tngl*) #'tngl)
#,(tangle #'body0) (define/with-syntax (ex-mod ex-nam ex-lng (ex-#%m . ex-rest))
#,@(if submod? (expand-syntax
(list #`(#,#'module hyper-literate-temp-expand #,lang-sym
(let ([submod #,(replace-context #'here #'tngl))))
(strip-context #`(ex-#%m #,(datum->syntax (syntax-local-introduce #'ex-rest)
#`(module doc scribble/doclang2 '(#%require lang-sym))
(define-syntax-rule (if-preexpanding a b) b) . ex-rest))
(define-syntax-rule (when-preexpanding . b) (begin)) (define/with-syntax tngl
(define-syntax-rule (unless-preexpanding . b) (begin . b)) (tangle #'body0 (if (attribute no-require-lang) #f #'lang)))
(require scribble/manual ;(replace-context
(only-in hyper-literate/private/lp chunk CHUNK)) ;(namespace-symbol->identifier '#%module-begin)
(begin body0 . body)))]) ;#`(#,(syntax/loc #'lang #%module-begin) …)
(syntax-case submod () #`(#,(namespace-symbol->identifier '#%module-begin)
[(_ . rest) tngl
(datum->syntax #'here (cons #'module* #'rest))]))) #,@(maybe-insert-doc-submod submod? lang-sym)))])))]))
'()))))])))])) (define-for-syntax (maybe-insert-doc-submod submod? lang-sym)
(if submod?
(list
(let ([submod
(strip-context
#`(module doc scribble/doclang2
(define-syntax-rule (if-preexpanding a b) b)
(define-syntax-rule (when-preexpanding . b) (begin))
(define-syntax-rule (unless-preexpanding . b) (begin . b))
(require scribble/manual
(only-in hyper-literate/private/lp
chunk
CHUNK)
(for-label #,lang-sym))
(begin body0 . body)))])
(syntax-case submod ()
[(_ . rest)
(datum->syntax #'here (cons #'module* #'rest))])))
'()))
(define-syntax module-begin/plain (make-module-begin #f)) (define-syntax module-begin/plain (make-module-begin #f))
(define-syntax module-begin/doc (make-module-begin #t)) (define-syntax module-begin/doc (make-module-begin #t))

10
private/lp.rkt
View File

@ -22,7 +22,7 @@
(identifier? #'name) (identifier? #'name)
(let* ([n (get-chunk-number (syntax-local-introduce #'name))] (let* ([n (get-chunk-number (syntax-local-introduce #'name))]
[str (symbol->string (syntax-e #'name))] [str (symbol->string (syntax-e #'name))]
[tag (format "~a:~a" str (or n 1))]) [tag (format "chunk:~a:~a" str (or n 1))])
(when n (when n
(inc-chunk-number (syntax-local-introduce #'name))) (inc-chunk-number (syntax-local-introduce #'name)))
@ -68,9 +68,9 @@
(make-splice (make-splice
(list (make-toc-element (list (make-toc-element
#f #f
(list (elemtag '(chunk (prefixable tag)) (list (elemtag '(prefixable tag)
(bold (italic (racket name)) " ::="))) (bold (italic (racket name)) " ::=")))
(list (smaller (elemref '(chunk (prefixable tag)) #:underline? #f (list (smaller (elemref '(prefixable tag) #:underline? #f
str str
rest ...)))) rest ...))))
(#,racketblock expr ...))))))])) (#,racketblock expr ...))))))]))
@ -82,9 +82,9 @@
(syntax-case stx () (syntax-case stx ()
[(_ id) [(_ id)
(identifier? #'id) (identifier? #'id)
(with-syntax ([tag (format "~a:1" (syntax-e #'id))] (with-syntax ([tag (format "chunk:~a:1" (syntax-e #'id))]
[str (format "~a" (syntax-e #'id))]) [str (format "~a" (syntax-e #'id))])
#'(elemref '(chunk (prefixable tag)) #:underline? #f str))])) #'(elemref '(prefixable tag) #:underline? #f str))]))
(provide (all-from-out scheme/base (provide (all-from-out scheme/base

6
test/test2.hl.rkt
View File

@ -1,14 +1,16 @@
#lang hyper-literate typed/racket/base #lang hyper-literate typed/racket/base
@(require (for-label typed/racket/base @(require (for-label typed/racket/base
typed/rackunit)) rackunit))
@title{Title} @title{Title}
Hello world. Hello world.
@chunk[<*> @chunk[<*>
(require typed/rackunit) (begin
; Wrapped with (begin …) to avoid the implicit require for-label.
(require typed/rackunit))
;; Would give an error as typed/racket/base is used on the #lang line: ;; Would give an error as typed/racket/base is used on the #lang line:
;curry ;curry