Add optparse-applicative for flags

This introduces the optparse-applicative library for parsing out any
subcommands/flags/args. Currently only supports --no-progress (-P).

app/Main.hs

@@ -1,150 +1,43 @@
 module Main where
 
-import Control.Monad.State
+import Options.Applicative
 import System.IO (hSetBuffering, BufferMode(NoBuffering), stdout)
-import System.Console.ANSI
-import System.ProgressBar
-import Text.Printf
-import Unused.TermSearch (search)
-import Unused.Parser (parseLines, ParseError)
-import Unused.Types
+import Unused.Parser (parseLines)
+import Unused.Types (withOneOccurrence, withOneFile)
+import Unused.CLI (SearchRunner(..), executeSearch, printParseError, printSearchResults, resetScreen)
+
+data Options = Options
+    { oSearchRunner :: SearchRunner
+    }
 
 main :: IO ()
-main = do
+main = run =<< execParser
+    (parseOptions `withInfo` "Analyze potentially unused code")
+
+run :: Options -> IO ()
+run options = do
+    hSetBuffering stdout NoBuffering
+
     terms <- pure . lines =<< getContents
-    results <- executeSearch terms
+    results <- executeSearch (oSearchRunner options) terms
     let response = parseLines $ unlines results
 
     resetScreen
-    case withOneOccurrence $ withOneFile response of
-        Right termMatchSet -> do
-            mapM_ (printDirectorySection $ maxWidth) responses
-          where
-            responses = responsesGroupedByPath termMatchSet
-            allSets = listFromMatchSet =<< map snd responses
-            allResults = fmap snd allSets
-            termLength = return . length . tmTerm
-            maxWidth = maximum $ termLength =<< trMatches =<< allResults
-        Left e ->
-            printParseError e
+
+    either printParseError printSearchResults $
+        withOneOccurrence $ withOneFile response
 
     return ()
 
-executeSearch :: [String] -> IO [String]
-executeSearch terms = do
-    resetScreen
-    printAnalysisHeader terms
-    (results, _) <- runStateT (performSearch $ length terms) terms
-    resetScreen
+withInfo :: Parser a -> String -> ParserInfo a
+withInfo opts desc = info (helper <*> opts) $ progDesc desc
 
-    return $ concat results
+parseOptions :: Parser Options
+parseOptions =
+    Options
+    <$> parseSearchRunner
+        (short 'P' <> long "no-progress" <> help "Don't display progress during analysis")
 
-performSearch :: Int -> StateT [String] IO [[String]]
-performSearch total = do
-    currentTerm <- getSearchTerm
-    searchResults <- liftIO $ search currentTerm
-
-    remainingTerms <- get
-    let remaining = length remainingTerms
-
-    liftIO $ printProgressBar (total - remaining) total
-
-    if remaining > 0
-        then do
-            res <- performSearch total
-            return $ searchResults:res
-        else return [searchResults]
-
-getSearchTerm :: StateT [String] IO String
-getSearchTerm = do
-    (x:xs) <- get
-    put xs
-    return x
-
-printProgressBar :: Int -> Int -> IO ()
-printProgressBar complete total = do
-    let message = "Working"
-    let progressBarWidth = 60
-
-    hSetBuffering stdout NoBuffering
-    progressBar (msg message) percentage progressBarWidth (toInteger complete) (toInteger total)
-
-printAnalysisHeader :: [String] -> IO ()
-printAnalysisHeader terms = do
-    setSGR [SetConsoleIntensity BoldIntensity]
-    putStr "Unused: "
-    setSGR [Reset]
-
-    putStr "analyzing "
-
-    setSGR [SetColor Foreground Dull Green]
-    putStr $ show $ length terms
-    setSGR [Reset]
-    putStr " terms\n\n"
-
-printDirectorySection :: Int -> (DirectoryPrefix, TermMatchSet) -> IO ()
-printDirectorySection w (dir, ss) = do
-    printDirectory dir
-    mapM_ (printTermResults w) $ listFromMatchSet ss
-    putStr "\n"
-
-printDirectory :: DirectoryPrefix -> IO ()
-printDirectory (DirectoryPrefix dir) = do
-    setSGR   [SetColor Foreground Vivid Black]
-    setSGR   [SetConsoleIntensity BoldIntensity]
-    putStrLn dir
-    setSGR   [Reset]
-
-printTermResults :: Int -> (String, TermResults) -> IO ()
-printTermResults w (_, results) =
-    printMatches w results $ trMatches results
-
-likelihoodColor :: RemovalLikelihood -> Color
-likelihoodColor High = Red
-likelihoodColor Medium = Yellow
-likelihoodColor Low = Green
-
-printMatches :: Int -> TermResults -> [TermMatch] -> IO ()
-printMatches w r ms =
-    forM_ ms $ \m -> do
-        setSGR [SetColor Foreground Dull (likelihoodColor $ trRemovalLikelihood r)]
-        setSGR [SetConsoleIntensity NormalIntensity]
-        putStr $ "     " ++ (printf termFormat $ tmTerm m)
-        setSGR [Reset]
-
-        setSGR [SetColor Foreground Vivid Cyan]
-        setSGR [SetConsoleIntensity NormalIntensity]
-        putStr $ (printNumber $ trTotalFiles r) ++ "," ++ (printNumber $ trTotalOccurrences r) ++ " "
-        setSGR [Reset]
-
-        setSGR [SetColor Foreground Dull Cyan]
-        setSGR [SetConsoleIntensity FaintIntensity]
-        putStr $ "  " ++ tmPath m
-        setSGR [Reset]
-        putStr "\n"
-  where
-    termFormat = "%-" ++ (show w) ++ "s"
-    printNumber = printf "%2d"
-
-printParseError :: ParseError -> IO ()
-printParseError e = do
-    setSGR [SetColor Background Vivid Red]
-    setSGR [SetColor Foreground Vivid White]
-    setSGR [SetConsoleIntensity BoldIntensity]
-
-    putStrLn "\nThere was a problem parsing the data:\n"
-
-    setSGR [Reset]
-
-    setSGR [SetColor Foreground Vivid Red]
-    setSGR [SetConsoleIntensity BoldIntensity]
-
-    print e
-    putStr "\n"
-
-    setSGR [Reset]
-
-resetScreen :: IO ()
-resetScreen = do
-    clearScreen
-    setCursorPosition 0 0
+parseSearchRunner :: Mod FlagFields SearchRunner -> Parser SearchRunner
+parseSearchRunner =
+    flag SearchWithProgress SearchWithoutProgress

