<commit_before>#lang scheme/unit
#|
update-region-end is now gone
get-region is gone
added reset-regions
added get-regions
|#

(require mzlib/class
         mzlib/thread
         mred
         mzlib/etc
         (lib "token-tree.ss" "syntax-color")
         (lib "paren-tree.ss" "syntax-color")
         (lib "default-lexer.ss" "syntax-color")
         string-constants
         "../preferences.ss"
         "sig.ss")

(import [prefix icon: framework:icon^]
        [prefix mode: framework:mode^]
        [prefix text: framework:text^]
        [prefix color-prefs: framework:color-prefs^]
        [prefix scheme: framework:scheme^])

(export (rename framework:color^
                (-text<%> text<%>)
                (-text% text%)
                (-text-mode<%> text-mode<%>)))

(init-depend framework:text^ framework:mode^)

(define (should-color-type? type)
  (not (memq type '(white-space no-color))))

(define -text<%>
  (interface (text:basic<%>)
    start-colorer
    stop-colorer
    force-stop-colorer
    
    is-stopped?
    is-frozen?
    freeze-colorer
    thaw-colorer
    
    reset-region
    reset-regions
    get-regions
    
    skip-whitespace
    backward-match
    backward-containing-sexp
    forward-match
    insert-close-paren
    classify-position))

(define text-mixin
  (mixin (text:basic<%>) (-text<%>)
    
    ;; For profiling
    (define timer #f)
    
    ;; ---------------------- Coloring modes ----------------------------
    
    ;; The tokenizer is stopped.  This is used by the surrogate to enter
    ;; a mode with no coloring or paren matching.
    (define stopped? #t)
    
    ;; The tokenizer is stopped and prevented from starting.  This is 
    ;; an internal call for debugging.
    (define force-stop? #f)
    
    ;; color-callback has been suspended because the text% became locked
    ;; and should be requeued when the text% is unlocked.
    (define restart-callback #f)
    
    ;; Some other tool wants to take over coloring the buffer, so the 
    ;; colorer shouldn't color anything.
    (define frozen? #f)
    ;; true iff the colorer must recolor from scratch when the freeze
    ;; is over.
    (define force-recolor-after-freeze #f)
    
    ;; ---------------------- Parenethesis matching ----------------------
    
    ;; The pairs of matching parens
    (define pairs '())
    
    ;; ---------------------- Lexing state ------------------------------

    (define-struct lexer-state
      (start-pos 
       end-pos
       ;; The tree of valid tokens, starting at start-pos
       tokens ; = (new token-tree%)
       ;; If the tree is completed
       up-to-date? ; #t
       ;; The tree of tokens that have been invalidated by an edit
       ;; but might still be valid.
       invalid-tokens ; = (new token-tree%)
       ;; The position right before the ainvalid-tokens tree
       invalid-tokens-start ; = +inf.0
       ;; The position right before the next token to be read
       current-pos
       ;; Paren-matching
       parens 
       )
      #:mutable)

    ;; The lexer
    (define get-token #f)

    (define/private (make-new-lexer-state start end)
      (make-lexer-state start
                        end
                        (new token-tree%)
                        #t
                        (new token-tree%)
                        +inf.0
                        0
                        (new paren-tree% (matches pairs))))

    (define lexer-states (list (make-new-lexer-state 0 'end)))

    (define/public (get-up-to-date?) 
      (andmap lexer-state-up-to-date? lexer-states))

    (define/private (find-ls pos)
      (ormap (lambda (ls)
               (and (<= (lexer-state-start-pos ls)
                        pos
                        (let ([end (lexer-state-end-pos ls)])
                          (if (eq? end 'end)
                              +inf.0
                              end)))
                    ls))
             lexer-states))

    ;; ---------------------- Interactions state ------------------------
    ;; The positions right before and right after the area to be tokenized
    
    (inherit last-position)
    
    (define/public (reset-region start end)
      (unless (<= 0 start (last-position))
        (raise-mismatch-error 'reset-region
                              "start position not inside editor: "
                              start))
      (unless (or (eq? 'end end) (<= 0 end (last-position)))
        (raise-mismatch-error 'reset-region
                              "end position not inside editor: "
                              end))
      (unless (or (eq? 'end end) (<= start end))
        (raise-mismatch-error 'reset-region
                              "end position before start position: "
                              (list end start)))
      (reset-regions (list (list start end))))
    
    (define/public (reset-regions _regions)
      (let loop ([regions _regions]
                 [pos 0])
        (cond
         [(null? regions) (void)]
         [(pair? regions)
          (let ([region (car regions)])
            (unless (and (list? region)
                         (= 2 (length region))
                         (number? (list-ref region 0))
                         (or (number? (list-ref region 1))
                             (and (null? (cdr regions))
                                  (eq? 'end (list-ref region 1)))))
              (error 'reset-regions 
                     "got a region that is not a list of two numbers (or 'end if it is the last region): ~e, all regions ~e" 
                     region
                     regions))
            (unless (and (<= pos (list-ref region 0))
                         (or (eq? 'end (list-ref region 1))
                             (<= (list-ref region 0) (list-ref region 1))))
              (error 'reset-regions "found regions with numbers out of order ~e" regions))
            (loop (cdr regions) (list-ref region 1)))]
         [else
          (error 'reset-regions "expected a list of regions, got ~e" regions)]))
      
      (set! lexer-states
            (let loop ([old lexer-states]
                       [new _regions])
              (cond
               [(null? new) null]
               [(and (pair? old)
                     (equal? (caar new) (lexer-state-start-pos (car old)))
                     (equal? (cadar new) (lexer-state-end-pos (car old))))
                (cons (car old)
                      (loop (cdr old) (cdr new)))]
               [else
                (cons (make-new-lexer-state (caar new) (cadar new))
                      (loop null (cdr new)))]))))<commit_msg>fix starting position for syntax coloring<commit_after>#lang scheme/unit
#|
update-region-end is now gone
get-region is gone
added reset-regions
added get-regions
|#

(require mzlib/class
         mzlib/thread
         mred
         mzlib/etc
         (lib "token-tree.ss" "syntax-color")
         (lib "paren-tree.ss" "syntax-color")
         (lib "default-lexer.ss" "syntax-color")
         string-constants
         "../preferences.ss"
         "sig.ss")

(import [prefix icon: framework:icon^]
        [prefix mode: framework:mode^]
        [prefix text: framework:text^]
        [prefix color-prefs: framework:color-prefs^]
        [prefix scheme: framework:scheme^])

(export (rename framework:color^
                (-text<%> text<%>)
                (-text% text%)
                (-text-mode<%> text-mode<%>)))

(init-depend framework:text^ framework:mode^)

(define (should-color-type? type)
  (not (memq type '(white-space no-color))))

(define -text<%>
  (interface (text:basic<%>)
    start-colorer
    stop-colorer
    force-stop-colorer
    
    is-stopped?
    is-frozen?
    freeze-colorer
    thaw-colorer
    
    reset-region
    reset-regions
    get-regions
    
    skip-whitespace
    backward-match
    backward-containing-sexp
    forward-match
    insert-close-paren
    classify-position))

(define text-mixin
  (mixin (text:basic<%>) (-text<%>)
    
    ;; For profiling
    (define timer #f)
    
    ;; ---------------------- Coloring modes ----------------------------
    
    ;; The tokenizer is stopped.  This is used by the surrogate to enter
    ;; a mode with no coloring or paren matching.
    (define stopped? #t)
    
    ;; The tokenizer is stopped and prevented from starting.  This is 
    ;; an internal call for debugging.
    (define force-stop? #f)
    
    ;; color-callback has been suspended because the text% became locked
    ;; and should be requeued when the text% is unlocked.
    (define restart-callback #f)
    
    ;; Some other tool wants to take over coloring the buffer, so the 
    ;; colorer shouldn't color anything.
    (define frozen? #f)
    ;; true iff the colorer must recolor from scratch when the freeze
    ;; is over.
    (define force-recolor-after-freeze #f)
    
    ;; ---------------------- Parenethesis matching ----------------------
    
    ;; The pairs of matching parens
    (define pairs '())
    
    ;; ---------------------- Lexing state ------------------------------

    (define-struct lexer-state
      (start-pos 
       end-pos
       ;; The tree of valid tokens, starting at start-pos
       tokens ; = (new token-tree%)
       ;; If the tree is completed
       up-to-date? ; #t
       ;; The tree of tokens that have been invalidated by an edit
       ;; but might still be valid.
       invalid-tokens ; = (new token-tree%)
       ;; The position right before the ainvalid-tokens tree
       invalid-tokens-start ; = +inf.0
       ;; The position right before the next token to be read
       current-pos
       ;; Paren-matching
       parens 
       )
      #:mutable)

    ;; The lexer
    (define get-token #f)

    (define/private (make-new-lexer-state start end)
      (make-lexer-state start
                        end
                        (new token-tree%)
                        #t
                        (new token-tree%)
                        +inf.0
                        start
                        (new paren-tree% (matches pairs))))

    (define lexer-states (list (make-new-lexer-state 0 'end)))

    (define/public (get-up-to-date?) 
      (andmap lexer-state-up-to-date? lexer-states))

    (define/private (find-ls pos)
      (ormap (lambda (ls)
               (and (<= (lexer-state-start-pos ls)
                        pos
                        (let ([end (lexer-state-end-pos ls)])
                          (if (eq? end 'end)
                              +inf.0
                              end)))
                    ls))
             lexer-states))

    ;; ---------------------- Interactions state ------------------------
    ;; The positions right before and right after the area to be tokenized
    
    (inherit last-position)
    
    (define/public (reset-region start end)
      (unless (<= 0 start (last-position))
        (raise-mismatch-error 'reset-region
                              "start position not inside editor: "
                              start))
      (unless (or (eq? 'end end) (<= 0 end (last-position)))
        (raise-mismatch-error 'reset-region
                              "end position not inside editor: "
                              end))
      (unless (or (eq? 'end end) (<= start end))
        (raise-mismatch-error 'reset-region
                              "end position before start position: "
                              (list end start)))
      (reset-regions (list (list start end))))
    
    (define/public (reset-regions _regions)
      (let loop ([regions _regions]
                 [pos 0])
        (cond
         [(null? regions) (void)]
         [(pair? regions)
          (let ([region (car regions)])
            (unless (and (list? region)
                         (= 2 (length region))
                         (number? (list-ref region 0))
                         (or (number? (list-ref region 1))
                             (and (null? (cdr regions))
                                  (eq? 'end (list-ref region 1)))))
              (error 'reset-regions 
                     "got a region that is not a list of two numbers (or 'end if it is the last region): ~e, all regions ~e" 
                     region
                     regions))
            (unless (and (<= pos (list-ref region 0))
                         (or (eq? 'end (list-ref region 1))
                             (<= (list-ref region 0) (list-ref region 1))))
              (error 'reset-regions "found regions with numbers out of order ~e" regions))
            (loop (cdr regions) (list-ref region 1)))]
         [else
          (error 'reset-regions "expected a list of regions, got ~e" regions)]))

      (set! lexer-states
            (let loop ([old lexer-states]
                       [new _regions])
              (cond
               [(null? new) null]
               [(and (pair? old)
                     (equal? (caar new) (lexer-state-start-pos (car old)))
                     (equal? (cadar new) (lexer-state-end-pos (car old))))
                (cons (car old)
                      (loop (cdr old) (cdr new)))]
               [else
                (cons (make-new-lexer-state (caar new) (cadar new))
                      (loop null (cdr new)))]))))

{'fraction_non_alphanumeric': 0.13868998266375215, 'fraction_numerical': 0.002487374689078164, 'mean_word_length': 1.3988428855541493, 'pattern_counts': {'":': 0, '<': 31, '<?xml version=': 0, '>': 19, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 6, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1668751', 'n_tokens_mistral': 3847, 'n_tokens_neox': 3570, 'n_words': 1122}