<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html>
<head>
<!-- Generated by HsColour, http://www.cs.york.ac.uk/fp/darcs/hscolour/ -->
<title>Distribution/TestSuite.hs</title>
<link type='text/css' rel='stylesheet' href='hscolour.css' />
</head>
<body>
<pre><a name="line-1"></a><span class='hs-comment'>{-# LANGUAGE CPP, ExistentialQuantification #-}</span>
<a name="line-2"></a><span class='hs-comment'>-----------------------------------------------------------------------------</span>
<a name="line-3"></a><span class='hs-comment'>-- |</span>
<a name="line-4"></a><span class='hs-comment'>-- Module : Distribution.TestSuite</span>
<a name="line-5"></a><span class='hs-comment'>-- Copyright : Thomas Tuegel 2010</span>
<a name="line-6"></a><span class='hs-comment'>--</span>
<a name="line-7"></a><span class='hs-comment'>-- Maintainer : cabal-devel@haskell.org</span>
<a name="line-8"></a><span class='hs-comment'>-- Portability : portable</span>
<a name="line-9"></a><span class='hs-comment'>--</span>
<a name="line-10"></a><span class='hs-comment'>-- This module defines the detailed test suite interface which makes it</span>
<a name="line-11"></a><span class='hs-comment'>-- possible to expose individual tests to Cabal or other test agents.</span>
<a name="line-12"></a>
<a name="line-13"></a><span class='hs-comment'>{- All rights reserved.
<a name="line-14"></a>
<a name="line-15"></a>Redistribution and use in source and binary forms, with or without
<a name="line-16"></a>modification, are permitted provided that the following conditions are
<a name="line-17"></a>met:
<a name="line-18"></a>
<a name="line-19"></a> * Redistributions of source code must retain the above copyright
<a name="line-20"></a> notice, this list of conditions and the following disclaimer.
<a name="line-21"></a>
<a name="line-22"></a> * Redistributions in binary form must reproduce the above
<a name="line-23"></a> copyright notice, this list of conditions and the following
<a name="line-24"></a> disclaimer in the documentation and/or other materials provided
<a name="line-25"></a> with the distribution.
<a name="line-26"></a>
<a name="line-27"></a> * Neither the name of Isaac Jones nor the names of other
<a name="line-28"></a> contributors may be used to endorse or promote products derived
<a name="line-29"></a> from this software without specific prior written permission.
<a name="line-30"></a>
<a name="line-31"></a>THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
<a name="line-32"></a>"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
<a name="line-33"></a>LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
<a name="line-34"></a>A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
<a name="line-35"></a>OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
<a name="line-36"></a>SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
<a name="line-37"></a>LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
<a name="line-38"></a>DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
<a name="line-39"></a>THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
<a name="line-40"></a>(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
<a name="line-41"></a>OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}</span>
<a name="line-42"></a>
<a name="line-43"></a><span class='hs-cpp'>#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610))</span>
<a name="line-44"></a><span class='hs-cpp'>#define NEW_EXCEPTION</span>
<a name="line-45"></a><span class='hs-cpp'>#endif</span>
<a name="line-46"></a>
<a name="line-47"></a><span class='hs-keyword'>module</span> <span class='hs-conid'>Distribution</span><span class='hs-varop'>.</span><span class='hs-conid'>TestSuite</span>
<a name="line-48"></a> <span class='hs-layout'>(</span> <span class='hs-comment'>-- * Example</span>
<a name="line-49"></a> <span class='hs-comment'>-- $example</span>
<a name="line-50"></a> <span class='hs-comment'>-- * Options</span>
<a name="line-51"></a> <span class='hs-conid'>Options</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span>
<a name="line-52"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>lookupOption</span>
<a name="line-53"></a> <span class='hs-layout'>,</span> <span class='hs-conid'>TestOptions</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span>
<a name="line-54"></a> <span class='hs-comment'>-- * Tests</span>
<a name="line-55"></a> <span class='hs-layout'>,</span> <span class='hs-conid'>Test</span>
<a name="line-56"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>pure</span><span class='hs-layout'>,</span> <span class='hs-varid'>impure</span>
<a name="line-57"></a> <span class='hs-layout'>,</span> <span class='hs-conid'>Result</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span>
<a name="line-58"></a> <span class='hs-layout'>,</span> <span class='hs-conid'>ImpureTestable</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span>
<a name="line-59"></a> <span class='hs-layout'>,</span> <span class='hs-conid'>PureTestable</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span>
<a name="line-60"></a> <span class='hs-layout'>)</span> <span class='hs-keyword'>where</span>
<a name="line-61"></a>
<a name="line-62"></a><span class='hs-cpp'>#ifdef NEW_EXCEPTION</span>
<a name="line-63"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Exception</span> <span class='hs-layout'>(</span> <span class='hs-varid'>evaluate</span><span class='hs-layout'>,</span> <span class='hs-varid'>catch</span><span class='hs-layout'>,</span> <span class='hs-varid'>throw</span><span class='hs-layout'>,</span> <span class='hs-conid'>SomeException</span><span class='hs-layout'>,</span> <span class='hs-varid'>fromException</span> <span class='hs-layout'>)</span>
<a name="line-64"></a><span class='hs-cpp'>#else</span>
<a name="line-65"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Exception</span> <span class='hs-layout'>(</span> <span class='hs-varid'>evaluate</span><span class='hs-layout'>,</span> <span class='hs-varid'>catch</span><span class='hs-layout'>,</span> <span class='hs-varid'>throw</span><span class='hs-layout'>,</span> <span class='hs-conid'>Exception</span><span class='hs-layout'>(</span><span class='hs-conid'>IOException</span><span class='hs-layout'>)</span> <span class='hs-layout'>)</span>
<a name="line-66"></a><span class='hs-cpp'>#endif</span>
<a name="line-67"></a>
<a name="line-68"></a><span class='hs-comment'>--TODO: it is totally unreasonable that we have to import things from GHC.* here.</span>
<a name="line-69"></a><span class='hs-comment'>-- see ghc ticket #3517</span>
<a name="line-70"></a><span class='hs-cpp'>#ifdef __GLASGOW_HASKELL__</span>
<a name="line-71"></a><span class='hs-cpp'>#if __GLASGOW_HASKELL__ >= 612</span>
<a name="line-72"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>GHC</span><span class='hs-varop'>.</span><span class='hs-conid'>IO</span><span class='hs-varop'>.</span><span class='hs-conid'>Exception</span> <span class='hs-layout'>(</span> <span class='hs-conid'>IOErrorType</span><span class='hs-layout'>(</span><span class='hs-conid'>Interrupted</span><span class='hs-layout'>)</span> <span class='hs-layout'>)</span>
<a name="line-73"></a><span class='hs-cpp'>#else</span>
<a name="line-74"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>GHC</span><span class='hs-varop'>.</span><span class='hs-conid'>IOBase</span> <span class='hs-layout'>(</span> <span class='hs-conid'>IOErrorType</span><span class='hs-layout'>(</span><span class='hs-conid'>Interrupted</span><span class='hs-layout'>)</span> <span class='hs-layout'>)</span>
<a name="line-75"></a><span class='hs-cpp'>#endif</span>
<a name="line-76"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>System</span><span class='hs-varop'>.</span><span class='hs-conid'>IO</span><span class='hs-varop'>.</span><span class='hs-conid'>Error</span> <span class='hs-layout'>(</span> <span class='hs-varid'>ioeGetErrorType</span> <span class='hs-layout'>)</span>
<a name="line-77"></a><span class='hs-cpp'>#endif</span>
<a name="line-78"></a>
<a name="line-79"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>List</span> <span class='hs-layout'>(</span> <span class='hs-varid'>unionBy</span> <span class='hs-layout'>)</span>
<a name="line-80"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Monoid</span> <span class='hs-layout'>(</span> <span class='hs-conid'>Monoid</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span> <span class='hs-layout'>)</span>
<a name="line-81"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Typeable</span> <span class='hs-layout'>(</span> <span class='hs-conid'>TypeRep</span> <span class='hs-layout'>)</span>
<a name="line-82"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Prelude</span> <span class='hs-varid'>hiding</span> <span class='hs-layout'>(</span> <span class='hs-varid'>catch</span> <span class='hs-layout'>)</span>
<a name="line-83"></a>
<a name="line-84"></a><a name="Options"></a><span class='hs-comment'>-- | 'Options' are provided to pass options to test runners, making tests</span>
<a name="line-85"></a><a name="Options"></a><span class='hs-comment'>-- reproducable. Each option is a @('String', 'String')@ of the form</span>
<a name="line-86"></a><a name="Options"></a><span class='hs-comment'>-- @(Name, Value)@. Use 'mappend' to combine sets of 'Options'; if the same</span>
<a name="line-87"></a><a name="Options"></a><span class='hs-comment'>-- option is given different values, the value from the left argument of</span>
<a name="line-88"></a><a name="Options"></a><span class='hs-comment'>-- 'mappend' will be used.</span>
<a name="line-89"></a><a name="Options"></a><span class='hs-keyword'>newtype</span> <span class='hs-conid'>Options</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Options</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>String</span><span class='hs-layout'>,</span> <span class='hs-conid'>String</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-90"></a> <span class='hs-keyword'>deriving</span> <span class='hs-layout'>(</span><span class='hs-conid'>Read</span><span class='hs-layout'>,</span> <span class='hs-conid'>Show</span><span class='hs-layout'>,</span> <span class='hs-conid'>Eq</span><span class='hs-layout'>)</span>
<a name="line-91"></a>
<a name="line-92"></a><span class='hs-keyword'>instance</span> <span class='hs-conid'>Monoid</span> <span class='hs-conid'>Options</span> <span class='hs-keyword'>where</span>
<a name="line-93"></a> <span class='hs-varid'>mempty</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Options</span> <span class='hs-conid'>[]</span>
<a name="line-94"></a> <span class='hs-varid'>mappend</span> <span class='hs-layout'>(</span><span class='hs-conid'>Options</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>Options</span> <span class='hs-varid'>b</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Options</span> <span class='hs-varop'>$</span> <span class='hs-varid'>unionBy</span> <span class='hs-layout'>(</span><span class='hs-varid'>equating</span> <span class='hs-varid'>fst</span><span class='hs-layout'>)</span> <span class='hs-varid'>a</span> <span class='hs-varid'>b</span>
<a name="line-95"></a> <span class='hs-keyword'>where</span>
<a name="line-96"></a> <span class='hs-varid'>equating</span> <span class='hs-varid'>p</span> <span class='hs-varid'>x</span> <span class='hs-varid'>y</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>p</span> <span class='hs-varid'>x</span> <span class='hs-varop'>==</span> <span class='hs-varid'>p</span> <span class='hs-varid'>y</span>
<a name="line-97"></a>
<a name="line-98"></a>
<a name="line-99"></a><a name="String"></a><span class='hs-keyword'>class</span> <span class='hs-conid'>TestOptions</span> <span class='hs-varid'>t</span> <span class='hs-keyword'>where</span>
<a name="line-100"></a> <span class='hs-comment'>-- | The name of the test.</span>
<a name="line-101"></a> <span class='hs-varid'>name</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>t</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>String</span>
<a name="line-102"></a>
<a name="line-103"></a> <span class='hs-comment'>-- | A list of the options a test recognizes. The name and 'TypeRep' are</span>
<a name="line-104"></a> <span class='hs-comment'>-- provided so that test agents can ensure that user-specified options are</span>
<a name="line-105"></a> <span class='hs-comment'>-- correctly typed.</span>
<a name="line-106"></a> <span class='hs-varid'>options</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>t</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>String</span><span class='hs-layout'>,</span> <span class='hs-conid'>TypeRep</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-107"></a>
<a name="line-108"></a> <span class='hs-comment'>-- | The default options for a test. Test frameworks should provide a new</span>
<a name="line-109"></a> <span class='hs-comment'>-- random seed, if appropriate.</span>
<a name="line-110"></a> <span class='hs-varid'>defaultOptions</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>t</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>Options</span>
<a name="line-111"></a>
<a name="line-112"></a> <span class='hs-comment'>-- | Try to parse the provided options. Return the names of unparsable</span>
<a name="line-113"></a> <span class='hs-comment'>-- options. This allows test agents to detect bad user-specified options.</span>
<a name="line-114"></a> <span class='hs-varid'>check</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>t</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Options</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>String</span><span class='hs-keyglyph'>]</span>
<a name="line-115"></a>
<a name="line-116"></a><a name="lookupOption"></a><span class='hs-comment'>-- | Read an option from the specified set of 'Options'. It is an error to</span>
<a name="line-117"></a><span class='hs-comment'>-- lookup an option that has not been specified. For this reason, test agents</span>
<a name="line-118"></a><span class='hs-comment'>-- should 'mappend' any 'Options' against the 'defaultOptions' for a test, so</span>
<a name="line-119"></a><span class='hs-comment'>-- the default value specified by the test framework will be used for any</span>
<a name="line-120"></a><span class='hs-comment'>-- otherwise-unspecified options.</span>
<a name="line-121"></a><span class='hs-definition'>lookupOption</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Read</span> <span class='hs-varid'>r</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Options</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>r</span>
<a name="line-122"></a><span class='hs-definition'>lookupOption</span> <span class='hs-varid'>n</span> <span class='hs-layout'>(</span><span class='hs-conid'>Options</span> <span class='hs-varid'>opts</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span>
<a name="line-123"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>lookup</span> <span class='hs-varid'>n</span> <span class='hs-varid'>opts</span> <span class='hs-keyword'>of</span>
<a name="line-124"></a> <span class='hs-conid'>Just</span> <span class='hs-varid'>str</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>read</span> <span class='hs-varid'>str</span>
<a name="line-125"></a> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>error</span> <span class='hs-varop'>$</span> <span class='hs-str'>"test option not specified: "</span> <span class='hs-varop'>++</span> <span class='hs-varid'>n</span>
<a name="line-126"></a>
<a name="line-127"></a><a name="Result"></a><span class='hs-keyword'>data</span> <span class='hs-conid'>Result</span>
<a name="line-128"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Pass</span> <span class='hs-comment'>-- ^ indicates a successful test</span>
<a name="line-129"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>Fail</span> <span class='hs-conid'>String</span> <span class='hs-comment'>-- ^ indicates a test completed unsuccessfully;</span>
<a name="line-130"></a> <span class='hs-comment'>-- the 'String' value should be a human-readable message</span>
<a name="line-131"></a> <span class='hs-comment'>-- indicating how the test failed.</span>
<a name="line-132"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>Error</span> <span class='hs-conid'>String</span> <span class='hs-comment'>-- ^ indicates a test that could not be</span>
<a name="line-133"></a> <span class='hs-comment'>-- completed due to some error; the test framework</span>
<a name="line-134"></a> <span class='hs-comment'>-- should provide a message indicating the</span>
<a name="line-135"></a> <span class='hs-comment'>-- nature of the error.</span>
<a name="line-136"></a> <span class='hs-keyword'>deriving</span> <span class='hs-layout'>(</span><span class='hs-conid'>Read</span><span class='hs-layout'>,</span> <span class='hs-conid'>Show</span><span class='hs-layout'>,</span> <span class='hs-conid'>Eq</span><span class='hs-layout'>)</span>
<a name="line-137"></a>
<a name="line-138"></a><a name="ImpureTestable"></a><span class='hs-comment'>-- | Class abstracting impure tests. Test frameworks should implement this</span>
<a name="line-139"></a><a name="ImpureTestable"></a><span class='hs-comment'>-- class only as a last resort for test types which actually require 'IO'.</span>
<a name="line-140"></a><a name="ImpureTestable"></a><span class='hs-comment'>-- In particular, tests that simply require pseudo-random number generation can</span>
<a name="line-141"></a><a name="ImpureTestable"></a><span class='hs-comment'>-- be implemented as pure tests.</span>
<a name="line-142"></a><a name="ImpureTestable"></a><span class='hs-keyword'>class</span> <span class='hs-conid'>TestOptions</span> <span class='hs-varid'>t</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>ImpureTestable</span> <span class='hs-varid'>t</span> <span class='hs-keyword'>where</span>
<a name="line-143"></a> <span class='hs-comment'>-- | Runs an impure test and returns the result. Test frameworks</span>
<a name="line-144"></a> <span class='hs-comment'>-- implementing this class are responsible for converting any exceptions to</span>
<a name="line-145"></a> <span class='hs-comment'>-- the correct 'Result' value.</span>
<a name="line-146"></a> <span class='hs-varid'>runM</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>t</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Options</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>Result</span>
<a name="line-147"></a>
<a name="line-148"></a><a name="PureTestable"></a><span class='hs-comment'>-- | Class abstracting pure tests. Test frameworks should prefer to implement</span>
<a name="line-149"></a><a name="PureTestable"></a><span class='hs-comment'>-- this class over 'ImpureTestable'. A default instance exists so that any pure</span>
<a name="line-150"></a><a name="PureTestable"></a><span class='hs-comment'>-- test can be lifted into an impure test; when lifted, any exceptions are</span>
<a name="line-151"></a><a name="PureTestable"></a><span class='hs-comment'>-- automatically caught. Test agents that lift pure tests themselves must</span>
<a name="line-152"></a><a name="PureTestable"></a><span class='hs-comment'>-- handle exceptions.</span>
<a name="line-153"></a><a name="PureTestable"></a><span class='hs-keyword'>class</span> <span class='hs-conid'>TestOptions</span> <span class='hs-varid'>t</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>PureTestable</span> <span class='hs-varid'>t</span> <span class='hs-keyword'>where</span>
<a name="line-154"></a> <span class='hs-comment'>-- | The result of a pure test.</span>
<a name="line-155"></a> <span class='hs-varid'>run</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>t</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Options</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Result</span>
<a name="line-156"></a>
<a name="line-157"></a><a name="Test"></a><span class='hs-comment'>-- | 'Test' is a wrapper for pure and impure tests so that lists containing</span>
<a name="line-158"></a><a name="Test"></a><span class='hs-comment'>-- arbitrary test types can be constructed.</span>
<a name="line-159"></a><a name="Test"></a><span class='hs-keyword'>data</span> <span class='hs-conid'>Test</span>
<a name="line-160"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>forall</span> <span class='hs-varid'>p</span><span class='hs-varop'>.</span> <span class='hs-conid'>PureTestable</span> <span class='hs-varid'>p</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>PureTest</span> <span class='hs-varid'>p</span>
<a name="line-161"></a> <span class='hs-keyglyph'>|</span> <span class='hs-keyword'>forall</span> <span class='hs-varid'>i</span><span class='hs-varop'>.</span> <span class='hs-conid'>ImpureTestable</span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>ImpureTest</span> <span class='hs-varid'>i</span>
<a name="line-162"></a>
<a name="line-163"></a><a name="pure"></a><span class='hs-comment'>-- | A convenient function for wrapping pure tests into 'Test's.</span>
<a name="line-164"></a><span class='hs-definition'>pure</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>PureTestable</span> <span class='hs-varid'>p</span> <span class='hs-keyglyph'>=></span> <span class='hs-varid'>p</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Test</span>
<a name="line-165"></a><span class='hs-definition'>pure</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>PureTest</span>
<a name="line-166"></a>
<a name="line-167"></a><a name="impure"></a><span class='hs-comment'>-- | A convenient function for wrapping impure tests into 'Test's.</span>
<a name="line-168"></a><span class='hs-definition'>impure</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ImpureTestable</span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'>=></span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Test</span>
<a name="line-169"></a><span class='hs-definition'>impure</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ImpureTest</span>
<a name="line-170"></a>
<a name="line-171"></a><span class='hs-keyword'>instance</span> <span class='hs-conid'>TestOptions</span> <span class='hs-conid'>Test</span> <span class='hs-keyword'>where</span>
<a name="line-172"></a> <span class='hs-varid'>name</span> <span class='hs-layout'>(</span><span class='hs-conid'>PureTest</span> <span class='hs-varid'>p</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>name</span> <span class='hs-varid'>p</span>
<a name="line-173"></a> <span class='hs-varid'>name</span> <span class='hs-layout'>(</span><span class='hs-conid'>ImpureTest</span> <span class='hs-varid'>i</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>name</span> <span class='hs-varid'>i</span>
<a name="line-174"></a>
<a name="line-175"></a> <span class='hs-varid'>options</span> <span class='hs-layout'>(</span><span class='hs-conid'>PureTest</span> <span class='hs-varid'>p</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>options</span> <span class='hs-varid'>p</span>
<a name="line-176"></a> <span class='hs-varid'>options</span> <span class='hs-layout'>(</span><span class='hs-conid'>ImpureTest</span> <span class='hs-varid'>i</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>options</span> <span class='hs-varid'>i</span>
<a name="line-177"></a>
<a name="line-178"></a> <span class='hs-varid'>defaultOptions</span> <span class='hs-layout'>(</span><span class='hs-conid'>PureTest</span> <span class='hs-varid'>p</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>defaultOptions</span> <span class='hs-varid'>p</span>
<a name="line-179"></a> <span class='hs-varid'>defaultOptions</span> <span class='hs-layout'>(</span><span class='hs-conid'>ImpureTest</span> <span class='hs-varid'>p</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>defaultOptions</span> <span class='hs-varid'>p</span>
<a name="line-180"></a>
<a name="line-181"></a> <span class='hs-varid'>check</span> <span class='hs-layout'>(</span><span class='hs-conid'>PureTest</span> <span class='hs-varid'>p</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>check</span> <span class='hs-varid'>p</span>
<a name="line-182"></a> <span class='hs-varid'>check</span> <span class='hs-layout'>(</span><span class='hs-conid'>ImpureTest</span> <span class='hs-varid'>p</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>check</span> <span class='hs-varid'>p</span>
<a name="line-183"></a>
<a name="line-184"></a><span class='hs-keyword'>instance</span> <span class='hs-conid'>ImpureTestable</span> <span class='hs-conid'>Test</span> <span class='hs-keyword'>where</span>
<a name="line-185"></a> <span class='hs-varid'>runM</span> <span class='hs-layout'>(</span><span class='hs-conid'>PureTest</span> <span class='hs-varid'>p</span><span class='hs-layout'>)</span> <span class='hs-varid'>o</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>catch</span> <span class='hs-layout'>(</span><span class='hs-varid'>evaluate</span> <span class='hs-varop'>$</span> <span class='hs-varid'>run</span> <span class='hs-varid'>p</span> <span class='hs-varid'>o</span><span class='hs-layout'>)</span> <span class='hs-varid'>handler</span>
<a name="line-186"></a>
<a name="line-187"></a> <span class='hs-comment'>-- Because we have to handle old and new style exceptions, GHC and non-GHC</span>
<a name="line-188"></a> <span class='hs-comment'>-- this code is totally horrible and really fragile. Has to be tested with</span>
<a name="line-189"></a> <span class='hs-comment'>-- lots of ghc versions to check it is right, and with non-ghc too. :-(</span>
<a name="line-190"></a><span class='hs-cpp'>#ifdef NEW_EXCEPTION</span>
<a name="line-191"></a> <span class='hs-keyword'>where</span>
<a name="line-192"></a> <span class='hs-varid'>handler</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>SomeException</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>Result</span>
<a name="line-193"></a> <span class='hs-varid'>handler</span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>fromException</span> <span class='hs-varid'>e</span> <span class='hs-keyword'>of</span>
<a name="line-194"></a> <span class='hs-conid'>Just</span> <span class='hs-varid'>ioe</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isInterruptedError</span> <span class='hs-varid'>ioe</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>throw</span> <span class='hs-varid'>e</span>
<a name="line-195"></a> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>Error</span> <span class='hs-layout'>(</span><span class='hs-varid'>show</span> <span class='hs-varid'>e</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-196"></a><span class='hs-cpp'>#else</span>
<a name="line-197"></a> <span class='hs-keyword'>where</span>
<a name="line-198"></a> <span class='hs-varid'>handler</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Exception</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>Result</span>
<a name="line-199"></a> <span class='hs-varid'>handler</span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>e</span> <span class='hs-keyword'>of</span>
<a name="line-200"></a> <span class='hs-conid'>IOException</span> <span class='hs-varid'>ioe</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isInterruptedError</span> <span class='hs-varid'>ioe</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>throw</span> <span class='hs-varid'>e</span>
<a name="line-201"></a> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>Error</span> <span class='hs-layout'>(</span><span class='hs-varid'>show</span> <span class='hs-varid'>e</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-202"></a><span class='hs-cpp'>#endif</span>
<a name="line-203"></a>
<a name="line-204"></a> <span class='hs-comment'>-- We do not want to catch control-C here, but only GHC</span>
<a name="line-205"></a> <span class='hs-comment'>-- defines the Interrupted exception type! (ticket #3517)</span>
<a name="line-206"></a> <span class='hs-varid'>isInterruptedError</span> <span class='hs-varid'>ioe</span> <span class='hs-keyglyph'>=</span>
<a name="line-207"></a><span class='hs-cpp'>#ifdef __GLASGOW_HASKELL__</span>
<a name="line-208"></a> <span class='hs-varid'>ioeGetErrorType</span> <span class='hs-varid'>ioe</span> <span class='hs-varop'>==</span> <span class='hs-conid'>Interrupted</span>
<a name="line-209"></a><span class='hs-cpp'>#else</span>
<a name="line-210"></a> <span class='hs-conid'>False</span>
<a name="line-211"></a><span class='hs-cpp'>#endif</span>
<a name="line-212"></a>
<a name="line-213"></a> <span class='hs-varid'>runM</span> <span class='hs-layout'>(</span><span class='hs-conid'>ImpureTest</span> <span class='hs-varid'>i</span><span class='hs-layout'>)</span> <span class='hs-varid'>o</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>runM</span> <span class='hs-varid'>i</span> <span class='hs-varid'>o</span>
<a name="line-214"></a>
<a name="line-215"></a><span class='hs-comment'>-- $example</span>
<a name="line-216"></a><span class='hs-comment'>-- The following terms are used carefully throughout this file:</span>
<a name="line-217"></a><span class='hs-comment'>--</span>
<a name="line-218"></a><span class='hs-comment'>-- [test interface] The interface provided by this module.</span>
<a name="line-219"></a><span class='hs-comment'>--</span>
<a name="line-220"></a><span class='hs-comment'>-- [test agent] A program used by package users to coordinates the running</span>
<a name="line-221"></a><span class='hs-comment'>-- of tests and the reporting of their results.</span>
<a name="line-222"></a><span class='hs-comment'>--</span>
<a name="line-223"></a><span class='hs-comment'>-- [test framework] A package used by software authors to specify tests,</span>
<a name="line-224"></a><span class='hs-comment'>-- such as QuickCheck or HUnit.</span>
<a name="line-225"></a><span class='hs-comment'>--</span>
<a name="line-226"></a><span class='hs-comment'>-- Test frameworks are obligated to supply, at least, instances of the</span>
<a name="line-227"></a><span class='hs-comment'>-- 'TestOptions' and 'ImpureTestable' classes. It is preferred that test</span>
<a name="line-228"></a><span class='hs-comment'>-- frameworks implement 'PureTestable' whenever possible, so that test agents</span>
<a name="line-229"></a><span class='hs-comment'>-- have an assurance that tests can be safely run in parallel.</span>
<a name="line-230"></a><span class='hs-comment'>--</span>
<a name="line-231"></a><span class='hs-comment'>-- Test agents that allow the user to specify options should avoid setting</span>
<a name="line-232"></a><span class='hs-comment'>-- options not listed by the 'options' method. Test agents should use 'check'</span>
<a name="line-233"></a><span class='hs-comment'>-- before running tests with non-default options. Test frameworks must</span>
<a name="line-234"></a><span class='hs-comment'>-- implement a 'check' function that attempts to parse the given options safely.</span>
<a name="line-235"></a><span class='hs-comment'>--</span>
<a name="line-236"></a><span class='hs-comment'>-- The packages cabal-test-hunit, cabal-test-quickcheck1, and</span>
<a name="line-237"></a><span class='hs-comment'>-- cabal-test-quickcheck2 provide simple interfaces to these popular test</span>
<a name="line-238"></a><span class='hs-comment'>-- frameworks. An example from cabal-test-quickcheck2 is shown below. A</span>
<a name="line-239"></a><span class='hs-comment'>-- better implementation would eliminate the console output from QuickCheck\'s</span>
<a name="line-240"></a><span class='hs-comment'>-- built-in runner and provide an instance of 'PureTestable' instead of</span>
<a name="line-241"></a><span class='hs-comment'>-- 'ImpureTestable'.</span>
<a name="line-242"></a><span class='hs-comment'>--</span>
<a name="line-243"></a><span class='hs-comment'>-- > import Control.Monad (liftM)</span>
<a name="line-244"></a><span class='hs-comment'>-- > import Data.Maybe (catMaybes, fromJust, maybe)</span>
<a name="line-245"></a><span class='hs-comment'>-- > import Data.Typeable (Typeable(..))</span>
<a name="line-246"></a><span class='hs-comment'>-- > import qualified Distribution.TestSuite as Cabal</span>
<a name="line-247"></a><span class='hs-comment'>-- > import System.Random (newStdGen, next, StdGen)</span>
<a name="line-248"></a><span class='hs-comment'>-- > import qualified Test.QuickCheck as QC</span>
<a name="line-249"></a><span class='hs-comment'>-- ></span>
<a name="line-250"></a><span class='hs-comment'>-- > data QCTest = forall prop. QC.Testable prop => QCTest String prop</span>
<a name="line-251"></a><span class='hs-comment'>-- ></span>
<a name="line-252"></a><span class='hs-comment'>-- > test :: QC.Testable prop => String -> prop -> Cabal.Test</span>
<a name="line-253"></a><span class='hs-comment'>-- > test n p = Cabal.impure $ QCTest n p</span>
<a name="line-254"></a><span class='hs-comment'>-- ></span>
<a name="line-255"></a><span class='hs-comment'>-- > instance Cabal.TestOptions QCTest where</span>
<a name="line-256"></a><span class='hs-comment'>-- > name (QCTest n _) = n</span>
<a name="line-257"></a><span class='hs-comment'>-- ></span>
<a name="line-258"></a><span class='hs-comment'>-- > options _ =</span>
<a name="line-259"></a><span class='hs-comment'>-- > [ ("std-gen", typeOf (undefined :: String))</span>
<a name="line-260"></a><span class='hs-comment'>-- > , ("max-success", typeOf (undefined :: Int))</span>
<a name="line-261"></a><span class='hs-comment'>-- > , ("max-discard", typeOf (undefined :: Int))</span>
<a name="line-262"></a><span class='hs-comment'>-- > , ("size", typeOf (undefined :: Int))</span>
<a name="line-263"></a><span class='hs-comment'>-- > ]</span>
<a name="line-264"></a><span class='hs-comment'>-- ></span>
<a name="line-265"></a><span class='hs-comment'>-- > defaultOptions _ = do</span>
<a name="line-266"></a><span class='hs-comment'>-- > rng <- newStdGen</span>
<a name="line-267"></a><span class='hs-comment'>-- > return $ Cabal.Options $</span>
<a name="line-268"></a><span class='hs-comment'>-- > [ ("std-gen", show rng)</span>
<a name="line-269"></a><span class='hs-comment'>-- > , ("max-success", show $ QC.maxSuccess QC.stdArgs)</span>
<a name="line-270"></a><span class='hs-comment'>-- > , ("max-discard", show $ QC.maxDiscard QC.stdArgs)</span>
<a name="line-271"></a><span class='hs-comment'>-- > , ("size", show $ QC.maxSize QC.stdArgs)</span>
<a name="line-272"></a><span class='hs-comment'>-- > ]</span>
<a name="line-273"></a><span class='hs-comment'>-- ></span>
<a name="line-274"></a><span class='hs-comment'>-- > check t (Cabal.Options opts) = catMaybes</span>
<a name="line-275"></a><span class='hs-comment'>-- > [ maybeNothing "max-success" ([] :: [(Int, String)])</span>
<a name="line-276"></a><span class='hs-comment'>-- > , maybeNothing "max-discard" ([] :: [(Int, String)])</span>
<a name="line-277"></a><span class='hs-comment'>-- > , maybeNothing "size" ([] :: [(Int, String)])</span>
<a name="line-278"></a><span class='hs-comment'>-- > ]</span>
<a name="line-279"></a><span class='hs-comment'>-- > -- There is no need to check the parsability of "std-gen"</span>
<a name="line-280"></a><span class='hs-comment'>-- > -- because the Read instance for StdGen always succeeds.</span>
<a name="line-281"></a><span class='hs-comment'>-- > where</span>
<a name="line-282"></a><span class='hs-comment'>-- > maybeNothing n x =</span>
<a name="line-283"></a><span class='hs-comment'>-- > maybe Nothing (\str -></span>
<a name="line-284"></a><span class='hs-comment'>-- > if reads str == x then Just n else Nothing)</span>
<a name="line-285"></a><span class='hs-comment'>-- > $ lookup n opts</span>
<a name="line-286"></a><span class='hs-comment'>-- ></span>
<a name="line-287"></a><span class='hs-comment'>-- > instance Cabal.ImpureTestable QCTest where</span>
<a name="line-288"></a><span class='hs-comment'>-- > runM (QCTest _ prop) o =</span>
<a name="line-289"></a><span class='hs-comment'>-- > catch go (return . Cabal.Error . show)</span>
<a name="line-290"></a><span class='hs-comment'>-- > where</span>
<a name="line-291"></a><span class='hs-comment'>-- > go = do</span>
<a name="line-292"></a><span class='hs-comment'>-- > result <- QC.quickCheckWithResult args prop</span>
<a name="line-293"></a><span class='hs-comment'>-- > return $ case result of</span>
<a name="line-294"></a><span class='hs-comment'>-- > QC.Success {} -> Cabal.Pass</span>
<a name="line-295"></a><span class='hs-comment'>-- > QC.GaveUp {}-></span>
<a name="line-296"></a><span class='hs-comment'>-- > Cabal.Fail $ "gave up after "</span>
<a name="line-297"></a><span class='hs-comment'>-- > ++ show (QC.numTests result)</span>
<a name="line-298"></a><span class='hs-comment'>-- > ++ " tests"</span>
<a name="line-299"></a><span class='hs-comment'>-- > QC.Failure {} -> Cabal.Fail $ QC.reason result</span>
<a name="line-300"></a><span class='hs-comment'>-- > QC.NoExpectedFailure {} -></span>
<a name="line-301"></a><span class='hs-comment'>-- > Cabal.Fail "passed (expected failure)"</span>
<a name="line-302"></a><span class='hs-comment'>-- > args = QC.Args</span>
<a name="line-303"></a><span class='hs-comment'>-- > { QC.replay = Just</span>
<a name="line-304"></a><span class='hs-comment'>-- > ( Cabal.lookupOption "std-gen" o</span>
<a name="line-305"></a><span class='hs-comment'>-- > , Cabal.lookupOption "size" o</span>
<a name="line-306"></a><span class='hs-comment'>-- > )</span>
<a name="line-307"></a><span class='hs-comment'>-- > , QC.maxSuccess = Cabal.lookupOption "max-success" o</span>
<a name="line-308"></a><span class='hs-comment'>-- > , QC.maxDiscard = Cabal.lookupOption "max-discard" o</span>
<a name="line-309"></a><span class='hs-comment'>-- > , QC.maxSize = Cabal.lookupOption "size" o</span>
<a name="line-310"></a><span class='hs-comment'>-- > }</span>
</pre></body>
</html>
