diff options
| -rw-r--r-- | Biz/Bild.hs | 7 | ||||
| -rw-r--r-- | Biz/Cli.hs | 36 | ||||
| -rw-r--r-- | Biz/Devalloc.hs | 25 | ||||
| -rw-r--r-- | Biz/Lint.hs | 20 |
4 files changed, 75 insertions, 13 deletions
diff --git a/Biz/Bild.hs b/Biz/Bild.hs index 96f63ad..60ad97a 100644 --- a/Biz/Bild.hs +++ b/Biz/Bild.hs @@ -116,6 +116,7 @@ module Biz.Bild where import Alpha hiding (sym, (<.>)) +import qualified Biz.Cli as Cli import Biz.Namespace (Namespace (..)) import qualified Biz.Namespace as Namespace import qualified Data.Char as Char @@ -125,15 +126,17 @@ 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 import qualified Prelude main :: IO () -main = Env.getArgs >>= Docopt.parseArgsOrExit help >>= run +main = Cli.main <| Cli.Plan help move test where - run args = + test _ = Exit.exitSuccess + move args = mapM getNamespace (Docopt.getAllArgs args (Docopt.argument "target")) /> catMaybes /> filter isBuildableNs diff --git a/Biz/Cli.hs b/Biz/Cli.hs new file mode 100644 index 0000000..f2d7fad --- /dev/null +++ b/Biz/Cli.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- : dep docopt +module Biz.Cli + ( Plan (..), + main, + Docopt.Docopt (..), + Docopt.Arguments, + Docopt.argument, + Docopt.docopt, + Docopt.getAllArgs, + ) +where + +import Alpha +import qualified System.Console.Docopt as Docopt +import qualified System.Environment as Environment + +data Plan = Plan + { help :: Docopt.Docopt, + move :: Docopt.Arguments -> IO (), + test :: Docopt.Arguments -> IO () + } + +main :: Plan -> IO () +main Plan {..} = + Environment.getArgs + >>= Docopt.parseArgsOrExit help + >>= \args -> + if args `has` Docopt.longOption "test" + then test args + else move args + +has :: Docopt.Arguments -> Docopt.Option -> Bool +has = Docopt.isPresent diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs index 6da2ff6..1134098 100644 --- a/Biz/Devalloc.hs +++ b/Biz/Devalloc.hs @@ -6,6 +6,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -18,6 +19,7 @@ -- : out devalloc -- : dep acid-state -- : dep clay +-- : dep docopt -- : dep envy -- : dep github -- : dep ixset @@ -41,6 +43,7 @@ where import Alpha hiding ((<.>)) import Biz.App (CSS (..), HtmlApp (..)) +import qualified Biz.Cli as Cli import qualified Biz.Look import qualified Clay import qualified Control.Exception as Exception @@ -192,7 +195,22 @@ upsertGitHubUser keep tok ghUser = case GitHub.userEmail ghUser of -- * main and test main :: IO () -main = Exception.bracket startup shutdown run +main = Cli.main <| Cli.Plan help move test + +help :: Cli.Docopt +help = + [Cli.docopt| +devalloc + +Usage: + devalloc [--test] + +Options: + --test Run the tests +|] + +move :: Cli.Arguments -> IO () +move _ = Exception.bracket startup shutdown run where startup = do cfg <- Envy.decodeWithDefaults Envy.defConfig @@ -232,8 +250,8 @@ testCookieSettings = Auth.cookieXsrfSetting = Nothing } -test :: IO Analysis -test = test_analyzeGitHub +test :: Cli.Arguments -> IO () +test _ = test_analyzeGitHub >> pure test_calculateScore >> pure () -- * app configurations @@ -742,6 +760,7 @@ calculateScore numTotal numBlackholes numLiabilities = numGood = numTotal - numBlackholes - numLiabilities maxScore = 100.0 +test_calculateScore :: [Bool] test_calculateScore = [ -- perfect 100 == calculateScore 100 0 0, diff --git a/Biz/Lint.hs b/Biz/Lint.hs index acf59c8..bad0806 100644 --- a/Biz/Lint.hs +++ b/Biz/Lint.hs @@ -9,12 +9,12 @@ module Biz.Lint (main) where import Alpha +import qualified Biz.Cli as Cli import Biz.Namespace (Ext (..), Namespace (..)) import qualified Biz.Namespace as Namespace import qualified Control.Concurrent.Async as Async import qualified Data.String as String import qualified Data.Text as Text -import qualified System.Console.Docopt as Docopt import qualified System.Directory as Directory import qualified System.Environment as Environment import qualified System.Exit as Exit @@ -22,21 +22,25 @@ import System.FilePath ((</>)) import qualified System.Process as Process main :: IO () -main = - Environment.getArgs - >>= Docopt.parseArgsOrExit help - >>= (\args -> return <| Docopt.getAllArgs args (Docopt.argument "file")) +main = Cli.main <| Cli.Plan help move test + +move :: Cli.Arguments -> IO () +move args = + (return <| Cli.getAllArgs args (Cli.argument "file")) >>= \case [] -> changedFiles >>= run >>= mapM printResult >>= exit files -> run (filter notcab files) >>= mapM printResult >>= exit +test :: Cli.Arguments -> IO () +test _ = Exit.exitSuccess + notcab :: FilePath -> Bool notcab ('_' : _) = False notcab _ = True -help :: Docopt.Docopt +help :: Cli.Docopt help = - [Docopt.docopt| + [Cli.docopt| lint Usage: @@ -53,7 +57,7 @@ exit results = Exit.exitWith <| if n > 0 then Exit.ExitFailure n else Exit.ExitS printResult :: Result -> IO Result -- printResult r@(Error err) = (putText <| "lint: error: " <> err) >> pure r -printResult r@(Error err) = pure r +printResult r@(Error _) = pure r printResult r@(Ok path_ linter_ (Bad err)) = (putText <| "lint: badd: " <> Text.pack linter_ <> ": " <> Text.pack path_) >> if err == "" then pure r else putText (Text.pack err) >> pure r |