diff options
Diffstat (limited to 'Biz')
| -rw-r--r-- | Biz/Bild.hs | 5 | ||||
| -rw-r--r-- | Biz/Pie.hs | 107 |
2 files changed, 59 insertions, 53 deletions
diff --git a/Biz/Bild.hs b/Biz/Bild.hs index 35ba7f0..2526395 100644 --- a/Biz/Bild.hs +++ b/Biz/Bild.hs @@ -265,7 +265,6 @@ build target@Target {..} = do putText <| show target Nix -> do putText <| "bild: nix: " <> Text.pack namespace - cwd <- Dir.getCurrentDirectory let outDir = root </> "_/bild/nix" Dir.createDirectoryIfMissing True outDir putText <| "bild: nix: remote: " <> Text.pack builder @@ -302,10 +301,6 @@ metaDep = Regex.string "-- : dep " *> Regex.many (Regex.psym Char.isAlpha) metaOut :: Regex.RE Char Out metaOut = Regex.string "-- : out " *> Regex.many (Regex.psym (/= ' ')) -require :: Text -> Maybe a -> a -require _ (Just x) = x -require s Nothing = panic <| s <> " not found" - -- | Replace 'a' in 's' with 'b'. reps :: String -> String -> String -> String reps a b s@(x : xs) = @@ -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 } |