(module move-pos mzscheme
(require (lib "plt-match.ss")
(lib "etc.ss")
(lib "lex.ss" "parser-tools")
(lib "contract.ss"))
(provide current-tab-break-length
current-line-break-mode)
(define-struct loc (line col pos) #f)
(define-struct move () #f)
(define-struct (move:no-op move) () #f)
(define-struct (move:tab move) () #f)
(define-struct (move:newline&forward move) (n f p) #f)
(define-struct (move:seq move) (next first) #f)
(define current-tab-break-length (make-parameter 8))
(define current-line-break-mode (make-parameter 'any))
(define (move-compose next-move first-move)
(match (list next-move first-move)
[(list _ (struct move:no-op ()))
next-move]
[(list (struct move:no-op ()) _)
first-move]
[(list (struct move:newline&forward (n1 f1 p1))
(struct move:newline&forward (n2 f2 p2)))
(cond [(= n1 0)
(make-move:newline&forward n2 (+ f1 f2) (+ p1 p2))]
[else
(make-move:newline&forward (+ n1 n2) f1 (+ p1 p2))])]
[(list (struct move:newline&forward (n1 f1 p1))
(struct move:seq ((struct move:newline&forward (n2 f2 p2))
rest-move)))
(cond [(= n1 0)
(make-move:seq (make-move:newline&forward n2 (+ f1 f2) (+ p1 p2))
rest-move)]
[else
(make-move:seq (make-move:newline&forward (+ n1 n2) f1 (+ p1 p2))
rest-move)])]
[else
(make-move:seq next-move first-move)]))
(define (apply-move a-move a-loc)
(local ((define (multiple-nearest n mul)
(* mul (quotient n mul))))
(match a-move
[(struct move:no-op ())
a-loc]
[(struct move:tab ())
(make-loc (loc-line a-loc)
(multiple-nearest
(+ (loc-col a-loc) (current-tab-break-length))
(current-tab-break-length))
(add1 (loc-pos a-loc)))]
[(struct move:newline&forward (n f p))
(cond [(= n 0)
(make-loc (loc-line a-loc)
(+ (loc-col a-loc) f)
(+ p (loc-pos a-loc)))]
[else
(make-loc (+ n (loc-line a-loc))
f
(+ p (loc-pos a-loc)))])]
[(struct move:seq (next first))
(apply-move next (apply-move first a-loc))])))
(define (get-move ip)
(let loop ([a-move (begin-lifted (make-move:no-op))])
(local ((define next-move (line-breaking-lexer ip)))
(cond
[next-move
(loop (move-compose next-move a-move))]
[else a-move]))))
(define line-breaking-lexer
(local
((define FORWARD (make-move:newline&forward 0 1 1))
(define NL (make-move:newline&forward 1 0 1))
(define NLNL (make-move:newline&forward 2 0 2))
(define NL-FORWARD (make-move:newline&forward 1 1 2))
(define TAB (make-move:tab))
)
(lexer
("\r\n"
(case (current-line-break-mode)
[(linefeed) NL]
[(return) NL-FORWARD]
[(return-linefeed) NL]
[(any) NL]
[(any-one) NLNL]))
("\n"
(case (current-line-break-mode)
[(linefeed) NL]
[(return) FORWARD]
[(return-linefeed) NL]
[(any) NL]
[(any-one) NL]))
("\r"
(case (current-line-break-mode)
[(linefeed) FORWARD]
[(return) NL]
[(return-linefeed) FORWARD]
[(any) NL]
[(any-one) NL]))
("\t"
TAB)
((repetition 1 +inf.0 (char-complement (char-set "\n\r\t")))
(make-move:newline&forward 0
(string-length lexeme)
(string-length lexeme)))
((eof) #f))))
(provide/contract [struct loc ((line natural-number/c)
(col natural-number/c)
(pos natural-number/c))]
[move?
(any/c . -> . boolean?)]
[apply-move
(move? loc? . -> . loc?)]
[move-compose
(move? move? . -> . move?)]
[get-move (input-port? . -> . move?)]))