diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index 32d55e2a..19a1fc43 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -889,8 +889,20 @@ ((a b . -> . c) . -> . (a . -> . (b . -> . c)))))] ;; mutable pairs [mcons (-poly (a b) (-> a b (-mpair a b)))] -[mcar (-poly (a b) (-> (-mpair a b) a))] -[mcdr (-poly (a b) (-> (-mpair a b) b))] -[set-mcar! (-poly (a b) (-> (-mpair a b) a -Void))] -[set-mcdr! (-poly (a b) (-> (-mpair a b) b -Void))] +[mcar (-poly (a b) + (cl->* (-> (-mpair a b) a) + (-> (-mlst a) a)))] +[mcdr (-poly (a b) + (cl->* (-> (-mpair a b) b) + (-> (-mlst a) (-mlst a))))] +[set-mcar! (-poly (a b) + (cl->* (-> (-mpair a b) a -Void) + (-> (-mlst a) a -Void)))] +[set-mcdr! (-poly (a b) + (cl->* (-> (-mpair a b) b -Void) + (-> (-mlst a) (-mlst a) -Void)))] [mpair? (make-pred-ty (make-MPairTop))] +[mlist (-poly (a) (->* (list) a (-mlst a)))] +[mlength (-poly (a) (-> (-mlst a) -Nat))] +[mreverse! (-poly (a) (-> (-mlst a) (-mlst a)))] +[mappend (-poly (a) (->* (list) (-mlst a) (-mlst a)))] diff --git a/collects/typed-scheme/private/base-types-new.rkt b/collects/typed-scheme/private/base-types-new.rkt index 23f0118d..0b9e7b8f 100644 --- a/collects/typed-scheme/private/base-types-new.rkt +++ b/collects/typed-scheme/private/base-types-new.rkt @@ -55,5 +55,6 @@ [Nothing (Un)] [Pairof (-poly (a b) (-pair a b))] [MPairof (-poly (a b) (-mpair a b))] +[MListof (-poly (a) (-mlst a))] [Sequenceof (-poly (a) (-seq a))] diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index a4bd73a5..d760dd9d 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/collects/typed-scheme/types/abbrev.rkt @@ -15,7 +15,8 @@ (for-template scheme/base scheme/contract scheme/promise scheme/tcp scheme/flonum)) (provide (all-defined-out) - (rename-out [make-Listof -lst])) + (rename-out [make-Listof -lst] + [make-MListof -mlst])) ;; convenient constructors @@ -36,6 +37,7 @@ (define (make-Listof elem) (-mu list-rec (*Un (-val null) (-pair elem list-rec)))) +(define (make-MListof elem) (-mu mlist-rec (*Un (-val null) (-mpair elem mlist-rec)))) (define (-lst* #:tail [tail (-val null)] . args) (for/fold ([tl tail]) ([a (reverse args)]) (-pair a tl))) @@ -62,6 +64,12 @@ [(_ elem-pats) #'(app untuple (? values elem-pats))]))) +(define-match-expander MListof: + (lambda (stx) + (syntax-parse stx + [(_ elem-pat) + #'(Mu: var (Union: (list (Value: '()) (MPair: elem-pat (F: var)))))]))) + (d/c (-result t [f -no-filter] [o -no-obj]) (c:->* (Type/c) (FilterSet? Object?) Result?) diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-scheme/types/printer.rkt index 2ae5a06c..1892423e 100644 --- a/collects/typed-scheme/types/printer.rkt +++ b/collects/typed-scheme/types/printer.rkt @@ -133,6 +133,10 @@ (fp "(Listof ~a)" elem-ty)] [(Mu: var (Union: (list (Pair: elem-ty (F: var)) (Value: '())))) (fp "(Listof ~a)" elem-ty)] + [(Mu: var (Union: (list (Value: '()) (MPair: elem-ty (F: var))))) + (fp "(MListof ~a)" elem-ty)] + [(Mu: var (Union: (list (MPair: elem-ty (F: var)) (Value: '())))) + (fp "(MListof ~a)" elem-ty)] [(Value: v) (cond [(or (symbol? v) (null? v)) (fp "'~a" v)] [else (fp "~a" v)])]