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

various tests, before cleanup

Browse Source
This commit is contained in:
Georges Dupéron 2016-06-16 18:38:55 +02:00
parent b895378a51
commit 21cd1f3ae3
5 changed files with 136 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
test/test.hl.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang hyper-literate/typed racket
@;((curry + 1) 2)
@chunk[<*>
1
;(ann 'eee Symbol)
;(define (f [x : 'e]) x)
#;((curry + 1) 2)]

174
typed/lang/common.rkt
View File

@ -8,6 +8,38 @@
(require (for-syntax racket/base syntax/boundmap racket/list (require (for-syntax racket/base syntax/boundmap racket/list
syntax/strip-context)) syntax/strip-context))
(require macro-debugger/syntax-browser)
(define-for-syntax ty-introducer
(let ([si (make-syntax-introducer)])
(λ (x)
#`(browse-syntax #'#,(si x))
(si x))))
(define-syntax (req-ty stx)
(ty-introducer
(syntax-local-introduce
#'(begin
(require (only-in typed/racket
ann
Symbol))
(ann 'aaa Symbol)))))
(req-ty)
(define-syntax (later stx)
(ty-introducer
#'(ann 'bbb Symbol)))
(later)
(define-syntax (later2 stx)
#'(later))
;(later2)
(require (only-in typed/racket
[#%module-begin modbeg-ty]
require/typed))
(begin-for-syntax (begin-for-syntax
(define first-id #f) (define first-id #f)
(define main-id #f) (define main-id #f)
@ -62,49 +94,51 @@
(syntax-local-introduce u))) (syntax-local-introduce u)))
(mapping-get chunk-groups m))) (mapping-get chunk-groups m)))
chunk-mentions)]) chunk-mentions)])
#`(begin body ... (let ([b-id (void)]) b-use) ...))) ;(displayln (dynamic-require 'typed/racket '#%module-begin))
(replace-context #'modbeg-ty
#`(begin 'xxx body ... (let ([b-id (void)]) b-use) ...))))
(define-for-syntax (strip-comments body) (define-for-syntax (strip-comments body)
(cond (cond
[(syntax? body) [(syntax? body)
(define r (strip-comments (syntax-e body))) (define r (strip-comments (syntax-e body)))
(if (eq? r (syntax-e body)) (if (eq? r (syntax-e body))
body body
(datum->syntax body r body body))] (datum->syntax body r body body))]
[(pair? body) [(pair? body)
(define a (car body)) (define a (car body))
(define ad (syntax-e a)) (define ad (syntax-e a))
(cond (cond
[(and (pair? ad) [(and (pair? ad)
(memq (syntax-e (car ad)) (memq (syntax-e (car ad))
'(code:comment '(code:comment
code:contract))) code:contract)))
(strip-comments (cdr body))] (strip-comments (cdr body))]
[(eq? ad 'code:blank) [(eq? ad 'code:blank)
(strip-comments (cdr body))] (strip-comments (cdr body))]
[(and (or (eq? ad 'code:hilite) [(and (or (eq? ad 'code:hilite)
(eq? ad 'code:quote)) (eq? ad 'code:quote))
(let* ([d (cdr body)] (let* ([d (cdr body)]
[dd (if (syntax? d) [dd (if (syntax? d)
(syntax-e d) (syntax-e d)
d)]) d)])
(and (pair? dd) (and (pair? dd)
(or (null? (cdr dd)) (or (null? (cdr dd))
(and (syntax? (cdr dd)) (and (syntax? (cdr dd))
(null? (syntax-e (cdr dd)))))))) (null? (syntax-e (cdr dd))))))))
(define d (cdr body)) (define d (cdr body))
(define r (define r
(strip-comments (car (if (syntax? d) (syntax-e d) d)))) (strip-comments (car (if (syntax? d) (syntax-e d) d))))
(if (eq? ad 'code:quote) (if (eq? ad 'code:quote)
`(quote ,r) `(quote ,r)
r)] r)]
[(and (pair? ad) [(and (pair? ad)
(eq? (syntax-e (car ad)) (eq? (syntax-e (car ad))
'code:line)) 'code:line))
(strip-comments (append (cdr ad) (cdr body)))] (strip-comments (append (cdr ad) (cdr body)))]
[else (cons (strip-comments a) [else (cons (strip-comments a)
(strip-comments (cdr body)))])] (strip-comments (cdr body)))])]
[else body])) [else body]))
(define-for-syntax (extract-chunks exprs) (define-for-syntax (extract-chunks exprs)
(let loop ([exprs exprs]) (let loop ([exprs exprs])
@ -120,31 +154,63 @@
[_ [_
(loop #'exprs)])]))) (loop #'exprs)])])))
(require racket/stxparam)
(define-syntax-parameter mbeg #'#%module-begin)
(define-for-syntax ((make-module-begin submod?) stx) (define-for-syntax ((make-module-begin submod?) stx)
(syntax-case stx () (syntax-case stx ()
[(_ body0 . body) [(mb lng . _)
(let ([expanded (let ()
(expand `(,#'module scribble-lp-tmp-name scribble/private/lp ;; TODO: get the actual symbol, instead of the string returned by scribble's at-reader
,@(strip-context #'(body0 . body))))]) (define lng-sym (string->symbol (regexp-replace "^ " (syntax-e #'lng) "")))
(syntax-case expanded () (dynamic-require lng-sym #f)
[(module name lang (mb . stuff)) (define ns1 (module->namespace lng-sym))
(begin (extract-chunks #'stuff) ;(define ns2 (make-empty-namespace))
#`(#%module-begin ;(namespace-attach-module ns1 'typed/racket ns2)
(tangle body0) (displayln ns1)
;; The `doc` submodule allows a `scribble/lp` module ;(displayln ns2)
;; to be provided to `scribble`: (parameterize ([current-namespace ns1])
#,@(if submod? (displayln (namespace-symbol->identifier '#%module-begin))
(displayln (namespace-syntax-introduce #'#%module-begin))
(replace-context
(namespace-symbol->identifier '#%module-begin)
#'(#%module-begin
(ann (cons 1 'b) (Pairof Number Symbol))
((make-predicate (Pairof Number Symbol)) (cons 1 'b))))
#;(namespace-syntax-introduce
)))])
#;(with-syntax ([md (namespace-module-identifier ns)])
#'(md typed/racket (ann 1 Number)))
#;(ty-introducer
(syntax-local-introduce
#'(modbeg-ty
(ann 'ccc Symbol))))
#;(syntax-case stx ()
[(_ body0 . body)
(let ([expanded
(expand `(,#'module scribble-lp-tmp-name scribble/private/lp;hyper-literate/typed/private/lp
,@(strip-context #'(body0 . body))))])
(syntax-case expanded ()
[(module name lang (mb . stuff))
(begin (extract-chunks #'stuff)
#`(modbeg-ty
#,(ty-introducer #'(let ([eee 'eee])
(ann eee Symbol)))
(tangle body0)
;; The `doc` submodule allows a `scribble/lp` module
;; to be provided to `scribble`:
#|#,@(if submod?
(list (list
(let ([submod (let ([submod
(strip-context (strip-context
#`(module doc scribble/doclang2 #`(module doc scribble/doclang2
(require scribble/manual (require scribble/manual
(only-in scribble/private/lp chunk CHUNK)) (only-in hyper-literate/typed/private/lp chunk CHUNK))
(begin body0 . body)))]) (begin body0 . body)))])
(syntax-case submod () (syntax-case submod ()
[(_ . rest) [(_ . rest)
(datum->syntax submod (cons #'module* #'rest))]))) (datum->syntax submod (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))

2
typed/lang/lang.rkt
View File

@ -5,4 +5,4 @@
(provide (except-out (all-from-out "common.rkt") (provide (except-out (all-from-out "common.rkt")
module-begin/plain module-begin/plain
module-begin/doc) module-begin/doc)
(rename-out [module-begin/doc #%module-begin])) (rename-out [module-begin/plain #%module-begin]))

2
typed/lang/reader.rkt
View File

@ -1,7 +1,7 @@
#lang s-exp syntax/module-reader #lang s-exp syntax/module-reader
;; Forked from scribble-lib/scribble/lp/lang/reader.rkt ;; Forked from scribble-lib/scribble/lp/lang/reader.rkt
scribble/lp/lang/lang hyper-literate/typed/lang/lang
#:read read-inside #:read read-inside
#:read-syntax read-syntax-inside #:read-syntax read-syntax-inside

4
typed/private/lp.rkt
View File

@ -81,6 +81,8 @@
#'(elemref '(chunk tag) #:underline? #f str))])) #'(elemref '(chunk tag) #:underline? #f str))]))
(provide (all-from-out scheme/base (require typed/racket/base)
(provide (all-from-out typed/racket/base ;scheme/base
scribble/manual) scribble/manual)
chunk CHUNK) chunk CHUNK)