blob: a26e0df7fd9afcfc027e6ba74ac0cad0c48553f7 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
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 ...))))
|