;;; ---------------------------------------------------------------------- ;;; File: ui-tests.lisp ;;; John, Bremen, Feb00 ;;; ;;; just ui access to the consistency tests.... put the flags for various ;;; tests in a separate package here rather than anything fancy so that ;;; they do not appear as curious globals anywhere else... ;;; ;;; 3.2+ uses positioned accepting-values macro ;;; ---------------------------------------------------------------------- (cl:defpackage "KPML-TEST-FLAGS" (:use "COMMON-LISP" "KPML") (:nicknames "KTF")) (in-package "KTF") (defvar all-languages? nil) (defvar file-name "/tmp/check.txt") (defvar uit T) (defvar uot T) (defvar evft T) (defvar expandt T) (defvar dolt T) (defvar cds T) (defvar iiuc T) (defvar ids T) (defvar ois T) (defvar ac T) (defvar ls nil) (defvar ra nil) (in-package "KPML") (defun SELECT-CONSISTENCY-CHECKS () (let ((stream (clim::frame-top-level-sheet clim:*application-frame*)) ) (restart-case (kpml-i::positioned-accepting-values (stream :own-window kpml-i::*own-window* :x-position 20 ;;; (first kpml-i::*confirmation-popups-xy*) :y-position 20 ;;; (second kpml-i::*confirmation-popups-xy*) :scroll-bars :horizontal :resynchronize-every-pass t :label "Consistency Checks Selector" :exit-boxes '((:exit "Run checks")(:abort "Cancel"))) (kpml-i::hd-accepts ktf::file-name 'clim:pathname "File for report" clim:+textual-dialog-view+) (kpml-i-terpri stream) (kpml-i::hd-accepts ktf::all-languages? '(member T nil) "All languages?" 'clim:radio-box-view) (kpml-i-terpri stream) (format stream "~% ") (clim:formatting-table (stream) (clim:formatting-row (stream) (clim:formatting-cell (stream) (kpml-i-terpri stream) (format stream "~%.... paradigmatic tests...~%") (kpml-i::hd-accepts ktf::uit '(member T nil) "Unreachable inputs test" 'clim:radio-box-view) (kpml-i-terpri stream) (kpml-i::hd-accepts ktf::uot '(member T nil) "Unreachable outputs test" 'clim:radio-box-view) (kpml-i-terpri stream) (kpml-i::hd-accepts ktf::evft '(member T nil) "Void features test" 'clim:radio-box-view)) (clim:formatting-cell (stream) (format stream "~2%.... syntagmatic tests...~%") (kpml-i::hd-accepts ktf::expandt '(member T nil) "Expand+Classify/Conflate/Lexify tests" 'clim:radio-box-view) (kpml-i-terpri stream) (kpml-i::hd-accepts ktf::dolt '(member T nil) "Default ordering loops tests" 'clim:radio-box-view))) (clim:formatting-row (stream) (clim:formatting-cell (stream) (kpml-i-terpri stream) (format stream "~2%.... resource surveys...~%") (kpml-i::hd-accepts ktf::cds '(member T nil) "Chooser definitions" 'clim:radio-box-view) (kpml-i-terpri stream) (kpml-i::hd-accepts ktf::ac '(member T nil) "Chooser feature usage" 'clim:radio-box-view) (kpml-i-terpri stream) (kpml-i::hd-accepts ktf::ls '(member T nil) "Lexicon items and used classes" 'clim:radio-box-view) ) (clim:formatting-cell (stream) (kpml-i-terpri stream) (kpml-i::hd-accepts ktf::iiuc '(member T nil) "Unbound inquiry implementations" 'clim:radio-box-view) (kpml-i-terpri stream) (kpml-i::hd-accepts ktf::ois '(member T nil) "Extent of implemented inquiries" 'clim:radio-box-view) (kpml-i-terpri stream) (kpml-i::hd-accepts ktf::ids '(member T nil) "Inquiry definitions" 'clim:radio-box-view) (kpml-i-terpri stream) (kpml-i::hd-accepts ktf::ra '(member T nil) "Region assignments" 'clim:radio-box-view) ))) (kpml-i-terpri stream)) (abort () (return-from SELECT-CONSISTENCY-CHECKS nil))) ;; Made a selection, now do the selected tests... (macrolet ((do-test (var test-function string) `(when ,var (format stream ,(concatenate 'string "~% Testing: " string "...")) (if (,test-function) (format stream "... !! Possible problem found.") (format stream "... OK."))))) (format *standard-output* "~%RUNNING TESTS....") (when ktf::file-name (macrolet ((do-tests () '(let ((*standard-output* output-stream)) (reset-system-network curlan) (create-valid-lexical-feature-list curlan) (create-list-of-test-alls) (clim:notify-user stream (with-output-to-string (stream) (format stream "~% Test results (~A)...~%" curlan) (do-test ktf::uit unreachable-inputs-test "unreachable inputs") (do-test ktf::uot unreachable-outputs-test "unreachable outputs") (do-test ktf::evft excess-void-features-test "void features") (do-test ktf::expandt expand-classify-test "potential expand and classify conflicts") (do-test ktf::expandt Expand-Out-Classify-Test "potential expand and outclassify conflicts") (do-test ktf::expandt Expand-Conflate-Test "potential expand and conflation conflicts") (do-test ktf::expandt Expand-Lexify-Test "potential expand and lexify conflicts") (do-test ktf::expandt Expand-Preselect-Test "potential expand and preselection conflicts") (do-test ktf::cds chooser-definition-survey "chooser definitions") (do-test ktf::ac analyze-choosers "chooser feature usage") (do-test ktf::dolt default-ordering-loops-test "default order loops") (do-test ktf::iiuc inquiry-implementations-unbound-check "inquiry implementations bound") (do-test ktf::ids inquiry-definition-survey "inquiry definitions") (do-test ktf::ois operator-implementation-survey "operator survey") (do-test ktf::ls lexicon-survey "lexicon survey") (do-test ktf::ra region-assignment-survey "region-metafunction assignment") (format stream "~2%Details in ~A" file-name) ))))) (unwind-protect (let ((file-name (merge-pathnames ktf::file-name (user-homedir-pathname)))) (with-open-file (output-stream file-name :direction :output :if-exists :new-version) (if ktf::all-languages? (loop for curlan in all_languages do (format output-stream "~% ====== Tests for language: ~A at: ~A" curlan (kpml::time-stamp)) (do-tests)) (do-tests)) ) )))))))