A graphical regular expression checker in plain Racket, supports PCRE
#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))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment