From b12f0ba53c6e67afd6ad1d9460a8e4377cc7da80 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 21 May 2012 18:00:47 -0400 Subject: [PATCH] Use the new syntax properties for checking keyword functions. Previously, some hacks were used to obtain the internal identifiers that implemented keyword functions directly, and give them types at startup. Now, the primary "function" (eg, `sort`) is given a type, and when used, the residual syntax properties are used to find `sort` from the real functions, and then the type of the real function is computed from the type of `sort`. Some creativity was required in the types of functions which take optional arguments that when present, alter the return type, such as `regexp-match*` and `file->list`. original commit: a377c4235743296e337db64341c8518fc7dce965 --- .../special-env-typecheck-tests.rkt | 4 +- collects/typed-racket/base-env/base-env.rkt | 261 +++++++++ .../base-env/base-special-env.rkt | 392 +------------ collects/typed-racket/env/lexical-env.rkt | 18 +- collects/typed-racket/rep/type-rep.rkt | 13 + collects/typed-racket/types/abbrev.rkt | 22 +- collects/typed-racket/types/kw-types.rkt | 527 ++++++++++++++++++ 7 files changed, 843 insertions(+), 394 deletions(-) create mode 100644 collects/typed-racket/types/kw-types.rkt diff --git a/collects/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt b/collects/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt index 5da1cb2e..c0a0717a 100644 --- a/collects/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt +++ b/collects/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt @@ -33,7 +33,7 @@ [(_ expr ty) (syntax/loc stx (tc-e expr #:ret (ret ty)))] [(_ a #:ret b) (quasisyntax/loc stx - (check-tc-result-equal? (format "~a ~a" #,(syntax-line stx) 'expr) + (check-tc-result-equal? (format "~a ~a" #,(syntax-line stx) 'a) #,(let ([ex (local-expand #'a 'expression null)]) (parameterize ([mutated-vars (find-mutated-vars ex)]) (tc-expr ex))) @@ -41,7 +41,7 @@ (define (typecheck-special-tests) (test-suite - "Typechecker tests" + "Special Typechecker tests" ;; should work but don't -- need expected type #| [tc-e (for/list ([(k v) (in-hash #hash((1 . 2)))]) 0) (-lst -Zero)] diff --git a/collects/typed-racket/base-env/base-env.rkt b/collects/typed-racket/base-env/base-env.rkt index 3f198c66..10219a6b 100644 --- a/collects/typed-racket/base-env/base-env.rkt +++ b/collects/typed-racket/base-env/base-env.rkt @@ -2577,3 +2577,264 @@ ;; reader graphs [make-reader-graph (-> Univ Univ)] + +;; keyword functions moved back to here: + +[file->string + (->key -Pathlike #:mode (one-of/c 'binary 'text) #f -String)] +(file->bytes (->key -Pathlike #:mode (one-of/c 'binary 'text) #f -Bytes)) +(file->value (->key -Pathlike #:mode (one-of/c 'binary 'text) #f Univ)) +(file->lines + (->key + -Pathlike + #:mode + (one-of/c 'binary 'text) + #f + #:line-mode + (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) + #f + (-lst -String))) +(file->bytes-lines + (->key + -Pathlike + #:line-mode + (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) + #f + #:mode + (one-of/c 'binary 'text) + #f + (-lst -Bytes))) +(display-to-file + (->key + Univ + -Pathlike + #:exists + (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace) + #f + #:mode + (one-of/c 'binary 'text) + #f + -Void)) +(display-lines-to-file + (->key + (-lst Univ) + -Pathlike + #:separator + Univ + #f + #:mode + (one-of/c 'binary 'text) + #f + #:exists + (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace) + #f + -Void)) +(write-to-file + (->key + Univ + -Pathlike + #:exists + (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace) + #f + #:mode + (one-of/c 'binary 'text) + #f + -Void)) +(file->list + (-poly (a) + (cl->* + (->optkey -Pathlike [(-> -Input-Port (Un))] #:mode (one-of/c 'binary 'text) #f (-lst Univ)) + (->optkey -Pathlike [(-> -Input-Port a)] #:mode (one-of/c 'binary 'text) #f (-lst a))))) +(get-preference + (let ((use-lock-type Univ) + (timeout-lock-there-type (-opt (-> -Path Univ))) + (lock-there-type (-opt (-> -Path Univ)))) + (cl->* + (->key + -Symbol + #:use-lock? + use-lock-type + #f + #:timeout-lock-there + timeout-lock-there-type + #f + #:lock-there + lock-there-type + #f + Univ) + (->key + -Symbol + (-> Univ) + #:use-lock? + use-lock-type + #f + #:timeout-lock-there + timeout-lock-there-type + #f + #:lock-there + lock-there-type + #f + Univ) + (->key + -Symbol + (-> Univ) + Univ + #:use-lock? + use-lock-type + #f + #:timeout-lock-there + timeout-lock-there-type + #f + #:lock-there + lock-there-type + #f + Univ) + (->key + -Symbol + (-> Univ) + Univ + (-opt -Pathlike) + #:use-lock? + use-lock-type + #f + #:timeout-lock-there + timeout-lock-there-type + #f + #:lock-there + lock-there-type + #f + Univ)))) +(make-handle-get-preference-locked + (let ((lock-there-type (-opt (-> -Path Univ))) + (max-delay-type -Real)) + (->optkey -Real -Symbol [(-> Univ) Univ (-opt -Pathlike)] + #:lock-there lock-there-type #f #:max-delay max-delay-type #f + (-> -Pathlike Univ)))) +(call-with-file-lock/timeout + (-poly + (a) + (->key + (-opt -Pathlike) + (one-of/c 'shared 'exclusive) + (-> a) + (-> a) + #:lock-file + (-opt -Pathlike) + #f + #:delay + -Real + #f + #:max-delay + -Real + #f + a))) +(sort + (-poly + (a b) + (cl->* + (->key (-lst a) (-> a a -Boolean) #:key (-> a a) #f #:cache-keys? -Boolean #f (-lst a)) + (->key (-lst a) (-> b b -Boolean) #:key (-> a b) #f #:cache-keys? -Boolean #f (-lst a))))) +(remove-duplicates + (-poly + (a b) + (cl->* + (->optkey (-lst a) ((-> a a Univ)) #:key (-> a a) #f (-lst a)) + (->optkey (-lst a) ((-> b b Univ)) #:key (-> a b) #f (-lst a))))) +(open-input-file (->key -Pathlike #:mode (one-of/c 'binary 'text) #f -Input-Port)) +(open-output-file + (->key + -Pathlike + #:mode + (one-of/c 'binary 'text) + #f + #:exists + (one-of/c 'error 'append 'update 'can-update 'replace 'truncate 'must-truncate 'truncate/replace) + #f + -Output-Port)) +(open-input-output-file + (->key + -Pathlike + #:mode + (one-of/c 'binary 'text) + #f + #:exists + (one-of/c 'error 'append 'update 'can-update 'replace 'truncate 'must-truncate 'truncate/replace) + #f + (-values (list -Input-Port -Output-Port)))) +(call-with-input-file + (-poly (a) (->key -Pathlike (-> -Input-Port a) #:mode (Un (-val 'binary) (-val 'text)) #f a))) +(call-with-output-file + (-poly (a) + (->key + -Pathlike + (-> -Output-Port a) + #:exists + (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace 'can-update 'must-truncate) + #f + #:mode + (one-of/c 'binary 'text) + #f + a))) +(call-with-input-file* (-poly (a) (->key -Pathlike (-> -Input-Port a) #:mode (Un (-val 'binary) (-val 'text)) #f a))) +(call-with-output-file* + (-poly + (a) + (->key + -Pathlike + (-> -Output-Port a) + #:exists + (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace 'can-update 'must-truncate) + #f + #:mode + (one-of/c 'binary 'text) + #f + a))) +(with-input-from-file (-poly (a) (->key -Pathlike (-> a) #:mode (Un (-val 'binary) (-val 'text)) #f a))) +(with-output-to-file + (-poly + (a) + (->key + -Pathlike + (-> a) + #:exists + (one-of/c 'error 'append 'update 'can-update 'replace 'truncate 'must-truncate 'truncate/replace) + #f + #:mode + (one-of/c 'binary 'text) + #f + a))) +(port->lines + (->optkey [-Input-Port] #:line-mode (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) #f (-lst -String))) +(port->bytes-lines + (->optkey [-Input-Port] #:line-mode (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) #f (-lst -Bytes))) +(display-lines + (->optkey (-lst Univ) [-Output-Port] #:separator Univ #f -Void)) +(find-relative-path (->key -SomeSystemPathlike -SomeSystemPathlike #:more-than-root? Univ #f -SomeSystemPath)) +(regexp-match* + (let ((N -Integer) + (?N (-opt -Integer)) + (-StrRx (Un -String -Regexp)) + (-BtsRx (Un -Bytes -Byte-Regexp)) + (-StrInput (Un -String -Path)) + (-BtsInput (Un -Input-Port -Bytes)) + (sel (λ (t) (-opt (-> (-lst t) t))))) + (cl->* + (->optkey -StrRx -StrInput (N ?N -Bytes) + #:match-select (sel -String) #f #:gap-select Univ #f + (-lst -String)) + (->optkey -BtsRx (Un -StrInput -BtsInput) (N ?N -Bytes) + #:match-select (sel -Bytes) #f #:gap-select Univ #f + (-lst -Bytes)) + (->optkey -Pattern -BtsInput (N ?N -Bytes) + #:match-select (sel -Bytes) #f #:gap-select Univ #f + (-lst -Bytes))))) +(regexp-match-positions* + (let* ((?outp (-opt -Output-Port)) + (B -Boolean) + (N -Integer) + (?N (-opt -Integer)) + (ind-pair (-pair -Index -Index)) + (sel (-> (-lst (-opt ind-pair)) (-opt ind-pair))) + (output (-opt (-pair ind-pair (-lst (-opt ind-pair))))) + (-Input (Un -String -Input-Port -Bytes -Path))) + (->optkey -Pattern -Input (N ?N -Bytes) #:match-select sel #f output))) \ No newline at end of file diff --git a/collects/typed-racket/base-env/base-special-env.rkt b/collects/typed-racket/base-env/base-special-env.rkt index 0f63180d..70f18ef0 100644 --- a/collects/typed-racket/base-env/base-special-env.rkt +++ b/collects/typed-racket/base-env/base-special-env.rkt @@ -17,12 +17,10 @@ (define-syntax (define-initial-env stx) (syntax-parse stx - [(_ initialize-env [id-expr ty] ... #:middle [id-expr* ty*] ...) + [(_ initialize-env [id-expr ty] ...) #`(begin (define initial-env (make-env [id-expr (λ () ty)] ... )) - (do-time "finished special types") - (define initial-env* (make-env [id-expr* (λ () ty*)] ...)) - (define (initialize-env) (initialize-type-env initial-env) (initialize-type-env initial-env*)) + (define (initialize-env) (initialize-type-env initial-env)) (provide initialize-env))])) (define (make-template-identifier what where) @@ -41,7 +39,6 @@ ;; make-promise [(make-template-identifier 'delay 'racket/private/promise) (-poly (a) (-> (-> a) (-Promise a)))] - ;; language [(make-template-identifier 'language 'string-constants/string-constant) -Symbol] @@ -133,390 +130,7 @@ ;; same [(make-template-identifier 'with-syntax-fail 'racket/private/with-stx) (-> (-Syntax Univ) (Un))] - - + ;; from the expansion of `make-temp-file` [(make-template-identifier 'make-temporary-file/proc 'racket/file) (->opt [-String (Un -Pathlike (-val 'directory) (-val #f)) (-opt -Pathlike)] -Path)] - - ;; below here: keyword-argument functions from the base environment - ;; FIXME: abstraction to remove duplication here - #:middle - - [((kw-expander-proc (syntax-local-value #'file->string))) - (->key -Pathlike #:mode (one-of/c 'binary 'text) #f -String)] - [((kw-expander-impl (syntax-local-value #'file->string))) - (-> (Un (-val #f) (one-of/c 'binary 'text)) -Boolean -Pathlike -String)] - - [((kw-expander-proc (syntax-local-value #'file->bytes))) - (->key -Pathlike #:mode (one-of/c 'binary 'text) #f -Bytes)] - [((kw-expander-impl (syntax-local-value #'file->bytes))) - (-> (Un (-val #f) (one-of/c 'binary 'text)) -Boolean -Pathlike -Bytes)] - - [((kw-expander-proc (syntax-local-value #'file->value))) - (->key -Pathlike #:mode (one-of/c 'binary 'text) #f Univ)] - [((kw-expander-impl (syntax-local-value #'file->value))) - (-> (Un (-val #f) (one-of/c 'binary 'text)) -Boolean -Pathlike Univ)] - - [((kw-expander-proc (syntax-local-value #'file->lines))) - (->key -Pathlike #:mode (one-of/c 'binary 'text) #f - #:line-mode (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) #f - (-lst -String))] - [((kw-expander-impl (syntax-local-value #'file->lines))) - (-> (Un (-val #f) (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one)) -Boolean - (Un (-val #f) (one-of/c 'binary 'text)) -Boolean - -Pathlike (-lst -String))] - - [((kw-expander-proc (syntax-local-value #'file->bytes-lines))) - (->key -Pathlike - #:line-mode (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) #f - #:mode (one-of/c 'binary 'text) #f - (-lst -Bytes))] - [((kw-expander-impl (syntax-local-value #'file->bytes-lines))) - (-> (Un (-val #f) (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one)) -Boolean - (Un (-val #f) (one-of/c 'binary 'text)) -Boolean - -Pathlike (-lst -Bytes))] - - [((kw-expander-proc (syntax-local-value #'display-to-file))) - (->key Univ -Pathlike - #:exists (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace) #f - #:mode (one-of/c 'binary 'text) #f - -Void)] - [((kw-expander-impl (syntax-local-value #'display-to-file))) - (-> (Un (-val #f) (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace)) -Boolean - (Un (-val #f) (one-of/c 'binary 'text)) -Boolean - Univ -Pathlike -Void)] - - [((kw-expander-proc (syntax-local-value #'display-lines-to-file))) - (->key (-lst Univ) -Pathlike - #:separator Univ #f - #:mode (one-of/c 'binary 'text) #f - #:exists (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace) #f - -Void)] - [((kw-expander-impl (syntax-local-value #'display-lines-to-file))) - (-> (Un (-val #f) (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace)) -Boolean - (Un (-val #f) (one-of/c 'binary 'text)) -Boolean - (Un (-val #f) Univ) -Boolean - (-lst Univ) -Pathlike -Void)] - - [((kw-expander-proc (syntax-local-value #'write-to-file))) - (->key Univ -Pathlike - #:exists (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace) #f - #:mode (one-of/c 'binary 'text) #f - -Void)] - [((kw-expander-impl (syntax-local-value #'write-to-file))) - (-> (Un (-val #f) (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace)) -Boolean - (Un (-val #f) (one-of/c 'binary 'text)) -Boolean - Univ -Pathlike -Void)] - - [((kw-expander-proc (syntax-local-value #'file->list))) - (-poly (a) - (cl->* (->key -Pathlike #:mode (one-of/c 'binary 'text) #f (-lst Univ)) - (->key -Pathlike (-> -Input-Port a) #:mode (one-of/c 'binary 'text) #f (-lst a))))] - [((kw-expander-impl (syntax-local-value #'file->list))) - (-poly (a) - (cl->* (-> (Un (-val #f) (one-of/c 'binary 'text)) -Boolean -Pathlike (-> -Input-Port a) (-val #t) (-lst a)) - (-> (Un (-val #f) (one-of/c 'binary 'text)) -Boolean -Pathlike Univ -Boolean (-lst Univ))))] - - [((kw-expander-proc (syntax-local-value #'get-preference))) - (let ((use-lock-type Univ) - (timeout-lock-there-type (-opt (-> -Path Univ))) - (lock-there-type (-opt (-> -Path Univ)))) - (cl->* - (->key -Symbol - #:use-lock? use-lock-type #f #:timeout-lock-there timeout-lock-there-type #f #:lock-there lock-there-type #f - Univ) - (->key -Symbol (-> Univ) - #:use-lock? use-lock-type #f #:timeout-lock-there timeout-lock-there-type #f #:lock-there lock-there-type #f - Univ) - (->key -Symbol (-> Univ) Univ - #:use-lock? use-lock-type #f #:timeout-lock-there timeout-lock-there-type #f #:lock-there lock-there-type #f - Univ) - (->key -Symbol (-> Univ) Univ (-opt -Pathlike) - #:use-lock? use-lock-type #f #:timeout-lock-there timeout-lock-there-type #f #:lock-there lock-there-type #f - Univ)))] - [((kw-expander-impl (syntax-local-value #'get-preference))) - (let ((use-lock-type Univ) - (timeout-lock-there-type (-opt (-> -Path Univ))) - (lock-there-type (-opt (-> -Path Univ)))) - (-> (-opt lock-there-type) -Boolean - (-opt timeout-lock-there-type) -Boolean - (-opt use-lock-type) -Boolean - -Symbol - (-opt (-> Univ)) (-opt Univ) (-opt (-opt -Pathlike)) - -Boolean -Boolean -Boolean - Univ))] - [((kw-expander-proc (syntax-local-value #'make-handle-get-preference-locked))) - (let ((lock-there-type (-opt (-> -Path Univ))) (max-delay-type -Real)) - (cl->* - (->key -Real -Symbol - #:lock-there lock-there-type #f #:max-delay max-delay-type #f - (-> -Pathlike Univ)) - (->key -Real -Symbol (-> Univ) - #:lock-there lock-there-type #f #:max-delay max-delay-type #f - (-> -Pathlike Univ)) - (->key -Real -Symbol (-> Univ) Univ - #:lock-there lock-there-type #f #:max-delay max-delay-type #f - (-> -Pathlike Univ)) - (->key -Real -Symbol (-> Univ) Univ (-opt -Pathlike) - #:lock-there lock-there-type #f #:max-delay max-delay-type #f - (-> -Pathlike Univ))))] - [((kw-expander-impl (syntax-local-value #'make-handle-get-preference-locked))) - (let ((lock-there-type (-opt (-> -Path Univ))) (max-delay-type -Real)) - (-> (-opt lock-there-type) -Boolean - (-opt max-delay-type) -Boolean - -Real -Symbol - (-opt (-> Univ)) (-opt Univ) (-opt (-opt -Pathlike)) - -Boolean -Boolean -Boolean - (-> -Pathlike Univ)))] - - [((kw-expander-proc (syntax-local-value #'call-with-file-lock/timeout))) - (-poly (a) - (->key (-opt -Pathlike) - (one-of/c 'shared 'exclusive) - (-> a) - (-> a) - #:lock-file (-opt -Pathlike) #f - #:delay -Real #f - #:max-delay -Real #f - a))] - [((kw-expander-impl (syntax-local-value #'call-with-file-lock/timeout))) - (-poly (a) - (-> (-opt -Real) -Boolean - (-opt (-opt -Pathlike)) -Boolean - (-opt -Real) -Boolean - (-opt -Pathlike) - (one-of/c 'shared 'exclusive) - (-> a) - (-> a) - a))] - - [((kw-expander-proc (syntax-local-value #'sort))) - (-poly (a b) (cl->* ((-lst a) (a a . -> . -Boolean) - #:cache-keys? -Boolean #f - . ->key . (-lst a)) - ((-lst a) (b b . -> . -Boolean) - #:key (a . -> . b) #t - #:cache-keys? -Boolean #f - . ->key . (-lst a))))] - [((kw-expander-impl (syntax-local-value #'sort))) - (-poly (a b) - (cl->* - ;; #:key not provided - (-> - -Boolean -Boolean Univ (-val #f) - (-lst a) (a a . -> . -Boolean) - (-lst a)) - ;; #:key provided - (-> - -Boolean -Boolean (a . -> . b) (-val #t) - (-lst a) (b b . -> . -Boolean) - (-lst a))))] - - [((kw-expander-proc (syntax-local-value #'remove-duplicates))) - (-poly (a b) (cl->* - ((-lst a) . -> . (-lst a)) - ((-lst a) (a a . -> . Univ) - . -> . (-lst a)) - ((-lst a) #:key (a . -> . b) #f - . ->key . (-lst a)) - ((-lst a) (b b . -> . Univ) - #:key (a . -> . b) #t - . ->key . (-lst a))))] - [((kw-expander-impl (syntax-local-value #'remove-duplicates))) - (-poly (a b) - (cl->* - (Univ (-val #f) ;; no key - (-lst a) (-val #f) -Boolean - . -> . (-lst a)) - (Univ (-val #f) ;; no key - (-lst a) (-> a a Univ) -Boolean - . -> . (-lst a)) - ((a . -> . b) (-val #t) ;; no key - (-lst a) (-opt (-> b b Univ)) -Boolean - . -> . (-lst a))))] - - [((kw-expander-proc (syntax-local-value #'open-input-file))) - (->key -Pathlike #:mode (one-of/c 'binary 'text) #f -Input-Port)] - [((kw-expander-impl (syntax-local-value #'open-input-file))) - (-> (-opt (one-of/c 'binary 'text)) -Boolean -Pathlike -Input-Port)] - - [((kw-expander-proc (syntax-local-value #'open-output-file))) - (->key -Pathlike - #:mode (one-of/c 'binary 'text) #f - #:exists (one-of/c 'error 'append 'update 'can-update - 'replace 'truncate - 'must-truncate 'truncate/replace) - #f - -Output-Port)] - [((kw-expander-impl (syntax-local-value #'open-output-file))) - (-> (-opt (one-of/c 'error 'append 'update 'can-update - 'replace 'truncate - 'must-truncate 'truncate/replace)) - -Boolean - (-opt (one-of/c 'binary 'text)) -Boolean - -Pathlike - -Output-Port)] - - [((kw-expander-proc (syntax-local-value #'open-input-output-file))) - (->key -Pathlike - #:mode (one-of/c 'binary 'text) #f - #:exists (one-of/c 'error 'append 'update 'can-update - 'replace 'truncate - 'must-truncate 'truncate/replace) - #f - (-values (list -Input-Port -Output-Port)))] - [((kw-expander-impl (syntax-local-value #'open-input-output-file))) - (-> (-opt (one-of/c 'error 'append 'update 'can-update - 'replace 'truncate - 'must-truncate 'truncate/replace)) - -Boolean - (-opt (one-of/c 'binary 'text)) -Boolean - -Pathlike - (-values (list -Input-Port -Output-Port)))] - - [((kw-expander-proc (syntax-local-value #'call-with-input-file))) - (-poly (a) (-Pathlike (-Input-Port . -> . a) #:mode (Un (-val 'binary) (-val 'text)) #f . ->key . a))] - [((kw-expander-impl (syntax-local-value #'call-with-input-file))) - (-poly (a) (-> (-opt (one-of/c 'binary 'text)) -Boolean -Pathlike (-Input-Port . -> . a) a))] - - [((kw-expander-proc (syntax-local-value #'call-with-output-file))) - (-poly (a) (-Pathlike (-Output-Port . -> . a) - #:exists (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace) #f - #:mode (one-of/c 'binary 'text) #f - . ->key . a))] - [((kw-expander-impl (syntax-local-value #'call-with-output-file))) - (-poly (a) (-> (-opt (one-of/c 'error 'append 'update 'can-update - 'replace 'truncate - 'must-truncate 'truncate/replace)) - -Boolean - (-opt (one-of/c 'binary 'text)) -Boolean - -Pathlike (-Output-Port . -> . a) - a))] - - ;; - - [((kw-expander-proc (syntax-local-value #'call-with-input-file*))) - (-poly (a) (-Pathlike (-Input-Port . -> . a) #:mode (Un (-val 'binary) (-val 'text)) #f . ->key . a))] - [((kw-expander-impl (syntax-local-value #'call-with-input-file*))) - (-poly (a) (-> (-opt (one-of/c 'binary 'text)) -Boolean -Pathlike (-Input-Port . -> . a) a))] - - [((kw-expander-proc (syntax-local-value #'call-with-output-file*))) - (-poly (a) (-Pathlike (-Output-Port . -> . a) - #:exists (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace) #f - #:mode (one-of/c 'binary 'text) #f - . ->key . a))] - [((kw-expander-impl (syntax-local-value #'call-with-output-file*))) - (-poly (a) (-> (-opt (one-of/c 'error 'append 'update 'can-update - 'replace 'truncate - 'must-truncate 'truncate/replace)) - -Boolean - (-opt (one-of/c 'binary 'text)) -Boolean - -Pathlike (-Output-Port . -> . a) - a))] - ;; - [((kw-expander-proc (syntax-local-value #'with-input-from-file))) - (-poly (a) (-Pathlike (-> a) #:mode (Un (-val 'binary) (-val 'text)) #f . ->key . a))] - [((kw-expander-impl (syntax-local-value #'with-input-from-file))) - (-poly (a) (-> (-opt (one-of/c 'binary 'text)) -Boolean -Pathlike (-> a) a))] - - [((kw-expander-proc (syntax-local-value #'with-output-to-file))) - (-poly (a) (->key -Pathlike (-> a) - #:exists (one-of/c 'error 'append 'update 'can-update - 'replace 'truncate - 'must-truncate 'truncate/replace) - #f - #:mode (one-of/c 'binary 'text) #f - a))] - [((kw-expander-impl (syntax-local-value #'with-output-to-file))) - (-poly (a) (-> (-opt (one-of/c 'error 'append 'update 'can-update - 'replace 'truncate - 'must-truncate 'truncate/replace)) - -Boolean - (-opt (one-of/c 'binary 'text)) -Boolean - -Pathlike (-> a) - a))] - - - [((kw-expander-proc (syntax-local-value #'port->lines))) - (cl->* - (->key #:line-mode (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) #f (-lst -String)) - (->key -Input-Port #:line-mode (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) #f (-lst -String)))] - [((kw-expander-impl (syntax-local-value #'port->lines))) - ((-opt (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one)) -Boolean - (-opt -Input-Port) -Boolean - . -> . - (-lst -String))] - - - [((kw-expander-proc (syntax-local-value #'port->bytes-lines))) - (cl->* - (->key #:line-mode (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) #f (-lst -Bytes)) - (->key -Input-Port #:line-mode (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) #f (-lst -Bytes)))] - [((kw-expander-impl (syntax-local-value #'port->bytes-lines))) - ((-opt (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one)) -Boolean - (-opt -Input-Port) -Boolean - . -> . - (-lst -Bytes))] - - - [((kw-expander-proc (syntax-local-value #'display-lines))) - (cl->* - ((-lst Univ) #:separator Univ #f . ->key . -Void) - ((-lst Univ) -Output-Port #:separator Univ #f . ->key . -Void))] - [((kw-expander-impl (syntax-local-value #'display-lines))) - ((-opt Univ) -Boolean - (-lst Univ) - (-opt -Output-Port) -Boolean - . -> . -Void)] - ; [find-relative-path (-SomeSystemPathlike -SomeSystemPathlike . -> . -SomeSystemPath)] - [((kw-expander-proc (syntax-local-value #'find-relative-path))) - (-SomeSystemPathlike -SomeSystemPathlike #:more-than-root? Univ #f . ->key . -SomeSystemPath)] - [((kw-expander-impl (syntax-local-value #'find-relative-path))) - (Univ -Boolean -SomeSystemPathlike -SomeSystemPathlike . -> . -SomeSystemPath)] - - ;; FIXME -- the below function do not actually support their keyword arguments - [((kw-expander-proc (syntax-local-value #'regexp-match*))) - (let ([N -Integer] - [?N (-opt -Integer)] - [-StrRx (Un -String -Regexp)] - [-BtsRx (Un -Bytes -Byte-Regexp)] - [-StrInput (Un -String -Path)] - [-BtsInput (Un -Input-Port -Bytes)]) - (cl->* - (-StrRx -StrInput [N ?N -Bytes] . ->opt . (-lst -String)) - (-BtsRx (Un -StrInput -BtsInput) [N ?N -Bytes] . ->opt . (-lst -Bytes)) - (-Pattern -BtsInput [N ?N -Bytes] . ->opt . (-lst -Bytes))))] - [((kw-expander-impl (syntax-local-value #'regexp-match*))) - (let ([N -Integer] - [B -Boolean] - [?N (-opt -Integer)] - [-StrRx (Un -String -Regexp)] - [-BtsRx (Un -Bytes -Byte-Regexp)] - [-StrInput (Un -String -Path)] - [-BtsInput (Un -Input-Port -Bytes)]) - (cl->* - (Univ (-val #f) Univ (-val #f) -StrRx -StrInput (-opt N) B (-opt ?N) B (-opt -Bytes) B . -> . (-lst -String)) - (Univ (-val #f) Univ (-val #f) -BtsRx (Un -StrInput -BtsInput) (-opt N) B (-opt ?N) B (-opt -Bytes) B . -> . (-lst -Bytes)) - (Univ (-val #f) Univ (-val #f) -Pattern -BtsInput (-opt N) B (-opt ?N) B (-opt -Bytes) B . -> . (-lst -Bytes))))] - - [((kw-expander-proc (syntax-local-value #'regexp-match-positions*))) - (let* ([?outp (-opt -Output-Port)] - [B -Boolean] - [N -Integer] - [?N (-opt -Integer)] - [ind-pair (-pair -Index -Index)] - [output (-opt (-pair ind-pair (-lst (-opt ind-pair))))] - [-Input (Un -String -Input-Port -Bytes -Path)]) - (->opt -Pattern -Input [N ?N ?outp -Bytes] output))] - [((kw-expander-impl (syntax-local-value #'regexp-match-positions*))) - (let* ([?outp (-opt -Output-Port)] - [B -Boolean] - [N -Integer] - [?N (-opt -Integer)] - [ind-pair (-pair -Index -Index)] - [output (-opt (-pair ind-pair (-lst (-opt ind-pair))))] - [-Input (Un -String -Input-Port -Bytes -Path)]) - (-> Univ (-val #f) Univ (-val #f) -Pattern -Input (-opt N) B (-opt ?N) B (-opt ?outp) B (-opt -Bytes) B output))] - - ) diff --git a/collects/typed-racket/env/lexical-env.rkt b/collects/typed-racket/env/lexical-env.rkt index 20eb9543..91c4cec7 100644 --- a/collects/typed-racket/env/lexical-env.rkt +++ b/collects/typed-racket/env/lexical-env.rkt @@ -9,7 +9,9 @@ (require "../utils/utils.rkt" "type-env-structs.rkt" "global-env.rkt" + "../types/kw-types.rkt" syntax/id-table + racket/keyword-transform racket/list (for-syntax syntax/parse syntax/parse/experimental/contract racket/base) (only-in scheme/contract ->* -> or/c any/c listof cons/c) (utils tc-utils mutated-vars) @@ -40,7 +42,21 @@ ;; find the type of identifier i, looking first in the lexical env, then in the top-level env ;; identifier -> Type (define (lookup-type/lexical i [env (lexical-env)] #:fail [fail #f]) - (lookup env i (λ (i) (lookup-type i (λ () ((or fail lookup-fail) i)))))) + (lookup env i (λ (i) (lookup-type i (λ () + (cond + [(syntax-procedure-alias-property i) + => (λ (prop) + (define orig (car (flatten prop))) + (define t (lookup-type/lexical orig env)) + (register-type i t) + t)] + [(syntax-procedure-converted-arguments-property i) + => (λ (prop) + (define orig (car (flatten prop))) + (define t (kw-convert (lookup-type/lexical orig env))) + (register-type i t) + t)] + [else ((or fail lookup-fail) i)])))))) ;; refine the type of i in the lexical env ;; (identifier type -> type) identifier -> environment diff --git a/collects/typed-racket/rep/type-rep.rkt b/collects/typed-racket/rep/type-rep.rkt index 6abbd38b..6f970194 100644 --- a/collects/typed-racket/rep/type-rep.rkt +++ b/collects/typed-racket/rep/type-rep.rkt @@ -233,6 +233,19 @@ (combine-frees (map free-idxs* (cons dty rs))))] [#:fold-rhs (*ValuesDots (map type-rec-id rs) (type-rec-id dty) dbound)]) +;; lazy-arr is NOT a Type +(def-type lazy-arr ([mand (listof Type/c)] + [opt (listof Type/c)] + [rng (or/c Values? ValuesDots?)] + [rest (or/c #f Type/c)] + [drest #f] ;; to be extended later + [kws (listof Keyword?)]) + [#:intern (list (map Rep-seq mand) (map Rep-seq opt) (Rep-seq rng) (and rest (Rep-seq rest)) + (and drest (cons (Rep-seq (car drest)) (cdr drest))) + (map Rep-seq kws))] + [#:frees (λ _ (int-err "lazy-arr frees"))] + [#:fold-rhs (int-err "lazy-arr fold")]) + ;; arr is NOT a Type (def-type arr ([dom (listof Type/c)] [rng (or/c Values? ValuesDots?)] diff --git a/collects/typed-racket/types/abbrev.rkt b/collects/typed-racket/types/abbrev.rkt index ed3ead09..8149d259 100644 --- a/collects/typed-racket/types/abbrev.rkt +++ b/collects/typed-racket/types/abbrev.rkt @@ -14,7 +14,7 @@ racket/udp (except-in racket/contract/base ->* ->) (prefix-in c: racket/contract/base) - (for-syntax racket/base syntax/parse) + (for-syntax racket/base syntax/parse racket/list) (for-template racket/base racket/contract/base racket/promise racket/tcp racket/flonum) racket/pretty racket/udp racket/place ;; for base type predicates @@ -399,7 +399,25 @@ (list (make-arr* (list ty ...) rng - #:kws (list (make-Keyword 'k kty opt) ...))))])) + #:kws (sort #:key (match-lambda [(Keyword: kw _ _) kw]) + (list (make-Keyword 'k kty opt) ...) + keywordoptkey stx) + (syntax-parse stx + [(_ ty:expr ... [oty:expr ...] (~seq k:keyword kty:expr opt:boolean) ... rng) + (let ([l (syntax->list #'(oty ...))]) + (with-syntax ([((extra ...) ...) + (for/list ([i (in-range (add1 (length l)))]) + (take l i))]) + #'(make-Function + (list + (make-arr* (list ty ... extra ...) + rng + #:kws (sort #:key (match-lambda [(Keyword: kw _ _) kw]) + (list (make-Keyword 'k kty opt) ...) + keyword (values Type Type) +(define (convert kw-t plain-t opt-t rng rest drest) + (define-values (mand-kw-t opt-kw-t) (partition (match-lambda [(Keyword: _ _ m) m]) kw-t)) + (define arities + (for/list ([i (length opt-t)]) + (make-arr* (append plain-t (take opt-t i)) + rng + #:kws kw-t + #:rest rest + #:drest drest))) + (define ts + (flatten + (list + mand-kw-t + (for/list ([k (in-list opt-kw-t)]) + (match k + [(Keyword: _ t _) (list (-opt t) -Boolean)])) + plain-t + (for/list ([t (in-list opt-t)]) (-opt t)) + (for/list ([t (in-list opt-t)]) -Boolean)))) + (make-Function (list (make-arr* ts rng #:rest rest #:drest drest)))) + +(define (prefix-of a b) + (define (drest-equal? a b) + (match* (a b) + [((list t b) (list t* b*)) (and (type-equal? t t*) (equal? b b*))] + [(_ _) #f])) + (define (kw-equal? a b) + (and (equal? (length a) (length b)) + (for/and ([k1 a] [k2 b]) + (type-equal? k1 k2)))) + (match* (a b) + [((arr: args result rest drest kws) + (arr: args* result* rest* drest* kws*)) + (and (< (length args) (length args*)) + (or (equal? rest rest*) (type-equal? rest rest*)) + (or (equal? drest drest*) (drest-equal? drest drest*)) + (type-equal? result result*) + (or (equal? kws kws*) (kw-equal? kws kws*)) + (for/and ([p args] [p* args*]) + (type-equal? p p*)))])) + +(define (arity-length a) + (match a + [(arr: args result rest drest kws) (length args)])) + + +(define (arg-diff a1 a2) + (match a2 + [(arr: args _ _ _ _) (drop args (arity-length a1))])) + +(define (find-prefixes l) + (define l* (sort l < #:key arity-length)) + (for/fold ([d (list)]) ([e (in-list l*)]) + (define prefix (for/or ([p (in-dict-keys d)]) + (and (prefix-of p e) p))) + (if prefix + (dict-set d prefix (arg-diff prefix e)) + (dict-set d e empty)))) + +(define (kw-convert ft) + (match ft + [(Function: arrs) + (define table (find-prefixes arrs)) + (define fns + (for/list ([(k v) (in-dict table)]) + (match k + [(arr: mand rng rest drest kws) + (convert kws mand v rng rest drest)]))) + (apply cl->* fns)] + [(Poly-names: names (Function: arrs)) + (define table (find-prefixes arrs)) + (define fns + (for/list ([(k v) (in-dict table)]) + (match k + [(arr: mand rng rest drest kws) + (convert kws mand v rng rest drest)]))) + (make-Poly names (apply cl->* fns))] + [_ (int-err 'kw-convert "non-function type" ft)])) + +(provide kw-convert) + +#| +(define pre + (list + (->key -Pathlike #:mode (one-of/c 'binary 'text) #f -String) + (->key -Pathlike #:mode (one-of/c 'binary 'text) #f -Bytes) + (->key -Pathlike #:mode (one-of/c 'binary 'text) #f Univ) + (->key + -Pathlike + #:mode + (one-of/c 'binary 'text) + #f + #:line-mode + (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) + #f + (-lst -String)) + (->key + -Pathlike + #:line-mode + (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) + #f + #:mode + (one-of/c 'binary 'text) + #f + (-lst -Bytes)) + (->key + Univ + -Pathlike + #:exists + (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace) + #f + #:mode + (one-of/c 'binary 'text) + #f + -Void) + (->key + (-lst Univ) + -Pathlike + #:separator + Univ + #f + #:mode + (one-of/c 'binary 'text) + #f + #:exists + (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace) + #f + -Void) + (->key + Univ + -Pathlike + #:exists + (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace) + #f + #:mode + (one-of/c 'binary 'text) + #f + -Void) + (-poly + (a) + (cl->* + (->optkey -Pathlike [(-> -Input-Port a)] #:mode (one-of/c 'binary 'text) #f (-lst a)) + (->optkey -Pathlike [(-> -Input-Port Univ)] #:mode (one-of/c 'binary 'text) #f (-lst Univ)))) + (let ((use-lock-type Univ) (timeout-lock-there-type (-opt (-> -Path Univ))) (lock-there-type (-opt (-> -Path Univ)))) + (cl->* + (->key + -Symbol + #:use-lock? + use-lock-type + #f + #:timeout-lock-there + timeout-lock-there-type + #f + #:lock-there + lock-there-type + #f + Univ) + (->key + -Symbol + (-> Univ) + #:use-lock? + use-lock-type + #f + #:timeout-lock-there + timeout-lock-there-type + #f + #:lock-there + lock-there-type + #f + Univ) + (->key + -Symbol + (-> Univ) + Univ + #:use-lock? + use-lock-type + #f + #:timeout-lock-there + timeout-lock-there-type + #f + #:lock-there + lock-there-type + #f + Univ) + (->key + -Symbol + (-> Univ) + Univ + (-opt -Pathlike) + #:use-lock? + use-lock-type + #f + #:timeout-lock-there + timeout-lock-there-type + #f + #:lock-there + lock-there-type + #f + Univ))) + (let ((lock-there-type (-opt (-> -Path Univ))) (max-delay-type -Real)) + (cl->* + (->key -Real -Symbol #:lock-there lock-there-type #f #:max-delay max-delay-type #f (-> -Pathlike Univ)) + (->key -Real -Symbol (-> Univ) #:lock-there lock-there-type #f #:max-delay max-delay-type #f (-> -Pathlike Univ)) + (->key -Real -Symbol (-> Univ) Univ #:lock-there lock-there-type #f #:max-delay max-delay-type #f (-> -Pathlike Univ)) + (->key + -Real + -Symbol + (-> Univ) + Univ + (-opt -Pathlike) + #:lock-there + lock-there-type + #f + #:max-delay + max-delay-type + #f + (-> -Pathlike Univ)))) + (-poly + (a) + (->key + (-opt -Pathlike) + (one-of/c 'shared 'exclusive) + (-> a) + (-> a) + #:lock-file + (-opt -Pathlike) + #f + #:delay + -Real + #f + #:max-delay + -Real + #f + a)) + (-poly + (a b) + (cl->* + (->key (-lst a) (-> a a -Boolean) #:key (-> a a) #f #:cache-keys? -Boolean #f (-lst a)) + (->key (-lst a) (-> b b -Boolean) #:key (-> a b) #f #:cache-keys? -Boolean #f (-lst a)))) + (-poly + (a b) + (cl->* + (->optkey (-lst a) [(-> a a Univ)] #:key (-> a a) #f (-lst a)) + (->optkey (-lst a) [(-> b b Univ)] #:key (-> a b) #f (-lst a)))) + (->key -Pathlike #:mode (one-of/c 'binary 'text) #f -Input-Port) + (->key + -Pathlike + #:mode + (one-of/c 'binary 'text) + #f + #:exists + (one-of/c 'error 'append 'update 'can-update 'replace 'truncate 'must-truncate 'truncate/replace) + #f + -Output-Port) + (->key + -Pathlike + #:mode + (one-of/c 'binary 'text) + #f + #:exists + (one-of/c 'error 'append 'update 'can-update 'replace 'truncate 'must-truncate 'truncate/replace) + #f + (-values (list -Input-Port -Output-Port))) + (-poly (a) (->key -Pathlike (-> -Input-Port a) #:mode (Un (-val 'binary) (-val 'text)) #f a)) + (-poly + (a) + (->key + -Pathlike + (-> -Output-Port a) + #:exists + (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace 'can-update 'must-truncate) + #f + #:mode + (one-of/c 'binary 'text) + #f + a)) + (-poly (a) (->key -Pathlike (-> -Input-Port a) #:mode (Un (-val 'binary) (-val 'text)) #f a)) + (-poly + (a) + (->key + -Pathlike + (-> -Output-Port a) + #:exists + (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace 'can-update 'must-truncate) + #f + #:mode + (one-of/c 'binary 'text) + #f + a)) + (-poly (a) (->key -Pathlike (-> a) #:mode (Un (-val 'binary) (-val 'text)) #f a)) + (-poly + (a) + (->key + -Pathlike + (-> a) + #:exists + (one-of/c 'error 'append 'update 'can-update 'replace 'truncate 'must-truncate 'truncate/replace) + #f + #:mode + (one-of/c 'binary 'text) + #f + a)) + (cl->* + (->key #:line-mode (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) #f (-lst -String)) + (->key -Input-Port #:line-mode (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) #f (-lst -String))) + (cl->* + (->key #:line-mode (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) #f (-lst -Bytes)) + (->key -Input-Port #:line-mode (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) #f (-lst -Bytes))) + (cl->* (->key (-lst Univ) #:separator Univ #f -Void) (->key (-lst Univ) -Output-Port #:separator Univ #f -Void)) + (->key -SomeSystemPathlike -SomeSystemPathlike #:more-than-root? Univ #f -SomeSystemPath) + (let ((N -Integer) + (?N (-opt -Integer)) + (-StrRx (Un -String -Regexp)) + (-BtsRx (Un -Bytes -Byte-Regexp)) + (-StrInput (Un -String -Path)) + (-BtsInput (Un -Input-Port -Bytes)) + (sel (λ (t) (-opt (-> (-lst t) t))))) + (cl->* + (->optkey -StrRx -StrInput (N ?N -Bytes) + #:match-select (sel -String) #f #:gap-select Univ #f + (-lst -String)) + (->optkey -BtsRx (Un -StrInput -BtsInput) (N ?N -Bytes) + #:match-select (sel -Bytes) #f #:gap-select Univ #f + (-lst -Bytes)) + (->optkey -Pattern -BtsInput (N ?N -Bytes) + #:match-select (sel -Bytes) #f #:gap-select Univ #f + (-lst -Bytes)))) + (let* ((?outp (-opt -Output-Port)) + (B -Boolean) + (N -Integer) + (?N (-opt -Integer)) + (ind-pair (-pair -Index -Index)) + (sel (-> (-lst (-opt ind-pair)) (-opt ind-pair))) + (output (-opt (-pair ind-pair (-lst (-opt ind-pair))))) + (-Input (Un -String -Input-Port -Bytes -Path))) + (->optkey -Pattern -Input [N ?N -Bytes] #:match-select sel #f output)))) + +(define post + (list (-> (Un (-val #f) (one-of/c 'binary 'text)) -Boolean -Pathlike -String) + (-> (Un (-val #f) (one-of/c 'binary 'text)) -Boolean -Pathlike -Bytes) + (-> (Un (-val #f) (one-of/c 'binary 'text)) -Boolean -Pathlike Univ) + (-> + (Un (-val #f) (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one)) + -Boolean + (Un (-val #f) (one-of/c 'binary 'text)) + -Boolean + -Pathlike + (-lst -String)) + (-> + (Un (-val #f) (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one)) + -Boolean + (Un (-val #f) (one-of/c 'binary 'text)) + -Boolean + -Pathlike + (-lst -Bytes)) + (-> + (Un (-val #f) (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace)) + -Boolean + (Un (-val #f) (one-of/c 'binary 'text)) + -Boolean + Univ + -Pathlike + -Void) + (-> + (Un (-val #f) (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace)) + -Boolean + (Un (-val #f) (one-of/c 'binary 'text)) + -Boolean + (Un (-val #f) Univ) + -Boolean + (-lst Univ) + -Pathlike + -Void) + (-> + (Un (-val #f) (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace)) + -Boolean + (Un (-val #f) (one-of/c 'binary 'text)) + -Boolean + Univ + -Pathlike + -Void) + (-poly + (a) + (cl->* + (-> (Un (-val #f) (one-of/c 'binary 'text)) -Boolean -Pathlike (-> -Input-Port a) (-val #t) (-lst a)) + (-> (Un (-val #f) (one-of/c 'binary 'text)) -Boolean -Pathlike Univ -Boolean (-lst Univ)))) + (let ((use-lock-type Univ) (timeout-lock-there-type (-opt (-> -Path Univ))) (lock-there-type (-opt (-> -Path Univ)))) + (-> + (-opt lock-there-type) + -Boolean + (-opt timeout-lock-there-type) + -Boolean + (-opt use-lock-type) + -Boolean + -Symbol + (-opt (-> Univ)) + (-opt Univ) + (-opt (-opt -Pathlike)) + -Boolean + -Boolean + -Boolean + Univ)) + (let ((lock-there-type (-opt (-> -Path Univ))) (max-delay-type -Real)) + (-> + (-opt lock-there-type) + -Boolean + (-opt max-delay-type) + -Boolean + -Real + -Symbol + (-opt (-> Univ)) + (-opt Univ) + (-opt (-opt -Pathlike)) + -Boolean + -Boolean + -Boolean + (-> -Pathlike Univ))) + (-poly + (a) + (-> + (-opt -Real) + -Boolean + (-opt (-opt -Pathlike)) + -Boolean + (-opt -Real) + -Boolean + (-opt -Pathlike) + (one-of/c 'shared 'exclusive) + (-> a) + (-> a) + a)) + (-poly + (a b) + (cl->* + (-> -Boolean -Boolean Univ (-val #f) (-lst a) (-> a a -Boolean) (-lst a)) + (-> -Boolean -Boolean (-> a b) (-val #t) (-lst a) (-> b b -Boolean) (-lst a)))) + (-poly + (a b) + (cl->* + (-> Univ (-val #f) (-lst a) (-val #f) -Boolean (-lst a)) + (-> Univ (-val #f) (-lst a) (-> a a Univ) -Boolean (-lst a)) + (-> (-> a b) (-val #t) (-lst a) (-opt (-> b b Univ)) -Boolean (-lst a)))) + (-> (-opt (one-of/c 'binary 'text)) -Boolean -Pathlike -Input-Port) + (-> + (-opt (one-of/c 'error 'append 'update 'can-update 'replace 'truncate 'must-truncate 'truncate/replace)) + -Boolean + (-opt (one-of/c 'binary 'text)) + -Boolean + -Pathlike + -Output-Port) + (-> + (-opt (one-of/c 'error 'append 'update 'can-update 'replace 'truncate 'must-truncate 'truncate/replace)) + -Boolean + (-opt (one-of/c 'binary 'text)) + -Boolean + -Pathlike + (-values (list -Input-Port -Output-Port))) + (-poly (a) (-> (-opt (one-of/c 'binary 'text)) -Boolean -Pathlike (-> -Input-Port a) a)) + (-poly + (a) + (-> + (-opt (one-of/c 'error 'append 'update 'can-update 'replace 'truncate 'must-truncate 'truncate/replace)) + -Boolean + (-opt (one-of/c 'binary 'text)) + -Boolean + -Pathlike + (-> -Output-Port a) + a)) + (-poly (a) (-> (-opt (one-of/c 'binary 'text)) -Boolean -Pathlike (-> -Input-Port a) a)) + (-poly + (a) + (-> + (-opt (one-of/c 'error 'append 'update 'can-update 'replace 'truncate 'must-truncate 'truncate/replace)) + -Boolean + (-opt (one-of/c 'binary 'text)) + -Boolean + -Pathlike + (-> -Output-Port a) + a)) + (-poly (a) (-> (-opt (one-of/c 'binary 'text)) -Boolean -Pathlike (-> a) a)) + (-poly + (a) + (-> + (-opt (one-of/c 'error 'append 'update 'can-update 'replace 'truncate 'must-truncate 'truncate/replace)) + -Boolean + (-opt (one-of/c 'binary 'text)) + -Boolean + -Pathlike + (-> a) + a)) + (-> (-opt (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one)) -Boolean (-opt -Input-Port) -Boolean (-lst -String)) + (-> (-opt (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one)) -Boolean (-opt -Input-Port) -Boolean (-lst -Bytes)) + (-> (-opt Univ) -Boolean (-lst Univ) (-opt -Output-Port) -Boolean -Void) + (-> Univ -Boolean -SomeSystemPathlike -SomeSystemPathlike -SomeSystemPath) + (let ((N -Integer) + (B -Boolean) + (?N (-opt -Integer)) + (-StrRx (Un -String -Regexp)) + (-BtsRx (Un -Bytes -Byte-Regexp)) + (-StrInput (Un -String -Path)) + (sel (λ (t) (-opt (-> (-lst t) t)))) + (-BtsInput (Un -Input-Port -Bytes))) + (cl->* + (-> Univ B (sel -String) B -StrRx -StrInput + (-opt N) (-opt ?N) (-opt -Bytes) B B B (-lst -String)) + (-> Univ B (sel -Bytes) B -BtsRx (Un -StrInput -BtsInput) + (-opt N) (-opt ?N) (-opt -Bytes) B B B (-lst -Bytes)) + (-> Univ B (sel -Bytes) B -Pattern -BtsInput + (-opt N) (-opt ?N) (-opt -Bytes) B B B (-lst -Bytes)))) + + (let* ([?outp (-opt -Output-Port)] + [B -Boolean] + [N -Integer] + [?N (-opt -Integer)] + [ind-pair (-pair -Index -Index)] + [output (-opt (-pair ind-pair (-lst (-opt ind-pair))))] + (sel (-> (-lst (-opt ind-pair)) (-opt ind-pair))) + [-Input (Un -String -Input-Port -Bytes -Path)]) + (-> (-opt sel) B -Pattern -Input (-opt N) (-opt ?N) (-opt -Bytes) B B B output)))) +|# \ No newline at end of file