Add tests from libraries/process/tests and libraries/Win32/tests to GHC

These tests were previously part of the libraries, which themselves are
submodules of the GHC repository. This commit moves the tests directly
to the GHC repository.

testsuite/tests/Win32/HandleConversion.hs

+module Main where
+
+import Graphics.Win32.Misc
+import System.IO
+import System.Win32.Types
+
+testStdHandle :: Handle -> StdHandleId -> IO ()
+testStdHandle haskHandle winStdHandle = do
+  winHandle <- getStdHandle winStdHandle
+  withHandleToHANDLE haskHandle $ print . (== winHandle)
+
+main :: IO ()
+main = do
+  testStdHandle stdin  sTD_INPUT_HANDLE
+  testStdHandle stdout sTD_OUTPUT_HANDLE
+  testStdHandle stderr sTD_ERROR_HANDLE

testsuite/tests/Win32/HandleConversion.stdout

+True
+True
+True

testsuite/tests/Win32/Makefile

+# This Makefile runs the tests using GHC's testsuite framework.  It
+# assumes the package is part of a GHC build tree with the testsuite
+# installed in ../../../testsuite.
+
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk

testsuite/tests/Win32/PokeTZI.hs

+module Main where
+
+import Control.Exception (assert)
+import Foreign
+import System.Win32.Time
+
+main :: IO ()
+main = do
+    (_, tzi) <- getTimeZoneInformation
+    alloca $ \buf -> do
+        poke buf tzi
+        tzi' <- peek buf
+        assert (tzi == tzi') $ return ()

testsuite/tests/Win32/Semaphores.hs

+module Main where
+
+import Control.Concurrent
+  ( forkIO, threadDelay )
+import Control.Monad
+  ( void )
+import Data.Foldable
+  ( for_ )
+
+import System.Win32.Event
+  ( waitForSingleObject )
+import System.Win32.File
+  ( closeHandle )
+import System.Win32.Semaphore
+  ( Semaphore(..), createSemaphore, releaseSemaphore )
+
+main :: IO ()
+main = do
+
+  (test_sem, ex1) <- mk_test_sem
+  (_, ex2) <- mk_test_sem
+
+  let sem_name = "win32-test-semaphore"
+  (sem, ex3) <- createSemaphore Nothing 2 3 (Just sem_name)
+
+  putStrLn (show ex1 ++ " " ++ show ex2 ++ " " ++ show ex3)
+  -- False True False
+
+  putStrLn "=========="
+  for_ [1,2,3] (run_thread sem)
+  -- finish: 1, 2
+
+  putStrLn "=========="
+  void $ releaseSemaphore sem 3
+  -- finish: 3
+
+  threadDelay 5000   -- 5 ms
+  for_ [4,5,6,7] (run_thread sem)
+  -- finish: 4, 5
+
+  threadDelay 1000   -- 1 ms
+  putStrLn "=========="
+  void $ releaseSemaphore sem 1
+  -- finish: 6
+
+  threadDelay 100000 -- 100 ms
+  putStrLn "=========="
+  closeHandle (semaphoreHandle test_sem)
+  closeHandle (semaphoreHandle sem)
+
+run_thread :: Semaphore -> Int -> IO ()
+run_thread sem i = do
+  threadDelay 1000 -- 1 ms
+  putStrLn ("start " ++ show i)
+  void $ forkIO $ do
+    res <- waitForSingleObject (semaphoreHandle sem) 50 -- 50 ms
+    putStrLn ("finish " ++ show i ++ ": " ++ show res)
+
+mk_test_sem :: IO (Semaphore, Bool)
+mk_test_sem = createSemaphore Nothing 1 1 (Just "test-sem")

testsuite/tests/Win32/Semaphores.stdout

+False True False
+==========
+start 1
+finish 1: 0
+start 2
+finish 2: 0
+start 3
+==========
+finish 3: 0
+start 4
+finish 4: 0
+start 5
+finish 5: 0
+start 6
+start 7
+==========
+finish 6: 0
+finish 7: 258
+==========

testsuite/tests/Win32/T4452.hs

+module Main where
+
+import Control.Monad
+import Foreign.Ptr
+import Graphics.Win32.GDI.Clip
+
+main = do
+  openClipboard nullPtr
+  go 0
+  where
+    go n = do
+      n' <- enumClipboardFormats n
+      unless (n == 0) (go n')

testsuite/tests/Win32/all.T

+test('registry001', normal, compile_and_run, [''])
+
+# This isn't a very good test to run automatically at the moment, since
+# it doesn't terminate
+test('helloworld', skip, compile_and_run, ['-package lang -package win32'])
+
+test('lasterror', normal, compile_and_run, ['-package Win32'])
+test('T4452', normal, compile_and_run, ['-package Win32'])
+test('PokeTZI', ignore_stdout, compile_and_run, ['-package Win32'])
+test('HandleConversion', normal, compile_and_run, ['-package Win32'])
+
+test('Semaphores', normal, compile_and_run, ['-threaded -package Win32'])

testsuite/tests/Win32/helloworld.hs

+-- Haskell version of "Hello, World" using the Win32 library.
+-- Demonstrates how the Win32 library can be put to use.
+-- (c) sof 1999
+
+
+module Main(main) where
+
+import qualified Win32
+import Addr
+
+-- Toplevel main just creates a window and pumps messages.
+-- The window procedure (wndProc) we pass in is partially
+-- applied with the user action that takes care of responding
+-- to repaint messages (WM_PAINT).
+
+main :: IO ()
+main = do
+  lpps <- Win32.malloc Win32.sizeofPAINTSTRUCT
+  hwnd <- createWindow 200 200 (wndProc lpps onPaint)
+  messagePump hwnd
+
+-- OnPaint handler for a window - draw a string centred
+-- inside it.
+onPaint :: Win32.RECT -> Win32.HDC -> IO ()
+onPaint (_,_,w,h) hdc = do
+   Win32.setBkMode hdc Win32.tRANSPARENT
+   Win32.setTextColor hdc (Win32.rgb 255 255 0)
+   let y | h==10     = 0
+         | otherwise = ((h-10) `div` 2)
+       x | w==50     = 0
+         | otherwise = (w-50) `div` 2
+   Win32.textOut hdc x y "Hello, world"
+   return ()
+
+-- Simple window procedure - one way to improve and generalise
+-- it would be to pass it a message map (represented as a
+-- finite map from WindowMessages to actions, perhaps).
+
+wndProc :: Win32.LPPAINTSTRUCT
+        -> (Win32.RECT -> Win32.HDC -> IO ()) -- on paint action
+        -> Win32.HWND
+        -> Win32.WindowMessage
+        -> Win32.WPARAM
+        -> Win32.LPARAM
+        -> IO Win32.LRESULT
+wndProc lpps onPaint hwnd wmsg wParam lParam
+ | wmsg == Win32.wM_DESTROY = do
+     Win32.sendMessage hwnd Win32.wM_QUIT 1 0
+     return 0
+ | wmsg == Win32.wM_PAINT && hwnd /= nullAddr = do
+     r <- Win32.getClientRect hwnd
+     paintWith lpps hwnd (onPaint r)
+     return 0
+ | otherwise =
+     Win32.defWindowProc (Just hwnd) wmsg wParam lParam
+
+createWindow :: Int -> Int -> Win32.WindowClosure -> IO Win32.HWND
+createWindow width height wndProc = do
+  let winClass = Win32.mkClassName "Hello"
+  icon         <- Win32.loadIcon   Nothing Win32.iDI_APPLICATION
+  cursor       <- Win32.loadCursor Nothing Win32.iDC_ARROW
+  bgBrush      <- Win32.createSolidBrush (Win32.rgb 0 0 255)
+  mainInstance <- Win32.getModuleHandle Nothing
+  Win32.registerClass
+          ( Win32.cS_VREDRAW + Win32.cS_HREDRAW
+          , mainInstance
+          , Just icon
+          , Just cursor
+          , Just bgBrush
+          , Nothing
+          , winClass
+          )
+  w <- Win32.createWindow
+                 winClass
+                 "Hello, World example"
+                 Win32.wS_OVERLAPPEDWINDOW
+                 Nothing Nothing -- leave it to the shell to decide the position
+                                 -- at where to put the window initially
+                 (Just width)
+                 (Just height)
+                 Nothing      -- no parent, i.e, root window is the parent.
+                 Nothing      -- no menu handle
+                 mainInstance
+                 wndProc
+  Win32.showWindow w Win32.sW_SHOWNORMAL
+  Win32.updateWindow w
+  return w
+
+messagePump :: Win32.HWND -> IO ()
+messagePump hwnd = do
+  msg  <- Win32.getMessage (Just hwnd) `catch` \ _ -> return nullAddr
+  if msg == nullAddr then
+    return ()
+   else do
+    Win32.translateMessage msg
+    Win32.dispatchMessage msg
+    messagePump hwnd
+
+paintWith :: Win32.LPPAINTSTRUCT -> Win32.HWND -> (Win32.HDC -> IO a) -> IO a
+paintWith lpps hwnd p = do
+  hdc  <- Win32.beginPaint hwnd lpps
+  a    <- p hdc
+  Win32.endPaint hwnd lpps
+  return a

testsuite/tests/Win32/lasterror.hs

+{-# LANGUAGE ForeignFunctionInterface #-}
+-- Test that the Win32 error code from getLastError is thread-local.
+
+import System.Win32
+import Control.Monad
+import Control.Concurrent
+
+main = do
+  setLastError 42
+  r <- getLastError
+  when (r /= 42) $ fail ("wrong: " ++ show r)
+  m <- newEmptyMVar
+  forkIO $ do setLastError 43; putMVar m ()
+  takeMVar m
+  r <- getLastError
+  when (r /= 42) $ fail ("wrong: " ++ show r)

testsuite/tests/Win32/registry001.hs

+import System.Win32
+import Control.Exception
+import Control.Monad
+
+x = "bumble"
+name = "test_registry001"
+
+-- Create, read, and delete a value (test for bug #3241)
+main = do
+  k1 <- regCreateKey hKEY_CURRENT_USER "Software"
+  k2 <- regCreateKey k1 "Haskell"
+  k3 <- regCreateKey k2 "GHC"
+  flip finally (regDeleteValue k3 name) $ do
+    regSetStringValue k3 name x
+    r <- regQueryDefaultValue k3 name
+    print r

testsuite/tests/Win32/registry001.stdout

+"bumble"

testsuite/tests/process/.gitignore

+.hpc*/
+*.o
+*.hi
+*.comp.std*
+*.run.std*
+*.eventlog
+*.genscript
+*.exe
+
+# specific files
+/T1780
+/T3231
+/T3994
+/T4198
+/T4889
+/T8343
+/process001
+/process001.out
+/process002
+/process002.out
+/process003
+/process004
+/process005
+/process006
+/process007
+/process007.tmp
+/process007_fd
+/process008
+/process009
+/process010
+/process011

testsuite/tests/process/Makefile

+# This Makefile runs the tests using GHC's testsuite framework.  It
+# assumes the package is part of a GHC build tree with the testsuite
+# installed in ../../../testsuite.
+
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+.PHONY: process007_fd
+process007_fd:
+	'$(TEST_HC)' -optc='-Wall' -no-hs-main -no-auto-link-packages process007_fd.c -o process007_fd
+
+.PHONY: T3994app
+T3994app:
+	'$(TEST_HC)' $(TEST_HC_OPTS) T3994app.hs -threaded

testsuite/tests/process/T1780.hs

+module Main where
+
+import Control.Concurrent
+import System.IO
+import System.Process
+
+launch :: String -> IO String
+launch i = do (hin,hout,herr,ph) <- runInteractiveProcess "cat" [] Nothing Nothing
+              -- forkIO $ collect ph  -- This doesn't seem to be relevant to the problem.
+              forkIO $ do hPutStr hin i
+                          hClose hin
+              hGetContents hout
+
+main :: IO ()
+main = do o <- foldl (>>=) (return "foo") (replicate 5 launch)
+          t <- myThreadId
+               -- timeout
+          forkIO $ do threadDelay 5000000; killThread t
+          putStrLn o

testsuite/tests/process/T1780.stdout

+foo

testsuite/tests/process/T3231.hs

+module Main (main) where
+
+import Control.Concurrent
+import System.IO
+import System.Cmd
+import System.Directory
+
+main = do
+    hSetBuffering stdout NoBuffering
+    forkIO $ f "foo1.txt"
+    forkIO $ f "foo2.txt"
+    threadDelay $ 2*1000000
+    putStrLn "Finished successfully"
+
+f file = do
+    h <- openFile file WriteMode
+    hPutStrLn h "fjkladsf"
+    system "sleep 1"
+    -- putChar '.'
+    hClose h
+    removeFile file
+    f file

testsuite/tests/process/T3231.stdout

+Finished successfully

testsuite/tests/process/T3994.hs

+module Main where
+
+import Control.Concurrent
+import System.IO
+import System.Process
+
+main :: IO ()
+main = do (_,Just hout,_,p) <- createProcess (proc "./T3994app" ["start", "10000"])
+                            { std_out = CreatePipe, create_group = True }
+          start <- hGetLine hout
+          putStrLn start
+          interruptProcessGroupOf p
+          t <- myThreadId
+               -- timeout
+          forkIO $ do
+            threadDelay 5000000
+            putStrLn "Interrupting a Running Process Failed"
+            hFlush stdout
+            killThread t
+          waitForProcess p
+          putStrLn "end"
+          return ()

testsuite/tests/process/T3994.stdout

+start
+end