;;;; typed-define.scm
;;;; Kon Lovett, Oct '17

(module typed-define

(;export
  define:
)

(import scheme)

(import chicken)

(import (only srfi-1 append! reverse!))
(require-library srfi-1)

;; typed scheme

(define-syntax define:
  (syntax-rules (-> -->)
    ;
    ;Pure
    ;
    ((_ (?name (?v ?t) ...) --> ?rt ?body ...)
      (define:-procedure (?name (?v ?t) ...) --> ?rt ?body ...) )
    ;
    ((_ (?name . (?rest ?at)) --> ?rt ?body ...)
      (define:-procedure (?name . (?rest ?at)) --> ?rt ?body ...) )
    ;
    ((_ (?name (?v ?t) . (?rest ?at)) --> ?rt ?body ...)
      (define:-procedure (?name (?v ?t) . (?rest ?at)) --> ?rt ?body ...) )
    ;
    ((_ (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) --> ?rt ?body ...)
      (define:-procedure (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) --> ?rt ?body ...) )
    ;
    ;Impure
    ;
    ((_ (?name (?v ?t) ...) -> ?rt ?body ...)
      (define:-procedure (?name (?v ?t) ...) -> ?rt ?body ...) )
    ;
    ((_ (?name . (?rest ?at)) -> ?rt ?body ...)
      (define:-procedure (?name . (?rest ?at)) -> ?rt ?body ...) )
    ;
    ((_ (?name (?v ?t) . (?rest ?at)) -> ?rt ?body ...)
      (define:-procedure (?name (?v ?t) . (?rest ?at)) -> ?rt ?body ...) )
    ;
    ((_ (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) -> ?rt ?body ...)
      (define:-procedure (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) -> ?rt ?body ...) )
    ;
    ;Impure Convenience
    ;
    ((_ (?name (?v ?t) ...) ?body ...)
      (define: (?name (?v ?t) ...) -> void
        ?body ...) )
    ;
    ((_ (?name (?v ?t) . (?rest ?at)) ?body ...)
      (define: (?name (?v ?t) . (?rest ?at)) -> void
        ?body ...) )
    ;
    ((_ (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) ?body ...)
      (define: (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) -> void
        ?body ...) ) ) )

;typed scheme support
(define-syntax define:-procedure
  (syntax-rules ()
    ;
    ;XXX
    ;
    ((_ (?name (?v ?t) ...) ?arrow ?rt ?body ...)
      (begin
        (: ?name (?t ... ?arrow ?rt))
        (define (?name ?v ...)
          ?body ... ) ) )
    ;
    ((_ (?name . (?rest ?at)) ?arrow ?rt ?body ...)
      (begin
        (: ?name (#!rest ?arrow ?rt))
        (define (?name . ?rest)
          ?body ... ) ) )
    ;
    ((_ (?name (?v ?t) . (?rest ?at)) ?arrow ?rt ?body ...)
      (begin
        (: ?name (?t #!rest ?arrow ?rt))
        (define (?name ?v . ?rest)
          ?body ... ) ) )
    ;
    ((_ (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) ?arrow ?rt ?body ...)
      (begin
        (: ?name (?t ... ?tn #!rest ?arrow ?rt))
        (define (?name ?v ... ?vn . ?rest)
          ?body ... ) ) ) ) )

) ;module typed-define