blob: c0d9d22f58453225b8cf7cc4dd8edf1641f2575b (
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
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
|
#lang racket/base
(require "core.rkt"
(for-syntax racket/base racket/syntax)
racket/string racket/function
racket/stxparam)
(provide (all-defined-out))
(define (replace-many s rep)
(foldl (λ (rep acc) (apply string-replace acc rep)) s rep))
(define casemap-empty '())
(define casemap-uppercase-strict-rfc1459
'(("{" "[") ("}" "]") ("|" "\\")))
(define casemap-lowercase-strict-rfc1459
(map reverse casemap-uppercase-strict-rfc1459))
(define casemap-uppercase-relaxed-rfc1459
(cons '("^" "~") casemap-uppercase-strict-rfc1459))
(define casemap-lowercase-relaxed-rfc1459
(map reverse casemap-uppercase-relaxed-rfc1459))
(define (irc-downcase s [casemap casemap-lowercase-relaxed-rfc1459])
(replace-many (string-downcase s) casemap))
(define (irc-upcase s [casemap casemap-uppercase-relaxed-rfc1459])
(replace-many (string-upcase s) casemap))
(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 (unaltered-source) (message-prefix-nick (current-message)))
(define (source) (irc-downcase (unaltered-source)))
(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 "0"]
#: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 ...))))
(define-syntax-rule (on-once condition action ...)
(on condition action ... hook-abort))
; does this belong here?
(define (safe-read-string s)
(call-with-default-reading-parameterization
(thunk (read (open-input-string s)))))
|