From 17dbb37e82e93260f0add0c3563f7fbaca27446e Mon Sep 17 00:00:00 2001
From: William G Hatch <william@hatch.uno>
Date: Mon, 19 Sep 2016 20:47:19 -0600
Subject: [PATCH] add initial version

---
 .gitignore             |   2 +
 info.rkt               |   6 ++
 udelim/lang/reader.rkt |  56 ++++++++++++++++
 udelim/main.rkt        | 143 +++++++++++++++++++++++++++++++++++++++++
 4 files changed, 207 insertions(+)
 create mode 100644 .gitignore
 create mode 100644 info.rkt
 create mode 100644 udelim/lang/reader.rkt
 create mode 100644 udelim/main.rkt

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..c7a9192
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,2 @@
+compiled/
+
diff --git a/info.rkt b/info.rkt
new file mode 100644
index 0000000..ae5e304
--- /dev/null
+++ b/info.rkt
@@ -0,0 +1,6 @@
+#lang info
+
+(define collection 'multi)
+(define deps '("base"
+               ))
+
diff --git a/udelim/lang/reader.rkt b/udelim/lang/reader.rkt
new file mode 100644
index 0000000..9f8a53c
--- /dev/null
+++ b/udelim/lang/reader.rkt
@@ -0,0 +1,56 @@
+(module reader racket/base
+  (require syntax/module-reader
+           udelim
+           )
+
+  (provide (rename-out [at-read read]
+                       [at-read-syntax read-syntax]
+                       [at-get-info get-info]))
+
+  (define udelim-table
+    (make-list-delim-readtable/wrap
+     #\﴾ #\﴿ '#%ornate-parens
+     #:base-readtable
+     (make-list-delim-readtable/wrap
+      #\⸨ #\⸩ '#%double-parens
+      #:base-readtable
+      (make-string-delim-readtable
+       #\“ #\”
+       #:base-readtable
+       (make-string-delim-readtable #\« #\»)))))
+  (define (wrap-reader p)
+    (lambda args
+      (parameterize ([current-readtable udelim-table])
+        (apply p args))))
+
+  (define-values (at-read at-read-syntax at-get-info)
+    (make-meta-reader
+     'udelim
+     "language path"
+     lang-reader-module-paths
+     wrap-reader
+     (lambda (orig-read-syntax)
+       (define read-syntax (wrap-reader orig-read-syntax))
+       (lambda args
+         (define stx (apply read-syntax args))
+         ;(define old-prop (syntax-property stx 'module-language))
+         ;(define new-prop `#(at-exp/lang/language-info get-language-info ,old-prop))
+         ;(syntax-property stx 'module-language new-prop)
+         stx
+         ))
+     (lambda (proc) proc)
+     #;(lambda (proc)
+       (lambda (key defval)
+         (define (fallback) (if proc (proc key defval) defval))
+         (define (try-dynamic-require mod export)
+           (or (with-handlers ([exn:fail? (λ (x) #f)])
+                 (dynamic-require mod export))
+               (fallback)))
+         (case key
+           [(color-lexer)
+            (try-dynamic-require 'syntax-color/scribble-lexer 'scribble-lexer)]
+           [(definitions-text-surrogate)
+            'scribble/private/indentation]
+           [(drracket:indentation)
+            (dynamic-require 'scribble/private/indentation 'determine-spaces)]
+           [else (fallback)]))))))
diff --git a/udelim/main.rkt b/udelim/main.rkt
new file mode 100644
index 0000000..e123710
--- /dev/null
+++ b/udelim/main.rkt
@@ -0,0 +1,143 @@
+#lang racket/base
+
+(provide
+ make-string-delim-readtable
+ make-string-delim-readtable/wrap
+ make-list-delim-readtable
+ make-list-delim-readtable/wrap
+ )
+
+(require syntax/readerr)
+
+(define (make-raise-balance-error l-paren r-paren)
+  (define raise-balance-error
+    (case-lambda
+      [(ch port) (raise-balance-error ch port #f #f #f #f)]
+      [(ch port src line col pos)
+       (raise-read-error (format "unexpected closing delimiter ~a~n" r-paren)
+                         src line col pos #f)]))
+  raise-balance-error)
+
+(define (make-string-reader l-paren r-paren)
+  ;; balance parens, and return the contents as a bare string with no escapes
+  (define string-reader
+    (case-lambda
+      [(ch port) (syntax->datum (string-reader ch port #f #f #f #f))]
+      [(ch port src line col pos)
+       (define-values (n-line n-col n-pos) (port-next-location port))
+       (define (loop ch cur-balance-level ch-so-far)
+         (cond [(equal? eof ch)
+                (error 'string-reader
+                       "unexpected eof, expected ~n more ~a characters"
+                       cur-balance-level r-paren)]
+               [(equal? ch l-paren) (loop (read-char port)
+                                            (add1 cur-balance-level)
+                                            (cons ch ch-so-far))]
+               [(not (equal? ch r-paren)) (loop (read-char port)
+                                                  cur-balance-level
+                                                  (cons ch ch-so-far))]
+               [(> cur-balance-level 1) (loop (read-char port)
+                                              (sub1 cur-balance-level)
+                                              (cons ch ch-so-far))]
+               [(< cur-balance-level 1)
+                ((make-raise-balance-error l-paren r-paren)
+                 src line col pos)]
+               [else
+                (let* ([final-chs (cdr (reverse ch-so-far))]
+                       [span (length final-chs)])
+                  (datum->syntax
+                   #f (apply string final-chs)
+                   (list src n-line n-col n-pos span)))]))
+       (loop ch 0 '())]))
+  string-reader)
+
+(define (make-list-reader l-paren r-paren)
+  (define paren-reader
+    (case-lambda
+      [(ch port) (syntax->datum (paren-reader ch port #f #f #f #f))]
+      [(ch port src line col pos)
+       (define (loop stxs-rev)
+         (let ([next-ch (read-char port)])
+           (if (equal? next-ch r-paren)
+               (datum->syntax #f (reverse stxs-rev))
+               (let ([one-stx (read-syntax/recursive src port next-ch)])
+                 (loop (cons one-stx stxs-rev))))))
+       (loop '())]))
+  paren-reader)
+
+(define (make-delim-reader/wrap unwrapped-reader-maker list? delim-l delim-r wrapper-sym)
+  (define reader (unwrapped-reader-maker delim-l delim-r))
+  (define delim-reader-wrapped
+    (case-lambda
+      [(ch port) (syntax->datum (delim-reader-wrapped ch port #f #f #f #f))]
+      [(ch port src line col pos)
+       (with-syntax ([str-stx (reader ch port src line col pos)])
+         (if list?
+             #`(#,wrapper-sym . str-stx)
+             #`(#,wrapper-sym str-stx)))]))
+  delim-reader-wrapped)
+
+(define (make-string-reader/wrap l r wrapper-sym)
+  (make-delim-reader/wrap make-string-reader #f l r wrapper-sym))
+(define (make-list-reader/wrap l r wrapper-sym)
+  (make-delim-reader/wrap make-list-reader #t l r wrapper-sym))
+
+(define (make-make-delim-readtable make-reader)
+  (λ (l-paren r-paren #:base-readtable [base-readtable #f])
+    (make-readtable
+     base-readtable
+     l-paren 'terminating-macro (make-reader l-paren r-paren)
+     r-paren 'terminating-macro (make-raise-balance-error l-paren r-paren))))
+
+(define (make-make-delim-readtable/wrap make-reader/wrap)
+  (λ (l-paren r-paren wrapper-symbol #:base-readtable [base-readtable #f])
+    (make-readtable
+     base-readtable
+     l-paren 'terminating-macro (make-reader/wrap l-paren r-paren wrapper-symbol)
+     r-paren 'terminating-macro (make-raise-balance-error l-paren r-paren))))
+
+(define make-string-delim-readtable
+  (make-make-delim-readtable make-string-reader))
+(define make-list-delim-readtable
+  (make-make-delim-readtable make-list-reader))
+(define make-string-delim-readtable/wrap
+  (make-make-delim-readtable/wrap make-string-reader/wrap))
+(define make-list-delim-readtable/wrap
+  (make-make-delim-readtable/wrap make-list-reader/wrap))
+
+
+(module+ test
+  (require rackunit)
+
+  (define mytable (make-string-delim-readtable #\{ #\}))
+  (define guillemet-table
+    (make-string-delim-readtable/wrap #\« #\» '#%guillemets))
+  (define ceil-table (make-list-delim-readtable #\⌈ #\⌉))
+  (define ceil-table/wrap (make-list-delim-readtable/wrap #\⌈ #\⌉ '#%ceil))
+
+  (parameterize ([current-readtable mytable])
+    (let ([port (open-input-string "  \"in a string {here\" {hello @{testing 123}foo} }goodbye")])
+      (check-equal? (syntax->datum (read-syntax "foo" port))
+                    "in a string {here")
+      (check-equal? (syntax->datum (read-syntax "foo" port))
+                    "hello @{testing 123}foo")
+      (check-exn exn? (λ () (read-syntax "foo" port)))))
+
+  (parameterize ([current-readtable guillemet-table])
+    (let ([port (open-input-string "  \"in a string «here\" «hello @«testing 123»foo» »goodbye")])
+      (check-equal? (syntax->datum (read-syntax "foo" port))
+                    "in a string «here")
+      (check-equal? (syntax->datum (read-syntax "foo" port))
+                    '(#%guillemets "hello @«testing 123»foo"))
+      (check-exn exn? (λ () (read-syntax "foo" port)))))
+
+  (parameterize ([current-readtable ceil-table])
+    (let ([port (open-input-string "(testing ⌈foo bar ⌈⌉ aoeu⌉ hello) foo")])
+      (check-equal? (syntax->datum (read-syntax "foo" port))
+                    '(testing (foo bar () aoeu) hello))))
+
+  (parameterize ([current-readtable ceil-table/wrap])
+    (let ([port (open-input-string "(testing ⌈foo bar ⌈⌉ aoeu⌉ hello) foo")])
+      (check-equal? (syntax->datum (read-syntax "foo" port))
+                    '(testing (#%ceil foo bar (#%ceil) aoeu) hello))))
+  )