From 574bb06fb719beac0c4f07a80b6380d9951bdb26 Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Fri, 3 Jun 2016 14:01:36 -0700
Subject: [PATCH] add custom indenter

---
 beautiful-racket-lib/br/main.rkt     | 28 +++++++++++++++++++++-
 beautiful-racket/br/demo/stacker.rkt | 35 +++++++++++++++-------------
 2 files changed, 46 insertions(+), 17 deletions(-)

diff --git a/beautiful-racket-lib/br/main.rkt b/beautiful-racket-lib/br/main.rkt
index 5ed358d..23fc833 100644
--- a/beautiful-racket-lib/br/main.rkt
+++ b/beautiful-racket-lib/br/main.rkt
@@ -23,4 +23,30 @@
 
 
 (module reader syntax/module-reader
-  #:language 'br)
\ No newline at end of file
+  #:language 'br
+  #:info my-get-info
+  
+  (require racket/class)
+  (define (indenter t pos)
+    (define reserved-terms (map string->list '("with-pattern" "with-shared-id" "define-macro")))
+    
+    (define sexp-start-pos (send t find-up-sexp pos))
+    (define paren-length 1)
+    (define sexp-name-start (send t skip-whitespace (+ paren-length (or sexp-start-pos 0)) 'forward #t))
+    (define sexp-name (for*/list ([p (in-naturals sexp-name-start)]
+                                  [c (in-value (send t get-character p))]
+                                  #:break (char-whitespace? c))
+                                 c))
+    (and (member sexp-name reserved-terms)
+         (let* ([paranum (send t position-paragraph sexp-name-start)]
+                [psp (send t paragraph-start-position paranum)]
+                [prev-indent (- sexp-name-start psp)])
+           (add1 prev-indent)))) ; #f will trigger default indentation
+  
+  (define (my-get-info key default default-filter)
+    (case key
+      #;[(color-lexer)
+         (dynamic-require 'syntax-color/default-lexer 'default-lexer)]
+      [(drracket:indentation) indenter]
+      [else
+       (default-filter key default)])))
\ No newline at end of file
diff --git a/beautiful-racket/br/demo/stacker.rkt b/beautiful-racket/br/demo/stacker.rkt
index c19fedd..1b6ae9d 100644
--- a/beautiful-racket/br/demo/stacker.rkt
+++ b/beautiful-racket/br/demo/stacker.rkt
@@ -1,18 +1,17 @@
 #lang br
 
-(define (read-syntax source-path input-port)
-  (define src-strs (remove-blank-lines (port->lines input-port)))
-  (define (make-datum str) (format-datum '(dispatch ~a) str))
-  (define src-exprs (map make-datum src-strs))
-  (strip-context
-   (with-pattern ([(SRC-EXPR ...) (map make-datum src-strs)])
-                 #'(module stacker-mod br/demo/stacker
-                     SRC-EXPR ...))))
+(define (read-syntax src-path in-port)
+  (define lines (remove-blank-lines (port->lines in-port)))
+  (define (make-exec-datum line) (format-datum '(exec ~a) line))
+  (define exec-exprs (map make-exec-datum lines))
+  (strip-context (with-pattern ([(EXEC-EXPR ...) exec-exprs])
+                   #'(module stacker-mod br/demo/stacker
+                       EXEC-EXPR ...))))
 (provide read-syntax)
 
-(define-macro (stacker-module-begin READER-LINE ...)
+(define-macro (stacker-module-begin SRC-LINE ...)
   #'(#%module-begin
-     READER-LINE ...
+     SRC-LINE ...
      (display (first stack))))
 (provide (rename-out [stacker-module-begin #%module-begin]))
 
@@ -20,10 +19,14 @@
 (define (push num) (set! stack (cons num stack)))
 (provide push)
 
-(define-cases dispatch
-  [(_ push num) (push num)]
-  [(_ op) (define op-result (op (first stack) (second stack)))
-          (set! stack (cons op-result (drop stack 2)))])
-(provide dispatch)
+(define-cases exec
+  [(_ func num) (func num)]
+  [(_ op) (define result (op (first stack) (second stack)))
+          (set! stack (cons result (drop stack 2)))])
+(provide exec)
 
-(provide + * #%app #%datum #%top-interaction)
\ No newline at end of file
+(provide + * #%app #%datum #%top-interaction)
+
+(module+ test 
+  (require rackunit)
+  (check-equal? (with-output-to-string (λ () (dynamic-require "stacker-test.rkt" #f))) "36"))
\ No newline at end of file