Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
210 lines (201 sloc) 9.57 KB
(define *protocols* #{})
(define *impls* #{})
; as this is loaded really early in the startup it looks a little hairy.
; sorry about that. i should probably define at least curry and compose
; before this is executed, but so far i have not.
; here be dragons.
(define-syntax defprotocol
(syntax-rules ()
((_ name functions ...)
(let ((env (current-env))
(list:cadr (lambda (x) (list:car (list:cdr x))))
(list:caadr (lambda (x) (list:car (list:car (list:cdr x)))))
(list:caddr (lambda (x) (list:car (list:cdr (list:cdr x)))))
(str (symbol->string 'name)))
(eval `(define (,(string->symbol (++ str "?")) arg)
,(++ "checks whether the given object <par>arg</par> implements the " str "
protocol. The following functions are part of this protocol:
<ul>" (foldl (lambda (acc x)
(++ acc "<li><fun>"
(symbol->string (list:car x))
'functions) "</ul>
- arg: the object that should be checked
complexity: O(1)
returns: a boolean")
(let* ((impls (*impls* ,str))
(funs (hash:kv-filter
(lambda (kv)
(eval (list (string->symbol (list:car kv))
(if (truthy? impls) impls (make-hash)))))
(not (list:null? funs))))
(lambda (x)
(define strx (symbol->string (list:car x)))
(eval `(define ,(list:car x) (lambda args
,(if (> (list:length x) 2)
(list:caddr x)
(++ "This function is part of the <fun>" str "?</fun> protocol.
Any datatype that uses it needs to implement this protocol.
- args: the arguments that need to be passed through (varargs); the first argument is always the datatype
complexity: varies with the implementation
returns: varies with the implementation"))
(let ((impls (*impls* ,str))
(arg (list:car args)))
(if (or (eq? (list:length args) ,(list:cadr x))
(eq? :overloaded ,(list:cadr x)))
(if (nil? impls)
"No implementation specified for protocol"
(let ((funs (hash:kv-filter
(lambda (kv)
(,list:caadr kv)
(if (list:null? funs)
"No implementation of protocol"
,str "found for type" (typeof arg))
((list:car (list:cdr (list:car (list:cdr (list:car funs)))))
(error:from-string ,strx "takes" ,(list:cadr x)
"arguments, but was given" (length args))))))
(hash:set! *protocols* (symbol->string 'name) 'functions))))))
(define-syntax defimpl
(syntax-rules ()
((_ name pred funcs)
(let ((proto (map list:car (*protocols* (symbol->string 'name))))
(given (map list:car 'funcs))
(wrong-forms (filter (lambda (x) (/= 2 (list:length x))) 'funcs))
(nfuncs (map (lambda (x)
(list (symbol->string (list:car x))
(eval (macro-expand (list:car (list:cdr x))))))
(if (list:null? wrong-forms)
(if (nil? proto)
(error:from-string "protocol" 'name "not defined.")
(if (eq? proto given)
(hash:update! *impls* (symbol->string 'name)
(lambda (x)
(let ((x (if (truthy? x) x #{})))
(hash:set! x
(symbol->string 'pred)
(list pred (make-hash nfuncs))))))
(error:from-string "protocol" 'name "expects" proto
"to be defined, was given" given)))
(error:from-string "wrong forms" wrong-forms
"; expect forms to be of the form (name implementation)"))))))
(defprotocol stringify (->string 1))
(defimpl stringify hash-map?
(lambda (el)
(if (eq? #{} el)
(let ((s (hash:keys-reduce (lambda (acc x)
(++ acc (->string x) " "
(->string (el x)) ", "))
(++ (substring s 0 (- (string:length s) 2)) "}")))))))
(defimpl stringify string? ((->string id)))
(defimpl stringify regex? ((->string (lambda (r) (++ "/" (regex:pattern r) "/")))))
(defimpl stringify number? ((->string number->string)))
(defimpl stringify error? ((->string error:text)))
(defimpl stringify opaque? ((->string (lambda (_) "<opaque>"))))
(defimpl stringify pair?
(lambda (el)
(if (null? el)
(++ "pair["
(reduce (lambda (acc x) (++ acc ", " (->string x)))
(->string (head el))
(tail el))
(defimpl stringify list?
(lambda (el)
(if (null? el)
(++ "["
(reduce (lambda (acc x) (++ acc ", " (->string x)))
(->string (head el))
(tail el))
(defimpl stringify vector?
(lambda (el)
(if (vector:empty? el)
(++ "{"
(vector:reduce (lambda (acc x) (++ acc ", " (->string x)))
(->string (vector:head el))
(vector:tail el))
(defimpl stringify simple-list?
(lambda (el)
(let ((el (from-simple-list el)))
(if (null? el)
(++ "simple["
(reduce (lambda (acc x) (++ acc ", " (->string x)))
(->string (head el))
(tail el))
(defimpl stringify byte-vector?
(lambda (el)
(if (byte-vector:empty? el)
(++ "byte{"
(byte-vector:reduce (lambda (acc x) (++ acc ", " (->string x)))
(->string (byte-vector:head el))
(byte-vector:tail el))
(defimpl stringify atom? ((->string symbol->string)))
(defimpl stringify symbol? ((->string symbol->string)))
(defimpl stringify port? ((->string (lambda (x) "<port"))))
(defimpl stringify char? ((->string string)))
(defimpl stringify boolean? ((->string (lambda (el) (if el "true" "false")))))
(defimpl stringify procedure? ((->string (lambda (p) (++ "<procedure: " (doc p) ">")))))
(defimpl stringify primitive? ((->string (lambda (p) (++ "<primitive: " (doc p) ">")))))
(defimpl stringify function? ((->string (lambda (p) (++ "<function: " (doc p) ">")))))
(defimpl stringify env? ((->string (lambda (env) "<env>"))))
(defimpl stringify nil? ((->string (lambda (n) "nil"))))
(defprotocol bytify (->bytes 1))
(defimpl bytify nil? ((->bytes ($ b{0}))))
(defimpl bytify byte-vector? ((->bytes id)))
(defimpl bytify number? ((->bytes number->bytes)))
(defimpl bytify string? ((->bytes string->byte-vector)))
(defimpl bytify hash-map? ((->bytes
(lambda (x)
(lambda (acc kv) (++ acc (->bytes (car kv)) (->bytes (cadr kv))))
(defimpl bytify list?
(lambda (x) (reduce (lambda (acc x) (++ acc (->bytes x))) b{} x)))))
(defimpl bytify char? ((->bytes (lambda (x) (->bytes (string x))))))
(defimpl bytify port? ((->bytes (lambda (x) b{0}))))
(defimpl bytify boolean? ((->bytes (lambda (x) (if x b{1} b{0})))))
(defimpl bytify atom? ((->bytes (lambda (x) (->bytes (symbol->string x))))))
(defimpl bytify symbol? ((->bytes (lambda (x) (->bytes (symbol->string x))))))
(define-syntax ->symbol
(syntax-rules ()
((->symbol xs ...)
(string->symbol (reduce ++ "" (map ->string '(xs ...)))))))