Skip to content

Instantly share code, notes, and snippets.

Created October 30, 2020 23:04
Show Gist options
  • Save erkin/bd7cd534a230731576d535bd2eb9d3d4 to your computer and use it in GitHub Desktop.
Save erkin/bd7cd534a230731576d535bd2eb9d3d4 to your computer and use it in GitHub Desktop.
A graphical regular expression checker in plain Racket, supports PCRE
#lang racket/base
(require racket/gui/base
(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
program-name program-version))
(define (quit)
(custodian-shutdown-all (current-custodian))
(queue-callback exit #t))
(define (about)
(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)))
(define (check-field)
(let ((input (send regexp-field get-value)))
(if (non-empty-string? input)
((mode) input (λ _ (incorrect-field))))
(define (check-toggle tickbox event)
(when (eq? 'check-box (send event get-event-type))
(mode (if (send tickbox get-value) pregexp regexp))
(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
(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)
(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:")
(λ (field event)
(when (eq? 'text-field (send event get-event-type))
(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)
(λ (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)
(send canvas set-canvas-background blank-colour)
(send* frame
(show #t)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment