#lang scheme
(require "typeclass-units.ss")

;; Shapes have a numeric area.
(define-signature shape^
  ((contracted [area (-> any/c number?)])))

;; Shapes have a slot for their shape^-exporting instance
(define-struct shape (instance))

;; A circle is a shape with a radius
(define-struct (circle shape) (radius))
(define-instance shape^ circle@
  (define (area c) (* pi (circle-radius c) (circle-radius c))))

(define (build-circle r)
  (make-circle circle@ r))
  
;; A square is a shape with a side length
(define-struct (square shape) (side))
(define-instance shape^ square@
  (define (area s) (* (square-side s) (square-side s))))

(define (build-square s)
  (make-square square@ s))


;; Compute the area of any shape
(define-constrained (shape-area (shape^) => shape)
  (area shape))

;; Sum the areas of a list of shapes
(define (sum-areas shapes)
  (foldl (λ(shape sum) (+ sum ((shape-area (shape-instance shape)) shape)))
         0
         shapes))

;; Try summing the areas of shapes in a heterogenous list.
(define (test-area)
  (sum-areas (list (build-square 4) (build-circle 3))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Example of violating a typeclass contract

(define-struct (bad shape) (foo))

(define-instance shape^ bad@
  (define (area b) "I'm not an area!"))

(define (build-bad x) (make-bad bad@ x))

(define (test-bad-shape)
  (let ((b (build-bad 'bar)))
    ((shape-area (shape-instance b)) b)))