xK/plugins/xB/calc

#!/usr/bin/env guile

  xB calc plugin, basic Scheme evaluator

  Copyright 2016 Přemysl Eric Janouch
  See the file LICENSE for licensing information.

!#

(import (rnrs (6)))
(use-modules ((rnrs) :version (6)))

; --- Message parsing ----------------------------------------------------------

(define-record-type message (fields prefix command params))
(define (parse-message line)
  (let f ([parts '()] [chars (string->list line)])
    (define (take-word w chars)
      (if (or (null? chars) (eqv? (car chars) #\x20))
        (f (cons (list->string (reverse w)) parts)
           (if (null? chars) chars (cdr chars)))
        (take-word (cons (car chars) w) (cdr chars))))
    (if (null? chars)
      (let ([data (reverse parts)])
        (when (< (length data) 2)
          (error 'parse-message "invalid message"))
        (make-message (car data) (cadr data) (cddr data)))
      (if (null? parts)
        (if (eqv? (car chars) #\:)
          (take-word '() (cdr chars))
          (f (cons #f parts) chars))
        (if (eqv? (car chars) #\:)
          (f (cons (list->string (cdr chars)) parts) '())
          (take-word '() chars))))))

; --- Utilities ----------------------------------------------------------------

(define (display-exception e port)
  (define (puts . x)
    (for-all (lambda (a) (display a port)) x)
    (newline port))

  (define (record-fields rec)
    (let* ([rtd (record-rtd rec)]
           [v (record-type-field-names rtd)]
           [len (vector-length v)])
      (map (lambda (k i) (cons k ((record-accessor rtd i) rec)))
        (vector->list v)
        (let c ([i len] [ls '()])
          (if (= i 0) ls (c (- i 1) (cons (- i 1) ls)))))))

  (puts "Caught " (record-type-name (record-rtd e)))
  (for-all
    (lambda (subtype)
      (puts "  " (record-type-name (record-rtd subtype)))
      (for-all
        (lambda (field) (puts "    " (car field) ": " (cdr field)))
        (record-fields subtype)))
    (simple-conditions e)))

; XXX - we have to work around Guile's lack of proper eol-style support
(define xc (make-transcoder (latin-1-codec) 'lf 'replace))
(define irc-input-port (transcoded-port (standard-input-port) xc))
(define irc-output-port (transcoded-port (standard-output-port) xc))

(define (send . message)
  (for-all (lambda (x) (display x irc-output-port)) message)
  (display #\return irc-output-port)
  (newline irc-output-port)
  (flush-output-port irc-output-port))

(define (get-line-crlf port)
  (define line (get-line port))
  (if (eof-object? line) line
    (let ([len (string-length line)])
      (if (and (> len 0) (eqv? (string-ref line (- len 1)) #\return))
        (substring line 0 (- len 1)) line))))

(define (get-config name)
  (send "XB get_config :" name)
  (car (message-params (parse-message (get-line-crlf irc-input-port)))))

(define (extract-nick prefix)
  (do ([i 0 (+ i 1)] [len (string-length prefix)])
      ([or (= i len) (char=? #\! (string-ref prefix i))]
       [substring prefix 0 i])))

(define (string-after s start)
  (let ([s-len (string-length s)] [with-len (string-length start)])
    (and (>= s-len with-len)
         (string=? (substring s 0 with-len) start)
         (substring s with-len s-len))))

; --- Calculator ---------------------------------------------------------------

; Evaluator derived from the example in The Scheme Programming Language.
;
; Even though EVAL with a carefully crafted environment would also do a good
; job at sandboxing, it would probably be impossible to limit execution time...

(define (env-new formals actuals env)
  (cond [(null? formals) env]
        [(symbol? formals) (cons (cons formals actuals) env)]
        [else (cons (cons (car formals) (car actuals))
                    (env-new (cdr formals) (cdr actuals) env))]))
(define (env-lookup var env) (cdr (assq var env)))
(define (env-assign var val env) (set-cdr! (assq var env) val))

(define (check-reductions r)
  (if (= (car r) 0)
    (error 'check-reductions "reduction limit exceeded")
    (set-car! r (- (car r) 1))))

; TODO - think about implementing more syntactical constructs,
;   however there's not much point in having anything else in a calculator...
(define (exec expr r env)
  (check-reductions r)
  (cond [(symbol? expr) (env-lookup expr env)]
        [(pair? expr)
         (case (car expr)
           [(quote) (cadr expr)]
           [(lambda) (lambda vals
                       (let ([env (env-new (cadr expr) vals env)])
                         (let loop ([exprs (cddr expr)])
                           (if (null? (cdr exprs))
                             (exec (car exprs) r env)
                             (begin (exec (car exprs) r env)
                                    (loop (cdr exprs)))))))]
           [(if) (if (exec (cadr expr) r env)
                   (exec (caddr expr) r env)
                   (exec (cadddr expr) r env))]
           [(set!) (env-assign (cadr expr) (exec (caddr expr) r env) env)]
           [else (apply (exec (car expr) r env)
                        (map (lambda (x) (exec x r env)) (cdr expr)))])]
        [else expr]))

(define-syntax forward
  (syntax-rules ()
    [(_) '()]
    [(_ a b ...) (cons (cons (quote a) a) (forward b ...))]))

; ...which can't prevent me from simply importing most of the standard library
(define base-library
  (forward
    ; Equivalence, procedure predicate, booleans
    eqv? eq? equal? procedure? boolean? boolean=? not
    ; numbers, numerical input and output
    number? complex? real? rational? integer?  exact? inexact? exact inexact
    real-valued? rational-valued? integer-valued? number->string string->number
    ; Arithmetic
    = < > <= >= zero? positive? negative? odd? even? finite? infinite? nan?
    min max + * - / abs div-and-mod div mod div0-and-mod0 div0 mod0
    gcd lcm numerator denominator floor ceiling truncate round
    rationalize exp log sin cos tan asin acos atan sqrt expt
    make-rectangular make-polar real-part imag-part magnitude angle
    ; Pairs and lists
    map for-each cons car cdr caar cadr cdar cddr
    caaar caadr cadar caddr cdaar cdadr cddar cdddr
    caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
    cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
    pair? null? list? list length append reverse list-tail list-ref
    ; Symbols
    symbol? symbol=? symbol->string string->symbol
    ; Characters
    char? char=? char<? char>? char<=? char>=?  char->integer integer->char
    ; Strings; XXX - omitted make-string - can cause OOM
    string? string=? string<? string>? string<=? string>=?
    string string-length string-ref substring
    string-append string->list list->string string-for-each string-copy
    ; Vectors; XXX - omitted make-vector - can cause OOM
    vector? vector vector-length vector-ref vector-set!
    vector->list list->vector vector-fill! vector-map vector-for-each
    ; Control features
    apply call/cc values call-with-values dynamic-wind))
(define extended-library
  (forward
    char-upcase char-downcase char-titlecase char-foldcase
    char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=?
    char-alphabetic? char-numeric? char-whitespace?
    char-upper-case? char-lower-case? char-title-case?
    string-upcase string-downcase string-titlecase string-foldcase
    string-ci=? string-ci<? string-ci>? string-ci<=? string-ci>=?
    find for-all exists filter partition fold-left fold-right
    remp remove remv remq memp member memv memq assp assoc assv assq cons*
    list-sort vector-sort vector-sort!
    bitwise-not bitwise-and bitwise-ior bitwise-xor bitwise-if
    bitwise-bit-count bitwise-length bitwise-first-bit-set bitwise-bit-set?
    bitwise-copy-bit bitwise-bit-field bitwise-copy-bit-field
    bitwise-arithmetic-shift bitwise-rotate-bit-field bitwise-reverse-bit-field
    bitwise-arithmetic-shift-left bitwise-arithmetic-shift-right
    set-car! set-cdr! string-set! string-fill!))
(define (interpret expr)
  (exec expr '(2000) (append base-library extended-library)))

; We could show something a bit nicer but it would be quite Guile-specific
(define (error-string e)
  (map (lambda (x) (string-append " " (symbol->string x)))
    (filter (lambda (x) (not (member x '(&who &message &irritants &guile))))
      (map (lambda (x) (record-type-name (record-rtd x)))
        (simple-conditions e)))))

(define (calc input respond)
  (define (stringify x)
    (call-with-string-output-port (lambda (port) (write x port))))
  (guard (e [else (display-exception e (current-error-port))
                  (apply respond "caught" (error-string e))])
    (let* ([input (open-string-input-port input)]
           [data (let loop ()
                   (define datum (get-datum input))
                   (if (eof-object? datum) '() (cons datum (loop))))])
      (call-with-values
        (lambda () (interpret (list (append '(lambda ()) data))))
        (lambda message
          (for-all (lambda (x) (respond (stringify x))) message))))))

; --- Main loop ----------------------------------------------------------------

(define prefix (get-config "prefix"))
(send "XB register")

(define (process msg)
  (when (string-ci=? (message-command msg) "PRIVMSG")
    (let* ([nick (extract-nick (message-prefix msg))]
           [target (car (message-params msg))]
           [response-begin
             (apply string-append "PRIVMSG "
               (if (memv (string-ref target 0) (string->list "#&!+"))
                 `(,target " :" ,nick ": ") `(,nick " :")))]
           [respond (lambda args (apply send response-begin args))]
           [text (cadr (message-params msg))]
           [input (or (string-after text (string-append prefix "calc "))
                      (string-after text (string-append prefix "= ")))])
      (when input (calc input respond)))))

(let main-loop ()
  (define line (get-line-crlf irc-input-port))
  (unless (eof-object? line)
    (guard (e [else (display-exception e (current-error-port))])
      (unless (string=? "" line)
        (process (parse-message line))))
    (main-loop)))