diff options
Diffstat (limited to 'app/Main.hs')
| -rw-r--r-- | app/Main.hs | 352 |
1 files changed, 41 insertions, 311 deletions
diff --git a/app/Main.hs b/app/Main.hs index c1224f9..8a043f7 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -370,40 +370,26 @@ module Main where -import CMark qualified as D import Control.Applicative ((<|>)) -import Control.Monad (when) import Data.Function ((&)) -import Data.List (find, intersperse, isPrefixOf) -import Data.List.Extra (list) -import Data.Map qualified as M -import Data.Maybe (catMaybes, maybeToList) -import Data.Set qualified as S +import Data.List (find, intersperse) import Data.Text qualified as T import Data.Text.IO qualified as T import Data.Text.Lazy qualified as LT import Data.Text.Lazy.IO qualified as LT -import Data.Time.Clock (UTCTime (utctDay)) import History (getHistory) -import History.CommitHash qualified as C -import History.IssueEvent (IssueEvent (..)) import Issue (Issue (..)) import Issue qualified as I -import Issue.Filter (Filter, applyFilters) import Issue.Filter qualified as I import Issue.Group qualified as I import Issue.Meta qualified as I -import Issue.Provenance qualified as I -import Issue.Sort (Sort, applySorts) +import Issue.Render () import Issue.Sort qualified as I -import Issue.Tag qualified as I import Options.Applicative ((<**>)) import Options.Applicative qualified as O -import Patch qualified as P -import Prettyprinter ((<+>)) -import Prettyprinter qualified as P -import Prettyprinter.Render.Terminal qualified as P import Process (proc, sh_, textInput) +import Render ((<<<)) +import Render qualified as P import Settings (Settings (..), readSettings) import System.Console.Terminal.Size qualified as Terminal import System.Exit (ExitCode (ExitFailure), exitWith) @@ -411,7 +397,6 @@ import System.IO (hClose, hFlush) import System.IO.Temp (withSystemTempFile) import System.Process.Typed qualified as P import Text.Printf -import TreeGrepper.Match qualified as G import Tuple () import Prelude hiding (id) @@ -484,8 +469,8 @@ widthOption = data Command = List { files :: [String], - filters :: [Filter], - sort :: [Sort], + filters :: [I.Filter], + sort :: [I.Sort], group :: Maybe T.Text, closed :: Bool } @@ -578,116 +563,43 @@ main :: IO () main = do settings <- readSettings O.execParser (O.info (options <**> O.helper) O.idm) >>= \case - Options {internalTags, colorize, noPager, width, command = List {sort, filters, files, group = Just group, closed}} -> do - let withinPath issue = if null files then True else any (\file -> file `isPrefixOf` issue.file) files + Options {colorize, noPager, width, command = List {sort, filters, files, group = Just group, closed}} -> do ungroupedIssues <- - applySorts sort - . applyFilters filters - . filter withinPath - . applyClosed closed + I.applySorts sort + . I.applyFilters filters + . I.applyPath files + . I.applyClosed closed . (._3) . last <$> getHistory - let groupedIssues = I.groupIssuesBy group ungroupedIssues - putDoc colorize noPager width - . P.vsep - . intersperse ("" :: P.Doc ann) - $ concatMap - ( \(name, issues) -> - ( P.annotate P.underlined $ - ( ( (("@" :: P.Doc ann) <> P.pretty group) <+> P.pretty name - ) - <+> ("(" :: P.Doc ann) - <> P.pretty (length issues) - <> (")" :: P.Doc ann) - ) - ) - : map - (P.indent 4) - ( map - ( \issue -> - let title = map (P.annotate P.bold . P.pretty) (T.words issue.title) - tags = prettyTags (issue.tags ++ if internalTags then issue.internalTags else []) - openedBy = P.annotate (P.color P.Black) ("by" <+> P.pretty issue.provenance.first.author.name) - openedOn = P.annotate (P.color P.Black) ("on" <+> P.pretty (show (utctDay issue.provenance.first.date))) - in P.nest 4 $ - P.fillSep - ( concat $ - [ title, - tags, - [ openedOn, - openedBy - ] - ] - ) - ) - issues - ) - ) - (M.toList groupedIssues) - Options {internalTags, colorize, noPager, width, command = List {sort, filters, files, group = Nothing, closed}} -> do - let withinPath issue = if null files then True else any (\file -> file `isPrefixOf` issue.file) files + let groupedIssues = I.groupIssuesByTag group ungroupedIssues + putDoc colorize noPager width (group, groupedIssues) + Options {colorize, noPager, width, command = List {sort, filters, files, group = Nothing, closed}} -> do issues <- - applySorts sort - . applyFilters filters - . filter withinPath - . applyClosed closed + I.applySorts sort + . I.applyFilters filters + . I.applyPath files + . I.applyClosed closed . (._3) . last <$> getHistory - putDoc colorize noPager width . P.vsep $ - map - ( \issue -> - let title = map (P.annotate P.bold . P.pretty) (T.words issue.title) - tags = prettyTags (issue.tags ++ if internalTags then issue.internalTags else []) - openedBy = P.annotate (P.color P.Black) ("by" <+> (P.pretty (issue.provenance.first.author.name))) - openedOn = P.annotate (P.color P.Black) ("on" <+> (P.pretty (show (utctDay ((issue.provenance.first.date)))))) - in P.nest 4 $ - P.fillSep - ( concat $ - [ title, - tags, - [ openedOn, - openedBy - ] - ] - ) - ) - issues + putDoc colorize noPager width . (P.vsep . intersperse "") $ + map (P.render . P.Summarized) issues Options {colorize, noPager, width, command = Log {patch}} -> do - ess' <- map (\(commitHash, issueEvents, _) -> (commitHash, issueEvents)) <$> getHistory + ess <- concatMap (._2) . reverse <$> getHistory putDoc colorize noPager width . P.vsep $ - concatMap - ( \(hash, es') -> - let shortHash = P.annotate (P.color P.Yellow) . P.pretty $ C.toShortText hash - in map - ( \e -> - let kwd = P.annotate (P.color P.Green) . P.pretty . T.pack - title issue = P.annotate (P.color P.Blue) . P.annotate P.bold $ P.pretty issue.title - in ( case e of - IssueCreated {issue} -> - shortHash <+> kwd "created" <+> title issue - IssueChanged {issue} -> - shortHash <+> kwd "changed" <+> title issue - IssueDeleted {issue} -> - shortHash <+> kwd "deleted" <+> title issue - ) - <+> if patch - then P.hardline <> P.render e.patch - else P.emptyDoc - ) - es' - ) - (reverse ess') + if patch + then map (P.render . P.Detailed) ess + else map (P.render . P.Summarized) ess Options {colorize, noPager, width, command = Show {id = Nothing}} -> do issues <- - applySorts [] - . applyFilters [] - . applyClosed False + I.applySorts [] + . I.applyFilters [] + . I.applyClosed False . (._3) . last <$> getHistory - mapM_ (\issue -> showIssue colorize noPager width issues issue) issues + putDoc colorize noPager width . P.vsep $ map (showIssue issues) issues Options {colorize, noPager, width, command = Show {id = Just id, edit}} -> do issues <- (._3) . last <$> getHistory issue <- @@ -702,8 +614,7 @@ main = do hClose h sh_ (proc "${EDITOR-vi} -- %" fp) I.replaceText issue =<< T.readFile fp - else do - showIssue colorize noPager width issues issue + else putDoc colorize noPager width $ showIssue issues issue Options {colorize, noPager, width, internalTags, command = Tags} -> do issues <- (._3) . last <$> getHistory let tags = @@ -716,198 +627,17 @@ main = do ) ) issues - tagsAndValues = - M.toList - . M.map (S.toList . S.fromList) - . foldl - ( flip - ( \tag -> - let vs = maybe [] (: []) (I.tagValue tag) - in (M.alter (Just . maybe vs (vs ++))) (I.tagKey tag) - ) - ) - M.empty - $ tags - putDoc colorize noPager width . P.vsep $ - map - ( \(tagKey, tagValues) -> - P.annotate P.bold (P.pretty ("@" <> tagKey)) - <+> P.hsep (map P.pretty tagValues) - ) - tagsAndValues - -showIssue :: Color -> Bool -> Maybe Int -> [Issue] -> Issue -> IO () -showIssue colorize noPager width issues issue = do - let meta = I.getMeta issues issue - putDoc colorize noPager width $ - P.vsep - [ P.annotate (P.color P.Green) $ - P.pretty $ - issue.file - ++ ":" - ++ show issue.start.row - ++ "\nvia " - ++ T.unpack (C.toText issue.provenance.first.hash) - ++ "\nby " - ++ T.unpack issue.provenance.first.author.name - ++ " <" - ++ T.unpack issue.provenance.first.author.email - ++ ">\nat " - ++ show issue.provenance.first.date - ++ "\n\n", - render (D.commonmarkToNode [] issue.rawText), - P.pretty $ - "\n@file " - ++ issue.file - ++ "\n@row " - ++ show issue.start.row - ++ "\n", - if (not $ null meta.referencedBy) - then - P.annotate (P.color P.Black) . P.vsep $ - P.pretty ("" :: T.Text) - : map - ( \(otherIssue, tag) -> - P.pretty ("This commit was referenced by issue " :: T.Text) - <> P.annotate P.bold (P.pretty otherIssue.id) - <> P.pretty (" (" :: T.Text) - <> P.annotate P.bold (P.pretty ("@" <> I.tagKey tag)) - <> P.pretty (")." :: T.Text) - ) - meta.referencedBy - else P.emptyDoc - ] - -render = maybe P.emptyDoc go . rec - where - rec (D.Node _ D.SOFTBREAK _) = Nothing - rec (D.Node _ D.THEMATIC_BREAK _) = Nothing - rec (D.Node p t ns) = Just $ D.Node p t (catMaybes $ map rec ns) - - go (D.Node _ D.DOCUMENT ns) = P.vsep (map go ns) - go (D.Node _ D.PARAGRAPH ns) = - P.hsep $ - map go ns - ++ [P.pretty ("\n" :: T.Text)] - go (D.Node _ D.BLOCK_QUOTE ns) = - P.annotate (P.color P.Black) . P.hsep $ - P.pretty (">" :: T.Text) - : [ P.align . P.hsep $ - map go ns - ++ [P.pretty ("\n" :: T.Text)] - ] - go (D.Node _ (D.HTML_BLOCK s) ns) = - P.annotate (P.color P.Green) $ - P.hsep - [ P.pretty (T.strip s), - P.pretty ("\n" :: T.Text) - ] - go (D.Node _ (D.CUSTOM_BLOCK _ _) ns) = - P.annotate (P.color P.Green) $ - P.hsep $ - map go ns - ++ [P.pretty ("\n" :: T.Text)] - go (D.Node _ (D.CODE_BLOCK _ s) ns) = - P.annotate (P.color P.Green) $ - P.hsep - [ P.pretty (T.strip s), - P.pretty ("\n" :: T.Text) - ] - go (D.Node _ (D.HEADING c) ns) = - P.annotate (P.color P.Magenta) . P.hsep $ - P.pretty (T.replicate c "#") - : map go ns - ++ [P.pretty ("\n" :: T.Text)] - go (D.Node _ (D.LIST as) ns) = - P.hsep (map ((P.pretty ("- " :: T.Text)) <>) (map go ns)) - go (D.Node _ D.ITEM ns) = P.hsep (map go ns) - go (D.Node _ (D.TEXT s) ns) = - P.hcat - . intersperse P.softline - . map (P.pretty . T.strip) - $ T.words s - go (D.Node _ D.LINEBREAK _) = P.hardline - go (D.Node _ (D.HTML_INLINE s) _) = - P.annotate (P.color P.Green) $ P.pretty (T.strip s) - go (D.Node _ (D.CUSTOM_INLINE _ _) ns) = - P.annotate (P.color P.Green) . P.hsep $ map go ns - go (D.Node _ (D.CODE s) _) = - P.annotate (P.color P.Green) $ P.pretty (T.strip s) - go (D.Node _ D.EMPH ns) = P.annotate P.italicized $ P.hsep (map go ns) - go (D.Node _ D.STRONG ns) = P.annotate P.bold $ P.hsep (map go ns) - go (D.Node _ D.SOFTBREAK _) = P.emptyDoc - go (D.Node _ (D.LINK url "") ns) = - P.annotate (P.color P.Blue) $ - P.hcat - [ P.pretty ("[" :: T.Text), - P.hsep (map go ns), - P.pretty ("](" :: T.Text), - P.pretty url, - P.pretty (")" :: T.Text) - ] - go (D.Node _ (D.LINK url title) ns) = - P.annotate (P.color P.Blue) $ - P.hcat - [ P.pretty ("[" :: T.Text), - P.hsep (map go ns), - P.pretty ("](" :: T.Text), - P.pretty url, - P.pretty (" \"" :: T.Text), - P.pretty title, - P.pretty ("\")" :: T.Text) - ] - go (D.Node _ (D.IMAGE url "") ns) = - P.annotate (P.color P.Blue) $ - P.hcat - [ P.pretty ("![" :: T.Text), - P.hsep (map go ns), - P.pretty ("](" :: T.Text), - P.pretty url, - P.pretty (")" :: T.Text) - ] - go (D.Node _ (D.IMAGE url title) ns) = - P.annotate (P.color P.Blue) $ - P.hcat - [ P.pretty ("![" :: T.Text), - P.hsep (map go ns), - P.pretty ("](" :: T.Text), - P.pretty url, - P.pretty (" \"" :: T.Text), - P.pretty title, - P.pretty ("\")" :: T.Text) - ] - -applyClosed :: Bool -> [Issue] -> [Issue] -applyClosed closed = filter (\issue -> closed || not issue.closed) - -prettyTags :: [I.Tag] -> [P.Doc P.AnsiStyle] -prettyTags = - map - ( \(key, values) -> - maybe - ( P.annotate P.bold - . P.annotate (P.color P.Yellow) - $ P.pretty ("@" <> key) - ) - ( P.annotate P.bold - . P.annotate (P.color P.Yellow) - . (P.pretty ("@" <> key) <+>) - . P.annotate (P.color P.Yellow) - . P.pretty - ) - (list Nothing (Just . T.intercalate ",") values) - ) - . M.toList - . M.map S.toList - . foldl - ( \dict tag -> - let value = S.fromList (maybeToList (I.tagValue tag)) - in M.alter (Just . maybe value (S.union value)) (I.tagKey tag) dict - ) - M.empty - -putDoc :: Color -> Bool -> Maybe Int -> P.Doc P.AnsiStyle -> IO () -putDoc colorize noPager width doc = do + putDoc colorize noPager width tags + +showIssue :: [Issue] -> Issue -> P.Doc P.AnsiStyle +showIssue issues issue = do + let meta = I.getMeta issues issue + issue + <<< ("\n" :: T.Text) + <<< meta + +putDoc :: P.Render a => Color -> Bool -> Maybe Int -> a -> IO () +putDoc colorize noPager width renderable = do isTty <- (== 1) <$> c_isatty 1 term <- Terminal.size let s = @@ -924,7 +654,7 @@ putDoc colorize noPager width doc = do then (\x -> x) else P.unAnnotate ) - $ doc + $ P.render renderable if not noPager && maybe False (length (LT.lines s) >) (Terminal.height <$> term) then sh_ |