From 5175f9d873610582f416319ff7b914fceb86bf74 Mon Sep 17 00:00:00 2001
From: WarGrey Gyoudmon Ju <juzhenliang@gmail.com>
Date: Sat, 9 Jul 2016 08:41:54 +0800
Subject: [PATCH] add or improve lots of base definitions (#372)

---
 .../typed-racket/base-env/base-env.rkt        | 68 +++++++++++--------
 1 file changed, 41 insertions(+), 27 deletions(-)

diff --git a/typed-racket-lib/typed-racket/base-env/base-env.rkt b/typed-racket-lib/typed-racket/base-env/base-env.rkt
index 248b062f..6acfba37 100644
--- a/typed-racket-lib/typed-racket/base-env/base-env.rkt
+++ b/typed-racket-lib/typed-racket/base-env/base-env.rkt
@@ -1872,24 +1872,23 @@
 
 ;; Section 13.1.9
 [make-input-port
- (->opt Univ
-        (Un (-> -Bytes (Un -Nat (-val eof) top-func (-evt Univ)))
-            -Input-Port)
-        (Un (-> -Bytes -Nat (-opt (-evt Univ))
-                (Un -Nat (-val eof) top-func (-evt Univ) (-val #f)))
-            -Input-Port
-            (-val #f))
-        (-> Univ)
-        [(-opt (-> (-evt Univ)))
-         (-opt (-> -PosInt (-evt Univ) (-evt Univ) Univ))
-         (-opt (-> (-values (list (-opt -Integer)
-                                  (-opt -Integer)
-                                  (-opt -Integer)))))
-         (-> Univ)
-         (Un -Integer -Port (-val #f) (-> (-opt -Integer)))
-         (-opt (cl->* (-> (one-of/c 'block 'none) Univ)
-                      (-> (-opt (one-of/c 'block 'none)))))]
-        -Input-Port)]
+ (let ([specials-func (-> (-opt -Integer) (-opt -Integer) (-opt -Integer) (-opt -Integer) Univ)])
+   (->opt Univ
+          (Un (-> -Bytes (Un -Nat (-val eof) specials-func (-evt Univ)))
+              -Input-Port)
+          (Un (-> -Bytes -Nat (-opt (-evt Univ))
+                  (Un -Nat (-val eof) specials-func (-evt Univ) (-val #f)))
+              -Input-Port
+              (-val #f))
+          (-> Univ)
+          [(-opt (-> (-evt Univ)))
+           (-opt (-> -PosInt (-evt Univ) (-evt Univ) Univ))
+           (-opt (-> (-values (list (-opt -Integer) (-opt -Integer) (-opt -Integer)))))
+           (-> Univ)
+           (Un -Integer -Port (-val #f) (-> (-opt -Integer)))
+           (-opt (cl->* (-> (one-of/c 'block 'none) Univ)
+                        (-> (-opt (one-of/c 'block 'none)))))]
+          -Input-Port))]
 [make-output-port
  (->opt Univ
         (-evt Univ)
@@ -1957,9 +1956,22 @@
 ;; Section 13.1.10.2
 [input-port-append  (->* (list Univ) -Input-Port -Input-Port)]
 
-;TODO write the type for this
-;It is fairly complicated and require events
-;make-input-port/read-to-peek
+[make-input-port/read-to-peek
+ (let ([specials-func (-> (-opt -Integer) (-opt -Integer) (-opt -Integer) (-opt -Integer) Univ)])
+   (->opt Univ
+          (-> -Bytes (Un -Nat (-val eof) specials-func (-evt -Zero)))
+          (Un (-> -Bytes -Nat (-> -Bytes -Nat (Un -Nat (-val eof) specials-func (-evt -Zero) (-val #f)))
+                  (Un -Nat (-val eof) specials-func (-evt -Zero) (-val #f)))
+              (-val #f))
+          (-> Univ)
+          [(-opt (-> (-values (list (-opt -Integer) (-opt -Integer) (-opt -Integer)))))
+           (-> Univ)
+           -Integer
+           (-opt (cl->* (-> (one-of/c 'block 'none) Univ)
+                        (-> (-opt (one-of/c 'block 'none)))))
+           Univ
+           (-opt (-> (Un -Nat (-val eof) top-func (-evt -Zero)) Univ))]
+          -Input-Port))]
 
 [make-limited-input-port (->opt -Input-Port -Nat [Univ] -Input-Port)]
 [make-pipe-with-specials (->opt [-Nat Univ Univ] (-values (list -Input-Port -Output-Port)))]
@@ -2524,9 +2536,9 @@
 [build-path/convention-type
   ((list -PathConventionType -SomeSystemPathlike*) -SomeSystemPathlike* . ->* . -SomeSystemPath)]
 
-[absolute-path? (-> -SomeSystemPath B)]
-[relative-path? (-> -SomeSystemPath B)]
-[complete-path? (-> -SomeSystemPath B)]
+[absolute-path? (-> -SomeSystemPathlike B)]
+[relative-path? (-> -SomeSystemPathlike B)]
+[complete-path? (-> -SomeSystemPathlike B)]
 
 [path->complete-path
  (cl->* (-> -Pathlike -Path)
@@ -2590,6 +2602,8 @@
 [explode-path (-SomeSystemPathlike . -> . (-lst (Un -SomeSystemPath (one-of/c 'up 'same))))]
 [simple-form-path (-Pathlike . -> . -Path)]
 [normalize-path (cl->* (-Pathlike [-Pathlike] . ->opt . -Path))]
+[path-get-extension (-SomeSystemPathlike . -> . (-opt -Bytes))]
+[path-has-extension? (-SomeSystemPathlike (Un -String -Bytes) . -> . (-opt -Bytes))]
 [filename-extension (-SomeSystemPathlike . -> . (-opt -Bytes))]
 [file-name-from-path (-Pathlike . -> . (-opt -Path))]
 [path-only (-SomeSystemPathlike . -> . (-opt -Path))]
@@ -2931,12 +2945,12 @@
 [logger-name (-> -Logger (-opt Sym))]
 [current-logger (-Param -Logger -Logger)]
 
-[log-message (cl->* (-> -Logger -Log-Level -String Univ -Void)
-                    (-> -Logger -Log-Level (Un (-val #f) -Symbol) -String Univ -Void))]
+[log-message (cl->* (->opt -Logger -Log-Level -String Univ [Univ] -Void)
+                    (->opt -Logger -Log-Level (Un (-val #f) -Symbol) -String Univ [Univ] -Void))]
 [log-level? (->opt -Logger -Log-Level [(-opt -Symbol)] B)]
 
 [log-receiver? (make-pred-ty -Log-Receiver)]
-[make-log-receiver (-> -Logger -Log-Level -Log-Receiver)]
+[make-log-receiver (->opt -Logger -Log-Level [(-opt -Symbol)] -Log-Receiver)]
 
 ;; Section 15.5.4 (Additional Logging Functions, racket/logging)
 [log-level/c (make-pred-ty (one-of/c 'none 'fatal 'error 'warning 'info 'debug))]