#|
file: balance.scm
author: Jan Skibinski
version: 0.1
initialized: 2007-01-05
license: at the bottom of this file
code type: Scheme and some embedded Applescript
For description see the previous post:
Balancing expressions containing parentheses, brackets and braces.
|#
;; procedure: (balance-range k)
;; Given the integer k representing cursor position just
;; before any of the "open" characters; that is, one of
;; '(open-paren open-bracket open-brace);
;; within the input text view of Scheme-OSA application:
;; 1. Produce range of integers bracketing a balanced
;; portion of a text that follows the cursor, such as
;; (13 56), where
;; + the first item is a copy of insertion point
;; + the second item is the position past the matching
;; "close" character; that is, one of
;; '(close-paren close-bracket close-brace)
;; 2. Call Applescript to select the computed range,
;; by executing attached applescript code
;; 3. Wait for the response from Applescript and display
;; selected range in output text view to show those
;; numbers to the user.
;; Failure to balance some portion of 'input-string
;; is indicated by identical values of both items in
;; computed range.
;;
(define (balance-range k)
(define result (balance-stream
(current-input-port)))
(define range
(cond
((positive? result)
(list k (+ result k 1)))
(else (list k k))))
(define handler (string->symbol
(string-append
"on select_range from range\r"
" try\r"
" tell application \"Scheme-OSA\"\r"
" set inputTextView to text view 1 of scroll view 1 of split view 1 of window 1\r"
" call method \"setSelectedRange:\" of inputTextView with parameter range\r"
" end tell\r"
" return range\r"
" on error msg number n\r"
" return msg\r"
" end try\r"
"end select_range\r")))
(osa (make-osa-string
(list handler 'select_range 'from range))))
;; procedure: (balance-stream port)
;; balance-stream :: input-port -> integer
;;
;; Providing that a stream begins with one of
;; the following characters:
;; '(open-paren open-bracket open-brace)
;; find index of one of
;; '(close-paren close-bracket close-brace), which
;; balances the opening character.
;; Ignore matching within strings or within line
;; comments.
;; [To do: provide similar escape mechanism from
;; block comments as well]
;;
;; On success: character position of matching
;; closing character
;; On failure: -1
;;
;; Implementation notes:
;; The balancer is not greedy: it exits on the
;; first match and discards the remaining characters
;; waiting in pipe.
;; This procedure maintains internally two stacks:
;; state stack and balance stack and two co-procedures:
;; balance/1 and test which manipulate those stacks.
;; Testing for balancing takes place only when the top
;; of the state stack is 'normal; that is,
;; not 'commenting and not 'quoting.
;;
(define (balance-stream port)
; Define open/close characters, quote and semicolon:
; Defined indirectly via integer->char to avoid
; confusion when attempting to
; balance this source code in TextWrangler
; or other ascii editors.
; Seems that not everyone is always perfect,
;not even TextWrangler.
(define open-paren (integer->char 40))
(define close-paren (integer->char 41))
(define open-bracket (integer->char 91))
(define close-bracket (integer->char 93))
(define open-brace (integer->char 123))
(define close-brace (integer->char 125))
(define double-quote (integer->char 34))
(define semicolon (integer->char 59))
; True if character x is a marker of End OF Data
; Our pipe should never be broken, because this
; would force the interpreter to exit.
; Consequently, no EOF is ever sent during normal
; transmission of data. To signal the end of data,
; a special marker must be appended
; to the end of data stream and then watched
;for within this procedure.
(define (end-of-data? x)
(char=? x #\@))
; Read and discard all characters till
;the end of the stream.
(define (skip-to-end port)
(define c (read-char port))
(if (not (end-of-data? c))
(skip-to-end port)))
;True if character x-open is a mate of y-close
(define (mate? x-open y-close)
(or
(and (char=? x-open open-paren)
(char=? y-close close-paren))
(and (char=? x-open open-bracket)
(char=? y-close close-bracket))
(and (char=? x-open open-brace)
(char=? y-close close-brace))))
;True if character x is one of
;(open-paren open-bracket open-brace)
(define (open? x)
(or
(char=? x open-paren)
(char=? x open-bracket)
(char=? x open-brace)))
;True if character x is one of
; (close-paren close-bracket close-brace)
(define (close? x)
(or
(char=? x close-paren)
(char=? x close-bracket)
(char=? x close-brace)))
; Recursive co-procedure:
; (balance/1 port n balance-stack state-stack)
; Exit with failure if EOF.
; Call the 'test co-procedure if in 'normal state.
; Otherwise, first decide whether or not to pop up
; and dismiss the current state from the state stack,
;and then recurse.
(define (balance/1 port n balance-stack state-stack)
(define c (read-char port))
(cond
; End of stream:
; break signaling the failure
((end-of-data? c) (list #f n c))
; Normal state:
;call co-procedure 'test
((eq? (car state-stack) 'normal)
(test c port (+ n 1) balance-stack state-stack))
; We are in 'quoting state
;and first char is double-quote:
; recurse with popped state-stack
((and
(eq? (car state-stack) 'quoting)
(char=? c double-quote))
(balance/1 port (+ n 1) balance-stack (cdr state-stack)))
; Commenting state and the first char
;is newline or return:
; recurse with popped state-stack
((and (eq? (car state-stack) 'commenting)
(or
(char=? c #\newline)
(char=? c #\return)))
(balance/1 port (+ n 1) balance-stack (cdr state-stack)))
; Otherwise: recurse with both
;stacks unchanged
(else (balance/1 port (+ n 1) balance-stack state-stack))
))
;Recursive co-procedure:
'(test x port n balance-stack state-stack).
;Test current character x and behave accordingly
(define (test x port n balance-stack state-stack)
(cond
;X is open char: push x on balance stack
; and recurse
((open? x)
(balance/1 port n
(cons x balance-stack) state-stack))
;X is double-quote: push 'quoting on
;state stack and recurse
((char=? x double-quote)
(balance/1 port n balance-stack
(cons 'quoting state-stack)))
;X is semicolon: push 'commenting on
;state stack and recurse
((char=? x semicolon)
(balance/1 port n balance-stack
(cons 'commenting state-stack)))
;X is not close char: ignore x and recurse
((not (close? x))
(balance/1 port n balance-stack state-stack))
;State stack is empty: break signaling failure
((null? balance-stack) (list #f n x))
;X is close char but is not a mate
; of top of balance stack:
; break signaling failure
((not (mate? (car balance-stack) x)) (list #f n x))
;X is close char and balance stack
;has just 1 element:
; Hurrah! Break signaling success
((= (length balance-stack) 1) (list #t n x))
;Otherwise, x is a matching close char:
; Partial match, pop up balance
; stack and recurse
(else (balance/1 port n
(cdr balance-stack) state-stack))))
; Peek the first character
(define c (peek-char port))
(cond
; Empty string?: discard end-of-data
; marker and fail
((end-of-data? c) (begin (skip-to-end port) -1))
; String does not start with "open" char?:
; discard everything and fail
((not (open? c)) (begin (skip-to-end port) -1))
(else
; Try the real balancing
(let ((result (balance/1 port -1 '() (list 'normal))))
(begin
; Some characters waiting in pipe?
; Discard them.
(if (not (end-of-data? (caddr result)))
(skip-to-end port))
(if (car result) (cadr result) -1))))))
#|
Copyright (C) Jan Skibinski (2006). All Rights Reserved.
Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
|#
No comments:
Post a Comment