1 files changed, 77 insertions, 0 deletions
diff --git a/irc/bot.rkt b/irc/bot.rkt
new file mode 100644
index 0000000..a26e0df
--- /dev/null
+++ b/irc/bot.rkt
@@ -0,0 +1,77 @@
+#lang racket/base
+(require "core.rkt"
+         (for-syntax racket/base racket/syntax)
+         racket/stxparam)
+(provide (all-defined-out))
+
+(define current-nick (make-parameter #f))
+
+(define (tags) (message-tags (current-message)))
+(define (prefix) (message-prefix (current-message)))
+(define (command) (message-command (current-message)))
+(define (args) (message-args (current-message)))
+(define (suffix) (message-suffix (current-message)))
+(define (params) (message-params (current-message)))
+
+(define (source) (message-prefix-nick (current-message)))
+(define (target) (car (params)))
+(define (context)
+  (let* ([t (target)]
+         [is-channel (memv (string-ref t 0) '(#\# #\& #\+))])
+    (if is-channel t (source))))
+
+(define-syntax-parameter it
+  (λ (stx) (raise-syntax-error 'it "Use of the \"it\" identifier is not allowed here" stx)))
+(define-syntax (comparison-functions stx)
+  (syntax-case stx ()
+    [(_ name)
+     (with-syntax ([name-is (format-id stx "~a-is" #'name)]
+                 [name-match (format-id stx "~a-match" #'name)])
+      #'(begin
+          (define (name-is expected)
+            (let ([actual (name)])
+            (and actual (equal? actual expected))))
+          (define-syntax-rule (name-match test)
+            (let ([actual (name)])
+              (and actual 
+                (syntax-parameterize ([it (make-rename-transformer #'actual)])
+                  test))))))]))
+
+(comparison-functions tags)
+(comparison-functions prefix)
+(comparison-functions command)
+(comparison-functions args)
+(comparison-functions suffix)
+(comparison-functions params)
+(comparison-functions source)
+(comparison-functions target)
+(comparison-functions context)
+
+(define (register [nick (current-nick)]
+                  #:user [user nick] #:mode [mode "*"]
+                  #:unused [unused "*"] #:realname [realname user]
+                  #:pass [pass #f])
+  (when pass (send (msg 'PASS '() pass)))
+  (send (msg 'USER (list user mode unused) realname))
+  (send (msg 'NICK '() nick)))
+
+(define (join . chans)
+  (send (msg 'JOIN chans #f)))
+
+(define (quit reason)
+  (send (msg 'QUIT '() reason)))
+
+(define (privmsg to content)
+  (send (msg 'PRIVMSG (list to) content)))
+
+(define (notice to content)
+  (send (msg 'NOTICE (list to) content)))
+
+(define (reply content)
+  (privmsg (context) content))
+
+(define (reply-notice content)
+  (notice (context) content))
+
+(define-syntax-rule (on condition action ...)
+  (hook-add (current-connection) (λ () (when condition action ...))))