Use weekly branch names in pie, and small refactors

1 files changed, 59 insertions, 48 deletions

diff --git a/Biz/Pie.hs b/Biz/Pie.hs
index d414a12..d3fca5f 100644
--- a/Biz/Pie.hs
+++ b/Biz/Pie.hs
@@ -45,12 +45,14 @@ where
 
 import Alpha
 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.Clock as Clock
+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
@@ -63,80 +65,89 @@ main = do
       "dev"
       "[P]roduct [I]mprovement [E]ngine"
       "manages .pie files, records data from product build sprints and user testing"
-      ( strArgument
-          <| help "the namespace of the app you are working on"
-          <> metavar "NAMESPACE"
-          <> value "Devalloc"
-      )
+      (pure mempty)
       <| do
         addCommand
-          "start"
-          "start a sprint"
-          (const . move Start)
+          "new"
+          "start new a weekly sprint"
+          (const . move New)
           (pure mempty)
         addCommand
           "update"
-          "submit update"
-          (const . move Update)
-          (pure mempty)
+          "submit weekly update for a namespace"
+          (move . Update)
+          (optNamespace)
         addCommand
           "feedback"
-          "submit user feedback"
-          (const . move Feedback)
-          (pure mempty)
-  form <- loadForm ns
-  newForm <- mov form {namespace = ns}
-  saveForm ns newForm
-
-type Namespace = String
-
-data Form = Form {namespace :: Namespace, roll :: [Entry]}
+          "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"
+
+data Form = Form {roll :: [Entry]}
   deriving (Generic, Aeson.ToJSON, Aeson.FromJSON, Show)
 
 instance Monoid Form where
-  mempty = Form "" []
+  mempty = Form []
 
 instance Semigroup Form where
-  a <> b = Form (namespace a <> namespace b) (roll a <> roll b)
+  a <> b = Form (roll a <> roll b)
 
 formFile :: String -> FilePath
 formFile ns = ns ++ ".pie"
 
-loadForm :: Namespace -> IO Form
+loadForm :: String -> IO Form
 loadForm ns =
   Directory.doesFileExist file >>= \case
-    False -> touch file >> return mempty
+    False -> return mempty
     True ->
       Aeson.decodeFileStrict file >>= \case
         Nothing -> panic <| Text.pack <| "could not decode: " ++ file
         Just x -> return x
   where
     file = formFile ns
-    touch f = writeFile f ""
 
-saveForm :: Namespace -> Form -> IO ()
-saveForm ns = Aeson.encodeFile (formFile ns)
+saveForm :: String -> Form -> IO ()
+saveForm "" _ = pure ()
+saveForm namespace form = Aeson.encodeFile (formFile namespace) form
 
 data Move
-  = Start
-  | Update
-  | Feedback
+  = New
+  | Update String
+  | Feedback String
 
 move :: Move -> Form -> IO Form
 move mov form = case mov of
-  Start ->
-    let branch = namespace form ++ "/sprint"
-     in Process.spawnProcess "git" ["show-ref", branch]
-          >>= Process.waitForProcess
-          >>= \case
-            Exit.ExitSuccess ->
-              Process.callProcess "git" ["switch", branch]
-            Exit.ExitFailure _ ->
-              Process.callProcess "git" ["switch", "-c", branch]
-          >> return form
-  Update ->
+  New -> do
+    week <- Time.getCurrentTime >>= return . Time.formatTime Time.defaultTimeLocale "%V"
+    let branch = "sprint-" <> week
+    proc <- Process.spawnProcess "git" ["show-ref", branch]
+    Process.waitForProcess proc >>= \case
+      Exit.ExitSuccess ->
+        Process.callProcess "git" ["switch", branch]
+      Exit.ExitFailure _ ->
+        Process.callProcess "git" ["switch", "-c", branch]
+      >> return form
+  Update namespace ->
     Haskeline.runInputT Haskeline.defaultSettings <| do
-      timestamp <- liftIO Clock.getCurrentTime
+      timestamp <- liftIO Time.getCurrentTime
       onTrack <- parseBool </ question "Are you on track?"
       isLaunched <- parseBool </ question "Are you launched?"
       weeksUntilLaunch <- parseInt </ question "How many weeks to launch?"
@@ -147,9 +158,9 @@ move mov form = case mov of
       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}
-  Feedback ->
+  Feedback namespace ->
     Haskeline.runInputT Haskeline.defaultSettings <| do
-      timestamp <- liftIO Clock.getCurrentTime
+      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}
@@ -159,7 +170,7 @@ question q = Maybe.fromJust </ (Haskeline.getInputLine <| q ++ " ")
 
 data Entry
   = BuildSprint
-      { timestamp :: Clock.UTCTime,
+      { timestamp :: Time.UTCTime,
         -- | Last week your goals were X. As of now, do you feel like you're on
         -- track to hit your goals?
         onTrack :: Bool,
@@ -181,7 +192,7 @@ data Entry
         goals :: Text
       }
   | UserFeedback
-      { timestamp :: Clock.UTCTime,
+      { timestamp :: Time.UTCTime,
         user :: Text,
         howDisappointed :: Disappointment
       }