From f7ec1fbb5f120dec1e063e337cfe0817df321201 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Tue, 25 Apr 2017 17:51:20 +0200
Subject: [PATCH] Allow customization of the at-exp character.

---
 lang/meta-first-line.rkt | 372 ++++-----------------------------------
 private/common.rkt       |  22 ++-
 2 files changed, 48 insertions(+), 346 deletions(-)

diff --git a/lang/meta-first-line.rkt b/lang/meta-first-line.rkt
index 094ac886..21e20c62 100644
--- a/lang/meta-first-line.rkt
+++ b/lang/meta-first-line.rkt
@@ -3,6 +3,7 @@
 (require scribble/reader
          racket/port
          racket/syntax
+         syntax/stx
          syntax/strip-context
          "first-line-utils.rkt"
          (only-in "../comment-reader.rkt" make-comment-readtable)
@@ -11,359 +12,48 @@
 (provide meta-read-inside
          meta-read-syntax-inside)
 
-(define (make-at-reader+comments #:syntax? [syntax? #t] #:inside? [inside? #f])
+(define (make-at-reader+comments #:syntax? [syntax? #t]
+                                 #:inside? [inside? #f]
+                                 #:char [command-char #\@])
   (make-at-reader
    #:syntax? syntax?
    #:inside? inside?
+   #:command-char command-char
    #:datum-readtable (λ (rt)
                        (make-comment-readtable
                         #:readtable rt
                         #:comment-wrapper '#%comment
                         #:unsyntax #f))))
 
+(define (get-command-char rd1)
+  (define rd1-datum (if (syntax? rd1) (syntax->datum rd1) rd1))
+  (if (and (pair? rd1-datum)
+           (keyword? (car rd1-datum))
+           (= 1 (string-length (keyword->string (car rd1-datum)))))
+      (values (string-ref (keyword->string (car rd1-datum)) 0)
+              (if (syntax? rd1)
+                  (datum->syntax rd1 (stx-cdr rd1) rd1 rd1)
+                  (cdr rd1)))
+      (values #\@ rd1)))
 
 (define (meta-read-inside in . args)
   (define rd1 (read-whole-first-line in))
-  (define rd (apply (make-at-reader+comments #:syntax? #f #:inside? #t)
+  (define-values (at-exp-char new-rd1) (get-command-char #'rd1))
+  (define rd (apply (make-at-reader+comments #:syntax? #f
+                                             #:inside? #t
+                                             #:char at-exp-char)
                     args))
-  `(,rd1 . ,rd))
-
-#;(begin
-  (require (rename-in syntax/parse [...+ …+])
-           syntax/stx
-           racket/match
-           racket/set
-           racket/list
-           racket/function
-           racket/vector
-           racket/contract
-           sexp-diff
-           racket/pretty
-           rackunit
-           (only-in racket/base [... …])
-           (for-syntax (rename-in racket/base [... …])))
-
-  (define first-comments/c
-    (flat-rec-contract R (cons/c (or/c #f (cons/c (syntax/c 'saved-props+srcloc)
-                                                  R)) #| nested |#
-                                 (listof syntax?) #| comments |#)))
-  (define comments-after/c
-    (listof syntax?))
-
-  (define/contract (with-first-comments e c)
-    (-> syntax?
-        (or/c #f first-comments/c)
-        syntax?)
-    (if (or (not c) (and (= (length c) 1) (not (first c))))
-        e
-        (syntax-property e 'first-comments c)))
-  
-  (define/contract (with-comments e c)
-    (-> syntax? (or/c #f comments-after/c) syntax?)
-    (if (or (not c) (null? c))
-        e
-        (syntax-property e 'comments-after c)))
-
-  ;;    ([#%comment c1] a [#%comment c2] . ([#%comment c3] b [#%comment c4]))
-  ;; => (aᶜ² . (bᶜ⁴)⁻ᶜ³)⁻ᶜ¹
-  ;;    (c1 a c2 . (c3 . (c4 b c5)))
-  ;; => (aᶜ² . (bᶜ⁵)⁻ᶜ³⁻⁻ᶜ⁴)⁻ᶜ¹
-  ;;    (c1 a c2 . (c3 . (c4 c5)))
-  ;; => (aᶜ² . ()⁻ᶜ³⁻⁻ᶜ⁴ᶜ⁵)⁻ᶜ¹
-  ;;    (c1 a (c2) b)
-  ;; => (a ()⁻ᶜ² b)⁻ᶜ¹
-  ;;    (c1 a (c2 . b) c)
-  ;; => (a b⁻ᶜ² c)⁻ᶜ¹
-  ;;    (c1 a (c2 . (c3 c4)) c)
-  ;; => (a ()⁻ᶜ²⁻⁻ᶜ³ᶜ⁴ c)⁻ᶜ¹
-  (define (hide-#%comment stx)
-    (match (syntax-e stx)
-      [(not (? pair?))
-       ;; TODO: recurse down vectors etc.
-       stx]
-      [(list* e* ... rest)
-       (syntax-parse e*
-         #:datum-literals (#%comment)
-         [({~and c₀ [#%comment . _]} …
-           {~seq {~and eᵢ {~not [#%comment . _]}}
-                 {~and cᵢⱼ [#%comment . _]} …}
-           …+)
-          (define new-e* (map with-comments
-                              (map hide-#%comment
-                                   (syntax->list #'(eᵢ …)))
-                              (map syntax->list
-                                   (syntax->list #'((cᵢⱼ …) …)))))
-          (define new-rest (if (null? rest)
-                               rest
-                               (hide-#%comment rest)))
-          (with-first-comments
-           (datum->syntax stx (append new-e* new-rest) stx stx)
-           (cons #f (syntax->list #'(c₀ …))))]
-         [({~and c₀ [#%comment . _]} …)
-          (define new-rest (if (null? rest)
-                               rest
-                               (hide-#%comment rest)))
-          (with-first-comments
-           (with-comments
-            (datum->syntax stx new-rest stx stx)
-            (if (syntax? new-rest)
-                (syntax-property new-rest 'comments-after)
-                '()))
-           (cons (if (syntax? new-rest)
-                     (cons (datum->syntax new-rest
-                                          'saved-props+srcloc
-                                          new-rest
-                                          new-rest)
-                           (or (syntax-property new-rest 'first-comments)
-                               ;; TODO: I'm dubious about this, better typecheck
-                               ;; everything…
-                               (cons #f null)))
-                     #f)
-                 (syntax->list #'(c₀ …))))])]))
-
-  (define/contract (extract-first-comments stx)
-    (-> syntax? (or/c #f first-comments/c))
-    (syntax-property stx 'first-comments))
-
-  (define/contract (extract-comments-after stx)
-    (-> syntax? (or/c #f comments-after/c))
-    (syntax-property stx 'comments-after))
-
-  (define/contract (restore-#%comment stx
-                                      #:replace-with (replace-with #f)
-                                      #:scope [scope (datum->syntax #f 'zero)])
-    (->* (syntax?)
-         (#:replace-with [or/c #f syntax? (-> syntax? syntax?)]
-          #:scope identifier?)
-         syntax?)
-    (define (erase-props stx)
-      (define stx* (if (syntax-property stx 'first-comments)
-                       (syntax-property stx 'first-comments #f)
-                       stx))
-      (if (syntax-property stx* 'comments-after)
-          (syntax-property stx* 'comments-after #f)
-          stx*))
-    (define (recur stx)
-      (restore-#%comment stx #:replace-with replace-with #:scope scope))
-    (define (replace-in commentᵢ)
-      (syntax-parse commentᵢ
-        #:datum-literals (#%comment)
-        [({~and c #%comment} . rest)
-         (if (syntax? replace-with)
-             (datum->syntax commentᵢ
-                            `(,(datum->syntax #'c replace-with #'c #'c)
-                              . ,((make-syntax-delta-introducer
-                                   scope
-                                   (datum->syntax #f 'zero))
-                                  #'rest
-                                  'add))
-                            commentᵢ
-                            commentᵢ)
-             (replace-with
-              (datum->syntax commentᵢ
-                             `(,#'c
-                               . ,((make-syntax-delta-introducer
-                                    scope
-                                    (datum->syntax #f 'zero))
-                                   #'rest
-                                   'add))
-                             commentᵢ
-                             commentᵢ)))]
-        [_
-         commentᵢ]))
-    (define (replace-in-after comments)
-      (if replace-with
-          (if (eq? comments #f)
-              comments
-              (stx-map replace-in comments))
-          comments))
-    (define (replace-in-first first-comments)
-      (define (replace-in-first1 first-comments)
-        (if (eq? first-comments #f)
-            first-comments
-            (cons (cons (caar first-comments)
-                        (replace-in-first1 (cdar first-comments)))
-                  (stx-map replace-in (cdr first-comments)))))
-      (if replace-with
-          (if (eq? first-comments #f)
-              first-comments
-              (cons (replace-in-first1 (car first-comments))
-                    (stx-map replace-in (cdr first-comments))))
-          first-comments))
-    (match (syntax-e stx)
-      [(list* e* ... rest)
-       ;; TODO: when extracting the comments properties, check that they have
-       ;; the right shape (listof syntax?) or (*list/c syntax? (list/c R))
-       ;; Or append-map when stx is a stx-list (not in a tail position for the
-       ;;                                       comments-after)
-       (define new-e*
-         (append-map (λ (eᵢ)
-                       (cons (recur eᵢ)
-                             (or (replace-in-after (extract-comments-after eᵢ))
-                                 '())))
-                     e*))
-       (define new-rest
-         (if (syntax? rest)
-             (recur rest)
-             ;; TODO: handle vectors etc. here?
-             rest))
-       (define first-comments
-         (or (replace-in-first (extract-first-comments stx))
-             #f))
-       (define (nest first-comments to-nest)
-         (cond
-           [(eq? first-comments #f)
-            to-nest]
-           [(eq? (car first-comments) #f)
-            (append (cdr first-comments) to-nest)]
-           [else
-            (nest1 first-comments to-nest)]))
-       (define (nest1 first-comments to-nest)
-         (if (eq? first-comments #f)
-             to-nest
-             (append (cdr first-comments)
-                     (datum->syntax (caar first-comments)
-                                    (nest (cdar first-comments) to-nest)))))
-       (define new-stx
-         (nest first-comments (append new-e* new-rest)))
-       (erase-props (datum->syntax stx new-stx stx stx))]
-      ;; TODO: recurse down vectors etc.
-      [(? vector? v)
-       ;; TODO: what if there is a first-comment property on the vector itself?
-       (erase-props
-        (datum->syntax stx
-                       (vector-map (λ (vᵢ)
-                                     (recur vᵢ))
-                                   v)
-                       stx
-                       stx))]
-      [other
-       'TODO…
-       other]))
-
-  (define (annotate-syntax e #:srcloc+scopes? [srcloc+scopes? #f])
-    (cond
-      [(syntax? e)
-       (append
-        (list 'syntax
-              (append-map (λ (kᵢ)
-                            (if (and (or (eq? kᵢ 'first-comments)
-                                         (eq? kᵢ 'comments-after))
-                                     (not (syntax-property e kᵢ)))
-                                (list)
-                                (list kᵢ (syntax-property e kᵢ))))
-                         (syntax-property-symbol-keys e)))
-        (if srcloc+scopes?
-            (list (syntax-source e)
-                  (syntax-line e)
-                  (syntax-column e)
-                  (syntax-position e)
-                  (syntax-span e)
-                  (syntax-source-module e)
-                  (hash-ref (syntax-debug-info e) 'context))
-            (list))
-        (list (annotate-syntax (syntax-e e) #:srcloc+scopes? srcloc+scopes?)))]
-      [(null? e)
-       'null]
-      [(list? e)
-       (list 'list
-             (map (λ (eᵢ) (annotate-syntax eᵢ #:srcloc+scopes? srcloc+scopes?))
-                  e))]
-      [(pair? e)
-       (list 'cons
-             (annotate-syntax (car e) #:srcloc+scopes? srcloc+scopes?)
-             (annotate-syntax (cdr e) #:srcloc+scopes? srcloc+scopes?))]
-      [(vector? e)
-       (list 'vector
-             (immutable? e)
-             (map (λ (eᵢ) (annotate-syntax eᵢ #:srcloc+scopes? srcloc+scopes?))
-                  (vector->list e)))]
-      [(symbol? e)
-       e]
-      [(string? e)
-       e]
-      [else
-       (raise-argument-error
-        'annotate-syntax
-        (string-append "a syntax object containing recursively on of the"
-                       " following: pair, null, vector, symbol, string")
-        0
-        e)]))
-
-  (define (same-syntax! a b)
-    (define answer (equal? (annotate-syntax a #:srcloc+scopes? #f)
-                           (annotate-syntax b #:srcloc+scopes? #f)))
-    (unless answer
-      (pretty-write
-       (sexp-diff (annotate-syntax a)
-                  (annotate-syntax b)))
-      (displayln a)
-      (displayln b))
-    answer)
-      
-  (define-syntax (check-same-syntax stx)
-    (syntax-case stx ()
-      [(_ a b)
-       (datum->syntax #'here
-                      `(check-true (same-syntax! ,#'a ,#'b))
-                      stx)]))
-  
-  (module+ test
-    (require rackunit)
-    (let ([stx #'(a b c)])
-      (check-same-syntax stx (hide-#%comment stx))))
-  
-  (define round-trip (compose restore-#%comment hide-#%comment))
-    
-  (module+ test
-    (define-syntax (check-round-trip stx)
-      (syntax-case stx ()
-        [(_ a)
-         (datum->syntax #'here
-                        `(begin
-                           (check-same-syntax (round-trip ,#'a) ,#'a)
-                           (check-equal? (syntax->datum (round-trip ,#'a))
-                                         (syntax->datum ,#'a)))
-                        stx)]))
-  
-    (check-round-trip #'(a (#%comment "b") c))
-  
-    (check-round-trip #'((#%comment "0") (#%comment "1")
-                                         a
-                                         (#%comment "b")
-                                         (#%comment "bb")
-                                         c
-                                         (#%comment "d")
-                                         (#%comment "dd")))
-    (check-round-trip #'([#%comment c1]
-                         a
-                         [#%comment c2]
-                         . ([#%comment c3] b [#%comment c4])))
-    (check-round-trip #'([#%comment c1]
-                         a
-                         [#%comment c2]
-                         . ([#%comment c3]
-                            . ([#%comment c4] b [#%comment c5]))))
-    (check-round-trip #'([#%comment c1]
-                         a
-                         [#%comment c2]
-                         . ([#%comment c3]
-                            . ([#%comment c4] [#%comment c5]))))
-    (check-round-trip #'([#%comment c1]
-                         a
-                         ([#%comment c2])
-                         b))
-    (check-round-trip #'([#%comment c1]
-                         a
-                         ([#%comment c2] . b)
-                         c)))
-  )
+  `(,new-rd1 . ,rd))
 
 (define (meta-read-syntax-inside source-name in . args)
-  (with-syntax* ([rd1 (read-syntax-whole-first-line source-name in)]
-                 [rd (apply (make-at-reader+comments #:syntax? #t #:inside? #t)
-                            source-name
-                            in
-                            args)]
-                 [rd-hide (hide-#%comment #'rd)])
-    #'(rd1 . rd-hide)))
\ No newline at end of file
+  (with-syntax ([rd1 (read-syntax-whole-first-line source-name in)])
+    (let-values ([(command-char new-rd1) (get-command-char #'rd1)])
+      (with-syntax* ([new-rd1-stx new-rd1]
+                     [rd (apply (make-at-reader+comments #:syntax? #t
+                                                         #:inside? #t
+                                                         #:char command-char)
+                                source-name
+                                in
+                                args)]
+                     [rd-hide (hide-#%comment #'rd)])
+        #'(new-rd1-stx . rd-hide)))))
\ No newline at end of file
diff --git a/private/common.rkt b/private/common.rkt
index 96c9e8fa..797f750b 100644
--- a/private/common.rkt
+++ b/private/common.rkt
@@ -151,11 +151,12 @@
 ;; module meta-languages.
 (define-syntax (continue stx)
   (syntax-case stx ()
-    [(_self lang-module-begin . body)
+    [(_self lang-module-begin maybe-chain₊ . body)
      (let ()
+       (define ch₊ (syntax->list #'maybe-chain₊))
        (define expanded (local-expand 
                          (datum->syntax stx
-                                        `(,#'lang-module-begin . ,#'body)
+                                        `(,#'lang-module-begin ,@ch₊ . ,#'body)
                                         stx
                                         stx)
                          'module-begin 
@@ -173,8 +174,15 @@
 (define-for-syntax ((make-module-begin submod?) stx)
   (syntax-parse stx
     ;; #:no-require-lang is ignored, but still allowed for compatibility.
-    [(_modbeg (lang:id (~optional (~and no-require-lang #:no-require-lang))
-                       (~optional (~and no-auto-require #:no-auto-require)))
+    ;; TODO: semantically, the no-require-lang and no-auto-require should be
+    ;; before the lang, as they are arguments to hyper-literate itself.
+    [(_modbeg {~or (lang:id
+                    {~optional (~and no-require-lang #:no-require-lang)}
+                    {~optional (~and no-auto-require #:no-auto-require)})
+                   (({~optional (~and no-require-lang #:no-require-lang)}
+                     {~optional (~and no-auto-require #:no-auto-require)}
+                     lang:id
+                     . chain₊))}
               body0 . body)
      (let ()
        (define lang-sym (syntax-e #'lang))
@@ -248,7 +256,11 @@
                                 (begn body0 . body)))))
                         '())
                  (require lang)
-                 (continue lang-modbeg tngl)) ;; TODO: put . tngl and remove the (begin _)
+                 (continue lang-modbeg
+                           #,(if (attribute chain₊)
+                                 #'(chain₊)
+                                 #'())
+                           tngl)) ;; TODO: put . tngl and remove the (begin _)
               )])))]))
 
 (define-syntax module-begin/plain (make-module-begin #f))