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

(module typed-define

(;export
  define:-record-type
  define:)

(import scheme chicken)

;; typed scheme

(define-syntax define:-record-type
  (syntax-rules ()
    ((_ ?tag (?ctor-id ?ctor-args ...) ?pred-id (?feld-var ?feld-typ ?feld-ref ...)  ...)
      (begin
        (define-type ?tag (struct ?tag))
        (: ?ctor-id (#!rest --> ?tag))
        (: ?pred-id (* -> boolean : ?tag))
        (type:-record-type-accessor ?tag (?feld-var ?feld-typ ?feld-ref ...)) ...
        ;build type-dict from ?ctor-args ...
        (define-record-type ?tag
          (?ctor-id ?ctor-args ...)
          ?pred-id
          (?feld-var ?feld-ref ...) ...) ) ) ) )

(define-syntax define:
  (syntax-rules (-> --> #!optional #!rest #!key)
    ;
    ;Pure
    ;
    ((_ (?name) --> ?rt ?body ...)
      (define:-procedure (?name) --> ?rt ?body ...) )
    ;
    ((_ (?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) ... (?vn ?tn) . (?rest ?at)) --> ?rt ?body ...)
      (define:-procedure (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) --> ?rt ?body ...) )
    ;
    ;Impure
    ;
    ((_ (?name) -> ?rt ?body ...)
      (define:-procedure (?name) -> ?rt ?body ...) )
    ;
    ((_ (?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) ... (?vn ?tn) . (?rest ?at)) -> ?rt ?body ...)
      (define:-procedure (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) -> ?rt ?body ...) )
    ;
    ;Impure Convenience
    ;
    ((_ (?name) ?body ...)
      (define: (?name) -> undefined
        ?body ...) )
    ;
    ((_ (?name (?v ?t) ...) ?body ...)
      (define: (?name (?v ?t) ...) -> undefined
        ?body ...) )
    ;
    ((_ (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) ?body ...)
      (define: (?name (?v ?t) ... (?vn ?tn) . (?rest ?at)) -> undefined
        ?body ...) ) ) )

;; typed scheme support

(define-syntax type:-record-type-accessor
  (syntax-rules ()
    ;
    ((_ ?tag (?var ?typ ?ref))
      (: ?ref ((struct ?tag) --> ?typ)) )
    ;
    ((_ ?tag (?var ?typ ?ref ?set))
      (begin
        (: ?ref ((struct ?tag) --> ?typ))
        (: ?set ((struct ?tag) ?typ -> undefined)) ) ) ) )

(define-syntax define:-procedure
  (syntax-rules ()
    ;
    ;XXX
    ;
    ((_ (?name) ?arrow ?rt ?body ...)
      (begin
        (: ?name (?arrow ?rt))
        (define (?name)
          ?body ... ) ) )
    ;
    ((_ (?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) ... (?vn ?tn) . (?rest ?at)) ?arrow ?rt ?body ...)
      (begin
        (: ?name (?t ... ?tn #!rest ?arrow ?rt))
        (define (?name ?v ... ?vn . ?rest)
          ?body ... ) ) ) ) )

) ;module typed-define