diff options
| -rw-r--r-- | Biz/Bild.hs | 4 | ||||
| -rw-r--r-- | Biz/Bild/Deps/Haskell.nix | 1 | ||||
| -rw-r--r-- | Biz/Cli.hs | 18 | ||||
| -rw-r--r-- | Biz/Devalloc.hs | 39 | ||||
| -rw-r--r-- | Biz/Lint.hs | 6 | ||||
| -rw-r--r-- | Biz/Test.hs | 24 |
6 files changed, 70 insertions, 22 deletions
diff --git a/Biz/Bild.hs b/Biz/Bild.hs index 60ad97a..0fd5bb4 100644 --- a/Biz/Bild.hs +++ b/Biz/Bild.hs @@ -119,6 +119,8 @@ import Alpha hiding (sym, (<.>)) import qualified Biz.Cli as Cli import Biz.Namespace (Namespace (..)) import qualified Biz.Namespace as Namespace +import Biz.Test ((@=?)) +import qualified Biz.Test as Test import qualified Data.Char as Char import qualified Data.List as List import qualified Data.String as String @@ -135,7 +137,7 @@ import qualified Prelude main :: IO () main = Cli.main <| Cli.Plan help move test where - test _ = Exit.exitSuccess + test = Test.group "Biz.Bild" [Test.unit "id" <| 1 @=? 1] move args = mapM getNamespace (Docopt.getAllArgs args (Docopt.argument "target")) /> catMaybes diff --git a/Biz/Bild/Deps/Haskell.nix b/Biz/Bild/Deps/Haskell.nix index dc33483..13d952d 100644 --- a/Biz/Bild/Deps/Haskell.nix +++ b/Biz/Bild/Deps/Haskell.nix @@ -50,6 +50,7 @@ with hpkgs; string-quote stripe-haskell tasty + tasty-hunit text time transformers @@ -14,13 +14,16 @@ module Biz.Cli where import Alpha +import qualified Data.Text as Text import qualified System.Console.Docopt as Docopt import qualified System.Environment as Environment +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.Runners as Tasty data Plan = Plan { help :: Docopt.Docopt, move :: Docopt.Arguments -> IO (), - test :: Docopt.Arguments -> IO () + test :: Tasty.TestTree } main :: Plan -> IO () @@ -28,9 +31,18 @@ main Plan {..} = Environment.getArgs >>= Docopt.parseArgsOrExit help >>= \args -> - if args `has` Docopt.longOption "test" - then test args + if args `has` Docopt.command "test" + then runTests test else move args +runTests :: Tasty.TestTree -> IO () +runTests tree = do + Tasty.installSignalHandlers + case Tasty.tryIngredients Tasty.defaultIngredients mempty tree of + Nothing -> do + hPutStrLn stderr <| Text.pack "no ingredients agreed to run" + exitFailure + Just act -> act >>= \ok -> if ok then exitSuccess else exitFailure + has :: Docopt.Arguments -> Docopt.Option -> Bool has = Docopt.isPresent diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs index 1134098..59e2240 100644 --- a/Biz/Devalloc.hs +++ b/Biz/Devalloc.hs @@ -32,6 +32,8 @@ -- : dep servant-auth-server -- : dep servant-lucid -- : dep servant-server +-- : dep tasty +-- : dep tasty-hunit -- : dep uuid -- : dep vector -- : dep warp @@ -45,6 +47,8 @@ import Alpha hiding ((<.>)) import Biz.App (CSS (..), HtmlApp (..)) import qualified Biz.Cli as Cli import qualified Biz.Look +import Biz.Test ((@=?)) +import qualified Biz.Test as Test import qualified Clay import qualified Control.Exception as Exception import Crypto.JOSE.JWK (JWK) @@ -203,10 +207,8 @@ help = devalloc Usage: - devalloc [--test] - -Options: - --test Run the tests + devalloc + devalloc test |] move :: Cli.Arguments -> IO () @@ -250,8 +252,13 @@ testCookieSettings = Auth.cookieXsrfSetting = Nothing } -test :: Cli.Arguments -> IO () -test _ = test_analyzeGitHub >> pure test_calculateScore >> pure () +test :: Test.Tree +test = + Test.group + "Biz.Devalloc" + [ -- test_analyzeGitHub, + test_calculateScore + ] -- * app configurations @@ -760,15 +767,14 @@ calculateScore numTotal numBlackholes numLiabilities = numGood = numTotal - numBlackholes - numLiabilities maxScore = 100.0 -test_calculateScore :: [Bool] +test_calculateScore :: Test.Tree test_calculateScore = - [ -- perfect - 100 == calculateScore 100 0 0, - -- all blackholes - 50 == calculateScore 100 100 0, - -- all liabilities - 70 == calculateScore 100 0 100 - ] + Test.group + "calculateScore" + [ Test.unit "perfect score" <| 100 @=? calculateScore 100 0 0, + Test.unit "all blackholes" <| 50 @=? calculateScore 100 100 0, + Test.unit "all liabilities" <| 70 @=? calculateScore 100 0 100 + ] lastTouched :: FilePath -> FilePath -> IO (FilePath, Int) lastTouched bareRepo path = do @@ -869,8 +875,9 @@ analyzeGitHub githubAuth cfg o r = do ghOwner = GitHub.mkName (Proxy :: Proxy GitHub.Owner) o ghRepo = GitHub.mkName (Proxy :: Proxy GitHub.Repo) r -test_analyzeGitHub :: IO Analysis -test_analyzeGitHub = analyzeGitHub () Envy.defConfig "bsima" "bin" +-- TODO: write this test +-- test_analyzeGitHub :: IO Analysis +-- test_analyzeGitHub = analyzeGitHub () Envy.defConfig "bsima" "bin" -- | Clone the repo to @<Config.depo>/<url>@. If repo already exists, just do a -- @git fetch@. Returns the full path to the local repo. diff --git a/Biz/Lint.hs b/Biz/Lint.hs index bad0806..bf7fa09 100644 --- a/Biz/Lint.hs +++ b/Biz/Lint.hs @@ -12,6 +12,8 @@ import Alpha import qualified Biz.Cli as Cli import Biz.Namespace (Ext (..), Namespace (..)) import qualified Biz.Namespace as Namespace +import Biz.Test ((@=?)) +import qualified Biz.Test as Test import qualified Control.Concurrent.Async as Async import qualified Data.String as String import qualified Data.Text as Text @@ -31,8 +33,8 @@ move args = [] -> changedFiles >>= run >>= mapM printResult >>= exit files -> run (filter notcab files) >>= mapM printResult >>= exit -test :: Cli.Arguments -> IO () -test _ = Exit.exitSuccess +test :: Test.Tree +test = Test.group "Biz.Bild" [Test.unit "id" <| 1 @=? 1] notcab :: FilePath -> Bool notcab ('_' : _) = False diff --git a/Biz/Test.hs b/Biz/Test.hs new file mode 100644 index 0000000..9af8912 --- /dev/null +++ b/Biz/Test.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Biz.Test + ( Tree, + group, + unit, + (@=?), + ) +where + +-- : dep tasty +-- : dep tasty-hunit +import Alpha hiding (group) +import qualified Test.Tasty as Tasty +import Test.Tasty.HUnit ((@=?)) +import qualified Test.Tasty.HUnit as HUnit + +type Tree = Tasty.TestTree + +group :: Tasty.TestName -> [Tasty.TestTree] -> Tasty.TestTree +group = Tasty.testGroup + +unit :: Tasty.TestName -> HUnit.Assertion -> Tasty.TestTree +unit = HUnit.testCase |