erkin · October 30, 2020 23:04
diff --git a/regexp-checker.rkt b/regexp-checker.rkt
 #lang racket/base
 (require racket/gui/base
         racket/class
         racket/list
         racket/string)

 (define program-name "regexp-checker")
 (define program-version "v0.1")

 (define version-message
  (format #<<version
 ~a ~a
 Copyright (C) 2020 Erkin Batu Altunbaş

 Permission to use, copy, modify, and/or distribute this software for
 any purpose with or without fee is hereby granted, provided that the
 above copyright notice and this permission notice appear in all
 copies.
 version
          program-name program-version))

 (define (quit)
  (custodian-shutdown-all (current-custodian))
  (queue-callback exit #t))

 (define (about)
  (message-box
   (string-append "About " program-name)
   version-message frame '(ok no-icon)))



 (define mode (make-parameter regexp))

 (define valid-colour (make-object color% "greenyellow"))
 (define invalid-colour (make-object color% "peachpuff"))
 (define blank-colour (make-object color% "lightblue"))

 (define (blank-field)
  (send regexp-field set-field-background blank-colour))
 (define (correct-field)
  (send regexp-field set-field-background valid-colour))
 (define (incorrect-field)
  (send regexp-field set-field-background invalid-colour))

 (define (blank-editor)
  (send text change-style
        (send styles find-named-style "Standard")
        0 (send text get-end-position)))

 (define (check-editor)
  (let ((input (send regexp-field get-value)))
    (if (non-empty-string? input)
        (for ((line (in-range (add1 (send text position-line (send text get-end-position))))))
          (let ((start (send text line-start-position line))
                (end (send text line-end-position line))
                (pattern ((mode) input (λ _ #f))))
            (send text change-style
                  (send styles find-named-style
                        (if (and pattern (regexp-match? pattern (send text get-text start end)))
                            "Correct" "Incorrect"))
                  start end)))
        (blank-editor))))

 (define (check-field)
  (let ((input (send regexp-field get-value)))
    (if (non-empty-string? input)
        (begin
          (correct-field)
          ((mode) input (λ _ (incorrect-field))))
        (begin
          (blank-field)
          (blank-editor)))))

 (define (check-toggle tickbox event)
  (when (eq? 'check-box (send event get-event-type))
    (mode (if (send tickbox get-value) pregexp regexp))
    (check-field)
    (check-editor)))

 (define frame
  (new frame%
       (label program-name)
       (width 640) (height 480)))

 (define pane
  (new horizontal-pane% (parent frame)
       (alignment '(center top))
       (vert-margin 5)
       (horiz-margin 10)
       (stretchable-height #f)))

 (define right-click-menu (new popup-menu%))

 (define text
  (new
   (class text% (super-new)
     (inherit get-admin position-line
              get-start-position get-end-position)
     (define/override (on-default-event event)
       (if (send event button-down? 'right)
           (let ((x (send event get-x)) (y (send event get-y)))
             (send (get-admin) popup-menu right-click-menu x y))
           (super on-default-event event)))
     (define/override (on-default-char event)
       (check-editor)
       (super on-default-char event)))))

 (define styles
  (send text get-style-list))

 (define canvas
  (new editor-canvas% (parent frame)
       (editor text)
       (label "lines")
       (style '(auto-vscroll auto-hscroll))))

 (define regexp-field
  (new text-field% (parent pane)
       (label "Regexp:")
       (callback
        (λ (field event)
          (when (eq? 'text-field (send event get-event-type))
            (check-field)
            (check-editor))))))

 (define pcre-toggle
  (new check-box% (parent pane)
       (label "PCRE")
       (callback check-toggle)))

 (define bottom-pane
  (new horizontal-pane% (parent frame)
       (alignment '(right bottom))
       (stretchable-height #f)))

 (define about-button
  (new button% (parent bottom-pane)
       (label "About")
       (callback (λ _ (about)))))

 (define quit-button
  (new button% (parent bottom-pane)
       (label "Quit")
       (callback (λ _ (quit)))))



 (define (populate-styles style-list)
  (let ((standard (send style-list find-named-style "Standard"))
        (blank-delta (make-object style-delta%))
        (incorrect-delta (make-object style-delta%))
        (correct-delta (make-object style-delta%)))
    (send* blank-delta
      (set-family 'modern)
      (set-delta-background blank-colour))
    (send standard set-delta blank-delta)

    (send* incorrect-delta
      (copy blank-delta)
      (set-delta-background invalid-colour))
    (send (send style-list new-named-style "Incorrect" standard)
          set-delta incorrect-delta)

    (send* correct-delta
      (copy blank-delta)
      (set-delta-background valid-colour))
    (send (send style-list new-named-style "Correct" standard)
          set-delta correct-delta)))

 (module+ main
  (application-quit-handler quit)
  (application-about-handler about)
  (error-display-handler
   (λ (str ex)
     (println str)
     (when (exn:fail? ex)
       (message-box "Error" str frame '(stop ok)))))

  (add-text-keymap-functions (send text get-keymap))
  (append-editor-operation-menu-items right-click-menu)
  (editor-set-x-selection-mode #t)
  (populate-styles styles)

  (blank-field)
  (send canvas set-canvas-background blank-colour)

  (send* frame
    (center)
    (show #t)))
	#lang racket/base
	(require racket/gui/base
	racket/class
	racket/list
	racket/string)

	(define program-name "regexp-checker")
	(define program-version "v0.1")

	(define version-message
	(format #<<version
	~a ~a
	Copyright (C) 2020 Erkin Batu Altunbaş

	Permission to use, copy, modify, and/or distribute this software for
	any purpose with or without fee is hereby granted, provided that the
	above copyright notice and this permission notice appear in all
	copies.
	version
	program-name program-version))

	(define (quit)
	(custodian-shutdown-all (current-custodian))
	(queue-callback exit #t))

	(define (about)
	(message-box
	(string-append "About " program-name)
	version-message frame '(ok no-icon)))



	(define mode (make-parameter regexp))

	(define valid-colour (make-object color% "greenyellow"))
	(define invalid-colour (make-object color% "peachpuff"))
	(define blank-colour (make-object color% "lightblue"))

	(define (blank-field)
	(send regexp-field set-field-background blank-colour))
	(define (correct-field)
	(send regexp-field set-field-background valid-colour))
	(define (incorrect-field)
	(send regexp-field set-field-background invalid-colour))

	(define (blank-editor)
	(send text change-style
	(send styles find-named-style "Standard")
	0 (send text get-end-position)))

	(define (check-editor)
	(let ((input (send regexp-field get-value)))
	(if (non-empty-string? input)
	(for ((line (in-range (add1 (send text position-line (send text get-end-position))))))
	(let ((start (send text line-start-position line))
	(end (send text line-end-position line))
	(pattern ((mode) input (λ _ #f))))
	(send text change-style
	(send styles find-named-style
	(if (and pattern (regexp-match? pattern (send text get-text start end)))
	"Correct" "Incorrect"))
	start end)))
	(blank-editor))))

	(define (check-field)
	(let ((input (send regexp-field get-value)))
	(if (non-empty-string? input)
	(begin
	(correct-field)
	((mode) input (λ _ (incorrect-field))))
	(begin
	(blank-field)
	(blank-editor)))))

	(define (check-toggle tickbox event)
	(when (eq? 'check-box (send event get-event-type))
	(mode (if (send tickbox get-value) pregexp regexp))
	(check-field)
	(check-editor)))

	(define frame
	(new frame%
	(label program-name)
	(width 640) (height 480)))

	(define pane
	(new horizontal-pane% (parent frame)
	(alignment '(center top))
	(vert-margin 5)
	(horiz-margin 10)
	(stretchable-height #f)))

	(define right-click-menu (new popup-menu%))

	(define text
	(new
	(class text% (super-new)
	(inherit get-admin position-line
	get-start-position get-end-position)
	(define/override (on-default-event event)
	(if (send event button-down? 'right)
	(let ((x (send event get-x)) (y (send event get-y)))
	(send (get-admin) popup-menu right-click-menu x y))
	(super on-default-event event)))
	(define/override (on-default-char event)
	(check-editor)
	(super on-default-char event)))))

	(define styles
	(send text get-style-list))

	(define canvas
	(new editor-canvas% (parent frame)
	(editor text)
	(label "lines")
	(style '(auto-vscroll auto-hscroll))))

	(define regexp-field
	(new text-field% (parent pane)
	(label "Regexp:")
	(callback
	(λ (field event)
	(when (eq? 'text-field (send event get-event-type))
	(check-field)
	(check-editor))))))

	(define pcre-toggle
	(new check-box% (parent pane)
	(label "PCRE")
	(callback check-toggle)))

	(define bottom-pane
	(new horizontal-pane% (parent frame)
	(alignment '(right bottom))
	(stretchable-height #f)))

	(define about-button
	(new button% (parent bottom-pane)
	(label "About")
	(callback (λ _ (about)))))

	(define quit-button
	(new button% (parent bottom-pane)
	(label "Quit")
	(callback (λ _ (quit)))))



	(define (populate-styles style-list)
	(let ((standard (send style-list find-named-style "Standard"))
	(blank-delta (make-object style-delta%))
	(incorrect-delta (make-object style-delta%))
	(correct-delta (make-object style-delta%)))
	(send* blank-delta
	(set-family 'modern)
	(set-delta-background blank-colour))
	(send standard set-delta blank-delta)

	(send* incorrect-delta
	(copy blank-delta)
	(set-delta-background invalid-colour))
	(send (send style-list new-named-style "Incorrect" standard)
	set-delta incorrect-delta)

	(send* correct-delta
	(copy blank-delta)
	(set-delta-background valid-colour))
	(send (send style-list new-named-style "Correct" standard)
	set-delta correct-delta)))

	(module+ main
	(application-quit-handler quit)
	(application-about-handler about)
	(error-display-handler
	(λ (str ex)
	(println str)
	(when (exn:fail? ex)
	(message-box "Error" str frame '(stop ok)))))

	(add-text-keymap-functions (send text get-keymap))
	(append-editor-operation-menu-items right-click-menu)
	(editor-set-x-selection-mode #t)
	(populate-styles styles)

	(blank-field)
	(send canvas set-canvas-background blank-colour)

	(send* frame
	(center)
	(show #t)))