Source

hstest / hstest.hs

Full commit
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
import           Control.Applicative                    ((<$>))
import           Control.Monad                          (when)
import           Data.Char                              (toUpper)
import           Data.Dynamic                           (fromDynamic)
import           Data.Function                          (on)
import           Data.List                              (intercalate, isPrefixOf, isSuffixOf, partition, maximumBy, sortBy)
import           Data.Maybe                             (catMaybes, fromMaybe)
import           Data.Monoid                            (Monoid (mappend, mempty, mconcat), Endo (Endo, appEndo))
import           Data.Version                           (showVersion)
import           Distribution.Package                   (PackageIdentifier (PackageIdentifier, pkgName, pkgVersion),
                                                         PackageName (PackageName))
import           Distribution.Version                   (Version (Version, versionBranch))
import qualified DynFlags                       as G    (defaultDynFlags, PackageFlag (ExposePackage, HidePackage, IgnorePackage))
import qualified GHC                            as G    (GhcMonad, packageFlags, getModuleGraph, ms_mod, setContext, moduleName,
                                                         moduleNameString, targetAllowObjCode, targetContents, ghcLink, flags,
                                                         hscTarget, load, modInfoTyThings, getModuleInfo, setTargets,
                                                         dynCompileExpr, runGhc, defaultErrorHandler, getSessionDynFlags,
                                                         setSessionDynFlags, ghcMode, importPaths, GhcMode (CompManager),
                                                         LoadHowMuch (LoadAllTargets), SuccessFlag (Failed, Succeeded),
                                                         TyThing (AnId), GhcLink (LinkInMemory), TargetId (TargetFile),
                                                         Target (Target, targetId), HscTarget (HscInterpreted),
                                                         DynFlag (Opt_ImplicitImportQualified), Ghc, ms_location, ml_hs_file)
import qualified GHC.Paths                      as G    (libdir)
import qualified Module                         as G    (mkModuleName)
import qualified MonadUtils                     as G    (liftIO)
import qualified Name                           as G    (nameOccName)
import qualified OccName                        as G    (occNameString)
import qualified Packages                       as G    (lookupModuleInAllPackages)
import qualified PackageConfig                  as G    (PackageConfig,
                                                         InstalledPackageInfo_ (InstalledPackageInfo, sourcePackageId, exposed))
import           Paths_hstest                           (version)
import           System.Console.GetOpt                  (usageInfo, getOpt, OptDescr (Option), ArgOrder (ReturnInOrder),
                                                         ArgDescr (ReqArg, NoArg, OptArg))
import           System.Directory                       (getDirectoryContents)
import           System.Environment                     (getArgs)
import           System.Exit                            (exitWith, exitFailure, exitSuccess, ExitCode (ExitSuccess, ExitFailure))
import           System.FilePath                        (splitSearchPath)
import           System.IO                              (hPutStrLn, stderr)
import qualified Test.HUnit                     as HU   (Counts (Counts, errors, failures, tried),
                                                         assertEqual, assertBool)
import qualified Var                            as G    (varName)


{-

This is how to embed QuickCheck properties in your code: make them top-level declarations whose names start with `prop_`.

You don't need to include each property explicitly in a list; that would make it too easy to add a property but forget to run it.

Instead, `hstest` looks through your program and builds the list of properties to run itself.

-}

prop_Count_Monoid_leftIdentity x'      = mappend mempty x == x
  where x = countFromInteger x'
prop_Count_Monoid_rightIdentity x'     = mappend x mempty == x
  where x = countFromInteger x'
prop_Count_Monoid_associative x' y' z' = mappend x (mappend y z) == mappend (mappend x y) z
  where x = countFromInteger x'
        y = countFromInteger y'
        z = countFromInteger z'


data QCResult = QCFailed [String]
              | QCPassed
              | QCExhausted Int
              | QCUnparsed String

