From 4ea4faa4f6405801de19d0ea56e8bc29aa4362e1 Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
Date: Fri, 15 Jan 2021 22:18:03 -0500
Subject: 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.
---
 Biz/Pie.hs | 92 ++++++++++++++++++++++++++++----------------------------------
 1 file changed, 41 insertions(+), 51 deletions(-)

(limited to 'Biz/Pie.hs')

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 ++ " ")
-- 
cgit v1.2.3