fmap-newtyped.lisp

(defgeneric _fmap (x f))

(defmacro fmap (f x)
  `(_fmap ,x #',f))

(defmethod _fmap ((x number) f)
  (funcall f x))

(defmethod _fmap ((x string) f)
  (funcall f x))

(defmethod _fmap ((x list) f)
  (mapcar f x))

(defmacro new (name &rest rest)
  (let* ((name-string (symbol-name name))
         (new-name (concatenate 'string "make-" name-string))
         (new-symbol (read-from-string new-name)))
    `(,new-symbol ,@rest)))

(defstruct newtyped label value)

(defun newtyped-p (x) (typep x 'newtyped))

(defmacro newtype (label value)
  `(new newtyped :label ',label :value ,value))

(defun label-eql (l x)
  (let ((is-newtyped (typep x 'newtyped)))
    (values (and is-newtyped (equalp l (newtyped-label x)))
            is-newtyped)))

(defmethod _fmap ((x newtyped) f)
  (let ((value (newtyped-value x))
        (label (newtyped-label x)))
    (new newtyped 
      :label label
      :value (funcall f value))))



(print (fmap 1+ 3))
(print (fmap 1+ (list 3 5 7 11)))
(print (fmap string-upcase "hallo!"))
(print (fmap 1- (newtype ID 3)))
(print (newtyped-value (fmap 1+ (newtype ID 3))))