Commit 85957913 authored by ttuegel's avatar ttuegel
Browse files

Added detailed test interface

Ticket #215 (Overhaul support for packages' tests).  This patch provides the
detailed test interface for exposing individual tests to Cabal and other test
agents.  It also provides the simple function Cabal will provide as the default
test runner.
parent 7953380d
......@@ -37,7 +37,8 @@ Flag base3
Library
build-depends: base >= 1 && < 5,
filepath >= 1 && < 1.3
filepath >= 1 && < 1.3,
extensible-exceptions >= 0.1 && < 0.2
if flag(base4) { build-depends: base >= 4 } else { build-depends: base < 4 }
if flag(base3) { build-depends: base >= 3 } else { build-depends: base < 3 }
if flag(base3)
......@@ -107,6 +108,7 @@ Library
Distribution.Simple.UserHooks,
Distribution.Simple.Utils,
Distribution.System,
Distribution.TestSuite,
Distribution.Text,
Distribution.Verbosity,
Distribution.Version,
......
......@@ -40,7 +40,10 @@ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
module Distribution.Simple.Test ( test ) where
module Distribution.Simple.Test
( test
, runTests
) where
import Distribution.PackageDescription
( PackageDescription(..), TestSuite(..), TestType(..) )
......@@ -52,6 +55,9 @@ import Distribution.Simple.InstallDirs
import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
import Distribution.Simple.Setup ( TestFlags(..), TestFilter(..), fromFlag )
import Distribution.Simple.Utils ( die, notice )
import Distribution.TestSuite
( Test(..) , Result(..), PureTestable(..), ImpureTestable(..)
, TestOptions(..) )
import Distribution.Text
import Distribution.Verbosity ( Verbosity, silent )
import Distribution.Version ( Version(..), withinVersion, withinRange )
......@@ -162,3 +168,26 @@ test pkg_descr lbi flags = do
showTestLog :: Verbosity -> FilePath -> IO ()
showTestLog verbosity outFile = when (verbosity > silent) $ do
withFile outFile ReadMode $ \hOut -> hGetContents hOut >>= putStrLn
runTmpOutput :: FilePath -> FilePath -> IO (FilePath, ExitCode)
runTmpOutput cmd base = do
tmp <- getTemporaryDirectory
time <- getClockTime
let timeString = formatTime $ toUTCTime time
file = tmp </> base ++ "-" ++ timeString ++ ".log"
withFile file WriteMode $ \hOut -> do
proc <- runProcess cmd [] Nothing Nothing Nothing
(Just hOut) (Just hOut)
exit <- waitForProcess proc
return (file, exit)
formatTime :: CalendarTime -> String
formatTime time =
show (ctYear time)
++ pad (fromEnum . ctMonth)
++ pad ctDay
++ "-"
++ pad ctHour
++ pad ctMin
++ pad ctSec
where pad f = (if f time < 10 then "0" else "") ++ show (f time)
\ No newline at end of file
{-# LANGUAGE ExistentialQuantification #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.TestSuite
-- Copyright : Thomas Tuegel 2010
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- This module defines the detailed test suite interface which makes it
-- possible to expose individual tests to Cabal or other test agents.
{- All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Isaac Jones nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
module Distribution.TestSuite
( Test(..)
, Options(..)
, Result(..)
, TestOptions(..)
, PureTestable(..)
, ImpureTestable(..)
) where
import Control.Exception.Extensible ( SomeException )
import Data.Dynamic ( Dynamic() )
import Data.Function ( on )
import Data.List ( unionBy )
import Data.Monoid ( Monoid(..) )
import Data.Typeable ( TypeRep )
newtype Options = Options [(String, Dynamic)]
instance Monoid Options where
mempty = Options []
-- | Combine two sets of 'Options'. If an option is named in only one of
-- the sets of 'Options', the associated value is used. If an option is
-- named in both arguments, the value specified in the left argument is
-- used.
mappend (Options a) (Options b) = Options $ unionBy ((==) `on` fst) a b
data Result
= Pass -- ^ The value indicating a successful test.
| Fail String -- ^ The value indicating a test completed
-- unsuccessfully. The 'String' value should be a
-- human-readable message indicating how the test
-- failed.
| Error SomeException -- ^ The value indicating a test that could not be
-- completed due to some error. The test framework
-- should provide an exception indicating the
-- nature of the error.
deriving Show
class TestOptions t where
-- | The name of the test.
name :: t -> String
-- | A list of the options a test recognizes. The name and 'TypeRep' are
-- provided so that test runners can ensure that user-specified options are
-- correctly typed.
options :: t -> [(String, TypeRep)]
-- | The default options for a test. Test frameworks should provide a new
-- random seed, if appropriate.
defaultOptions :: t -> IO Options
-- | Class abstracting impure tests. Test frameworks should implement this
-- class only as a last resort for test types which actually require 'IO'.
-- In particular, tests that simply require pseudo-random number generation can
-- be implemented as pure tests.
class TestOptions t => ImpureTestable t where
-- | Runs an impure test and returns the result. Test frameworks
-- implementing this class are responsible for converting any exceptions to
-- the correct 'Result' value.
getResult :: t -> Options -> IO Result
-- | Class abstracting pure tests. Test frameworks should prefer to implement
-- this class over 'ImpureTestable'.
class TestOptions t => PureTestable t where
-- | The result of a pure test. Test frameworks implementing this class
-- are responsible for converting any exceptions to the correct 'Result'
-- value.
result :: t -> Options -> Result
data Test
= forall p. PureTestable p => PureTest p
| forall i. ImpureTestable i => ImpureTest i
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment