www

commit 0410d1eb0732467c16e8dcf8135fc97a7bbd408b
parent 62b5459e052579c4c0e03197548bdb4f12d69ffa
Author: Georges Dupéron <georges.duperon@gmail.com>
Date:   Sat,  4 Feb 2017 07:45:01 +0100

Fixed arrows in DrRacket, fixed bug with empty || identifier

Diffstat:
M
private/subscripts.rkt
 | 
8
++++++--
M
private/template-subscripts.rkt
 | 
11
++++++-----

2 files changed, 12 insertions(+), 7 deletions(-)
diff --git a/private/subscripts.rkt b/private/subscripts.rkt
@@ -1,6 +1,7 @@
 #lang racket/base
 
 (provide subscript-equal?
+         extract-subscripts
          drop-subscripts
          find-subscript-binders)
 
@@ -15,8 +16,11 @@
 
 (define/contract (extract-subscripts id)
   (-> identifier? string?)
-  (cadr (regexp-match #px".(_.+|[ₐₑₕᵢⱼₖₗₘₙₒₚᵣₛₜᵤᵥₓᵦᵧᵨᵩᵪ]*)$"
-                     (symbol->string (syntax-e id)))))
+  (let ([match (regexp-match #px".(_.+|[ₐₑₕᵢⱼₖₗₘₙₒₚᵣₛₜᵤᵥₓᵦᵧᵨᵩᵪ]*)$"
+                             (symbol->string (syntax-e id)))])
+     (if (>= (length match) 2)
+         (cadr match)
+         "")))
 
 (define/contract (string-replace* str from* to*)
   (->i ([str string?]
diff --git a/private/template-subscripts.rkt b/private/template-subscripts.rkt
@@ -269,18 +269,19 @@
 
   ;; Draw arrows in DrRacket.
   (with-arrows
-   (define subscripts (subscript-equal? #'bound #'binder₀))
+   (define bound-subscripts (extract-subscripts #'bound))
+   (define binder-subscripts (extract-subscripts #'binder₀))
    (define bound-id-str (identifier->string #'bound))
    (for ([binder (in-list (syntax->list #'(binder₀ binderᵢ …)))])
      (define binder-id-str (identifier->string binder))
      (record-sub-range-binders! (vector #'bound
                                         (- (string-length bound-id-str)
-                                           (string-length subscripts))
-                                        (string-length subscripts)
+                                           (string-length bound-subscripts))
+                                        (string-length bound-subscripts)
                                         binder
                                         (- (string-length binder-id-str)
-                                           (string-length subscripts))
-                                        (string-length subscripts))))
+                                           (string-length binder-subscripts))
+                                        (string-length binder-subscripts))))
    #;(define binder0-id-str (identifier->string #'binder0))
    #;(record-sub-range-binders! (vector #'bound
                                         (- (string-length bound-id-str)