Tuplanolla

#lang r5rs

(#%require srfi/39)
(#%require (prefix base: racket/base)
           (prefix base: racket/function))
(#%require (prefix match: racket/match))

(define (make-method)
  (make-parameter 'unimplemented-method))

(define-syntax forall
  (syntax-rules ()
    ((_ arg ...) (lambda arg ...))))

(base:define-namespace-anchor anchor)

(define (with-instance-thunk inst thunk)
  (eval `(parameterize ,inst (,thunk))
        (base:namespace-anchor->namespace anchor)))

(define-syntax with-instance
  (syntax-rules ()
    ((_ inst body ...)
     (with-instance-thunk inst (lambda () body ...)))))

(define fmap-method (make-method))
(define (fmap f a)
  ((fmap-method) f a))

(define functor-identity?
  (forall (a)
    (equal? (fmap base:identity a)
            a)))

(define functor-compose?
  (forall (f g a)
    (equal? (fmap (base:compose f g) a)
            (fmap f (fmap g a)))))

(define list-functor
  `((fmap-method ,(lambda (f a) (map f a)))))

(with-instance list-functor
  (display (fmap (lambda (x) (+ 1 x)) (list 42 13)))
  (newline))