From cfa194b9364413cb5bf815322df6e0fd5c39b8b0 Mon Sep 17 00:00:00 2001 From: Joshua Clayton Date: Sat, 11 Jun 2016 07:15:22 -0400 Subject: [PATCH] Roll up App into a monad transformer stack This introduces a monad transformer stack to cover our reader (options from the CLI) and except (for handling failure cases, initially missing tags or invalid config). This ensures errors are bubbled up appropriately (and halt program execution) and the Options are available in the correct locations within the app. This also separates options parsing (which remains in app/Main.) from translating those options into the correctly executed runner and generated output. --- app/App.hs | 133 +++++++++++++++++++++++++++++++++++++++++++++++++++ app/Main.hs | 85 ++------------------------------ unused.cabal | 1 + 3 files changed, 138 insertions(+), 81 deletions(-) create mode 100644 app/App.hs diff --git a/app/App.hs b/app/App.hs new file mode 100644 index 0000000..2bf9e9c --- /dev/null +++ b/app/App.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} + +module App + ( Options(..) + , runProgram + ) where + +import qualified Data.Bifunctor as B +import Control.Monad.Reader +import Control.Monad.Except +import Unused.Grouping (CurrentGrouping(..), groupedResponses) +import Unused.Types (TermMatchSet, RemovalLikelihood(..)) +import Unused.TermSearch (SearchResults(..), fromResults) +import Unused.ResponseFilter (withOneOccurrence, withLikelihoods, ignoringPaths) +import Unused.Cache +import Unused.TagsSource +import Unused.ResultsClassifier +import Unused.Aliases (termsAndAliases) +import Unused.Parser (parseResults) +import Unused.CLI (SearchRunner(..), renderHeader, executeSearch, withRuntime) +import qualified Unused.CLI.Views as V + +type AppConfig = MonadReader Options + +data AppError + = TagError TagSearchOutcome + | InvalidConfigError [ParseConfigError] + +newtype App a = App { + runApp :: ReaderT Options (ExceptT AppError IO) a +} deriving (Monad, Functor, Applicative, AppConfig, MonadError AppError, MonadIO) + +data Options = Options + { oSearchRunner :: SearchRunner + , oSingleOccurrenceMatches :: Bool + , oLikelihoods :: [RemovalLikelihood] + , oAllLikelihoods :: Bool + , oIgnoredPaths :: [String] + , oGrouping :: CurrentGrouping + , oWithoutCache :: Bool + , oFromStdIn :: Bool + } + +runProgram :: Options -> IO () +runProgram options = withRuntime $ + runExceptT (runReaderT (runApp run) options) >>= either renderError return + +run :: App () +run = do + terms <- termsWithAlternatesFromConfig + + liftIO $ renderHeader terms + results <- withCache . (`executeSearch` terms) =<< searchRunner + + printResults . (`parseResults` results) =<< loadAllConfigs + +termsWithAlternatesFromConfig :: App [String] +termsWithAlternatesFromConfig = do + aliases <- concatMap lcTermAliases <$> loadAllConfigs + terms <- calculateTagInput + + return $ termsAndAliases aliases terms + +renderError :: AppError -> IO () +renderError (TagError e) = V.missingTagsFileError e +renderError (InvalidConfigError e) = V.invalidConfigError e + +printResults :: TermMatchSet -> App () +printResults ts = do + filters <- optionFilters ts + grouping <- groupingOptions + liftIO $ V.searchResults $ groupedResponses grouping filters + +loadAllConfigs :: App [LanguageConfiguration] +loadAllConfigs = do + configs <- liftIO (B.first InvalidConfigError <$> loadAllConfigurations) + either throwError return configs + +calculateTagInput :: App [String] +calculateTagInput = do + tags <- liftIO . fmap (B.first TagError) . loadTags =<< readFromStdIn + either throwError return tags + where + loadTags b = if b then loadTagsFromPipe else loadTagsFromFile + +withCache :: IO SearchResults -> App SearchResults +withCache f = + liftIO . operateCache =<< runWithCache + where + operateCache b = if b then withCache' f else f + withCache' = fmap SearchResults . cached "term-matches" . fmap fromResults + +optionFilters :: AppConfig m => TermMatchSet -> m TermMatchSet +optionFilters tms = foldl (>>=) (pure tms) matchSetFilters + where + matchSetFilters = + [ singleOccurrenceFilter + , likelihoodsFilter + , ignoredPathsFilter + ] + +singleOccurrenceFilter :: AppConfig m => TermMatchSet -> m TermMatchSet +singleOccurrenceFilter tms = do + allowsSingleOccurrence <- oSingleOccurrenceMatches <$> ask + return $ if allowsSingleOccurrence + then withOneOccurrence tms + else tms + +likelihoodsFilter :: AppConfig m => TermMatchSet -> m TermMatchSet +likelihoodsFilter tms = + withLikelihoods . likelihoods <$> ask <*> pure tms + where + likelihoods options + | oAllLikelihoods options = [High, Medium, Low] + | null $ oLikelihoods options = [High] + | otherwise = oLikelihoods options + +ignoredPathsFilter :: AppConfig m => TermMatchSet -> m TermMatchSet +ignoredPathsFilter tms = ignoringPaths . oIgnoredPaths <$> ask <*> pure tms + +readFromStdIn :: AppConfig m => m Bool +readFromStdIn = oFromStdIn <$> ask + +groupingOptions :: AppConfig m => m CurrentGrouping +groupingOptions = oGrouping <$> ask + +searchRunner :: AppConfig m => m SearchRunner +searchRunner = oSearchRunner <$> ask + +runWithCache :: AppConfig m => m Bool +runWithCache = not . oWithoutCache <$> ask diff --git a/app/Main.hs b/app/Main.hs index c5c87fd..ea95863 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,42 +1,14 @@ module Main where -import Control.Monad.IO.Class (liftIO) -import qualified Data.Bifunctor as B -import Control.Monad.Except (ExceptT(..), runExceptT) +import App import Options.Applicative import Data.Maybe (fromMaybe) -import Unused.Parser (parseResults) -import Unused.Types (TermMatchSet, RemovalLikelihood(..)) -import Unused.TermSearch (SearchResults(..), fromResults) -import Unused.ResultsClassifier -import Unused.ResponseFilter (withOneOccurrence, withLikelihoods, ignoringPaths) -import Unused.Grouping (CurrentGrouping(..), groupedResponses) -import Unused.CLI (SearchRunner(..), withRuntime, renderHeader, executeSearch) -import qualified Unused.CLI.Views as V -import Unused.Cache -import Unused.Aliases (termsAndAliases) -import Unused.TagsSource - -data Options = Options - { oSearchRunner :: SearchRunner - , oSingleOccurrenceMatches :: Bool - , oLikelihoods :: [RemovalLikelihood] - , oAllLikelihoods :: Bool - , oIgnoredPaths :: [String] - , oGrouping :: CurrentGrouping - , oWithoutCache :: Bool - , oFromStdIn :: Bool - } - -data AppError - = TagError TagSearchOutcome - | InvalidConfigError [ParseConfigError] +import Unused.Grouping (CurrentGrouping(..)) +import Unused.Types (RemovalLikelihood(..)) +import Unused.CLI (SearchRunner(..)) main :: IO () main = runProgram =<< parseCLI - where - runProgram options = withRuntime $ - runExceptT (run options) >>= either renderError return parseCLI :: IO Options parseCLI = @@ -48,55 +20,6 @@ parseCLI = \ in a codebase that are unused." pFooter = "CLI USAGE: $ unused" -renderError :: AppError -> IO () -renderError (TagError e) = V.missingTagsFileError e -renderError (InvalidConfigError e) = V.invalidConfigError e - -run :: Options -> ExceptT AppError IO () -run options = do - terms' <- withException TagError $ calculateTagInput options - languageConfig <- withException InvalidConfigError loadAllConfigurations - - let terms = termsWithAlternatesFromConfig languageConfig terms' - - liftIO $ renderHeader terms - results <- liftIO $ withCache options $ executeSearch (oSearchRunner options) terms - - liftIO $ printResults options $ parseResults languageConfig results - where - withException e = ExceptT . fmap (B.first e) - -termsWithAlternatesFromConfig :: [LanguageConfiguration] -> [String] -> [String] -termsWithAlternatesFromConfig lcs = - termsAndAliases aliases - where - aliases = concatMap lcTermAliases lcs - -printResults :: Options -> TermMatchSet -> IO () -printResults options = V.searchResults . groupedResponses (oGrouping options) . optionFilters options - -calculateTagInput :: Options -> IO (Either TagSearchOutcome [String]) -calculateTagInput Options{ oFromStdIn = True } = loadTagsFromPipe -calculateTagInput Options{ oFromStdIn = False } = loadTagsFromFile - -withCache :: Options -> IO SearchResults -> IO SearchResults -withCache Options{ oWithoutCache = True } = id -withCache Options{ oWithoutCache = False } = fmap SearchResults . cached "term-matches" . fmap fromResults - -optionFilters :: Options -> (TermMatchSet -> TermMatchSet) -optionFilters o = - foldl1 (.) filters - where - filters = - [ if oSingleOccurrenceMatches o then withOneOccurrence else id - , withLikelihoods likelihoods - , ignoringPaths $ oIgnoredPaths o - ] - likelihoods - | oAllLikelihoods o = [High, Medium, Low] - | null (oLikelihoods o) = [High] - | otherwise = oLikelihoods o - withInfo :: Parser a -> String -> String -> String -> ParserInfo a withInfo opts h d f = info (helper <*> opts) $ header h <> progDesc d <> footer f diff --git a/unused.cabal b/unused.cabal index 527136b..16e7d88 100644 --- a/unused.cabal +++ b/unused.cabal @@ -80,6 +80,7 @@ executable unused , optparse-applicative , mtl , transformers + other-modules: App default-language: Haskell2010 test-suite unused-test