Add bild --test

This argument will run the tests for an output after building. It's active in
'ci' so running that will ensure tests are passing. This way testing a
namespace and building a namespace are as close together as possible, so
presumably it will be that much easier to write good tests.

6 files changed, 109 insertions, 70 deletions

diff --git a/Biz/Bild.hs b/Biz/Bild.hs
index 0fd5bb4..721da46 100644
--- a/Biz/Bild.hs
+++ b/Biz/Bild.hs
@@ -125,10 +125,8 @@ import qualified Data.Char as Char
 import qualified Data.List as List
 import qualified Data.String as String
 import qualified Data.Text as Text
-import qualified System.Console.Docopt as Docopt
 import qualified System.Directory as Dir
 import qualified System.Environment as Env
-import qualified System.Exit as Exit
 import System.FilePath ((</>))
 import qualified System.Process as Process
 import qualified Text.Regex.Applicative as Regex
@@ -137,24 +135,24 @@ import qualified Prelude
 main :: IO ()
 main = Cli.main <| Cli.Plan help move test
   where
-    test = Test.group "Biz.Bild" [Test.unit "id" <| 1 @=? 1]
+    test = Test.group "Biz.Bild" [Test.unit "id" <| 1 @=? (1 :: Integer)]
     move args =
-      mapM getNamespace (Docopt.getAllArgs args (Docopt.argument "target"))
+      mapM getNamespace (Cli.getAllArgs args (Cli.argument "target"))
         /> catMaybes
         /> filter isBuildableNs
         >>= mapM analyze
-        >>= mapM_ build
+        >>= mapM_ (build (args `Cli.has` Cli.longOption "test"))
 
-help :: Docopt.Docopt
+help :: Cli.Docopt
 help =
-  [Docopt.docopt|
+  [Cli.docopt|
 bild
 
 Usage:
-  bild <target>...
+  bild [--test] <target>...
 
 Options:
-  -v, --verbose    Show output from underlying compiler
+  --test  Run tests on a target after building.
 |]
 
 type Dep = String
@@ -286,8 +284,8 @@ detectGhcCompiler _ content
 jsSuffix :: String -> Bool
 jsSuffix = List.isSuffixOf ".js"
 
-build :: Target -> IO ()
-build target@Target {..} = do
+build :: Bool -> Target -> IO ()
+build andTest target@Target {..} = do
   root <- Env.getEnv "BIZ_ROOT"
   case compiler of
     GhcExe -> do
@@ -310,6 +308,9 @@ build target@Target {..} = do
           "-o",
           outDir </> out
         ]
+      when andTest <| do
+        putStrLn <| "bild: dev: test: " <> Namespace.toPath namespace
+        Process.callProcess (outDir </> out) ["test"]
     GhcLib -> do
       putStrLn <| "bild: dev: ghc-lib: " <> Namespace.toPath namespace
       putText <| "bild: dev: bilder: " <> Text.pack builder
diff --git a/Biz/Bild/ShellHook.sh b/Biz/Bild/ShellHook.sh
index 05707dc..bb529dd 100644
--- a/Biz/Bild/ShellHook.sh
+++ b/Biz/Bild/ShellHook.sh
@@ -114,7 +114,7 @@ alias sentry="watch --color --exec bash -c run-sentry"
 
 # Poor man's ci
 function run-ci() {
-  lint **/* && bild **/*
+  lint **/* && bild --test **/*
 }
 alias ci="time run-ci"
 
diff --git a/Biz/Cli.hs b/Biz/Cli.hs
index cdd2f80..0f7b6d4 100644
--- a/Biz/Cli.hs
+++ b/Biz/Cli.hs
@@ -10,6 +10,10 @@ module Biz.Cli
     Docopt.argument,
     Docopt.docopt,
     Docopt.getAllArgs,
+    Docopt.getArg,
+    Docopt.longOption,
+    Docopt.command,
+    has,
   )
 where
 
diff --git a/Biz/Pie.hs b/Biz/Pie.hs
index 7df794f..ddaa6ee 100644
--- a/Biz/Pie.hs
+++ b/Biz/Pie.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
@@ -34,72 +35,50 @@
 --
 -- : out pie
 -- : dep aeson
+-- : dep docopt
+-- : dep haskeline
 -- : dep protolude
--- : dep optparse-simple
 -- : dep parsec
--- : dep haskeline
+-- : dep tasty
+-- : dep tasty-hunit
 module Biz.Pie
   ( main,
   )
 where
 
 import Alpha
+import qualified Biz.Cli as Cli
+import Biz.Test ((@=?))
+import qualified Biz.Test as Test
 import qualified Data.Aeson as Aeson
