static.rkt

#lang racket

(require (for-syntax racket/base
                     syntax/id-table
                     syntax/parse
                     syntax/parse/lib/function-header))
(module+ test (require rackunit))

(begin-for-syntax
  (define raw-sc (make-syntax-introducer))
  (define ctc-sc (make-syntax-introducer))

  (struct carrier-info (ctc-name raw-name arg-ctcs ret-ctc)
    #:property prop:rename-transformer 0)

  (define (make-ctc-map params-stx arg-ctcs-stx)
    (make-immutable-free-id-table
     (map cons (syntax->list params-stx) (syntax->list arg-ctcs-stx))))

  (define (satisfies? ctc-map op-info args)
    (define op-ctc-args (carrier-info-arg-ctcs op-info))
    (and (= (length op-ctc-args) (length args))
         (for/and ([op-ctc-arg (in-list op-ctc-args)]
                   [arg (in-list args)])
           (define arg-satisfies (free-id-table-ref ctc-map arg (λ () #f)))
           (and arg-satisfies (free-identifier=? arg-satisfies op-ctc-arg)))))

  (define (optimize-body stx ctc-map)
    (let go ([stx stx])
      (syntax-parse stx
        [(?name:id ?arg:id ...)
         #:do [(define-values (op-info _)
                 (syntax-local-value/immediate #'?name (λ () (values #f #f))))]
         #:when (carrier-info? op-info)
         #:when (satisfies? ctc-map op-info (syntax->list #'(?arg ...)))
         #:with ?raw-name (carrier-info-raw-name op-info)
         #'(?raw-name ?arg ...)]
        [(?e ...) (datum->syntax stx (map go (syntax->list #'(?e ...))))]
        [_ stx]))))

(define-syntax (define/contract/opt stx)
  (syntax-parse stx
    #:literals (->)
    [(_ ?header:function-header
        (-> ?arg-ctc:id ... ?ret-ctc:id)
        ?body:expr ...)
     #:with ?name #'?header.name
     #:with ?ctc-name (ctc-sc #'?name)
     #:with ?raw-name (raw-sc #'?name)
     #:with (?p ...) #'?header.params
     #:do [(define ctc-map (make-ctc-map #'(?p ...) #'(?arg-ctc ...)))]
     #:with ?opt-body (optimize-body #'(λ (?p ...) ?body ...) ctc-map)
     #'(begin
         (define-syntax ?name
           (carrier-info #'?ctc-name #'?raw-name
                         (list #'?arg-ctc ...)
                         #'?ret-ctc))
         (define (?raw-name ?p ...) ?body ...)
         (define/contract ?ctc-name (-> ?arg-ctc ... ?ret-ctc) ?opt-body))]))

(module+ test
  (define (integer! x)
    (displayln "ok")
    (integer? x))

  (define/contract/opt (my-add1 x)
    (-> integer! integer?)
    (+ 1 x))

  (define/contract/opt (f x)
    (-> integer! integer?)
    (my-add1 x))

  ;; notice only one "ok"
  (check-eq? (f 42) 43))