src/Unused/CLI.hs

@@ -0,0 +1,11 @@
+module Unused.CLI
+    ( module Unused.CLI.Search
+    , module Unused.CLI.SearchError
+    , module Unused.CLI.SearchResult
+    , module Unused.CLI.Util
+    ) where
+
+import Unused.CLI.Search
+import Unused.CLI.SearchError
+import Unused.CLI.SearchResult
+import Unused.CLI.Util

src/Unused/CLI/Search.hs

@@ -0,0 +1,33 @@
+module Unused.CLI.Search
+    ( SearchRunner(..)
+    , executeSearch
+    ) where
+
+import Unused.CLI.SearchWithProgress (searchWithProgressBar)
+import Unused.CLI.SearchWithoutProgress (searchWithoutProgressBar)
+import Unused.CLI.Util
+
+data SearchRunner = SearchWithProgress | SearchWithoutProgress
+
+executeSearch :: SearchRunner -> [String] -> IO [String]
+executeSearch runner terms = do
+    resetScreen
+    printAnalysisHeader terms
+    runSearch runner terms <* resetScreen
+
+printAnalysisHeader :: [String] -> IO ()
+printAnalysisHeader terms = do
+    setSGR [SetConsoleIntensity BoldIntensity]
+    putStr "Unused: "
+    setSGR [Reset]
+
+    putStr "analyzing "
+
+    setSGR [SetColor Foreground Dull Green]
+    putStr $ show $ length terms
+    setSGR [Reset]
+    putStr " terms\n\n"
+
+runSearch :: SearchRunner -> ([String] -> IO [String])
+runSearch SearchWithProgress    = searchWithProgressBar
+runSearch SearchWithoutProgress = searchWithoutProgressBar

src/Unused/CLI/SearchError.hs

@@ -0,0 +1,24 @@
+module Unused.CLI.SearchError
+    ( printParseError
+    ) where
+
+import Unused.Parser (ParseError)
+import Unused.CLI.Util
+
+printParseError :: ParseError -> IO ()
+printParseError e = do
+    setSGR [SetColor Background Vivid Red]
+    setSGR [SetColor Foreground Vivid White]
+    setSGR [SetConsoleIntensity BoldIntensity]
+
+    putStrLn "\nThere was a problem parsing the data:\n"
+
+    setSGR [Reset]
+
+    setSGR [SetColor Foreground Vivid Red]
+    setSGR [SetConsoleIntensity BoldIntensity]
+
+    print e
+    putStr "\n"
+
+    setSGR [Reset]

src/Unused/CLI/SearchResult.hs