-import qualified Data.List as List
 import qualified Data.Maybe as Maybe
 import qualified Data.Text as Text
 import qualified Data.Time as Time
-import Options.Applicative.Simple
 import qualified System.Console.Haskeline as Haskeline
 import qualified System.Directory as Directory
-import qualified System.Environment as Env
 import qualified System.Exit as Exit
 import qualified System.Process as Process
 import qualified Text.Parsec as Parsec
 import qualified Text.Parsec.String as Parsec
 
 main :: IO ()
-main = do
-  (ns, mov) <-
-    simpleOptions
-      "dev"
-      "[P]roduct [I]mprovement [E]ngine"
-      "manages .pie files, records data from product build sprints and user testing"
-      (pure mempty)
-      <| do
-        addCommand
-          "new"
-          "start new a weekly sprint"
-          (const <. move New)
-          (pure mempty)
-        addCommand
-          "update"
-          "submit weekly update for a namespace"
-          (move <. Update)
-          optNamespace
-        addCommand
-          "feedback"
-          "submit user feedback for a namespace"
-          (move <. Feedback)
-          optNamespace
-  cwd <- Directory.getCurrentDirectory
-  root <- Env.getEnv "BIZ_ROOT"
-  let fullNamespace =
-        require "namespace" <| List.stripPrefix "/"
-          <| ((cwd List.\\ root) <> "/" <> Text.unpack ns)
-  putText <| "ns:" <> ns
-  putText <| "fullNamespace:" <> ns
-  oldForm <- loadForm fullNamespace
-  newForm <- mov oldForm
-  saveForm (Text.unpack ns) newForm
-
-optNamespace :: Parser String
-optNamespace =
-  strOption
-    <| help "the namespace of the app you are working on"
-    <> long "namespace"
-    <> short 'n'
-    <> value "Devalloc"
+main = Cli.main <| Cli.Plan help move test
+
+test :: Test.Tree
+test = Test.group "Biz.Pie" [Test.unit "id" <| 1 @=? (1 :: Integer)]
+
+help :: Cli.Docopt
+help =
+  [Cli.docopt|
+[p]roduct [i]mprovement [e]ngine
+manages .pie files, records data from product build sprints and user testing
+
+Usage:
+  pie new
+  pie update <ns>
+  pie feedback <ns>
+  pie test
+|]
 
 newtype Form = Form {roll :: [Entry]}
   deriving (Generic, Aeson.ToJSON, Aeson.FromJSON, Show)
@@ -133,8 +112,18 @@ data Move
   | Update String
   | Feedback String
 
-move :: Move -> Form -> IO Form
-move mov form = case mov of
+fromArgs :: Cli.Arguments -> Move
+fromArgs args
+  | cmd "new" = New
+  | cmd "update" = Update <| getArg "ns"
+  | cmd "feedback" = Feedback <| getArg "ns"
+  | otherwise = panic "could not get move from args"
+  where
+    cmd a = args `Cli.has` Cli.command a
+    getArg a = Maybe.fromJust <| args `Cli.getArg` Cli.argument a
+
+move :: Cli.Arguments -> IO ()
+move args = case fromArgs args of
   New -> do
     week <- Time.getCurrentTime >>= return <. Time.formatTime Time.defaultTimeLocale "%V"
     let branch = "sprint-" <> week
@@ -144,9 +133,9 @@ move mov form = case mov of
         Process.callProcess "git" ["switch", branch]
       Exit.ExitFailure _ ->
         Process.callProcess "git" ["switch", "-c", branch]
-      >> return form
   Update namespace ->
     Haskeline.runInputT Haskeline.defaultSettings <| do
+      form <- liftIO <| loadForm namespace
       timestamp <- liftIO Time.getCurrentTime
       onTrack <- parseBool </ question "Are you on track?"
       isLaunched <- parseBool </ question "Are you launched?"
@@ -157,13 +146,14 @@ move mov form = case mov of
       mostImprovement <- parseText </ question "What most improved your primary metric?"
       biggestObstacle <- parseText </ question "What is your biggest obstacle?"
       goals <- parseText </ question "What are your top 1-3 goals for next week?"
-      return <| form {roll = BuildSprint {..} : roll form}
+      liftIO <| saveForm namespace <| form {roll = BuildSprint {..} : roll form}
   Feedback namespace ->
     Haskeline.runInputT Haskeline.defaultSettings <| do
+      form <- liftIO <| loadForm namespace
       timestamp <- liftIO Time.getCurrentTime
       user <- parseText </ question "User?"
       howDisappointed <- parseDisappointment </ question "How disappointed? (1=very, 2=somewhat, 3=not)"