reportQCResult n (QCUnparsed s)    = concat ["While testing ", n, ":\n", s]
reportQCResult n (QCExhausted c)   = concat ["Exhausted ", n, " after ", show c, " tests\n"]
reportQCResult n  QCPassed         = concat ["Passed ", n, "\n"]
reportQCResult n (QCFailed params) = unlines (concat ["Failed ", n, ":"] : map f params)
  where f param = concat [" *  ", param]

shouldExplicitlyReportQCResult QCPassed = False
shouldExplicitlyReportQCResult _        = True


data HUResult = HUResult HU.Counts [HUProblem]
data HUProblem = HUError String | HUFailure String

reportHUResult n (HUResult _ [])       = concat ["Passed ", n, "\n"]
reportHUResult n (HUResult _ problems) = concatMap f problems
  where f (HUFailure "") = concat ["Failed ", n, "\n"]
        f (HUFailure s)  = concat ["Failed ", n, ": ", s, "\n"]
        f (HUError   "") = concat ["Error in ", n, "\n"]
        f (HUError   s)  = concat ["Error in ", n, ": ", s, "\n"]

shouldExplicitlyReportHUResult (HUResult _ []) = False
shouldExplicitlyReportHUResult (HUResult _ _)  = True


data Count = Count [Int] deriving (Eq, Show)

instance Monoid Count
  where mempty = Count (replicate cResultIndicies 0)
        mappend (Count xs) (Count ys) = Count (zipWith (+) xs ys)

countFromInteger :: Integer -> Count
countFromInteger = Count . map integerFromBits . scatter . bitsFromInteger . abs
  where bitsFromInteger 0 = []
        bitsFromInteger i = (case i `mod` 2 of
                                0 -> False
                                1 -> True) : bitsFromInteger (i `div` 2)
        integerFromBits = foldr (\is i -> 2 * i + if is then 1 else 0) 0
        scatter = foldr f (replicate cResultIndicies [])
          where f x (xs : xss) = xss ++ [x : xs]

countResultI i = Count $ map f [0 .. cResultIndicies - 1]
  where f i' = if i == i' then 1 else 0

