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"))
(define build-deps '("scribble-lib" "racket-doc" "rackunit-doc"))
(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 version "0.0")
(define pkg-authors '(|Georges Dupéron|))

5
lang.rkt
View File

@ -2,7 +2,4 @@
;; Forked from scribble-lib/scribble/lp/lang/lang2.rkt
(require "private/common.rkt")
(provide (except-out (all-from-out "private/common.rkt")
module-begin/plain
module-begin/doc)
(rename-out [module-begin/doc #%module-begin]))
(provide (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
#:read read-inside
#:read-syntax read-syntax-inside
#:read meta-read-inside
#:read-syntax meta-read-syntax-inside
#:whole-body-readers? #t
;; don't use scribble-base-info for the #:info arg, since
;; scribble/lp files are not directly scribble'able.
#:language-info (scribble-base-language-info)
#:info (scribble-base-reader-info)
(require scribble/reader
(require "meta-first-line.rkt"
(only-in scribble/base/reader
scribble-base-reader-info
scribble-base-language-info))

114
private/common.rkt
View File

@ -28,7 +28,7 @@
chunks id
`(,@(mapping-get chunks id) ,@exprs))))
(define-for-syntax (tangle orig-stx)
(define-for-syntax (tangle orig-stx req-lng)
(define chunk-mentions '())
(unless first-id
(raise-syntax-error 'scribble/lp "no chunks"))
@ -37,6 +37,21 @@
(define (shift nstx) (replace-context orig-stx nstx))
(define body
(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
main-id
(let loop ([block (get-chunk main-id)])
@ -63,8 +78,11 @@
(mapping-get chunk-groups m)))
chunk-mentions)])
;(displayln (dynamic-require 'tyyyyyyyyyyyped/racket '#%module-begin))
(replace-context #'#%module-begin;modbeg-ty
#`(begin body ... (let ([b-id (void)]) b-use) ...))))
;; TODO: use disappeared-use and disappeared-binding.
;; 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)
(cond
@ -122,51 +140,69 @@
[_
(loop #'exprs)])])))
(require racket/stxparam)
(define-syntax-parameter mbeg #'#%module-begin)
(require (only-in typed/racket)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; WORKAROUND
(require (for-syntax racket/syntax
syntax/parse))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require (only-in typed/racket)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; WORKAROUND ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require (for-syntax racket/pretty))
(define-for-syntax ((make-module-begin submod?) stx)
(syntax-case stx ()
[(_modbeg lang body0 . body)
(syntax-parse stx
[(_modbeg (lang:id (~optional (~and no-require-lang #:no-require-lang)))
body0 . body)
(let ()
;; TODO: get the actual symbol, instead of the string returned by
;; 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) "")))
(define lang-sym (syntax-e #'lang))
(let ([expanded
(expand `(,#'module scribble-lp-tmp-name hyper-literate/private/lp
(define-syntax-rule (if-preexpanding a b) a)
(define-syntax-rule (when-preexpanding . b) (begin . b))
(define-syntax-rule (unless-preexpanding . b) (begin))
,@(strip-context #'(body0 . body))))])
(expand `(,#'module
scribble-lp-tmp-name hyper-literate/private/lp
(define-syntax-rule (if-preexpanding a b) a)
(define-syntax-rule (when-preexpanding . b) (begin . b))
(define-syntax-rule (unless-preexpanding . b) (begin))
,@(strip-context #'(body0 . body))))])
(syntax-case expanded ()
[(module name lang (mb . stuff))
[(module name elang (mb . stuff))
(let ()
(extract-chunks #'stuff)
(dynamic-require lang-sym #f)
(namespace-require `(for-meta -1 ,lang-sym))
(replace-context
(namespace-symbol->identifier '#%module-begin)
#`(#%module-begin
#,(tangle #'body0)
#,@(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))
(begin body0 . body)))])
(syntax-case submod ()
[(_ . rest)
(datum->syntax #'here (cons #'module* #'rest))])))
'()))))])))]))
#;(begin
(define/with-syntax tngl (tangle #'body0))
(define/with-syntax (tngl0 . tngl*) #'tngl)
(define/with-syntax (ex-mod ex-nam ex-lng (ex-#%m . ex-rest))
(expand-syntax
#`(#,#'module hyper-literate-temp-expand #,lang-sym
#,(replace-context #'here #'tngl))))
#`(ex-#%m #,(datum->syntax (syntax-local-introduce #'ex-rest)
'(#%require lang-sym))
. ex-rest))
(define/with-syntax tngl
(tangle #'body0 (if (attribute no-require-lang) #f #'lang)))
;(replace-context
;(namespace-symbol->identifier '#%module-begin)
;#`(#,(syntax/loc #'lang #%module-begin) …)
#`(#,(namespace-symbol->identifier '#%module-begin)
tngl
#,@(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/doc (make-module-begin #t))

10
private/lp.rkt
View File

@ -22,7 +22,7 @@
(identifier? #'name)
(let* ([n (get-chunk-number (syntax-local-introduce #'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
(inc-chunk-number (syntax-local-introduce #'name)))
@ -68,9 +68,9 @@
(make-splice
(list (make-toc-element
#f
(list (elemtag '(chunk (prefixable tag))
(list (elemtag '(prefixable tag)
(bold (italic (racket name)) " ::=")))
(list (smaller (elemref '(chunk (prefixable tag)) #:underline? #f
(list (smaller (elemref '(prefixable tag) #:underline? #f
str
rest ...))))
(#,racketblock expr ...))))))]))
@ -82,9 +82,9 @@
(syntax-case stx ()
[(_ 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))])
#'(elemref '(chunk (prefixable tag)) #:underline? #f str))]))
#'(elemref '(prefixable tag) #:underline? #f str))]))
(provide (all-from-out scheme/base

6
test/test2.hl.rkt
View File

@ -1,14 +1,16 @@
#lang hyper-literate typed/racket/base
@(require (for-label typed/racket/base
typed/rackunit))
rackunit))
@title{Title}
Hello world.
@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:
;curry