Polymorphic contracts and generics

gistfile1.rkt

#lang racket

;; generics with parametric contracts

(module stack racket
  (require racket/generic)
  
  ;; The following defines:
  ;;   * gen:stack
  ;;   * stack?
  ;;   * stack/c
  ;;   * stack-push
  ;;   * stack-pop
  ;;   * stack-peek
  (define-generics stack
    (stack-push stack elem)
    (stack-pop stack)
    (stack-peek stack))
  
  (define (make-stack/c elem/c)
    (define rec-stack/c (recursive-contract (make-stack/c elem/c)))
    (stack/c
     [stack-push (-> rec-stack/c elem/c rec-stack/c)]
     [stack-pop (-> rec-stack/c rec-stack/c)]
     [stack-peek (-> rec-stack/c elem/c)]))

  (define elem/c (new-∀/c 'elem))
  (define poly-stack/c (make-stack/c elem/c))

  (provide gen:stack
           stack?
           make-stack/c
           ;; generic functions have polymorphic contracts
           (contract-out 
            [stack-push (-> poly-stack/c elem/c poly-stack/c)]
            [stack-pop (-> poly-stack/c poly-stack/c)]
            [stack-peek (-> poly-stack/c elem/c)])))
  
(module instance racket
  (require (submod ".." stack))
  
  (define-struct list-stack (l)
    #:methods gen:stack
    [(define (stack-push stack elem)
       (list-stack (cons elem (list-stack-l stack))))
     (define (stack-pop stack)
       (define lst (list-stack-l stack))
       (if (empty? lst)
           stack
           (list-stack (cdr lst))))
     (define (stack-peek stack)
       (car (list-stack-l stack)))])
  
  (provide
   (contract-out
    ;; specific instantiation of contract
    [list-stack (-> (listof symbol?) (make-stack/c symbol?))])))

(require 'stack 'instance)

(define stack (list-stack '(a b c)))

;; these work fine
(stack-pop stack)
(stack-peek stack)
(stack-pop (stack-push stack 'e))

;; contract violation
(stack-push stack 5)