-      return <| form {roll = UserFeedback {..} : roll form}
+      liftIO <| saveForm namespace <| form {roll = UserFeedback {..} : roll form}
 
 question :: String -> Haskeline.InputT IO String
 question q = Maybe.fromJust </ (Haskeline.getInputLine <| q ++ " ")
diff --git a/Biz/Que/Host.hs b/Biz/Que/Host.hs
index f41c683..ce3f5da 100644
--- a/Biz/Que/Host.hs
+++ b/Biz/Que/Host.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
 -- | Interprocess communication
@@ -14,10 +15,13 @@
 -- : out que-server
 --
 -- : dep async
+-- : dep docopt
 -- : dep envy
 -- : dep protolude
 -- : dep scotty
 -- : dep stm
+-- : dep tasty
+-- : dep tasty-hunit
 -- : dep unagi-chan
 -- : dep unordered-containers
 module Biz.Que.Host
@@ -26,6 +30,9 @@ module Biz.Que.Host
 where
 
 import Alpha hiding (gets, modify, poll)
+import qualified Biz.Cli as Cli
+import Biz.Test ((@=?))
+import qualified Biz.Test as Test
 import qualified Control.Concurrent.Go as Go
 import qualified Control.Concurrent.STM as STM
 import qualified Control.Exception as Exception
@@ -49,7 +56,10 @@ import qualified Prelude
 {-# ANN module ("HLint: ignore Reduce duplication" :: Prelude.String) #-}
 
 main :: IO ()
-main = Exception.bracket startup shutdown <| uncurry Warp.run
+main = Cli.main <| Cli.Plan help move test
+
+move :: Cli.Arguments -> IO ()
+move _ = Exception.bracket startup shutdown <| uncurry Warp.run
   where
     startup =
       Envy.decodeWithDefaults Envy.defConfig >>= \c -> do
@@ -64,6 +74,19 @@ main = Exception.bracket startup shutdown <| uncurry Warp.run
     shutdown :: a -> IO a
     shutdown = pure <. identity
 
+help :: Cli.Docopt
+help =
+  [Cli.docopt|
+que-server
+
+Usage:
+  que-server
+  que-server test
+|]
+
+test :: Test.Tree
+test = Test.group "Biz.Que.Host" [Test.unit "id" <| 1 @=? (1 :: Integer)]
+
 newtype App a = App
   { runApp :: ReaderT (STM.TVar AppState) IO a
   }
diff --git a/Biz/Que/Site.hs b/Biz/Que/Site.hs
index 99486a4..c4a6e0d 100644
--- a/Biz/Que/Site.hs
+++ b/Biz/Que/Site.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
@@ -8,16 +9,22 @@
 -- : out que-website
 --
 -- : dep async
+-- : dep docopt
 -- : dep config-ini
 -- : dep process
 -- : dep protolude
 -- : dep req
+-- : dep tasty
+-- : dep tasty-hunit
 module Biz.Que.Site
   ( main,
   )
 where
 
 import Alpha
+import qualified Biz.Cli as Cli
+import Biz.Test ((@=?))
+import qualified Biz.Test as Test
 import qualified Control.Concurrent.Async as Async
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.Ini.Config as Config
@@ -32,12 +39,11 @@ import System.FilePath ((</>))
 import qualified System.Process as Process
 
 main :: IO ()
-main = do
-  (src, ns) <-
-    Environment.getArgs >>= \case
-      [src] -> return (src, "_") -- default to _ ns which is special
-      [src, ns] -> return (src, Text.pack ns)
-      _ -> Exit.die "usage: que-website <srcdir> [namespace]"
+main = Cli.main <| Cli.Plan help move test
+
+move :: Cli.Arguments -> IO ()
+move args = do
+  let (Just src, Just ns) = (getArg "src", Text.pack </ getArg "ns")
   mKey <- getKey ns
   putText <| "serving " <> Text.pack src <> " at " <> ns
   run mKey ns
@@ -49,6 +55,21 @@ main = do
         apidocs = src </> "Apidocs.md",
         tutorial = src </> "Tutorial.md"
       }
+  where
+    getArg = Cli.getArg args <. Cli.argument
+
+help :: Cli.Docopt
+help =
+  [Cli.docopt|
+que-website
+
+Usage:
+  que-website <src> <ns>
+  que-website test
+|]
+
+test :: Test.Tree
+test = Test.group "Biz.Que.Site" [Test.unit "id" <| 1 @=? (1 :: Integer)]
 
 getKey :: Namespace -> IO (Maybe Key)
 getKey ns = do