reportCount s' (Count cs) = concat [s', ": ", if null s then "0 tests!" else s]
  where s = ucfirst $ intercalate ", " . catMaybes . zipWith f ss $ cs
        f _            0 = Nothing
        f (s, (s', _)) 1 = Just $ concat [s, " 1 ", s']
        f (s, (_, s')) c = Just $ concat [s, " ", show c, " ", s']
        ss = [("failed", sProperties),
              ("couldn't parse results of", sProperties),
              ("couldn't compile", sFiles),
              ("failed", sTests),
              ("found errors in", sTests),
              ("exhausted arguments while checking", sProperties),
              ("passed", sProperties),
              ("passed", sTests)]
        sFiles = ("file", "files")
        sProperties = ("property", "properties")
        sTests = ("test", "tests")
        ucfirst ""       = ""
        ucfirst (ch : s) = toUpper ch : s

putCountLn s c = putStrLn (reportCount s c) >> return c

iFailedProperty : iUnparsedProperty : iUncompiledFile : iFailedTest : iErroneousTest :  -- FAIL
        iExhaustedProperty :                                                            -- not proven
        iPassedProperty : iPassedTest :                                                 -- WIN
        cResultIndicies : _ = [0..]                                     -- must be grouped like this for `exitCodeFor` to work

exitCodeFor (Count cs) = case length $ takeWhile (== 0) cs of
                                c | c < iExhaustedProperty -> ExitFailure 2
                                c | c < iPassedProperty    -> ExitFailure 1
                                _                          -> ExitSuccess

countQCResult (QCFailed _)    = countResultI iFailedProperty
countQCResult  QCPassed       = countResultI iPassedProperty
countQCResult (QCExhausted _) = countResultI iExhaustedProperty
countQCResult (QCUnparsed _)  = countResultI iUnparsedProperty

countHUResult (HUResult count _) = mconcat [mreplicate cPassed (countResultI iPassedTest),
                                            mreplicate cErroneous (countResultI iErroneousTest),
                                            mreplicate cFailed (countResultI iFailedTest)]
  where cErroneous = HU.errors count
        cFailed = HU.failures count
        cPassed = HU.tried count - cFailed - cErroneous

mreplicate c x = mconcat $ replicate c x


data PropertyTester = QuickCheck1 | QuickCheck2
data IndividualTest = QuickCheckTest String | HUnitTest String deriving (Eq, Show)
data Verbosity = NoOutput | NormalOutput deriving Eq

runIndividualTest :: G.GhcMonad m => Verbosity -> PropertyTester -> IndividualTest -> m Count
runIndividualTest verbosity QuickCheck1 (QuickCheckTest nTest)
  = do  result <- fmap (maybe wrongTestResult divineTestResult . fromDynamic) (G.dynCompileExpr expr)
        when (verbosity /= NoOutput && shouldExplicitlyReportQCResult result) (G.liftIO $ putStr $ reportQCResult nTest result)
        return (countQCResult result)
  where -- `expr` originally copied from Test.QuickCheck, copyright © Koen Claessen <koen@chalmers.se>, licenced under BSD3
        expr = concat ["let evaluateList xs = do {Control.Exception.evaluate xs;",
                                                 "case xs of {",
                                                      "[] -> return xs;",
                                                      "x : xs' -> Control.Exception.evaluate x >> evaluateList xs' >> return xs",
                                                 "}} in ",
                       "let gen = Test.QuickCheck.evaluate (Test.QuickCheck.property ", nTest, ") in ",
                       "let f rnd0 cPassed cMissed stamps",
                             "| cPassed == 100  = \"Passed\"",
                             "| cMissed == 1000 = \"Exhausted\"",
                             "| otherwise       = let (rnd1, rnd2) = System.Random.split rnd0 in ",
                                                 "let result = Test.QuickCheck.generate ((cPassed `div` 2) + 3) rnd2 gen in ",
                                                 "case Test.QuickCheck.ok result of",
                                                     "{Nothing    -> f rnd1 cPassed (1 + cMissed) stamps;",
                                                      "Just True  -> f rnd1 (1 + cPassed) cMissed ",
                                                                        "(Test.QuickCheck.stamp result : stamps);",
                                                      "Just False -> unlines (\"Failed\" : Test.QuickCheck.arguments result)} in ",
                       "let showException e = return $ unlines [\"Failed\", concat [\"Exception: '\",",
                                                                         "show (e :: Control.Exception.SomeException), \"'\"]] in ",
                       "let dof = do {gen <- System.Random.newStdGen;",
                                     "Control.Exception.catch (evaluateList $ f gen 0 0 []) showException} in ",
                       "System.IO.Unsafe.unsafePerformIO dof"]
        divineTestResult :: String -> QCResult
        divineTestResult "Passed"                       = QCPassed
        divineTestResult "Exhausted"                    = QCExhausted 1000
        divineTestResult s | "Failed" `isPrefixOf` s    = QCFailed (tail $ lines s)
                           | otherwise                  = QCUnparsed s
        wrongTestResult = QCFailed [concat ["Was expecting ", nTest, " to be of type Test.QuickCheck.Testable a => a"]]

runIndividualTest verbosity QuickCheck2 (QuickCheckTest nTest)
  = do  result <- fmap (maybe wrongTestResult divineTestResult . fromDynamic) (G.dynCompileExpr expr)
        when (verbosity /= NoOutput && shouldExplicitlyReportQCResult result) (G.liftIO $ putStr $ reportQCResult nTest result)
        return (countQCResult result)
  where -- `expr` originally copied from Test.QuickCheck, copyright © Koen Claessen <koen@chalmers.se>, licenced under BSD3
        expr = concat ["let gen = Test.QuickCheck.Gen.unGen (Test.QuickCheck.property ", nTest, ") in ",
                       "let test cSuccess cDiscarded expectedFailure randomSeed ",
                             "| cSuccess   >= 100 = return (if expectedFailure then \"Passed\" else \"Unexpected pass\")",
                             "| cDiscarded >= 500 = return \"Exhausted\" ",
                             "| otherwise ",
                                  "= let (rnd1,rnd2) = System.Random.split randomSeed in ",
                                    "do { Test.QuickCheck.Property.MkRose mres ts <- Test.QuickCheck.Property.protectRose $",
                                                "Test.QuickCheck.Property.unProp $ gen rnd1",
                                                        "$ cSuccess `mod` 100 + cDiscarded `div` 10 ",
                                       "; res <- mres ",
                                       "; case Test.QuickCheck.Property.ok res of ",
                                           "{ Just True -> test (cSuccess + 1) cDiscarded (Test.QuickCheck.Property.expect res) ",
                                                                "rnd2",
                                           "; Nothing -> test cSuccess (cDiscarded + 1) (Test.QuickCheck.Property.expect res) rnd2",
                                           "; Just False -> return ((if Test.QuickCheck.Property.expect res then \"Failed\\n\" ",
                                                                                                    "else \"Expected failure\\n\")",
                                                                "++ Test.QuickCheck.Property.reason res) ",
                                           "} ",
                                       "} in ",
                       "System.IO.Unsafe.unsafePerformIO (System.Random.newStdGen >>= test 0 0 False)"]
        divineTestResult :: String -> QCResult
        divineTestResult "Passed"                               = QCPassed
        divineTestResult "Unexpected pass"                      = QCPassed
        divineTestResult "Exhausted"                            = QCExhausted 500
        divineTestResult s | "Failed" `isPrefixOf` s            = QCFailed (tail $ lines s)
                           | "Expected failure" `isPrefixOf` s  = QCFailed (tail $ lines s)
                           | otherwise                          = QCUnparsed s
        wrongTestResult = QCFailed [concat ["Was expecting ", nTest, " to be of type Test.QuickCheck.Testable a => a"]]

runIndividualTest verbosity _ (HUnitTest nTest)
  = do  result <- fmap (maybe wrongTestResult divineTestResult . fromDynamic) (G.dynCompileExpr expr)
        when (verbosity /= NoOutput && shouldExplicitlyReportHUResult result) (G.liftIO $ putStr $ reportHUResult nTest result)
        return (countHUResult result)
  where expr = concat ["let onStart huState myState = return myState in ",
                       "let onError message huState myState = return (Left message : myState) in ",
                       "let onFailure message huState myState = return (Right message : myState) in ",
                       "let f (Test.HUnit.Counts a b c d, messages) = (a, b, c, d, messages) in ",
                       "f (System.IO.Unsafe.unsafePerformIO (Test.HUnit.performTest onStart onError onFailure []",
                                                                "(Test.HUnit.test ", nTest, ")))"]
        divineTestResult :: (Int, Int, Int, Int, [Either String String]) -> HUResult
        divineTestResult (a, b, c, d, messages) = HUResult (HU.Counts a b c d) $ map f (reverse messages)
          where f (Left s)  = HUError s
                f (Right s) = HUFailure s
        wrongTestResult = HUResult (HU.Counts 1 1 1 0)
                                   [HUError (concat ["Was expecting ", nTest, " to be of type Test.HUnit.Testable a => a"])]

runModuleTests' :: Monoid res => (IndividualTest -> G.Ghc res) -> res -> String -> G.Ghc res
runModuleTests' runTest wontCompile nf = do     G.setTargets targets
                                                G.load G.LoadAllTargets >>= loaded
  where loaded G.Failed = return wontCompile
        loaded G.Succeeded = G.getModuleGraph >>= loadedModule . f
          where f summaries = (summaries, map G.ms_mod $ filter ((== Just nf) . G.ml_hs_file . G.ms_location) summaries)
        loadedModule (_, [interestingModule])
              = G.getModuleInfo interestingModule >>= performTests . fmap (catMaybes . map testFromTyThing . G.modInfoTyThings)
          where performTests Nothing = error "Was expecting module to be loaded"
                performTests (Just ns) = G.setContext [interestingModule] [] >> fmap mconcat (mapM runTest ns)
        loadedModule (summaries, _) = error (concat ["loadedModule did not find ", nf, " in ",
                                                     intercalate ", " $ map display summaries])
          where display summary = concat [G.moduleNameString (G.moduleName $ G.ms_mod summary), " (",
                                          show (G.ml_hs_file $ G.ms_location summary), ")"]
        testFromTyThing (G.AnId identity) = if "prop_" `isPrefixOf` n then Just (QuickCheckTest n) else 
                                            if "test_" `isPrefixOf` n then Just (HUnitTest n)      else Nothing
          where n = G.occNameString . G.nameOccName $ G.varName identity
        testFromTyThing _ = Nothing
        targets = [G.Target {G.targetId = G.TargetFile nf Nothing, G.targetAllowObjCode = False, G.targetContents = Nothing}]

test_collectCorrectNamesOfTests
  = runGhc defaultFlags (runModuleTests' (return . (: [])) [] "f/test-names.hs") >>= HU.assertEqual "" correct
  where correct = [QuickCheckTest "prop_withNoArgs", QuickCheckTest "prop_withOneArg", QuickCheckTest "prop_withTwoArgs",
                   HUnitTest "test_withNoArgs", HUnitTest "test_withOneArg",
                   QuickCheckTest "prop_first", HUnitTest "test_second"]

runModuleTests'' verbosity tester nf
  = do  stats <- runModuleTests' (runIndividualTest verbosity tester) (countResultI iUncompiledFile) nf
        G.liftIO $ when (verbosity /= NoOutput) (putCountLn nf stats >> return ())
        return stats
runModuleTests = runModuleTests'' NormalOutput

test'runsPropertyTester pt nf wanted
      = runGhc defaultFlags (ensureUsingCorrectPropertyTester pt >> runModuleTests'' NoOutput pt nf) >>= HU.assertEqual "" wanted
test_runsQuickCheck1 = test'runsPropertyTester QuickCheck1 "f/quickcheck-1.hs"
                        (mreplicate 3 (countResultI iPassedProperty) `mappend` countResultI iFailedProperty)
test_runsQuickCheck2 = test'runsPropertyTester QuickCheck2 "f/quickcheck-2.hs"
                        (mreplicate 3 (countResultI iPassedProperty) `mappend` mreplicate 2 (countResultI iFailedProperty))

test'exceptionInTestCodeShouldntCauseCrash qc
      = runGhc defaultFlags (ensureUsingCorrectPropertyTester qc >> runModuleTests'' NoOutput qc "f/quickcheck-exception.hs")
        >>= HU.assertEqual "" (countQCResult $ QCFailed [])
test_exceptionInTestCodeShouldntCauseCrashForQuickCheck1 = test'exceptionInTestCodeShouldntCauseCrash QuickCheck1
test_exceptionInTestCodeShouldntCauseCrashForQuickCheck2 = test'exceptionInTestCodeShouldntCauseCrash QuickCheck2


getPackagesExposingModule :: String -> G.Ghc [G.PackageConfig]
getPackagesExposingModule n = fmap (map fst . filter snd . (`G.lookupModuleInAllPackages` G.mkModuleName n)) G.getSessionDynFlags

test_gpemSaysMadeUpModuleIsNotInstalled
      = runGhc defaultFlags (getPackagesExposingModule "Not.A.Real.Module.H82xj") >>= HU.assertBool "" . null
test_gpemSaysPreludeIsInstalled = runGhc defaultFlags (getPackagesExposingModule "Prelude") >>= HU.assertBool "" . (not . null)


ensureUsingCorrectPropertyTester pt = ensureUsingQuickCheck (case pt of
                                                                  QuickCheck1 -> 1
                                                                  QuickCheck2 -> 2)

ensureUsingQuickCheck :: Int -> G.Ghc ()
ensureUsingQuickCheck i
  = do  (candidates, impostors) <- partition (isQuickCheck i) <$> getPackagesExposingModule "Test.QuickCheck"
        dynFlags <- G.getSessionDynFlags
        G.setSessionDynFlags dynFlags {G.packageFlags = concat [exposingBest candidates,
                                                                hidingAll impostors,
                                                                G.packageFlags dynFlags]}
        return ()
  where hidingAll = map (G.HidePackage . nameOfPackage) . filter G.exposed
        exposingBest []         = error "Can't use QuickCheck-1 as it is not installed"
        exposingBest candidates
              = case filter G.exposed candidates of
                        []                -> [G.ExposePackage . nameOfPackage $ maximumBy byVersion candidates]
                        [_]               -> []
                        exposedCandidates -> G.HidePackage . nameOfPackage <$> tail (reverse $ sortBy byVersion exposedCandidates)
        nameOfPackage (G.InstalledPackageInfo {G.sourcePackageId = PackageIdentifier {pkgName = PackageName n,
                                                                                      pkgVersion = v}})
              = intercalate "-" [n, showVersion v]
        byVersion = compare `on` pkgVersion . G.sourcePackageId

isQuickCheck :: Int -> G.InstalledPackageInfo_ a -> Bool
isQuickCheck i (G.InstalledPackageInfo {G.sourcePackageId = packageId})
              = pkgName packageId == PackageName "QuickCheck" && [i] `isPrefixOf` versionBranch (pkgVersion packageId)

resolvePropertyTester :: Maybe PropertyTester -> G.Ghc PropertyTester
resolvePropertyTester = maybe check return
  where check = do      (qc2s, notQc2s) <- partition (isQuickCheck 2) <$> getPackagesExposingModule "Test.QuickCheck"
                        case (qc2s, partition (isQuickCheck 1) notQc2s) of
                             ([], ([], _)) -> G.liftIO $ hPutStrLn stderr "Cannot find QUickCheck-2 or QuickCheck-1" >> exitWith (ExitFailure 3)
                             ([], _)       -> return QuickCheck1
                             _             -> return QuickCheck2


runGhc :: Flags -> G.Ghc a -> IO a
runGhc flags act = G.runGhc (Just G.libdir) (G.defaultErrorHandler G.defaultDynFlags $ init >> act)
  where init = do       -- have to get and then set dynamic flags even if I don't want to change them
                        -- somehow this initialises fields I don't want to care about
                        dynFlags <- G.getSessionDynFlags
                        G.setSessionDynFlags dynFlags {G.ghcMode = G.CompManager, G.ghcLink = G.LinkInMemory,
                                                       G.hscTarget = G.HscInterpreted,
                                                       G.flags = G.Opt_ImplicitImportQualified : G.flags dynFlags,
                                                       G.packageFlags = packageFlags ++ G.packageFlags dynFlags,
                                                       G.importPaths = G.importPaths dynFlags ++ reverse (ndsImportFromFlags flags)}
        packageFlags = map f (pkgsFromFlags flags)
          where f (ExposePkg n) = G.ExposePackage n
                f (HidePkg n)   = G.HidePackage n
                f (IgnorePkg n) = G.IgnorePackage n


cmdLineDescr = [Option "" ["help"]           (NoArg $ withModeOption HelpMode)              "display this help",
                Option "" ["version"]        (NoArg $ withModeOption VersionMode)           "show the version number",
                Option "" ["use-quickcheck1"](NoArg $ withPropertyTester QuickCheck1)       "use QuickCheck-1 to test properties",
                Option "" ["use-quickcheck2"](NoArg $ withPropertyTester QuickCheck2)       "use QuickCheck-2 to test properties",
                Option "" ["expose-package"] (ReqArg (withPkg . ExposePkg) "PACKAGE")       "expose a package",
                Option "" ["hide-package"]   (ReqArg (withPkg . HidePkg) "PACKAGE")         "hide a package",
                Option "" ["ignore-package"] (ReqArg (withPkg . IgnorePkg) "PACKAGE")       "ignore a package",
                Option "i" []                (OptArg (withNdsImport' . splitSearchPath . fromMaybe "") "[DIRLIST]")
                                                                "add directory to module search list (leave blank to clear)"]

usageMsg = usageInfo "Usage: hstest [FLAGS] [SOURCE FILES]" cmdLineDescr

getCommandLineOptions wrap = getArgs >>= act . getOpt (ReturnInOrder wrap) cmdLineDescr
  where act (opts, _, [])   = return opts
        act (_,    _, errs) = hPutStrLn stderr (unlines errs ++ usageMsg) >> exitFailure

data Options = Options {modeFromOptions :: Mode,
                        nfsFromOptions :: [String],
                        flagsFromOptions :: Flags,
                        propertyTester :: Maybe PropertyTester}
data Mode = NormalMode | HelpMode | VersionMode
noOptions = Options NormalMode [] defaultFlags Nothing
withModeOption mode opts = opts {modeFromOptions = mode}
withNfOption nf opts = opts {nfsFromOptions = nf : nfsFromOptions opts}
withNfsOption nfs opts = opts {nfsFromOptions = nfs}
withPropertyTester pt = \opts -> opts {propertyTester = Just pt}
alterFlags :: (Flags -> Flags) -> Options -> Options
alterFlags f opts = opts {flagsFromOptions = f (flagsFromOptions opts)}

data Flags = Flags {pkgsFromFlags :: [PkgFlag],
                    ndsImportFromFlags :: [FilePath]}
data PkgFlag = ExposePkg String
             | HidePkg String
             | IgnorePkg String
defaultFlags = Flags [] []
withPkg pkg = alterFlags $ \flags -> flags {pkgsFromFlags = pkg : pkgsFromFlags flags}
withNdImport nd = alterFlags $ \flags -> flags {ndsImportFromFlags = nd : ndsImportFromFlags flags}
withNdsImport nds = alterFlags $ \flags -> flags {ndsImportFromFlags = nds}
withNdsImport' []  = withNdsImport []
withNdsImport' nds = appEndo . mconcat . map (Endo . withNdImport) $ nds

main = fmap (foldr ($) noOptions) (getCommandLineOptions withNfOption) >>= defaultNfs >>= act >>= exitWith . exitCodeFor
  where act Options {modeFromOptions = VersionMode} = putStrLn ("hstest " ++ showVersion version) >> exitSuccess
        act Options {modeFromOptions = HelpMode} = putStrLn usageMsg >> exitSuccess
        act opts = runGhc' opts $ runOnList ((resolvePropertyTester $ propertyTester opts) `secretly` ensureUsingCorrectPropertyTester)
                                            runModuleTests
                                            (G.liftIO . putCountLn "Total" . mconcat)
                                            (G.liftIO $ putStrLn "No Haskell source files!" >> return mempty)
                                            (nfsFromOptions opts)
        defaultNfs opts @ Options {nfsFromOptions = []}
              = fmap ((`withNfsOption` opts) . filter (".hs" `isSuffixOf`)) (getDirectoryContents ".")
        defaultNfs opts = return opts
        runGhc' = runGhc . flagsFromOptions

runOnList :: Monad m => m a -> (a -> x -> m b) -> ([b] -> m b) -> m b -> [x] -> m b
runOnList before each reduce onNone = act
  where act []  = onNone
        act [x] = do    a <- before
                        each a x
        act xs  = do    a <- before
                        reduce =<< mapM (each a) xs

secretly :: Monad m => m a -> (a -> m b) -> m a
overt `secretly` covert = do    a <- overt
                                covert a
                                return a