#!r6rs
[library [typed-lists [0 0 1]]
    [export
        typed-list-type?
        typed-list?
        define-list-type
        typed-cons
        typed-car
        typed-cdr
        ]
    [import
        [rnrs [6]]
        ]

[define (typed-list? x)
    [or (null? x) (typed-list?* x)]]

[define (typed-list-type? xs type)
    [assert (typed-list? xs)]
    [or (null? xs) (eqv? type (get-type xs))]]

[define-record-type [typed-list typed-cons typed-list?*]
    [fields
        [immutable car typed-car]
        [immutable cdr typed-cdr]
        [immutable type get-type]
        ]

    [protocol
        [lambda [make]
            [lambda [car cdr type?]
                [assert (procedure? type?)]
                [assert (type? car)]
                [assert (typed-list? cdr)]
                [assert (typed-list-type? cdr type?)]
                (make car cdr type?)]]]]

[define-syntax define-list-type [lambda [stx]
    [syntax-case stx []
        [[define-list-type type?]
            (identifier? #'type?)
            [let* [
                    [name     (symbol->string (syntax->datum #'type?))]
                    [cons*    (datum->syntax #'define-list-type (string->symbol (string-append name "-cons")))]
                    [list*    (datum->syntax #'define-list-type (string->symbol (string-append name "-list")))]
                    [car*     (datum->syntax #'define-list-type (string->symbol (string-append name "-car")))]
                    [cdr*     (datum->syntax #'define-list-type (string->symbol (string-append name "-cdr")))]
                    [list?*   (datum->syntax #'define-list-type (string->symbol (string-append name "-list?")))]
                    ]
                #`[begin
                    [define (#,cons* x y) (typed-cons x y type?)]
                    [define (#,list* . xs)
                        [if (null? xs) xs
                            (#,cons* (car xs) (apply #,list* (cdr xs)))]]
                    [define (#,car* x)
                        [assert (typed-list-type? x type?)]
                        (typed-car x)]
                    [define (#,cdr* x)
                        [assert (typed-list-type x type?)]
                        (typed-cdr x)]
                    [define (#,list?* x)
                        [and (typed-list? x) (typed-list-type? x type?)]]
                    ]]]
            ]]]

]

;; the empty typed-list is simply ()

;; example usage:

[define-typed-list integer?]
;; this makes available integer?-cons, integer?-car, integer?-cdr, integer?-list, integer?-list?

[define an-int-list (integer?-list 1 2 3 4 5)]
[define a-not-quote-intlist (integer?-list 1 2 3 4 5.1)] ;; ==> ERROR

(integer?-list? an-int-list) ;; ==> #t

[define-typed-list even?]

[define evens (even?-list 2 4 6)]

(integer?-list? evens?) ;; ==> #f, the check happens in constant time, it does not verify the contents of the list

(integer?-car an-int-list) ==> ERROR