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

First step towards a parameterizable meta-language

Browse Source
This commit is contained in:
Georges Dupéron 2016-06-16 18:47:16 +02:00
parent 21cd1f3ae3
commit e785765209
2 changed files with 17 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
test/test.hl.rkt
View File

@ -1,4 +1,4 @@
#lang hyper-literate/typed racket #lang hyper-literate/typed typed/racket
@;((curry + 1) 2) @;((curry + 1) 2)

64
typed/lang/common.rkt
View File

@ -8,38 +8,6 @@
(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)
@ -94,8 +62,8 @@
(syntax-local-introduce u))) (syntax-local-introduce u)))
(mapping-get chunk-groups m))) (mapping-get chunk-groups m)))
chunk-mentions)]) chunk-mentions)])
;(displayln (dynamic-require 'typed/racket '#%module-begin)) ;(displayln (dynamic-require 'tyyyyyyyyyyyped/racket '#%module-begin))
(replace-context #'modbeg-ty (replace-context #'#%module-begin;modbeg-ty
#`(begin 'xxx body ... (let ([b-id (void)]) b-use) ...)))) #`(begin 'xxx body ... (let ([b-id (void)]) b-use) ...))))
(define-for-syntax (strip-comments body) (define-for-syntax (strip-comments body)
@ -157,6 +125,8 @@
(require racket/stxparam) (require racket/stxparam)
(define-syntax-parameter mbeg #'#%module-begin) (define-syntax-parameter mbeg #'#%module-begin)
;(require (only-in tyyyyyyyyyyyped/racket))
(define-for-syntax ((make-module-begin submod?) stx) (define-for-syntax ((make-module-begin submod?) stx)
(syntax-case stx () (syntax-case stx ()
[(mb lng . _) [(mb lng . _)
@ -166,29 +136,27 @@
(dynamic-require lng-sym #f) (dynamic-require lng-sym #f)
(define ns1 (module->namespace lng-sym)) (define ns1 (module->namespace lng-sym))
;(define ns2 (make-empty-namespace)) ;(define ns2 (make-empty-namespace))
;(namespace-attach-module ns1 'typed/racket ns2) ;(namespace-attach-module ns1 'tyyyyyyyyyyyped/racket ns2)
(displayln ns1) ;(displayln ns1)
;(displayln ns2) ;(displayln ns2)
(parameterize ([current-namespace ns1]) (parameterize ([current-namespace ns1])
(displayln (namespace-symbol->identifier '#%module-begin)) (namespace-require `(for-meta -1 ,lng-sym))
(displayln (namespace-syntax-introduce #'#%module-begin)) #|(displayln (namespace-symbol->identifier '#%module-begin))
(displayln (replace-context
(namespace-symbol->identifier '#%module-begin)
#'#%module-begin))|#
(replace-context (replace-context
(namespace-symbol->identifier '#%module-begin) (namespace-symbol->identifier '#%module-begin)
#'(#%module-begin #'(#%module-begin
(ann (cons 1 'b) (Pairof Number Symbol)) (+ 'a)
((make-predicate (Pairof Number Symbol)) (cons 1 'b)))) #;(ann (cons 1 'b) (Pairof Number Symbol))
#;((make-predicate (Pairof Number Symbol)) (cons 1 'b))))
#;(namespace-syntax-introduce #;(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 () #;(syntax-case stx ()
[(_ body0 . body) [(_ body0 . body)
(let ([expanded (let ([expanded
(expand `(,#'module scribble-lp-tmp-name scribble/private/lp;hyper-literate/typed/private/lp (expand `(,#'module scribble-lp-tmp-name scribble/private/lp;hyper-literate/tyyyyyyyyyyyped/private/lp
,@(strip-context #'(body0 . body))))]) ,@(strip-context #'(body0 . body))))])
(syntax-case expanded () (syntax-case expanded ()
[(module name lang (mb . stuff)) [(module name lang (mb . stuff))
@ -205,7 +173,7 @@
(strip-context (strip-context
#`(module doc scribble/doclang2 #`(module doc scribble/doclang2
(require scribble/manual (require scribble/manual
(only-in hyper-literate/typed/private/lp chunk CHUNK)) (only-in hyper-literate/tyyyyyyyyyyyped/private/lp chunk CHUNK))
(begin body0 . body)))]) (begin body0 . body)))])
(syntax-case submod () (syntax-case submod ()
[(_ . rest) [(_ . rest)