diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Distribution.Simple - -main :: IO () -main = defaultMainWithHooks simpleUserHooks diff --git a/lame-tester.cabal b/lame-tester.cabal --- a/lame-tester.cabal +++ b/lame-tester.cabal @@ -1,6 +1,6 @@ Name: lame-tester -Version: 1.2.1 -Cabal-version: >=1.16.0 +Version: 1.4.0 +Cabal-version: >=1.22.0 License: BSD3 License-File: LICENSE.txt Author: Jason Bertsche @@ -18,25 +18,34 @@ library hs-source-dirs: src exposed-modules: Tester.Dialect, Tester.RunSettings, Tester.Suite + default-extensions: OverloadedStrings default-language: Haskell2010 build-depends: - base >= 4.6 && < 5, - bifunctors >= 4.1, - containers >= 0.5, - semigroups >= 0.9, - validation >= 0.3 + base-noprelude >= 4.8 && < 5, + bizzlelude >= 1.2.0 && < 1.3.0, + containers >= 0.5.11 && < 0.6.0, + semigroups >= 0.18.4 && < 0.19.0, + validation >= 1 && < 1.1.0 GHC-Options: -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wmissing-import-lists + -Wredundant-constraints -fno-warn-name-shadowing + -funbox-strict-fields test-suite tests type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: test + default-extensions: OverloadedStrings default-language: Haskell2010 + other-modules: UnitTests build-depends: - base >= 4.6 && < 5, - containers >= 0.5, - lame-tester >= 1.2, - tasty >= 0.10, - tasty-hunit >= 0.9 + bizzlelude, + containers, + lame-tester, + tasty >= 1.0.1 && < 1.1.0, + tasty-hunit >= 0.10.0 && < 0.11.0 diff --git a/src/Tester/Dialect.hs b/src/Tester/Dialect.hs --- a/src/Tester/Dialect.hs +++ b/src/Tester/Dialect.hs @@ -20,7 +20,7 @@ excludingTo x y = FlagCells $ fmap DontRun [x..y] andAlso, butAlso :: (CellBox a, CellBox b) => a -> b -> FlagCells -andAlso x y = FlagCells $ (unbox x) ++ (unbox y) +andAlso x y = FlagCells $ (unbox x) <> (unbox y) butAlso = andAlso class CellBox x where diff --git a/src/Tester/RunSettings.hs b/src/Tester/RunSettings.hs --- a/src/Tester/RunSettings.hs +++ b/src/Tester/RunSettings.hs @@ -1,9 +1,7 @@ module Tester.RunSettings(Settings(..), cellsToSettings) where -import Control.Arrow((>>>)) - import Data.List(sort) -import Data.Set(empty, insert, Set) +import Data.Set(empty, insert) import Tester.Dialect(CellBox, FlagCell(DontRun, Run, ToggleCell), ToggleFlag(StackTrace), unbox) @@ -13,8 +11,6 @@ isStackTracing :: Bool } deriving (Eq, Show) -a |> f = f a - cellsToSettings :: (CellBox x) => x -> Settings cellsToSettings cellBox = foldr constructSettings baseSettings optimizedCells where @@ -38,4 +34,4 @@ data OptCell = OStackTrace - | ORun { num :: Int } + | ORun Int diff --git a/src/Tester/Suite.hs b/src/Tester/Suite.hs --- a/src/Tester/Suite.hs +++ b/src/Tester/Suite.hs @@ -1,57 +1,45 @@ -module Tester.Suite(Result, runTests, Suite(..), TestResult(..), unsafeRunTests) where - -import Control.Arrow((>>>)) +module Tester.Suite(Result, runTests, Suite(..), TestResult(..)) where import Data.Bifoldable(bifoldMap) import Data.List.NonEmpty(NonEmpty) -import Data.Map((!), Map) -import Data.Monoid(Monoid(mappend, mempty)) +import Data.Map((!)) import Data.Validation(Validation) -import Data.Set as Set - -import System.IO.Unsafe(unsafePerformIO) +import qualified Data.Set as Set import Tester.Dialect(FlagCells) import Tester.RunSettings(cellsToSettings, testNums) -a |> f = f a - type Result f s = Validation (NonEmpty f) s data TestResult = TestSuccess - | TestFailure { msg :: String } deriving (Eq, Show) + | TestFailure { msg :: Text } deriving (Eq, Show) data Suite a b c = Suite { testMap :: Map Int a, runTest :: a -> Result b c, - failsToStr :: NonEmpty b -> String, - succToStr :: c -> String + failsToStr :: NonEmpty b -> Text, + succToStr :: c -> Text } +instance Semigroup TestResult where + ( TestFailure m1) <> (TestFailure m2) = TestFailure $ m1 <> m2 + x@(TestFailure _) <> _ = x + _ <> x@(TestFailure _) = x + _ <> _ = TestSuccess + instance Monoid TestResult where - mempty = TestSuccess - mappend (TestFailure m1) (TestFailure m2) = TestFailure $ m1 `mappend` m2 - mappend x@(TestFailure _) _ = x - mappend _ x@(TestFailure _) = x - mappend _ _ = mempty + mempty = TestSuccess + mappend = (<>) runTests :: FlagCells -> (Suite a b c) -> [TestResult] runTests c s@(Suite _ _ failsToStr _) = fmap (resultToTR failsToStr) $ generateResults c s -unsafeRunTests :: FlagCells -> (Suite a b c) -> [TestResult] -unsafeRunTests c s@(Suite _ _ failsToStr succToStr) = seq (unsafePerformIO evilIO) testResults - where - results = generateResults c s - testResults = fmap (resultToTR failsToStr) results - strs = fmap (bifoldMap failsToStr succToStr) results - evilIO = mapM_ putStrLn strs - generateResults :: FlagCells -> (Suite a b c) -> [Result b c] generateResults cells (Suite testMap runTest _ _) = - cells |> (cellsToSettings >>> testNums >>> Set.toList >>> (fmap $ (testMap!) >>> runTest)) + cells |> (cellsToSettings >>> testNums >>> Set.toList >>> (fmap $ (testMap !) >>> runTest)) -resultToTR :: (NonEmpty a -> String)-> Result a b -> TestResult +resultToTR :: (NonEmpty a -> Text)-> Result a b -> TestResult resultToTR fToStr = bifoldMap (fToStr >>> TestFailure) $ const TestSuccess diff --git a/test/UnitTests.hs b/test/UnitTests.hs new file mode 100644 --- /dev/null +++ b/test/UnitTests.hs @@ -0,0 +1,39 @@ +module UnitTests(tests) where + +import Data.Set(empty, fromList, insert, singleton) + +import Test.Tasty(testGroup, TestTree) +import Test.Tasty.HUnit((@?=), testCase) + +import Tester.Dialect(andAlso, butAlso, CellBox, excludingTo, FlagCell(DontRun, Run), FlagCells(FlagCells), runningTo, ToggleFlag(StackTrace), unbox) +import Tester.RunSettings(cellsToSettings, Settings(Settings)) + +tests = testGroup "Test settings DSL" [ + testCells "Simple run" (Run 2) (singleton 2) False + , testCells "Simple range" (5 `runningTo` 20) (fromList [5..20]) False + , testCells "Simple flag" (StackTrace) empty True + , testCells "Simples combined" (Run 2 `andAlso` 5 `runningTo` 20 `butAlso` StackTrace) ((fromList >>> (insert 2)) [5..20]) True + , testCells "Unnecessary exemption 1" (DontRun 2) empty False + , testCells "Unnecessary exemption 2" (Run 6 `andAlso` DontRun 2) (singleton 6) False + , testCells "Unnecessary exempt range 1" (5 `excludingTo` 10) empty False + , testCells "Unnecessary exempt range 2" (15 `runningTo` 25 `andAlso` 5 `excludingTo` 10) (fromList [15..25]) False + , testCells "Exemption from single 1" (Run 2 `andAlso` DontRun 2) empty False + , testCells "Exemption from single 2" (Run 101 `andAlso` Run 9 `andAlso` DontRun 9 `andAlso` Run 10) (fromList [10, 101]) False + , testCells "Exemption from range 1" (1 `runningTo` 10 `butAlso` DontRun 10) (fromList [1..9]) False + , testCells "Exemption from range 2" (1 `runningTo` 10 `butAlso` DontRun 9) ((fromList >>> (insert 10)) [1..8]) False + , testCells "Exempt range from single 1" (Run 6 `butAlso` 1 `excludingTo` 10) empty False + , testCells "Exempt range from single 2" (Run 6 `butAlso` 1 `excludingTo` 10 `andAlso` Run 12) (singleton 12) False + , testCells "Exempt range from range 1" (1 `runningTo` 20 `butAlso` 5 `excludingTo` 10) (fromList [1,2,3,4,11,12,13,14,15,16,17,18,19,20]) False + , testCells "Exempt range from range 2" (10 `runningTo` 20 `butAlso` 5 `excludingTo` 12) (fromList [13..20]) False + , testCells "Exempt range from range 3" (10 `runningTo` 20 `butAlso` 17 `excludingTo` 25) (fromList [10..16]) False + , testCells "Exempt range from mix 1" (1 `runningTo` 20 `butAlso` 3 `excludingTo` 18 `andAlso` Run 25) (fromList [1,2,19,20,25]) False + , testCells "Exempt range from mix 2" (5 `runningTo` 20 `butAlso` 3 `excludingTo` 18 `andAlso` Run 1) (fromList [1, 19, 20]) False + , testCells "Bringing it all back home" (Run 22 `andAlso` 10 `runningTo` 15 `butAlso` 11 `excludingTo` 14 `butAlso` Run 20 `andAlso` StackTrace `andAlso` Run 5 `andAlso` DontRun 6 `butAlso` Run 6) (fromList [5, 10, 15, 20, 22]) True + ] + +testCells :: (CellBox b) => Text -> b -> Set Int -> Bool -> TestTree +testCells desc box numSet isStackTracing = testCase (asString desc) assertion + where + cells = FlagCells $ unbox box + settings = Settings numSet isStackTracing + assertion = cellsToSettings cells @?= settings