(module proj mzscheme
  (require (lib "plt-match.ss")
           (lib "unitsig.ss")
           (lib "etc.ss")
           (lib "list.ss"))
  (require (planet "maybe.ss" ("jaymccarthy" "mmss.plt" 1)))
  (require "fmap.ss")
  (provide (all-defined))
  
  (define (proj-fmap@ proj proj-1 fmap@)
    (define proj@
      (unit/sig fmap^ (import (base-fmap : fmap^))      
        (define fmap? base-fmap:fmap?)
        (define is-equal? #f)
        (define elt-equal? #f)
        (define empty base-fmap:empty)
        (define empty? base-fmap:empty?)
        (define (singleton k v)
          (base-fmap:singleton (proj k) v))
        (define (lookup k t)
          (base-fmap:lookup (proj k) t))
        (define (insert c k v t)
          (base-fmap:insert c (proj k) v t))
        (define (remove k t)
          (base-fmap:remove (proj k) t))
        (define merge base-fmap:merge)
        (define (foldr f i t)
          (base-fmap:foldr (lambda (k v acc)
                             (f (proj-1 k) v acc))
                           i t))
        (define (member? k t)
          (base-fmap:member? (proj k) t))))
    (compound-unit/sig (import)
                       (link [BASE : fmap^ (fmap@)]
                             [PROJ : fmap^ (proj@ BASE)])
                       (export (open PROJ)))))