hWaitForInput-accurate-stdin test

3 files changed, 53 insertions, 0 deletions

diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T
index a6cb96d771..25e851b877 100644
--- a/libraries/base/tests/all.T
+++ b/libraries/base/tests/all.T
@@ -202,6 +202,7 @@ test('T8089',
      compile_and_run, [''])
 test('hWaitForInput-accurate-socket', reqlib('unix'), compile_and_run, [''])
 test('T8684', expect_broken(8684), compile_and_run, [''])
+test('hWaitForInput-accurate-stdin', normal, compile_and_run, [''])
 test('T9826',normal, compile_and_run,[''])
 test('T9848',
         [ collect_stats('bytes allocated')
diff --git a/libraries/base/tests/hWaitForInput-accurate-stdin.hs b/libraries/base/tests/hWaitForInput-accurate-stdin.hs
new file mode 100644
index 0000000000..f38a0b3f36
--- /dev/null
+++ b/libraries/base/tests/hWaitForInput-accurate-stdin.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE CPP #-}
+
+import Control.Concurrent
+import Control.Monad
+import GHC.Clock
+import System.Environment
+import System.Exit
+import System.IO
+import System.Process
+import System.Timeout
+
+-- IMPORTANT: Re-run this test _manually_ on windows if/when you change
+-- the code in `libraries/base/cbits/inputReady.c` that mentions
+-- `FILE_TYPE_CHAR`. Only when you run the code manually, in cmd.exe
+-- or PowerShell, does this code path get activated.
+-- Running this code in mintty does not count.
+main :: IO ()
+main = do
+    args <- getArgs
+    case args of
+        [] -> do
+            let cp =
+                    (shell
+                         ((if isLinuxHost
+                               then ("./" ++)
+                               else id)
+                              "hWaitForInput-accurate-stdin --read-from-stdin"))
+                        {std_in = CreatePipe}
+            (_, _, _, ph) <- createProcess cp
+            waitForProcess ph >>= exitWith
+        ("--read-from-stdin":_) -> do
+            let nanoSecondsPerSecond = 1000 * 1000 * 1000
+            let milliSecondsPerSecond = 1000
+            let timeToSpend = 1
+            let timeToSpendNano = timeToSpend * nanoSecondsPerSecond
+            let timeToSpendMilli = timeToSpend * milliSecondsPerSecond
+            start <- getMonotonicTimeNSec
+            b <- hWaitForInput stdin timeToSpendMilli
+            end <- getMonotonicTimeNSec
+            let timeSpentNano = fromIntegral $ end - start
+            let delta = timeSpentNano - timeToSpendNano
+            -- We can never wait for a shorter amount of time than specified
+            putStrLn $ "delta >= 0: " ++ show (delta >= 0)
+        _ -> error "should not happen."
+
+isLinuxHost :: Bool
+#if defined(mingw32_HOST_OS)
+isLinuxHost = False
+#else
+isLinuxHost = True
+#endif
diff --git a/libraries/base/tests/hWaitForInput-accurate-stdin.stdout b/libraries/base/tests/hWaitForInput-accurate-stdin.stdout
new file mode 100644
index 0000000000..f1e939c51d
--- /dev/null
+++ b/libraries/base/tests/hWaitForInput-accurate-stdin.stdout
@@ -0,0 +1 @@
+delta >= 0: True