core: fix the prefix system

The ordering of prefixes matter. Unbreakable prefixes and
breakable prefixes can be interleaved, so we can't store
their information in two separate channels.

Fixes #49

common.rkt

@@ -18,7 +18,9 @@
 (struct thing () #:transparent)
 (struct commentable thing (inline-comment) #:transparent)
 (struct visible commentable () #:transparent)
-(struct node visible (opener closer prefix breakable-prefix content) #:transparent)
+
+;; prefix :: (listof (cons (or/c 'breakable 'unbreakable) string?))
+(struct node visible (opener closer prefix content) #:transparent)
 (struct atom visible (content type) #:transparent)
 (struct full-atom atom () #:transparent)
 ;; invariant: n >= 1

conventions.rkt

@@ -225,7 +225,7 @@
 (define-pretty (format-clause-2/indirect #:kw-map [kw-map default-kw-map] #:flat? [flat? #t])
   #:type values
   (match doc
-    [(node _ (or "(" "[") (or ")" "]") #f #f xs)
+    [(node _ (or "(" "[") (or ")" "]") '() xs)
      ;; general case
      (alt (cost '(0 0 1)
                 (pretty-node
@@ -250,7 +250,7 @@
 (define-pretty format-binding-pairs/indirect
   #:type values
   (match doc
-    [(node _ _ _ #f #f xs)
+    [(node _ _ _ '() xs)
      (pretty-node
       (try-indent
        #:n 0
@@ -264,7 +264,7 @@
 (define-pretty format-define-args/indirect
   #:type values
   (match doc
-    [(node _ _ _ #f #f xs)
+    [(node _ _ _ '() xs)
      (pretty-node
       (try-indent
        #:n 0

core.rkt

@@ -66,7 +66,7 @@
                      ['block-comment (big-text content)]
                      [_ (text content)]))]
                  [(line-comment comment) (full (text comment))]
-                 [(node _ _ _ _ _ xs)
+                 [(node _ _ _ _ xs)
                   (match (extract xs (list #f))
                     [#f ((hook #f) d)]
                     [(list (list (atom _ content 'symbol)) _ _) ((hook content) d)]
@@ -86,17 +86,19 @@
     (set-box! current-pretty #f)))
 
 (define (pretty-node* n d #:node [the-node n] #:unfits [unfits '()] #:adjust [adjust '("(" ")")])
-  (match-define (node comment opener closer prefix breakable-prefix _) the-node)
+  (match-define (node comment opener closer prefix _) the-node)
   (define doc
     (pretty-comment comment
-                    (<+> (text (string-append (or prefix "") (if adjust (first adjust) opener)))
+                    (<+> (text (if adjust (first adjust) opener))
                          d
                          (text (if adjust (second adjust) closer)))))
   (define doc*
-    (if breakable-prefix
-        (alt (<$> (text breakable-prefix) doc)
-             (<+> (text breakable-prefix) doc))
-        doc))
+    (for/fold ([doc doc]) ([prefix (in-list (reverse prefix))])
+      (match prefix
+        [(cons 'breakable tk)
+         (alt (<$> (text tk) doc) (<+> (text tk) doc))]
+        [(cons 'unbreakable tk)
+         (<+> (text tk) doc)])))
   (match unfits
     ['() doc*]
     [_ (<$> (v-concat (map (unbox current-pretty) unfits)) doc*)]))

read.rkt

@@ -78,7 +78,7 @@
                        [(equal? closer-sym closer)
                         (define-values (this xs*)
                           (process-tail
-                           (node #f open-paren closer-text #f #f (dropf (reverse (dropf acc newl?)) newl?))
+                           (node #f open-paren closer-text '() (dropf (reverse (dropf acc newl?)) newl?))
                            xs))
                         (values (done this) xs*)]
                        [else

realign.rkt

@@ -32,16 +32,15 @@
             ['()
              #:when (not just-read-sexp-comment?)
              (match visible
-               [(node comment opener closer prefix breakable-prefix content)
+               [(node comment opener closer prefix content)
                 (cons
                  (sexp-comment comment
                                'disappeared
                                ""
                                (list (struct-copy node
                                                   visible
                                                   [inline-comment #:parent commentable #f]
-                                                  [breakable-prefix
-                                                   (string-append "#;" (or breakable-prefix ""))])))
+                                                  [prefix (cons (cons 'breakable "#;") prefix)])))
                  xs)]
                [_ (cons (sexp-comment (commentable-inline-comment visible)
                                       'any
@@ -65,13 +64,12 @@
             (match visible
               ;; don't create a new wrapper, just transfer content
               [(wrapper _ tk* _) (struct-copy wrapper visible [tk (string-append tk tk*)])]
-              [(node _ _ _ prefix breakable-prefix _)
-               (case (string-length tk)
-                 [(1) (struct-copy node visible [prefix (string-append tk (or prefix ""))])]
-                 [else (struct-copy node
-                                    visible
-                                    [breakable-prefix (string-append tk (or breakable-prefix ""))])])]
+              [(node _ _ _ prefix _)
+               (match tk
+                 [(app string-length 1)
+                  (struct-copy node visible [prefix (cons (cons 'unbreakable tk) prefix)])]
+                 [_ (struct-copy node visible [prefix (cons (cons 'breakable tk) prefix)])])]
               [_ (wrapper (commentable-inline-comment visible) tk (strip-comment visible))])
             xs))])]
-      [(cons (node comment opener closer prefix breakable-prefix xs*) xs)
-       (cons (node comment opener closer prefix breakable-prefix (loop xs* #f)) (loop xs #f))])))
+      [(cons (node comment opener closer prefix xs*) xs)
+       (cons (node comment opener closer prefix (loop xs* #f)) (loop xs #f))])))

tests/test-cases/test-quasisyntax.rkt

@@ -0,0 +1 @@
+#`'#,(abc def)

tests/test-cases/test-quasisyntax.rkt.out

@@ -0,0 +1 @@
+#`'#,(abc def)