Implement Biz.Cli

Wraps docopt rather nicely. It's much nicer than optparse-applicative and runs
tests with the --test argument automatically. Next I just need to implement a
test framework.

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