diff options
Diffstat (limited to 'app/Main.hs')
| -rw-r--r-- | app/Main.hs | 190 |
1 files changed, 97 insertions, 93 deletions
diff --git a/app/Main.hs b/app/Main.hs index 30495a5..771fd68 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} @@ -65,13 +66,12 @@ module Main where -import Control.Exception (Exception, catch, throw, throwIO) +import Control.Exception (Exception, catch, handle, throw, throwIO) import Data.Aeson qualified as A import Data.ByteString.Lazy qualified as L import Data.ByteString.Lazy.Char8 qualified as L8 -import Data.List (intercalate) +import Data.List (find, intercalate) import Data.Maybe (catMaybes) -import Data.Maybe qualified as Maybe import Data.String qualified as String import Data.Text qualified as T import Issue (Issue (..)) @@ -85,118 +85,113 @@ import Prettyprinter qualified as P import Prettyprinter.Render.Terminal qualified as P import System.Exit (ExitCode (ExitFailure), exitWith) import System.FilePath qualified as F -import System.IO (hPutStrLn, stderr) import System.Process.Typed qualified as P import Text.Printf import TreeGrepper.Match qualified as G import TreeGrepper.Result qualified as G - -data Options = Options - { optCommand :: Command - } - deriving (Show) +import Prelude hiding (id) data Command = List { files :: [String], - filters :: [Filter] + filters :: [Filter], + internalTags :: Bool } | Show - { files :: [String], - filters :: [Filter] + { id :: String } deriving (Show) -commandParser :: O.Parser Command -commandParser = - O.hsubparser - ( O.command "list" (O.info listCommandParser (O.progDesc "List all issues")) - <> O.command "show" (O.info showCommandParser (O.progDesc "Show details of all issues")) - ) +cmd :: O.Parser Command +cmd = + O.hsubparser . mconcat $ + [ O.command "list" . O.info listCmd $ + O.progDesc "List all issues", + O.command "show" . O.info showCmd $ + O.progDesc "Show details of all issues" + ] + +listCmd :: O.Parser Command +listCmd = + List + <$> filesArg + <*> I.filterArg + <*> internalTagsFlag + +showCmd :: O.Parser Command +showCmd = Show <$> idArg -optionsParser :: O.Parser Options -optionsParser = Options <$> commandParser +filesArg :: O.Parser [String] +filesArg = O.many (O.strArgument (O.metavar "FILE" <> O.action "file")) -listCommandParser :: O.Parser Command -listCommandParser = List <$> filesArg <*> I.filterOption +internalTagsFlag :: O.Parser Bool +internalTagsFlag = + O.switch + ( O.long "internal-tags" + <> O.help "Whether to display internal tags." + ) -showCommandParser :: O.Parser Command -showCommandParser = Show <$> filesArg <*> I.filterOption +idArg :: O.Parser String +idArg = + O.strArgument + ( O.metavar "ID" + <> O.completer + ( O.listIOCompleter $ + catMaybes . map I.id <$> listIssues [] [] + ) + ) -filesArg :: O.Parser [String] -filesArg = O.many (O.strArgument (O.metavar "FILE" <> O.action "file")) +die :: String -> IO a +die s = do + printf "error: %s\n" s + exitWith (ExitFailure 1) main :: IO () main = do - options <- O.execParser (O.info (commandParser <**> O.helper) O.idm) - let files - | opts@(List {}) <- options = opts.files - | opts@(Show {}) <- options = opts.files - filePaths <- getFiles files - let filters - | opts@(List {}) <- options = opts.filters - | opts@(Show {}) <- options = opts.filters - issues <- - filter (I.applyFilter filters) - . concat - <$> catch - ( fmap Maybe.catMaybes $ - mapM - (\filename -> catch (fmap Just (getIssues filename)) (forgetGetIssuesExceptions)) - filePaths - ) - ( \(InvalidTreeGrepperResult e) -> - do - hPutStrLn stderr e - exitWith (ExitFailure 1) - ) - case options of - List {} -> listMatches issues - Show {} -> showMatches issues - -showMatches :: [Issue] -> IO () -showMatches issues = do - putDoc . P.vsep $ - map - ( \issue -> - P.vsep - ( concat - [ [P.annotate P.bold (P.pretty issue.title)], - maybe [] ((: []) . P.pretty) issue.description, - map - ( \(I.Tag k v) -> - P.annotate (P.colorDull P.Yellow) $ - P.pretty ("@" `T.append` k `T.append` " " `T.append` v) - ) - issue.tags - ] - ) - ) - issues - -listMatches :: [Issue] -> IO () -listMatches issues = - putDoc . P.vsep $ - map - ( \issue -> - P.hsep - ( concat - [ [P.annotate P.bold (P.pretty issue.title)], - map - ( \(I.Tag k v) -> - P.annotate (P.colorDull P.Yellow) $ - P.pretty ("@" `T.append` k `T.append` ":" `T.append` v) - ) - issue.tags - ] - ) - ) - issues + O.execParser (O.info (cmd <**> O.helper) O.idm) >>= \case + List {filters, files, internalTags} -> do + issues <- listIssues filters files + putDoc . P.vsep $ + map + ( \issue -> + P.hsep + ( concat + [ [P.annotate P.bold (P.pretty issue.title)], + map + ( \(I.Tag k v) -> + P.annotate (P.colorDull P.Yellow) $ + P.pretty ("@" `T.append` k `T.append` ":" `T.append` v) + ) + ( issue.tags + ++ if internalTags then issue.internalTags else [] + ) + ] + ) + ) + issues + Show {id} -> do + issues <- listIssues [] [] + case find ((==) (Just id) . I.id) issues of + Nothing -> die (printf "no issue with id `%s'\n" id) + Just issue -> + putDoc $ + P.vsep + ( concat + [ [P.annotate P.bold (P.pretty issue.title)], + maybe [] ((: []) . P.pretty) issue.description, + map + ( \(I.Tag k v) -> + P.annotate (P.colorDull P.Yellow) $ + P.pretty ("@" `T.append` k `T.append` " " `T.append` v) + ) + issue.tags + ] + ) putDoc :: P.Doc P.AnsiStyle -> IO () putDoc doc = do isTty <- (== 1) <$> c_isatty 1 - P.putDoc . (if isTty then id else P.unAnnotate) $ doc + P.putDoc . (if isTty then (\x -> x) else P.unAnnotate) $ doc foreign import ccall "unistd.h isatty" c_isatty :: Int -> IO Int @@ -214,8 +209,17 @@ data InvalidTreeGrepperResult = InvalidTreeGrepperResult instance Exception InvalidTreeGrepperResult -forgetGetIssuesExceptions :: UnknownFileExtension -> IO (Maybe a) -forgetGetIssuesExceptions _ = pure Nothing +listIssues :: [Filter] -> [FilePath] -> IO [Issue] +listIssues filters files = + filter (I.applyFilter filters) . concat + <$> catch + ( mapM (handle forgetGetIssuesExceptions . getIssues) + =<< getFiles files + ) + (\(InvalidTreeGrepperResult e) -> die e) + where + forgetGetIssuesExceptions :: UnknownFileExtension -> IO [a] + forgetGetIssuesExceptions _ = pure [] getIssues :: FilePath -> IO [Issue] getIssues filename = |