From 53e80f6f38bbc2cf60375ed63fa6c05ebf7fa399 Mon Sep 17 00:00:00 2001
From: Casey Klein <clklein@racket-lang.org>
Date: Wed, 17 Aug 2011 11:59:10 -0500
Subject: [PATCH] Adds a syncheck:add-arrow example to the docs

---
 collects/scribblings/tools/tools.scrbl | 45 ++++++++++++++++++++++++++
 1 file changed, 45 insertions(+)

diff --git a/collects/scribblings/tools/tools.scrbl b/collects/scribblings/tools/tools.scrbl
index e14afc0656..d82f3563f8 100644
--- a/collects/scribblings/tools/tools.scrbl
+++ b/collects/scribblings/tools/tools.scrbl
@@ -11,6 +11,7 @@
             (for-label framework/framework)
             (for-label drracket/syncheck-drracket-button
                        drracket/check-syntax)
+            scribble/eval
             scribble/extract)
    
    (define (File x) @tt[x])
@@ -765,6 +766,50 @@ Check Syntax is a part of the DrRacket collection, but is implemented via the to
   The @racket[syncheck:find-source-object] method ignores its arguments
   and returns @racket[#f];
   all of the other methods ignore their arguments and return @racket[(void)].
+  
+  @examples[#:eval (let ([evaluator (make-base-eval)])
+                   (evaluator '(require drracket/check-syntax))
+                   evaluator)
+            (require racket/class)
+            (define arrows-collector%
+              (class (annotations-mixin object%)
+                (super-new)
+                (define/override (syncheck:find-source-object stx)
+                  stx)
+                (define/override (syncheck:add-arrow start-source-obj	 
+                                                     start-left	 
+                                                     start-right	 
+                                                     end-source-obj	 
+                                                     end-left	 
+                                                     end-right	 
+                                                     actual?	 
+                                                     phase-level)
+                  (set! arrows 
+                        (cons (list start-source-obj end-source-obj)
+                              arrows)))
+                (define arrows '())
+                (define/public (collected-arrows) arrows)))
+            (define (arrows form)
+              (define base-namespace
+                (make-base-namespace))
+              (define-values (add-syntax done)
+                (make-traversal base-namespace #f))
+              (define collector (new arrows-collector%))
+              (parameterize ([current-annotations collector]
+                             [current-namespace base-namespace])
+                (add-syntax (expand form))
+                (done))
+              (send collector collected-arrows))
+            (define (make-id name pos orig?)
+              (datum->syntax
+               #f
+               name
+               (list #f #f #f pos (string-length (symbol->string name)))
+               (and orig? #'is-orig)))
+            (arrows `(λ (,(make-id 'x 1 #t)) ,(make-id 'x 2 #t)))
+            (arrows `(λ (x) x))
+            (arrows `(λ (,(make-id 'x 1 #f)) ,(make-id 'x 2 #t)))
+            (arrows `(λ (,(make-id 'x 1 #t)) x))]
 }
 
 @(define-syntax-rule