    module Test.Chell.Types
    	( Test
    	, test
    	, testName

    	, TestOptions
    	, defaultTestOptions
    	, testOptionSeed
    	, testOptionTimeout

    	, TestResult(TestPassed, TestSkipped, TestFailed, TestAborted)

    	, Failure
    	, failure
    	, failureLocation
    	, failureMessage

    	, Location
    	, location
    	, locationFile
    	, locationModule
    	, locationLine

    	, Suite
    	, suite
    	, suiteName
    	, suiteTests

    	, BuildSuite
    	, SuiteOrTest
    	, skipIf
    	, skipWhen

    	, runTest

    	, handleJankyIO
    	) where

    import qualified Control.Exception
    import           Control.Exception (SomeException, Handler(..), catches, throwIO)
    import           System.Timeout (timeout)

    -- | A 'Test' is, essentially, an IO action that returns a 'TestResult'. Tests
    -- are aggregated into suites (see 'Suite').
    data Test = Test String (TestOptions -> IO TestResult)

    instance Show Test where
    	showsPrec d (Test name _) = showParen (d > 10) (showString "Test " . shows name)

    -- | Define a test, with the given name and implementation.
    test :: String -> (TestOptions -> IO TestResult) -> Test
    test = Test

    -- | Get the name a test was given when it was defined; see 'test'.
    testName :: Test -> String
    testName (Test name _) = name

    -- | Test options are passed to each test, and control details about how the
    -- test should be run.
    data TestOptions = TestOptions
    	{

    	-- | Get the RNG seed for this test run. The seed is generated once, in
    	-- 'defaultMain', and used for all tests. It is also logged to reports
    	-- using a note.
    	--
    	-- When using 'defaultMain', users may specify a seed using the
    	-- @--seed@ command-line option.
    	--
    	-- 'testOptionSeed' is a field accessor, and can be used to update
    	-- a 'TestOptions' value.
    	  testOptionSeed :: Int

    	-- | An optional timeout, in millseconds. Tests which run longer than
    	-- this timeout will be aborted.
    	--
    	-- When using 'defaultMain', users may specify a timeout using the
    	-- @--timeout@ command-line option.
    	--
    	-- 'testOptionTimeout' is a field accessor, and can be used to update
    	-- a 'TestOptions' value.
    	, testOptionTimeout :: Maybe Int
    	}
    	deriving (Show, Eq)

    -- | Default test options.
    --
    -- >$ ghci
    -- >Prelude> import Test.Chell
    -- >
    -- >Test.Chell> testOptionSeed defaultTestOptions
    -- >0
    -- >
    -- >Test.Chell> testOptionTimeout defaultTestOptions
    -- >Nothing
    defaultTestOptions :: TestOptions
    defaultTestOptions = TestOptions
    	{ testOptionSeed = 0
    	, testOptionTimeout = Nothing
    	}

    -- | The result of running a test.
    --
    -- To support future extensions to the testing API, any users of this module
    -- who pattern-match against the 'TestResult' constructors should include a
    -- default case. If no default case is provided, a warning will be issued.
    data TestResult
    	-- | The test passed, and generated the given notes.
    	= TestPassed [(String, String)]

    	-- | The test did not run, because it was skipped with 'skipIf'
    	-- or 'skipWhen'.
    	| TestSkipped

    	-- | The test failed, generating the given notes and failures.
    	| TestFailed [(String, String)] [Failure]

    	-- | The test aborted with an error message, and generated the given
    	-- notes.
    	| TestAborted [(String, String)] String

    	-- Not exported; used to generate GHC warnings for users who don't
    	-- provide a default case.
    	| TestResultCaseMustHaveDefault
    	deriving (Show, Eq)

    -- | Contains details about a test failure.
    data Failure = Failure
    	{
    	-- | If given, the location of the failing assertion, expectation,
    	-- etc.
    	--
    	-- 'failureLocation' is a field accessor, and can be used to update
    	-- a 'Failure' value.
    	  failureLocation :: Maybe Location

    	-- | If given, a message which explains why the test failed.
    	--
    	-- 'failureMessage' is a field accessor, and can be used to update
    	-- a 'Failure' value.
    	, failureMessage :: String
    	}
    	deriving (Show, Eq)

    -- | An empty 'Failure'; use the field accessors to populate this value.
    failure :: Failure
    failure = Failure Nothing ""

    -- | Contains details about a location in the test source file.
    data Location = Location
    	{
    	-- | A path to a source file, or empty if not provided.
    	--
    	-- 'locationFile' is a field accessor, and can be used to update
    	-- a 'Location' value.
    	  locationFile :: String

    	-- | A Haskell module name, or empty if not provided.
    	--
    	-- 'locationModule' is a field accessor, and can be used to update
    	-- a 'Location' value.
    	, locationModule :: String

    	-- | A line number, or Nothing if not provided.
    	--
    	-- 'locationLine' is a field accessor, and can be used to update
    	-- a 'Location' value.
    	, locationLine :: Maybe Integer
    	}
    	deriving (Show, Eq)

    -- | An empty 'Location'; use the field accessors to populate this value.
    location :: Location
    location = Location "" "" Nothing

    -- | A suite is a node in a hierarchy of tests, similar to a directory in the
    -- filesystem. Each suite has a name and a list of children, which are either
    -- suites or tests.
    data Suite = Suite String [SOT]
    	deriving (Show)

    data SOT
    	= SOT_Suite Suite
    	| SOT_Test Test

    instance Show SOT where
    	showsPrec d (SOT_Test t) = showsPrec d t
    	showsPrec d (SOT_Suite s) = showsPrec d s

    -- | See 'suite'.
    class BuildSuite a where
    	addChildren :: Suite -> a

    instance BuildSuite Suite where
    	addChildren (Suite name cs) = Suite name (reverse cs)

    -- | See 'suite'.
    class SuiteOrTest a where
    	toSOT :: a -> SOT
    	skipIf_ :: Bool -> a -> a
    	skipWhen_ :: IO Bool -> a -> a

    instance SuiteOrTest Suite where
    	toSOT = SOT_Suite
    	skipIf_ skip s@(Suite name children) = if skip
    		then Suite name (map skipSOT children)
    		else s
    	skipWhen_ p (Suite name children) = Suite name (map (skipWhenSOT p) children)

    instance SuiteOrTest Test where
    	toSOT = SOT_Test
    	skipIf_ skip t@(Test name _) = if skip
    		then Test name (\_ -> return TestSkipped)
    		else t
    	skipWhen_ p (Test name io) = Test name (\opts -> do
    		skip <- p
    		if skip then return TestSkipped else io opts)

    skipSOT :: SOT -> SOT
    skipSOT (SOT_Test (Test name _)) = SOT_Test (Test name (\_ -> return TestSkipped))
    skipSOT (SOT_Suite (Suite name cs)) = SOT_Suite (Suite name (map skipSOT cs))

    skipWhenSOT :: IO Bool -> SOT -> SOT
    skipWhenSOT p (SOT_Suite s) = SOT_Suite (skipWhen_ p s)
    skipWhenSOT p (SOT_Test t) = SOT_Test (skipWhen_ p t)

    -- | Conditionally skip tests. Use this to avoid commenting out tests
    -- which are currently broken, or do not work on the current platform.
    --
    -- @
    --tests :: Suite
    --tests = 'suite' \"tests\"
    --    test_Foo
    --    ('skipIf' builtOnUnix test_WindowsSpecific)
    --    test_Bar
    -- @
    --
    skipIf :: SuiteOrTest a => Bool -> a -> a
    skipIf = skipIf_

    -- | Conditionally skip tests, depending on the result of a runtime check. The
    -- predicate is checked before each test is started.
    --
    -- @
    --tests :: Suite
    --tests = 'suite' \"tests\"
    --    test_Foo
    --    ('skipWhen' noNetwork test_PingGoogle)
    --    test_Bar
    -- @
    skipWhen :: SuiteOrTest a => IO Bool -> a -> a
    skipWhen = skipWhen_

    instance (SuiteOrTest t, BuildSuite s) => BuildSuite (t -> s) where
    	addChildren (Suite name cs) = \b -> addChildren (Suite name (toSOT b : cs))

    -- | Define a new 'Suite', with the given name and children.
    --
    -- The type of this function allows any number of children to be added,
    -- without requiring them to be homogenous types.
    --
    -- @
    --test_Addition :: Test
    --test_Subtraction :: Test
    --test_Show :: Test
    --
    --tests_Math :: Suite
    --tests_Math = 'suite' \"math\"
    --    test_Addition
    --    test_Subtraction
    --
    --tests_Prelude :: Suite
    --tests_Prelude = 'suite' \"prelude\"
    --    tests_Math
    --    test_Show
    -- @
    suite :: BuildSuite a => String -> a
    suite name = addChildren (Suite name [])

    -- | Get a suite's name. Suite names may be any string, but are typically
    -- plain ASCII so users can easily type them on the command line.
    --
    -- >$ ghci chell-example.hs
    -- >Ok, modules loaded: Main.
    -- >
    -- >*Main> suiteName tests_Math
    -- >"math"
    suiteName :: Suite -> String
    suiteName (Suite name _) = name

    -- | Get the full list of tests contained within this 'Suite'. Each test is
    -- given its full name within the test hierarchy, where names are separated
    -- by periods.
    --
    -- >$ ghci chell-example.hs
    -- >Ok, modules loaded: Main.
    -- >
    -- >*Main> suiteTests tests_Math
    -- >[Test "math.addition",Test "math.subtraction"]
    suiteTests :: Suite -> [Test]
    suiteTests = go "" where
    	prefixed prefix str = if null prefix
    		then str
    		else prefix ++ "." ++ str

    	go prefix (Suite name children) = concatMap (step (prefixed prefix name)) children

    	step prefix (SOT_Suite s) = go prefix s
    	step prefix (SOT_Test (Test name io)) = [Test (prefixed prefix name) io]

    -- | Run a test, wrapped in error handlers. This will return 'TestAborted' if
    -- the test throws an exception or times out.
    runTest :: Test -> TestOptions -> IO TestResult
    runTest (Test _ io) options = handleJankyIO options (io options) (return [])

    handleJankyIO :: TestOptions -> IO TestResult -> IO [(String, String)] -> IO TestResult
    handleJankyIO opts getResult getNotes = do
    	let withTimeout = case testOptionTimeout opts of
    		Just time -> timeout (time * 1000)
    		Nothing -> fmap Just

    	let hitTimeout = str where
    		str = "Test timed out after " ++ show time ++ " milliseconds"
    		Just time = testOptionTimeout opts

    	tried <- withTimeout (try getResult)
    	case tried of
    		Just (Right ret) -> return ret
    		Nothing -> do
    			notes <- getNotes
    			return (TestAborted notes hitTimeout)
    		Just (Left err) -> do
    			notes <- getNotes
    			return (TestAborted notes err)

    try :: IO a -> IO (Either String a)
    try io = catches (fmap Right io) [Handler handleAsync, Handler handleExc] where
    	handleAsync :: Control.Exception.AsyncException -> IO a
    	handleAsync = throwIO

    	handleExc :: SomeException -> IO (Either String a)
    	handleExc exc = return (Left ("Test aborted due to exception: " ++ show exc))