Changeset 882

Timestamp:

05/24/07 22:43:25 (1 year ago)

Author:

shawnw

Message:

expr: helper now does linting of help files

Files:

• 1.8.3/branches/experimental/game/txt/helper/Makefile (modified) (1 diff)
• 1.8.3/branches/experimental/game/txt/helper/README (modified) (1 diff)
• 1.8.3/branches/experimental/game/txt/helper/entry.scm (modified) (4 diffs)
• 1.8.3/branches/experimental/game/txt/helper/helper.scm (modified) (1 diff)
• 1.8.3/branches/experimental/game/txt/helper/options.scm (modified) (2 diffs)
• 1.8.3/branches/experimental/game/txt/helper/read.scm (modified) (2 diffs)
• 1.8.3/branches/experimental/game/txt/helper/warnings.scm (added)

1.8.3/branches/experimental/game/txt/helper/Makefile

@@ -3 +3 @@
-CSCOPTS=-O2
-
-
-
+
+
+
+
+
-
-options.o: options.scm

1.8.3/branches/experimental/game/txt/helper/README

@@ -9 +9 @@
-(Assuming the pennmush/game/txt directory)
-
--f help.db
+[-f help.db]
-
-
+
+
-
-
+
-
-
+
+
+
+
+
+
+
+
+

1.8.3/branches/experimental/game/txt/helper/entry.scm

