From 560836a8048d3b55f8cdb6b251b0abf708d7a6bf Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 17 Feb 2009 16:14:12 +0000
Subject: [PATCH] Draw :-> and :--> ourselves, similar to --> and friends.

svn: r13698
---
 collects/redex/private/arrow.ss | 13 ++++++++++++-
 collects/redex/private/pict.ss  | 12 ++++++++++--
 2 files changed, 22 insertions(+), 3 deletions(-)

diff --git a/collects/redex/private/arrow.ss b/collects/redex/private/arrow.ss
index 023f748cb6..c8dad8c4a5 100644
--- a/collects/redex/private/arrow.ss
+++ b/collects/redex/private/arrow.ss
@@ -7,7 +7,7 @@
 (provide/contract
  [make-arrow-pict
   (-> string?
-      (symbols 'curvy 'straight 'straight-double)
+      (symbols 'curvy 'straight 'straight-double 'map)
       symbol?
       number?
       (-> pict?))])
@@ -71,6 +71,17 @@
             (case style
               [(curvy)
                (send dc draw-path path dx dy)]
+              [(map)
+               (send dc draw-line
+                     dx
+                     (- (+ dy line-pos) (/ head-height 2))
+                     dx
+                     (+ (+ dy line-pos) (/ head-height 2)))
+               (send dc draw-line 
+                     dx
+                     (+ dy line-pos)
+                     (+ dx w)
+                     (+ dy line-pos))]
               [(straight)
                (send dc draw-line 
                      dx
diff --git a/collects/redex/private/pict.ss b/collects/redex/private/pict.ss
index 89bc5c0e89..43d3e8edff 100644
--- a/collects/redex/private/pict.ss
+++ b/collects/redex/private/pict.ss
@@ -344,6 +344,8 @@
 (define short-curvy-arrow-pict (mk-arrow-pict "m" 'curvy))
 (define double-arrow-pict (mk-arrow-pict "xxx" 'straight-double))
 (define short-double-arrow-pict (mk-arrow-pict "m" 'straight-double))
+(define map-arrow-pict (mk-arrow-pict "m" 'map))
+(define long-map-arrow-pict (mk-arrow-pict "xxx" 'map))
 
 (define user-arrow-table (make-hasheq))
 (define (set-arrow-pict! arr thunk)
@@ -362,8 +364,14 @@
           [(>->) (basic-text "\u21a3" (default-style))]
           [(~~>) (curvy-arrow-pict)]
           [(~>) (short-curvy-arrow-pict)]
-          [(:->) (basic-text "\u21a6" (default-style))]
-          [(:-->) (basic-text "\u27fc" (default-style))]
+          [(:->) 
+           (if STIX?
+               (basic-text "\u21a6" (default-style))
+               (map-arrow-pict))]
+          [(:-->) 
+           (if STIX?
+               (basic-text "\u27fc" (default-style))
+               (long-map-arrow-pict))]
           [(c->) (basic-text "\u21aa" (default-style))]
           [(-->>) (basic-text "\u21a0" (default-style))]
           [(>--) (basic-text "\u291a" (default-style))]