Implement Biz.Test with tasty

Also changes the --test option to a 'test' command. This is because running the
tests for a namespace/exe should never be combined with anything else: you
either want to run the tests, or not.

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
diff --git a/Biz/Cli.hs b/Biz/Cli.hs
index f2d7fad..cdd2f80 100644
--- a/Biz/Cli.hs
+++ b/Biz/Cli.hs
@@ -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