#!/usr/bin/newlisp
;; @module generics
;; @author Jeff Ober <jeffober@gmail.com>
;; @version 1.2
;; @location http://static.artfulcode.net/newlisp/generics.lsp
;; @description Provides generic functions for newLISP. Requires the util module.
;;
;; <p>
;; <h4>Version history</h4>
;; <b>1.2</b>
;; • methods may now use 'args'
;;
;; <b>1.1</b>
;; • fixed bug in method lookups that disallowed certain similar type combinations
;;
;; <b>1.0</b>
;; • initial release
;; </p>
;;; util module required
(define _generics:_generics) ; hash to store generic functions
(define (method-name fn-name params)
(string (cons (name fn-name) params)))
(define (add-generic fn-name params body)
(or (_generics (string fn-name)) (_generics (string fn-name) '()))
(let ((type-list '()) (arg-list '()))
(dolist (p params)
(unless (and (list? p) (string? (first p))) ; ("type" (param default)) or ("type" param)
(setq p (list nil p)))
(push (p 0) type-list -1)
(push (p 1) arg-list -1))
(letex ((arg-list arg-list) (body body))
(letn ((lst (_generics (string fn-name)))
(f (fn arg-list body))
(existing (find (list type-list f) lst)))
(if existing (pop lst existing))
(push (list type-list f) lst)
(_generics (string fn-name) lst)))))
(define (match-score type-signature param-type-list)
(if (> (length type-signature) (length param-type-list))
0
(let ((score 0))
(dolist (elt type-signature)
(inc 'score (cond ((nil? elt) 0.5)
((= elt (nth $idx param-type-list)) 1)
(true 0))))
score)))
(define (get-method fn-name params , func (n 0))
(dolist (f (_generics (string fn-name)))
(let ((x (match-score (first f) (map 'type-of params))))
(when (> x n)
(setq n x)
(setq func f))))
(or func (throw-error (string "no method " fn-name " found matching "
(map 'type-of params)))))
(define (call-method fn-name params)
(let ((f (get-method fn-name params)))
(if f
(local (res)
(if (catch (apply (last f) params) 'res)
res
(throw-error (format "error signaled in %s %s:\n\t%s"
(string fn-name)
(string (first f))
res))))
(throw-error (format "No method '%s for parameter types %s"
(name fn-name)
(string (map 'type-of params)))))))
;; @syntax (define-method (<sym-name> (<string-type-1> (<sym-param-1> <default-value-1>)) ...) <body>)
;; @param <sym-name> the method's name
;; @param <string-type-n> the type of the nth parameter
;; @param <sym-param-n> the name of the nth parameter
;; @param <default-value-n> optional; the default nth of the first parameter
;; @param <body> the forms that make up the function body
;;
;; <p>Creates a generic function as <sym-name> that corresponds to the types of the parameters passed.
;; Passed parameters are a list of a string type and a normal function parameter, which may be either
;; a symbol or a list of a symbol and the parameter's default value.</p>
;;
;; <p>Generic functions are <parametrically polymorphic>. This means that a function may have
;; multiple type signatures, and the code block that is applied is determined at run-time by the
;; types of the values passed to it.</p>
;;
;; <p>Note that all <em>listed</em> parameters are required for generic functions. This additionally
;; means that the practice of using "empty" parameters after a comma is not supported for generic
;; functions either.</p>
;;
;; Each parameter may consist of:<pre>
;; (string-type (sym-param default-value))
;; (string-type sym-param)
;; (sym-param default-value)
;; sym-param
;; </pre>
;;
;; <p>Parameters without a type will match any type of value. Parameters with a type must match
;; the passed value's type to match with a generic function.</p>
;;
;; @example
;; (define-method (area ("integer" x) ("integer" y))
;; (* x y))
;;
;; (area 3 4) => 12
;; (area 3 "four") => error!
;;
;; (define-method (area ("integer" x) ("string" y))
;; (format "%d times %s" x y))
;;
;; (area 3 "four") => "3 times four"
(define-macro (define-method)
(letex ((fn-name (args 0 0))
(param-list (rest (args 0)))
(body (cons 'begin (rest (args)))))
(add-generic 'fn-name 'param-list 'body)
(unless (lambda? fn-name)
(define (fn-name)
(call-method 'fn-name (args))))))
(global 'define-method)
syntax highlighting with newLISP and newLISPdoc