(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)
  
  
  ;; A move is one of the following:
  (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)
  
  
  
  ;; current-tab-break-length: the tab break length we use when we
  ;; see a #\tab.
  (define current-tab-break-length (make-parameter 8))
  
  
  ;; current-line-break-mode: (parameterof
  ;;                           (union 'linefeed 'return
  ;;                                  'return-linefeed
  ;;                                  'any 'any-one)
  ;; Tells the line-breaking-lexer what interpretation
  ;; to choose for line breakers, similar to what read-line uses.
  (define current-line-break-mode (make-parameter 'any))
  
  
  
  ;; move-compose: move move -> move
  ;;
  ;; Composes two moves together, assuming that the first move is applied
  ;; first, and then the next move afterward.
  (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)]))
  
  
  ;; apply-move: move loc -> loc
  ;;
  ;; Applies a move on a-loc.
  ;;
  (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))])))
  
  
  ;; get-move: input-port -> move
  ;;
  ;; Returns the move we should do after seeing the content in ip.
  (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]))))

  
  
  ;; line-breaking-lexer: input-port -> (union move #f)
  ;; Consumes a unit of text from the input port, and computes an
  ;; appropriate next moving action on a position, or #f if
  ;; we're all done.
  (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))))
  
  
  
  ;; Moves are meant to be opaque, so we do not export most of the move
  ;; stuff outside.
  
  (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?)]))