diff options
| -rw-r--r-- | Biz/Bild.hs | 23 | ||||
| -rw-r--r-- | Biz/Bild/ShellHook.sh | 2 | ||||
| -rw-r--r-- | Biz/Cli.hs | 4 | ||||
| -rw-r--r-- | Biz/Pie.hs | 92 | ||||
| -rw-r--r-- | Biz/Que/Host.hs | 25 | ||||
| -rw-r--r-- | Biz/Que/Site.hs | 33 |
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" @@ -10,6 +10,10 @@ module Biz.Cli Docopt.argument, Docopt.docopt, Docopt.getAllArgs, + Docopt.getArg, + Docopt.longOption, + Docopt.command, + has, ) where @@ -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 |