Add command abstraction

1 files changed, 62 insertions, 0 deletions

diff --git a/irc/command.rkt b/irc/command.rkt
new file mode 100644
index 0000000..933f7e5
--- /dev/null
+++ b/irc/command.rkt
@@ -0,0 +1,62 @@
+#lang racket/base
+(require (for-syntax racket/base racket/list syntax/parse syntax/parse/lib/function-header)
+         irc/bot irc/users racket/format racket/string)
+(provide define-command)
+
+(struct command-registration (signature help power action))
+(define current-commands (make-parameter (make-hash)))
+
+(define (command-add signature action
+                     #:help [help #f]
+                     #:power [power 0])
+  (hash-set! (current-commands)
+    (car signature) (command-registration signature help power action)))
+
+(define (sufficient-power? nick wanted)
+  (or (= wanted 0)
+      (and (is-identified? nick)
+           (>= (user-power nick) wanted))))
+
+(define (command-process)
+  (define s-exp (safe-read-string (string-join (cdr (params)))))
+  (when (pair? s-exp)
+    (define command (hash-ref (current-commands) (car s-exp) #f))
+    (define required-power (command-registration-power command))
+    (when command
+      (if (sufficient-power? (source) required-power)
+        (apply (command-registration-action command)
+               (cdr s-exp))
+        (reply (format "Insufficient power (~a required)" required-power))))))
+
+(on (and (command-is 'PRIVMSG)
+         (not (source-is (current-nick))))
+    (command-process))
+
+(define-syntax (define-command stx)
+  (define-splicing-syntax-class single-keyword
+    (pattern (~seq kwname:keyword kwval:expr)))
+
+  (syntax-parse stx
+    [(_ (name:id fn ...)
+        kw:single-keyword ...
+        action ...)
+     (with-syntax ([(kw ...)
+                    (append* (map syntax->list (syntax->list #'(kw ...))))])
+       #'(command-add '(name fn ...) kw ... (lambda (fn ...) action ...)))]))
+
+(define-command (list)
+  #:help "List all registered commands"
+  (reply (~s (hash-map (current-commands)
+                       (λ (k v) (car (command-registration-signature v)))))))
+
+(define-command (help [command #f])
+  #:help "Display command argument names and description"
+  (if command
+    (let ([c (hash-ref (current-commands) command #f)])
+      (if c
+        (let* ([cr (command-registration-signature c)]
+               [help (command-registration-help c)])
+          (if help (reply (format "~s - ~a" cr help))
+                   (reply (~s cr))))
+        (reply "There is no such command")))
+    (reply "You need to supply a command name, e.g. (help list)")))