@@ -0,0 +1,62 @@
+module Unused.CLI.SearchResult
+    ( printSearchResults
+    ) where
+
+import Control.Monad (forM_)
+import Text.Printf
+import Unused.Types
+import Unused.CLI.Util
+
+printSearchResults :: TermMatchSet -> IO ()
+printSearchResults termMatchSet =
+    mapM_ (printDirectorySection maxWidth) responses
+  where
+    responses = responsesGroupedByPath termMatchSet
+    allSets = listFromMatchSet =<< map snd responses
+    allResults = map snd allSets
+    termLength = return . length . tmTerm
+    maxWidth = maximum $ termLength =<< trMatches =<< allResults
+
+printDirectorySection :: Int -> (DirectoryPrefix, TermMatchSet) -> IO ()
+printDirectorySection w (dir, ss) = do
+    printDirectory dir
+    mapM_ (printTermResults w) $ listFromMatchSet ss
+    putStr "\n"
+
+printDirectory :: DirectoryPrefix -> IO ()
+printDirectory (DirectoryPrefix dir) = do
+    setSGR   [SetColor Foreground Vivid Black]
+    setSGR   [SetConsoleIntensity BoldIntensity]
+    putStrLn dir
+    setSGR   [Reset]
+
+printTermResults :: Int -> (String, TermResults) -> IO ()
+printTermResults w (_, results) =
+    printMatches w results $ trMatches results
+
+likelihoodColor :: RemovalLikelihood -> Color
+likelihoodColor High = Red
+likelihoodColor Medium = Yellow
+likelihoodColor Low = Green
+
+printMatches :: Int -> TermResults -> [TermMatch] -> IO ()
+printMatches w r ms =
+    forM_ ms $ \m -> do
+        setSGR [SetColor Foreground Dull (likelihoodColor $ trRemovalLikelihood r)]
+        setSGR [SetConsoleIntensity NormalIntensity]
+        putStr $ "     " ++ (printf termFormat $ tmTerm m)
+        setSGR [Reset]
+
+        setSGR [SetColor Foreground Vivid Cyan]
+        setSGR [SetConsoleIntensity NormalIntensity]
+        putStr $ (printNumber $ trTotalFiles r) ++ "," ++ (printNumber $ trTotalOccurrences r) ++ " "
+        setSGR [Reset]
+
+        setSGR [SetColor Foreground Dull Cyan]
+        setSGR [SetConsoleIntensity FaintIntensity]
+        putStr $ "  " ++ tmPath m
+        setSGR [Reset]
+        putStr "\n"
+  where
+    termFormat = "%-" ++ (show w) ++ "s"
+    printNumber = printf "%2d"

src/Unused/CLI/SearchWithProgress.hs

@@ -0,0 +1,40 @@
+module Unused.CLI.SearchWithProgress
+    ( searchWithProgressBar
+    ) where
+
+import Control.Monad.State
+import System.ProgressBar
+import Unused.TermSearch (search)
+
+searchWithProgressBar :: [String] -> IO [String]
+searchWithProgressBar terms =
+    (concat . fst) <$> runStateT (performSearch $ length terms) terms
+
+performSearch :: Int -> StateT [String] IO [[String]]
+performSearch total = do
+    currentTerm <- getSearchTerm
+    searchResults <- liftIO $ search currentTerm
+
+    remainingTerms <- get
+    let remaining = length remainingTerms
+
+    liftIO $ printProgressBar (total - remaining) total
+
+    if remaining > 0
+        then do
+            res <- performSearch total
+            return $ searchResults:res
+        else return [searchResults]
+
+getSearchTerm :: StateT [String] IO String
+getSearchTerm = do
+    (x:xs) <- get
+    put xs
+    return x
+
+printProgressBar :: Int -> Int -> IO ()
+printProgressBar complete total = do
+    let message = "Working"
+    let progressBarWidth = 60
+
+    progressBar (msg message) percentage progressBarWidth (toInteger complete) (toInteger total)

src/Unused/CLI/SearchWithoutProgress.hs

@@ -0,0 +1,9 @@
+module Unused.CLI.SearchWithoutProgress
+    ( searchWithoutProgressBar
+    ) where
+
+import Unused.TermSearch (search)
+
+searchWithoutProgressBar :: [String] -> IO [String]
+searchWithoutProgressBar terms =
+    concat <$> mapM search terms

src/Unused/CLI/Util.hs

@@ -0,0 +1,11 @@
+module Unused.CLI.Util
+    ( resetScreen
+    , module System.Console.ANSI
+    ) where
+
+import System.Console.ANSI
+
+resetScreen :: IO ()
+resetScreen = do
+    clearScreen
+    setCursorPosition 0 0

unused.cabal

@@ -20,12 +20,22 @@ library
                      , Unused.Types
                      , Unused.Util
                      , Unused.Regex
+                     , Unused.CLI
+                     , Unused.CLI.Search
+                     , Unused.CLI.SearchError
+                     , Unused.CLI.SearchResult
+                     , Unused.CLI.SearchWithProgress
+                     , Unused.CLI.SearchWithoutProgress
+                     , Unused.CLI.Util
   build-depends:       base >= 4.7 && < 5
                      , process
                      , parsec
                      , containers
                      , filepath
                      , regex-tdfa
+                     , mtl
+                     , terminal-progress-bar
+                     , ansi-terminal
   default-language:    Haskell2010
 
 executable unused
@@ -34,10 +44,7 @@ executable unused
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall
   build-depends:       base
                      , unused
-                     , ansi-terminal
-                     , containers
-                     , terminal-progress-bar
-                     , mtl
+                     , optparse-applicative
   default-language:    Haskell2010
 
 test-suite unused-test