From 213253f5313ea720e7d2fb4914f5b2637c7b23a2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Fri, 29 Jul 2016 17:12:57 +0200
Subject: [PATCH] Bug #1402 on phc-adt/test/test-structure-low-level.rkt
 43fd1bad4173baad0ede84e8ed88f917eec7b327

---
 main.rkt           | 11 ++++++---
 private/common.rkt | 58 ++++++++++++++++++++++++++++++----------------
 private/lp.rkt     | 35 +++++++++++++++++-----------
 3 files changed, 67 insertions(+), 37 deletions(-)

diff --git a/main.rkt b/main.rkt
index 104aff7e..64f3da67 100644
--- a/main.rkt
+++ b/main.rkt
@@ -2,11 +2,16 @@
 
 (require (for-syntax racket/base
                      racket/syntax)
-         scribble/lp2)
+         (except-in scribble/lp2 chunk CHUNK))
 
-(provide ck defck repeat-chunk)
+(require (only-in hyper-literate/private/lp
+                  chunk
+                  CHUNK))
 
-(define-syntax-rule (ck e) e)
+(provide defck
+         repeat-chunk
+         chunk
+         CHUNK)
 
 (define-syntax (defck stx)
   (syntax-case stx ()
diff --git a/private/common.rkt b/private/common.rkt
index 283faddb..e4aea319 100644
--- a/private/common.rkt
+++ b/private/common.rkt
@@ -6,7 +6,8 @@
          module-begin/doc)
 
 (require (for-syntax racket/base syntax/boundmap racket/list
-                     syntax/strip-context))
+                     syntax/strip-context
+                     syntax/srcloc))
 
 (begin-for-syntax
   (define first-id #f)
@@ -185,25 +186,42 @@
                  tngl
                  #,@(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))])))
+                         (with-syntax*
+                             ([ctx #'body0 #;(syntax-local-introduce #'body0)]
+                              ;; TODO: this is a hack, it would be nice to get
+                              ;; the actual source location of the lang.
+                              [bd1 (update-source-location #'body0
+                                                           #:line #f
+                                                           #:column #f
+                                                           #:position 7
+                                                           #:span 14)]
+                              [lng (datum->syntax #'ctx 'scribble/doclang2 #'bd1 #'bd1)]
+                              [begn (datum->syntax #'ctx 'begin)])
+                           #`(module* doc lng ;module doc scribble/doclang2
+                               #,@(syntax-local-introduce
+                                   ;; TODO: instead use:
+                                   ;; (begin-for-syntax (set! preexpanding #f))
+                                   ;; and make these identifiers exported by
+                                   ;; hyper-literate
+                                   (strip-context
+                                    #'((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
+                                                hyper-literate))))
+                               #,(datum->syntax #'ctx
+                                                `(require ,(datum->syntax #'bd1 'scribble/manual #'bd1 #'bd1)
+                                                          ,(datum->syntax #'bd1 'hyper-literate #'bd1 #'bd1)
+                                                          #;(only-in scribble/private/lp chunk CHUNK)))
+                               (begn body0 . body))
+                           ;(strip-context
+                           #;#`(modl doc lng ;module doc scribble/doclang2
+                                     
+                                     (begn body0 . body))))
                         '())))])))]))
 
 (define-syntax module-begin/plain (make-module-begin #f))
diff --git a/private/lp.rkt b/private/lp.rkt
index 26df6c2b..f9057dc9 100644
--- a/private/lp.rkt
+++ b/private/lp.rkt
@@ -1,7 +1,10 @@
 #lang scheme/base
 ;; Forked from scribble-lib/scribble/private/lp.rkt
 
-(require (for-syntax scheme/base syntax/boundmap)
+(require (for-syntax scheme/base
+                     syntax/boundmap
+                     syntax/parse
+                     racket/syntax)
          scribble/scheme scribble/decode scribble/manual scribble/struct)
 
 (begin-for-syntax
@@ -16,8 +19,8 @@
     (free-identifier-mapping-put! chunk-numbers id 2)))
 
 (define-for-syntax ((make-chunk racketblock) stx)
-  (syntax-case stx ()
-    [(_ name expr ...)
+  (syntax-parse stx
+    [(_ (~optional (~seq #:save-as save-as)) name expr ...)
      ;; no need for more error checking, using chunk for the code will do that
      (identifier? #'name)
      (let* ([n (get-chunk-number (syntax-local-introduce #'name))]
@@ -56,16 +59,10 @@
                            (syntax->list #'(expr ...)))]
                      
                      [(rest ...) (if n
-                                           #`((subscript #,(format "~a" n)))
-                                           #`())])
-         #`(begin
-             (require (for-label for-label-mod ... ...))
-             #,@(if n
-                    #'()
-                    #'((define-syntax name (make-element-id-transformer
-                                            (lambda (stx) #'(chunkref name))))
-                       (begin-for-syntax (init-chunk-number #'name))))
-             (make-splice
+                                     #`((subscript #,(format "~a" n)))
+                                     #`())])
+         (define/with-syntax pre-content
+           #`(make-splice
               (list (make-toc-element
                      #f
                      (list (elemtag '(prefixable tag)
@@ -73,7 +70,17 @@
                      (list (smaller (elemref '(prefixable tag) #:underline? #f
                                              str
                                              rest ...))))
-                    (#,racketblock expr ...))))))]))
+                    (#,racketblock expr ...))))
+         #`(begin
+             (require (for-label for-label-mod ... ...))
+             #,@(if n
+                    #'()
+                    #'((define-syntax name (make-element-id-transformer
+                                            (lambda (stx) #'(chunkref name))))
+                       (begin-for-syntax (init-chunk-number #'name))))
+             #,(if (attribute save-as)
+                   #'(define-syntax (save-as s) (syntax pre-content))
+                   #'pre-content))))]))
 
 (define-syntax chunk (make-chunk #'racketblock))
 (define-syntax CHUNK (make-chunk #'RACKETBLOCK))