[commit: packages/directory] master: Hook test suite to `cabal test` (b80a204)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/directory

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/b80a2041a72d0408f774fa05f7b0685a927d2c71/directory

>---------------------------------------------------------------

commit b80a2041a72d0408f774fa05f7b0685a927d2c71
Author: Phil Ruffwind <rf at rufflewind.com>
Date:   Mon Mar 2 05:09:03 2015 -0500

    Hook test suite to `cabal test`
    
    `cabal test` now invokes the GHC test framework to run the tests.  In
    effect, it's just a wrapper that runs `tools/run-tests` with the correct
    environment.
    
    This is somewhat complicated by the fact that we cannot add `process` as
    a dependency, so we have to reinvent the wheel just to launch the shell
    script.


>---------------------------------------------------------------

b80a2041a72d0408f774fa05f7b0685a927d2c71
 directory.cabal         | 14 +++++------
 test/main.hs            | 20 ----------------
 tools/dispatch-tests.hs | 63 +++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 70 insertions(+), 27 deletions(-)

diff --git a/directory.cabal b/directory.cabal
index c648e0d..d134c05 100644
--- a/directory.cabal
+++ b/directory.cabal
@@ -64,10 +64,10 @@ Library
     ghc-options: -Wall
 
 test-suite test
-  default-language: Haskell2010
-  hs-source-dirs: test
-  main-is: main.hs
-  type: exitcode-stdio-1.0
-  build-depends: base
-               , directory
-               , containers
+    default-language: Haskell2010
+    other-extensions: CPP ForeignFunctionInterface
+    ghc-options:      -Wall
+    hs-source-dirs:   tools
+    main-is:          dispatch-tests.hs
+    type:             exitcode-stdio-1.0
+    build-depends:    base, directory
diff --git a/test/main.hs b/test/main.hs
deleted file mode 100644
index 7a9fcb3..0000000
--- a/test/main.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
--- Simplistic test suite for now. Worthwhile to add a dependency on a
--- test framework at some point.
-module Main (main) where
-
-import qualified Data.Set         as Set
-import           Prelude          (IO, error, fmap, return, show, (==))
-import           System.Directory (getDirectoryContents)
-
-main :: IO ()
-main = do
-    let expected = Set.fromList
-            [ "."
-            , ".."
-            , "main.hs"
-            ]
-    actual <- fmap Set.fromList (getDirectoryContents "test")
-    if expected == actual
-        then return ()
-        else error (show (expected, actual))
diff --git a/tools/dispatch-tests.hs b/tools/dispatch-tests.hs
new file mode 100644
index 0000000..598cd8b
--- /dev/null
+++ b/tools/dispatch-tests.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
+module Main (main) where
+import Foreign (Ptr)
+import Foreign.C (CChar(..), CInt(..), withCString)
+import Data.Functor ((<$>))
+import System.Directory ()     -- to make sure `directory` is built beforehand
+import System.Environment (getArgs)
+import System.Exit (ExitCode(ExitSuccess, ExitFailure), exitWith)
+
+main :: IO ()
+main = do
+
+  -- check if 'cabal exec' is supported (didn't exist until 1.20)
+  cabalExecTest <- rawSystem "sh" ["-c", "cabal >/dev/null 2>&1 exec true"]
+
+  -- execute in the Cabal sandbox environment if possible
+  let prefix = case cabalExecTest of
+                 ExitSuccess   -> ["cabal", "exec", "--"]
+                 ExitFailure _ -> []
+
+  args <- getArgs
+  let command : arguments = prefix ++ ["sh", "tools/run-tests"] ++ args
+  exitWith =<< normalizeExitCode <$> rawSystem command arguments
+
+makeExitCode :: Int -> ExitCode
+makeExitCode 0 = ExitSuccess
+makeExitCode e = ExitFailure e
+
+-- on Linux the exit code is right-shifted by 8 bits, causing exit codes to be
+-- rather large; older versions of GHC don't seem to handle that well in
+-- `exitWith`
+normalizeExitCode :: ExitCode -> ExitCode
+normalizeExitCode  ExitSuccess    = ExitSuccess
+normalizeExitCode (ExitFailure _) = ExitFailure 1
+
+-- we can't use the `process` library as it causes a dependency cycle with
+-- Cabal, so we reinvent the wheel here in a simplistic way; this will
+-- probably break with non-ASCII characters on Windows
+rawSystem :: String -> [String] -> IO ExitCode
+rawSystem cmd args  =
+  withCString (quoteCmdArgs (cmd : args)) $ \ c_command ->
+  makeExitCode . fromIntegral <$> c_system c_command
+
+-- handle the different quoting rules in CMD.EXE vs POSIX shells
+quoteCmdArgs :: [String] -> String
+quoteCmdArgs cmdArgs =
+#ifdef mingw32_HOST_OS
+  -- the arcane quoting rules require us to add an extra set of quotes
+  -- around the entire thing: see `help cmd` or look at
+  -- https://superuser.com/a/238813
+  "\"" ++ unwords (quote <$> cmdArgs) ++ "\""
+  where quote s = "\"" ++ replaceElem '"' "\"\"" s ++ "\""
+#else
+  unwords (quote <$> cmdArgs)
+  where quote s = "'" ++ replaceElem '\'' "'\\''" s ++ "'"
+#endif
+
+replaceElem :: Eq a => a -> [a] -> [a] -> [a]
+replaceElem match repl = concat . (replace <$>)
+  where replace c | c == match = repl
+                  | otherwise  = [c]
+
+foreign import ccall safe "stdlib.h system" c_system :: Ptr CChar -> IO CInt