@@ -2 +2 @@
-
-(declare
+ (unit helper:entry)
- (fixnum)
- (usual-integrations)
- (disable-interrupts)
- (unit helper:entry)
- (export entry-version make-help-entry help-entry? help-entry-name
-
+
+
-      help-entries-save help-entries-load)
- (bound-to-procedure make-help-entry help-entry? help-entry-name
-
-
+
+
+
+
+
-
-(define-constant he-file 1)
@@ -17 +21 @@
-(define entry-version (apply bitwise-ior flags))
-
+(define minimum-flags (list he-file))
+(define minimum-version (apply bitwise-ior minimum-flags))
+
+
+(define (check-versions minvers vers2)
+  (= (bitwise-and minvers vers2) minvers))
+
+(define (can-use? vers)
+  (check-versions minimum-version vers))
+
+(define (supports? vers what)
+  (> (bitwise-ior vers he-file) 0))
+
-(define-record-type help-entry 
-
+ xrefs
-  help-entry?
-  (name help-entry-name)
-  (aliases help-entry-aliases)
-
+
+
-
-(define-record-printer (help-entry x out)
-)
+ ~S)~N
-       (help-entry-name x)
-       (help-entry-aliases x)
-
+
+
-
-(define-reader-ctor 'help-entry make-help-entry)
-
+
-; Write a help entry list to a file
-(define (help-entries-save lst filename)
@@ -45 +64 @@
-      (signal 'invalid-argument)))
-
+(define (update-to-current vers data) data)
+
-; Load a help entry list
-(define (help-entries-load filename)
@@ -51 +72 @@
-      (let ((version (read)))
-    (cond
-integer
+can-use
-      (signal 'invalid-file-format))
-     ((not (= version entry-version))
-      (signal 'invalid-file-version))
-
-
-
-
-
-
+
+
+
+
+
+
+

1.8.3/branches/experimental/game/txt/helper/helper.scm

@@ -2 +2 @@
- (fixnum)
- (usual-integrations)
-
+
+
+
+
-
-(require-extension srfi-37)
-
-
-
-
+;
+;
+;
-
-
+(define help
+  (option
+   '(#\h "help") #f #f
+   (lambda (o n x vals)
+     (print #<<END
+Usage: helper [OPTIONS] CMD [ CMDARGS ]
+ 
+ OPTIONS:
+  -f HELPDB             Set the help database file
+  --warn-line-length N  The cutoff to warn about long lines in check.
+
+ COMMANDS:
+   init HELP.TXT  Create a new help database
+   check          Scan help entries for possible problems.
+END
+)
+     (exit 0))))
+
+(define set-db-file
+  (option
+   '(#\f) #t #f
+   (lambda (o n filename vals)
+     (option-set! 'help-db filename) 
+     '())))
+
+(define set-warn-line-length
+  (option
+   '("warn-line-length") #t #f
+   (lambda (o n len vals) 
+     (option-set! 'warn-line-length (string->number len))
+     '())))
+
+(define (load-help-db)
+  (help-entries-load (option-get 'help-db)))
+
+(define (handle-init helpfile)
+  (let ((help-db (option-get 'help-db)))
+    (printf "Making new help database ~S from help file ~S.\n"
+        help-db helpfile)
+    (if (file-exists? help-db) (delete-file help-db))
+    (help-entries-save (read-help-file helpfile) help-db)))
+
+(define (handle-checks)
+  (let ((help-db (load-help-db)))
+    (check-warnings help-db)))
+
+(define (commands cmd)
+  (if
+   (or (not (list? cmd)) (null? cmd))
+   (error "Missing command. Use helper --help for usage.")
+   (let ((arglen (length (cdr cmd)))
+     (args (cdr cmd))
+     (cmdname (car cmd)))
+     (cond
+      ((string-ci= cmdname "init")
+       (if (= arglen 1)
+       (handle-init (car args))
+       (error "init expects a help file name")))
+      ((string-ci= cmdname "check")
+       (handle-checks))
+      (else
+       (error "unknown command name " cmdname))))))
+
+(handle-exceptions
+ exn
+ (begin
+   (switch exn
+    ('invalid-argument (display "error: invalid argument\n"
+                (current-error-port)))
+    ('invalid-file-format (fprintf (current-error-port)
+                   "error: ~S is not a valid help db\n"
+                   (option-get 'help-db)))
+    ('invalid-file-version (fprintf (current-error-port)
+                    "error: ~S was created by an older version of this program and cannot  be read.\n"
+                    (option-get 'help-db)))
+    ('no-such-option (display "error: Attempted to use an invalid config option\n"
+                  (current-error-port)))
+    ('parse-error (display "error: parse error in help file\n" 
+               (current-error-port)))
+    (else (abort exn)))
+    (exit 1))
+ (commands
+  (reverse (args-fold
+        (command-line-arguments)
+        (list help set-db-file set-warn-line-length)
+        (lambda (o n x vals)
+          (fprintf (current-error-port) "Unrecognized option ~A\n" n)
+          (exit 1))
+        cons
+        '()))))
+
+
+
+

1.8.3/branches/experimental/game/txt/helper/options.scm

@@ -5 +5 @@
- (unit helper:options)
- (usual-integrations)
-
-option 
+-get
+real-
-
-(define options-tab
-  '((tempate-directory . "helper/templates")
+    (warn-line-length . 78)
-    (help-db . "help.db")))
-
@@ -20 +21 @@
-    (signal 'no-such-option))))
-
-
+real-
-  (let ((val (assq name options-tab)))
-    (if val (cdr val) (signal 'no-such-option))))
-
- (getter-with-setter 
+-get (getter-with-setter real-

1.8.3/branches/experimental/game/txt/helper/read.scm

@@ -4 +4 @@
- (disable-interrupts)
- (unit helper:read)
-
+ helper:warnings
- (export read-help-file)
-
+
+
+
-
-; Read a help file, return a list version
-(define (read-help-file filename)
-  (with-input-from-file filename do-read-help-file))
+
+; Remove leading empty lines (Blank or all whitespace) from list
+(define (trim-empty-lines lst)
+  (cond
+   ((null? lst) '())
+   ((string-null? (string-trim-both (car lst)))
+    (trim-empty-lines (cdr lst)))
+   (else lst)))
+
+(define (not-null? lst) (not (null? lst)))
-
-; Really read a help file
@@ -21 +33 @@
-       (current-aliases '())
-       (current-body '()))
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-                    ; Start of new entry
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-