Posted at

TypeSafe CLOS MOP

More than 5 years have passed since last update.

Gauche の CLOS, MOP, define-macro を使って Perl の moose 的 TypeSafe Scheme OOP をやってみる

See also

http://voqn.blogspot.com/2011/09/type-safe-metaclass-for-gauche-mop.html


mop.scm

(define-class <type-safe-meta> (<class>) (()))

(define-method compute-get-n-set ((class <type-safe-meta>) slot)
(let* ((has? (cut slot-definition-option slot <> #f))
(acc (compute-slot-accessor class slot (next-method)))
(type-error
(^ (value type)
(error
#`"Type Error : require type ,|type| but ,(class-of value)"
value)))
(validate-type
(^v (if-let1 t (has? :is-a)
(if (is-a? v t) v (type-error v t))
v)))
(validate-value
(^v (if-let1 validate (has? :validate) (validate v) v)))
(filter-value
(^v (if-let1 f (has? :filter) (f v) v))))
(if (or (has? :is-a) (has? :validate) (has? :filter))
(let1 filter/validate (.$ filter-value validate-value validate-type)
(list (^ (o) (slot-ref-using-accessor o acc))
(^ (o v) (slot-set-using-accessor! o acc (filter/validate v)))
(^ (o) (slot-bound-using-accessor? o acc))
#t))
(next-method))))



macro.scm

(define-macro (define-class* name supers slots . options)

`(define-class ,name ,supers
,(map (^s (let ((has? (cut get-keyword <> <> #f))
(key (car s))
(accessor (^ (k a) (string->symbol #`",|k|-,|a|")))
(rest (cdr s)))
(let1 compl (^ (k i)
(if (has? k rest) '()
(list k i)))
`(,key
,@(compl :init-value (make-init-value rest))
,@(compl :init-keyword (make-keyword key))
,@(compl :getter (accessor key 'of))
,@(if (or (has? :setter rest)
(has? :read-only rest)) '()
(list :setter (accessor key 'set!)))
,@rest))))
slots)
,@options))

(define (make-init-value key-list)
(let1 has? (cut get-keyword <> key-list #f)
(if-let1 t
(has? :is-a)
(case t
((<number> <complex> <real> <integer>) 0)
((<string>) "")
((<boolean>) #f)
((<list>) '())
((<vector>) '#())
(else (make t)))
(undefined))))



example.scm

(define (loop-mod$ max) 

(^x ((^v (if (= v (floor v)) (x->integer v) v))
(cond ((<= max x) (fmod x max))
((> 0 x) (fmod (+ x max) max))
(else x)))))

(define (inner$ min max) (cut clamp min <> max))

(define-class* <hsl> (<color>)
((hue :is-a <real> :filter (loop-mod$ 360))
(saturation :is-a <real> :filter (inner$ 0 1))
(luminance :is-a <real> :filter (inner$ 0 1))))