diff --git a/test/test.hl.rkt b/test/test.hl.rkt new file mode 100644 index 00000000..4415822e --- /dev/null +++ b/test/test.hl.rkt @@ -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)] \ No newline at end of file diff --git a/typed/lang/common.rkt b/typed/lang/common.rkt index ee2e0ec2..2ea796af 100644 --- a/typed/lang/common.rkt +++ b/typed/lang/common.rkt @@ -8,6 +8,38 @@ (require (for-syntax racket/base syntax/boundmap racket/list 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 (define first-id #f) (define main-id #f) @@ -52,7 +84,7 @@ (if subs (list (restore expr (loop subs))) (list (shift expr)))))) - block))))) + block))))) (with-syntax ([(body ...) (strip-comments body)] ;; construct arrows manually [((b-use b-id) ...) @@ -62,50 +94,52 @@ (syntax-local-introduce u))) (mapping-get chunk-groups m))) 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) (cond - [(syntax? body) - (define r (strip-comments (syntax-e body))) - (if (eq? r (syntax-e body)) - body - (datum->syntax body r body body))] - [(pair? body) - (define a (car body)) - (define ad (syntax-e a)) - (cond - [(and (pair? ad) - (memq (syntax-e (car ad)) - '(code:comment - code:contract))) - (strip-comments (cdr body))] - [(eq? ad 'code:blank) - (strip-comments (cdr body))] - [(and (or (eq? ad 'code:hilite) - (eq? ad 'code:quote)) - (let* ([d (cdr body)] - [dd (if (syntax? d) - (syntax-e d) - d)]) - (and (pair? dd) - (or (null? (cdr dd)) - (and (syntax? (cdr dd)) - (null? (syntax-e (cdr dd)))))))) - (define d (cdr body)) - (define r - (strip-comments (car (if (syntax? d) (syntax-e d) d)))) - (if (eq? ad 'code:quote) - `(quote ,r) - r)] - [(and (pair? ad) - (eq? (syntax-e (car ad)) - 'code:line)) - (strip-comments (append (cdr ad) (cdr body)))] - [else (cons (strip-comments a) - (strip-comments (cdr body)))])] - [else body])) - + [(syntax? body) + (define r (strip-comments (syntax-e body))) + (if (eq? r (syntax-e body)) + body + (datum->syntax body r body body))] + [(pair? body) + (define a (car body)) + (define ad (syntax-e a)) + (cond + [(and (pair? ad) + (memq (syntax-e (car ad)) + '(code:comment + code:contract))) + (strip-comments (cdr body))] + [(eq? ad 'code:blank) + (strip-comments (cdr body))] + [(and (or (eq? ad 'code:hilite) + (eq? ad 'code:quote)) + (let* ([d (cdr body)] + [dd (if (syntax? d) + (syntax-e d) + d)]) + (and (pair? dd) + (or (null? (cdr dd)) + (and (syntax? (cdr dd)) + (null? (syntax-e (cdr dd)))))))) + (define d (cdr body)) + (define r + (strip-comments (car (if (syntax? d) (syntax-e d) d)))) + (if (eq? ad 'code:quote) + `(quote ,r) + r)] + [(and (pair? ad) + (eq? (syntax-e (car ad)) + 'code:line)) + (strip-comments (append (cdr ad) (cdr body)))] + [else (cons (strip-comments a) + (strip-comments (cdr body)))])] + [else body])) + (define-for-syntax (extract-chunks exprs) (let loop ([exprs exprs]) (syntax-case exprs () @@ -120,31 +154,63 @@ [_ (loop #'exprs)])]))) +(require racket/stxparam) +(define-syntax-parameter mbeg #'#%module-begin) + (define-for-syntax ((make-module-begin submod?) stx) (syntax-case stx () - [(_ body0 . body) - (let ([expanded - (expand `(,#'module scribble-lp-tmp-name scribble/private/lp - ,@(strip-context #'(body0 . body))))]) - (syntax-case expanded () - [(module name lang (mb . stuff)) - (begin (extract-chunks #'stuff) - #`(#%module-begin - (tangle body0) - ;; The `doc` submodule allows a `scribble/lp` module - ;; to be provided to `scribble`: - #,@(if submod? + [(mb lng . _) + (let () + ;; TODO: get the actual symbol, instead of the string returned by scribble's at-reader + (define lng-sym (string->symbol (regexp-replace "^ " (syntax-e #'lng) ""))) + (dynamic-require lng-sym #f) + (define ns1 (module->namespace lng-sym)) + ;(define ns2 (make-empty-namespace)) + ;(namespace-attach-module ns1 'typed/racket ns2) + (displayln ns1) + ;(displayln ns2) + (parameterize ([current-namespace ns1]) + (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 (let ([submod (strip-context #`(module doc scribble/doclang2 (require scribble/manual - (only-in scribble/private/lp chunk CHUNK)) + (only-in hyper-literate/typed/private/lp chunk CHUNK)) (begin body0 . body)))]) (syntax-case submod () [(_ . rest) (datum->syntax submod (cons #'module* #'rest))]))) - '())))]))])) + '())|#))]))])) (define-syntax module-begin/plain (make-module-begin #f)) (define-syntax module-begin/doc (make-module-begin #t)) diff --git a/typed/lang/lang.rkt b/typed/lang/lang.rkt index 4daed8bf..681a1fbb 100644 --- a/typed/lang/lang.rkt +++ b/typed/lang/lang.rkt @@ -5,4 +5,4 @@ (provide (except-out (all-from-out "common.rkt") module-begin/plain module-begin/doc) - (rename-out [module-begin/doc #%module-begin])) + (rename-out [module-begin/plain #%module-begin])) diff --git a/typed/lang/reader.rkt b/typed/lang/reader.rkt index 057733b3..cf672b17 100644 --- a/typed/lang/reader.rkt +++ b/typed/lang/reader.rkt @@ -1,7 +1,7 @@ #lang s-exp syntax/module-reader ;; Forked from scribble-lib/scribble/lp/lang/reader.rkt -scribble/lp/lang/lang +hyper-literate/typed/lang/lang #:read read-inside #:read-syntax read-syntax-inside diff --git a/typed/private/lp.rkt b/typed/private/lp.rkt index 1fe016b0..4aa3778c 100644 --- a/typed/private/lp.rkt +++ b/typed/private/lp.rkt @@ -81,6 +81,8 @@ #'(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) chunk CHUNK)