packages feed

lame-tester (empty) → 1.1

raw patch · 7 files changed

+226/−0 lines, 7 filesdep +HUnitdep +basedep +bifunctorssetup-changed

Dependencies added: HUnit, base, bifunctors, containers, lame-tester, semigroups, test-framework, test-framework-hunit, validation

Files

+ LICENSE.txt view
@@ -0,0 +1,25 @@+PathFinding Project - Tester-Haskell Module+Copyright (c) 2014, Jason Bertsche+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 Jason Bertsche nor the+      names of project 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 JASON BERTSCHE 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lame-tester.cabal view
@@ -0,0 +1,43 @@+Name:                lame-tester+Version:             1.1+Cabal-version:       >=1.16.0+License:             BSD3+License-File:        LICENSE.txt+Author:              Jason Bertsche+Maintainer:          jason.bertsche@gmail.com+Homepage:            http://github.com/TheBizzle+Category:            Demo+Synopsis:            A strange and unnecessary selective test-running library+Description:         A strange and unnecessary selective test-running library+Build-type:          Simple++source-repository head+  type:     git+  location: git@github.com:TheBizzle/Tester-Haskell.git++library+  hs-source-dirs:   src+  exposed-modules:  Tester.Dialect, Tester.RunSettings, Tester.Suite+  default-language: Haskell2010+  build-depends:+    base       >= 4.6 && < 5,+    bifunctors >= 4.1,+    containers >= 0.5,+    semigroups >= 0.9,+    validation >= 0.3+  GHC-Options:+    -Wall+    -fno-warn-name-shadowing++test-suite tests+  type:             exitcode-stdio-1.0+  main-is:          Main.hs+  hs-source-dirs:   test+  default-language: Haskell2010+  build-depends:+    base                       >= 4.6 && < 5,+    containers                 >= 0.5,+    HUnit                      >= 1.2,+    lame-tester                >= 1.1,+    test-framework             >= 0.8,+    test-framework-hunit       >= 0.3
+ src/Tester/Dialect.hs view
@@ -0,0 +1,51 @@+module Tester.Dialect(CellBox(..), FlagCell(..), FlagCells(..), ToggleFlag(..), andAlso, butAlso, excludingTo, runningTo) where++data ToggleFlag+  = StackTrace deriving (Eq, Show)++data FlagCell+  = ToggleCell { flag :: ToggleFlag }+  | DontRun    { num :: Int }+  | Run        { num :: Int } deriving (Eq, Show)++data FlagCells+  = FlagCells {+      cells :: [FlagCell]+    } deriving (Eq, Show)++runningTo :: Int -> Int -> FlagCells+runningTo x y = FlagCells $ fmap Run [x..y]++excludingTo :: Int -> Int -> FlagCells+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)+butAlso = andAlso++class CellBox x where+  unbox :: x -> [FlagCell]++instance CellBox FlagCells where+  unbox (FlagCells cells) = cells++instance CellBox FlagCell where+  unbox cell = [cell]++instance CellBox ToggleFlag where+  unbox flag = unbox (ToggleCell flag)++-- Example: [DontRun 0, Run 1, DontRun 2, Run 2, Run 3, DontRun 5, StackTrace]+instance Ord FlagCell where+  (Run        a) <= (Run        b) = a <= b+  (DontRun    a) <= (DontRun    b) = a <= b+  (ToggleCell _) <= (ToggleCell _) = True+  (ToggleCell _) <= (DontRun    _) = False+  (ToggleCell _) <= (Run        _) = False+  (DontRun    _) <= (ToggleCell _) = True+  (Run        _) <= (ToggleCell _) = True+  (Run        a) <= (DontRun    b) = a < b+  (DontRun    a) <= (Run        b) = a <= b++infixl 6 `runningTo`,`excludingTo`+infixl 2 `andAlso`,`butAlso`
+ src/Tester/RunSettings.hs view
@@ -0,0 +1,41 @@+module Tester.RunSettings(Settings(..), cellsToSettings) where++import Control.Arrow((>>>))++import Data.List(sort)+import Data.Set(empty, insert, Set)++import Tester.Dialect(CellBox, FlagCell(DontRun, Run, ToggleCell), ToggleFlag(StackTrace), unbox)++data Settings+  = Settings {+    testNums       :: Set Int,+    isStackTracing :: Bool+  } deriving (Eq, Show)++a |> f = f a++cellsToSettings :: (CellBox x) => x -> Settings+cellsToSettings cellBox = foldr constructSettings baseSettings optimizedCells+  where+    baseSettings   = (Settings empty False)+    optimizedCells = cellBox |> (unbox >>> optimize)++constructSettings :: OptCell -> Settings -> Settings+constructSettings OStackTrace (Settings nums _)       = Settings nums    True+constructSettings (ORun num)  (Settings nums tracing) = Settings newNums tracing+  where+    newNums = insert num nums++optimize :: [FlagCell] -> [OptCell]+optimize = sort >>> foldr f []+  where+    f (ToggleCell StackTrace) acc@(OStackTrace : _)     = acc+    f (ToggleCell StackTrace) acc                       = OStackTrace : acc+    f (Run        num)        acc                       = (ORun num)  : acc+    f (DontRun    num)        ((ORun h) : t) | h == num = t+    f (DontRun    _)          acc                       = acc++data OptCell+  = OStackTrace+  | ORun { num :: Int }
+ src/Tester/Suite.hs view
@@ -0,0 +1,57 @@+module Tester.Suite(Result, runTests, Suite(..), TestResult(..), unsafeRunTests) where++import Control.Arrow((>>>))++import Data.Bifoldable(bifoldMap)+import Data.List.NonEmpty(NonEmpty)+import Data.Map((!), Map)+import Data.Monoid(Monoid(mappend, mempty))+import Data.Validation(Validation)++import Data.Set as Set++import System.IO.Unsafe(unsafePerformIO)++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)++data Suite a b c+  = Suite {+    testMap    :: Map Int a,+    runTest    :: a -> Result b c,+    failsToStr :: NonEmpty b -> String,+    succToStr  :: c -> String+  }++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++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)))++resultToTR :: (NonEmpty a -> String)-> Result a b -> TestResult+resultToTR fToStr = bifoldMap (\nel -> TestFailure $ fToStr nel) (const TestSuccess)
+ test/Main.hs view
@@ -0,0 +1,7 @@+module Main where++import qualified UnitTests++import Test.Framework.Runners.Console (defaultMain)++main = defaultMain $ [UnitTests.tests]