From 4ea4faa4f6405801de19d0ea56e8bc29aa4362e1 Mon Sep 17 00:00:00 2001 From: Ben Sima 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/Bild.hs | 23 +++++++------ Biz/Bild/ShellHook.sh | 2 +- Biz/Cli.hs | 4 +++ Biz/Pie.hs | 92 +++++++++++++++++++++++---------------------------- Biz/Que/Host.hs | 25 +++++++++++++- Biz/Que/Site.hs | 33 ++++++++++++++---- 6 files changed, 109 insertions(+), 70 deletions(-) (limited to 'Biz') 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 ... + bild [--test] ... 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 + pie feedback + 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 Haskeline.runInputT Haskeline.defaultSettings <| do + form <- liftIO <| loadForm namespace timestamp <- liftIO Time.getCurrentTime user <- parseText Haskeline.InputT IO String question q = Maybe.fromJust 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 [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 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 + 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 -- cgit v1.2.3