A graphical regular expression checker in plain Racket, supports PCRE

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)))