aboutsummaryrefslogtreecommitdiffstats
path: root/app
diff options
context:
space:
mode:
Diffstat (limited to 'app')
-rw-r--r--app/History/CommitHash.hs14
-rw-r--r--app/History/CommitInfo.hs4
-rw-r--r--app/History/IssueEvent.hs28
-rw-r--r--app/Issue/Filter.hs15
-rw-r--r--app/Issue/Group.hs16
-rw-r--r--app/Issue/Meta.hs24
-rw-r--r--app/Issue/Render.hs88
-rw-r--r--app/Issue/Tag.hs54
-rw-r--r--app/Main.hs352
-rw-r--r--app/Patch.hs35
-rw-r--r--app/Render.hs196
11 files changed, 482 insertions, 344 deletions
diff --git a/app/History/CommitHash.hs b/app/History/CommitHash.hs
index f1b8283..cbe4db1 100644
--- a/app/History/CommitHash.hs
+++ b/app/History/CommitHash.hs
@@ -8,6 +8,7 @@ where
import Data.Binary (Binary)
import Data.Text qualified as T
import GHC.Generics (Generic)
+import Render qualified as P
data CommitHash
= WorkingTree
@@ -21,3 +22,16 @@ toShortText (Commit hash) = T.take 7 hash
toText :: CommitHash -> T.Text
toText WorkingTree = "<dirty>"
toText (Commit hash) = hash
+
+instance P.Render CommitHash where
+ render = P.render . P.Detailed
+
+instance P.Render (P.Detailed CommitHash) where
+ render (P.Detailed commitHash) =
+ P.styled [P.color P.Yellow] $
+ P.render (toText commitHash)
+
+instance P.Render (P.Summarized CommitHash) where
+ render (P.Summarized commitHash) =
+ P.styled [P.color P.Yellow] $
+ P.render (toShortText commitHash)
diff --git a/app/History/CommitInfo.hs b/app/History/CommitInfo.hs
index c5224b2..2c861a6 100644
--- a/app/History/CommitInfo.hs
+++ b/app/History/CommitInfo.hs
@@ -20,7 +20,7 @@ import History.PartialCommitInfo (PartialCommitInfo (..))
import Issue (Issue (..))
import Issue.Provenance qualified as I
import Parallel (parSequence)
-import Patch qualified as P
+import Patch qualified as A
import Process (sh)
import System.FilePath ((</>))
import System.IO.Temp (withSystemTempDirectory)
@@ -110,7 +110,7 @@ diffCommitInfos maybeOldInfo newInfo =
let cwd = tmp
T.writeFile (tmp </> "old") old
T.writeFile (tmp </> "new") new
- P.parse . LT.toStrict . LT.decodeUtf8 <$> sh ("git diff --no-index -- old new || :" & setWorkingDir cwd)
+ A.parse . LT.toStrict . LT.decodeUtf8 <$> sh ("git diff --no-index -- old new || :" & setWorkingDir cwd)
mergeListsBy :: (a -> a -> Bool) -> (a -> a -> b) -> (a -> b) -> (a -> b) -> [a] -> [a] -> [b]
mergeListsBy eq onBoth onLeft onRight lefts rights =
diff --git a/app/History/IssueEvent.hs b/app/History/IssueEvent.hs
index 0900f13..93bd133 100644
--- a/app/History/IssueEvent.hs
+++ b/app/History/IssueEvent.hs
@@ -2,7 +2,10 @@ module History.IssueEvent (IssueEvent (..)) where
import History.CommitHash (CommitHash)
import Issue (Issue)
+import Issue.Render qualified as I
import Patch (Patch)
+import Render ((<<<))
+import Render qualified as P
data IssueEvent
= IssueCreated
@@ -22,3 +25,28 @@ data IssueEvent
patch :: Patch
}
deriving (Show)
+
+instance P.Render IssueEvent where
+ render = P.render . P.Detailed
+
+instance P.Render (P.Detailed IssueEvent) where
+ render (P.Detailed issueEvent) =
+ P.Summarized issueEvent
+ <<< P.hardline @P.AnsiStyle
+ <<< issueEvent.patch
+
+instance P.Render (P.Summarized IssueEvent) where
+ render (P.Summarized issueEvent) =
+ case issueEvent of
+ IssueCreated {hash, issue} ->
+ P.Summarized hash
+ <<< P.styled [P.color P.Green] "created"
+ <<< I.IssueTitle issue
+ IssueChanged {hash, issue} ->
+ P.Summarized hash
+ <<< P.styled [P.color P.Green] "changed"
+ <<< I.IssueTitle issue
+ IssueDeleted {hash, issue} ->
+ P.Summarized hash
+ <<< P.styled [P.color P.Green] "deleted"
+ <<< I.IssueTitle issue
diff --git a/app/Issue/Filter.hs b/app/Issue/Filter.hs
index e8209a7..68eda87 100644
--- a/app/Issue/Filter.hs
+++ b/app/Issue/Filter.hs
@@ -2,11 +2,14 @@ module Issue.Filter
( Filter,
filterArg,
applyFilters,
+ applyClosed,
+ applyPath,
)
where
import Control.Applicative (liftA2, (<|>))
import Data.Attoparsec.Text qualified as A
+import Data.List (isPrefixOf)
import Data.Text (Text)
import Data.Text qualified as T
import Issue (Issue (..))
@@ -132,3 +135,15 @@ op (Ge) = flip (>=)
op (Gt) = flip (>)
op (Le) = flip (<=)
op (Lt) = flip (<)
+
+applyClosed :: Bool -> [Issue] -> [Issue]
+applyClosed closed = filter (\issue -> closed || not issue.closed)
+
+applyPath :: [FilePath] -> [Issue] -> [Issue]
+applyPath files =
+ filter
+ ( \issue ->
+ if null files
+ then True
+ else any (`isPrefixOf` issue.file) files
+ )
diff --git a/app/Issue/Group.hs b/app/Issue/Group.hs
index 69caf20..2f19a98 100644
--- a/app/Issue/Group.hs
+++ b/app/Issue/Group.hs
@@ -1,15 +1,13 @@
module Issue.Group
( groupArg,
- groupIssuesBy,
+ groupIssuesByTag,
)
where
import Data.Map (Map)
import Data.Map qualified as M
-import Data.Maybe (mapMaybe)
import Data.Text qualified as T
import Issue (Issue (..))
-import Issue.Tag (Tag (..))
import Issue.Tag qualified as I
import Options.Applicative qualified as O
@@ -28,20 +26,14 @@ groupArg =
| "@" `T.isPrefixOf` s = Just (T.drop 1 s)
| otherwise = Nothing
-groupIssuesBy :: T.Text -> [Issue] -> Map T.Text [Issue]
-groupIssuesBy group issues =
+groupIssuesByTag :: T.Text -> [Issue] -> Map T.Text [Issue]
+groupIssuesByTag tagKey issues =
foldl
( \collected issue ->
foldl
(flip $ M.alter (Just . maybe [issue] (issue :)))
collected
- (groupsOfIssue group issue)
+ (I.tagValuesOf tagKey (issue.tags ++ issue.internalTags))
)
M.empty
issues
-
-groupsOfIssue :: T.Text -> Issue -> [T.Text]
-groupsOfIssue group issue =
- mapMaybe I.tagValue
- . filter (\(Tag key _) -> key == group)
- $ issue.tags ++ issue.internalTags
diff --git a/app/Issue/Meta.hs b/app/Issue/Meta.hs
index 19ccab3..6e3bbf0 100644
--- a/app/Issue/Meta.hs
+++ b/app/Issue/Meta.hs
@@ -4,8 +4,13 @@ module Issue.Meta
)
where
+import Data.List (intersperse)
+import Data.Text qualified as T
import Issue (Issue (..))
-import Issue.Tag (Tag, tagValue)
+import Issue.Render ()
+import Issue.Tag (Tag, TagKey (..), tagValue)
+import Render ((<<<))
+import Render qualified as P
data Meta = Meta
{ referencedBy :: [(Issue, Tag)]
@@ -24,3 +29,20 @@ getMeta issues issue =
)
issues
}
+
+instance P.Render Meta where
+ render meta =
+ if (not $ null meta.referencedBy)
+ then
+ P.styled [P.italicized]
+ . (P.vsep . intersperse P.hardline)
+ $ map
+ ( \(otherIssue, tag) ->
+ ("This commit was referenced by issue " :: T.Text)
+ <<< P.Linked otherIssue
+ <<< (" (" :: T.Text)
+ <<< TagKey tag
+ <<< (")." :: T.Text)
+ )
+ meta.referencedBy
+ else P.emptyDoc
diff --git a/app/Issue/Render.hs b/app/Issue/Render.hs
new file mode 100644
index 0000000..ea504d5
--- /dev/null
+++ b/app/Issue/Render.hs
@@ -0,0 +1,88 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Issue.Render
+ ( IssueTitle (..),
+ IssueDescription (..),
+ IssueTags (..),
+ IssueOpenedOn (..),
+ IssueOpenedBy (..),
+ )
+where
+
+import Data.List (intersperse)
+import Data.Map qualified as M
+import Data.Text qualified as T
+import Data.Time.Clock (UTCTime (utctDay))
+import Issue (Issue (..))
+import Issue.Provenance (Author (..), Commit (..), Provenance (..))
+import Render ((<<<))
+import Render qualified as P
+
+instance P.Render (P.Detailed Issue) where
+ render (P.Detailed issue) = P.renderAsMarkdown issue.rawText
+
+instance P.Render Issue where
+ render = P.render . P.Detailed
+
+newtype IssueTitle = IssueTitle {unIssueTitle :: Issue}
+
+instance P.Render IssueTitle where
+ render (IssueTitle issue)
+ | issue.closed = P.styled [P.colorDull P.Red] $ P.render issue.title
+ | otherwise = P.styled [(P.color P.Green)] $ P.render issue.title
+
+newtype IssueDescription = IssueDescription {unIssueDescription :: Issue}
+
+instance P.Render IssueDescription where
+ render (IssueDescription issue) = maybe P.emptyDoc P.pretty issue.description
+
+instance P.Render (P.Linked Issue) where
+ render (P.Linked issue)
+ | issue.closed =
+ P.styled [P.underlined, P.colorDull P.Red] $
+ ("(closed)" :: T.Text) <<< P.render issue.id
+ | otherwise =
+ P.styled [P.underlined, (P.color P.Green)] $
+ P.render issue.id
+
+instance P.Render (P.Summarized Issue) where
+ render (P.Summarized issue) =
+ P.nest 4 $
+ IssueTitle issue
+ <<< IssueTags issue
+ <<< IssueOpenedOn issue
+ <<< IssueOpenedBy issue
+
+newtype IssueTags = IssueTags {unIssueTags :: Issue}
+
+instance P.Render IssueTags where
+ render (IssueTags issue) = P.render issue.tags
+
+newtype IssueOpenedBy = IssueOpenedBy {unIssueOpenedBy :: Issue}
+
+instance P.Render IssueOpenedBy where
+ render (IssueOpenedBy issue) =
+ ("by" :: T.Text) <<< issue.provenance.first.author.name
+
+newtype IssueOpenedOn = IssueOpenedOn {unIssueOpenedOn :: Issue}
+
+instance P.Render IssueOpenedOn where
+ render (IssueOpenedOn issue) =
+ ("on" :: T.Text) <<< utctDay issue.provenance.first.date
+
+instance P.Render (T.Text, M.Map T.Text [Issue]) where
+ render (tagKey, groupedIssues) =
+ (P.vsep . intersperse ("" :: P.Doc ann)) $
+ concatMap
+ ( \(name, issues) ->
+ ( P.styled [P.underlined] $
+ ("@" <> tagKey)
+ <<< name
+ <<< P.parens @P.AnsiStyle (P.pretty (length issues))
+ )
+ : map
+ (P.indent 4)
+ ( map (P.render . IssueTitle) issues
+ )
+ )
+ (M.toList groupedIssues)
diff --git a/app/Issue/Tag.hs b/app/Issue/Tag.hs
index ca550aa..b0d4d3c 100644
--- a/app/Issue/Tag.hs
+++ b/app/Issue/Tag.hs
@@ -4,15 +4,22 @@ module Issue.Tag
tagKey,
tagValue,
tagValuesOf,
+ TagKey (..),
+ TagValue (..),
)
where
import CMark qualified as D
import Data.Binary (Binary)
-import Data.Maybe (catMaybes, mapMaybe)
+import Data.List (intersperse)
+import Data.Map qualified as M
+import Data.Maybe (catMaybes, isJust, mapMaybe)
+import Data.Set qualified as S
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Generics (Generic)
+import Render ((<<<))
+import Render qualified as P
data Tag = Tag Text (Maybe Text) deriving (Show, Generic, Binary, Eq)
@@ -53,3 +60,48 @@ extractTags = collect . D.commonmarkToNode []
. T.words
)
. T.lines
+
+instance P.Render Tag where
+ render tag
+ | isJust (tagValue tag) = TagKey tag <<< (" " :: T.Text) <<< TagValue tag
+ | otherwise = P.render (TagKey tag)
+
+newtype TagKey = TagKey {unTagKey :: Tag}
+
+instance P.Render TagKey where
+ render (TagKey tag) =
+ P.styled [P.bold, P.color P.Yellow] $
+ P.render ("@" <> tagKey tag)
+
+newtype TagValue = TagValue {unTagValue :: Tag}
+
+instance P.Render TagValue where
+ render (TagValue tag) =
+ maybe P.emptyDoc (P.styled [P.color P.Yellow] . P.render) $
+ tagValue tag
+
+instance P.Render [Tag] where
+ render tags =
+ P.vsep $
+ map
+ ( \(tagKey, tagValues) ->
+ TagKey (Tag tagKey Nothing)
+ <<< (P.hcat . intersperse P.comma)
+ (map (P.render . TagValue) (map (Tag tagKey . Just) tagValues))
+ )
+ tagsAndValues
+ where
+ tagsAndValues :: [(T.Text, [T.Text])]
+ tagsAndValues =
+ (M.toList . M.map S.toList)
+ . foldl
+ ( flip
+ ( \tag ->
+ let vs = maybe S.empty S.singleton (tagValue tag)
+ in M.alter
+ (Just . maybe vs (S.union vs))
+ (tagKey tag)
+ )
+ )
+ M.empty
+ $ tags
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_
diff --git a/app/Patch.hs b/app/Patch.hs
index f1c547a..0600a34 100644
--- a/app/Patch.hs
+++ b/app/Patch.hs
@@ -1,16 +1,14 @@
module Patch
( Patch,
parse,
- render,
)
where
import Control.Exception (throw)
import Data.Text qualified as T
import Exception qualified as E
-import Prettyprinter (pretty)
-import Prettyprinter qualified as P
-import Prettyprinter.Render.Terminal qualified as P
+import Render ((<<<))
+import Render qualified as P
import Text.Diff.Parse qualified as D
import Text.Diff.Parse.Types qualified as D
@@ -22,16 +20,19 @@ newtype Patch = Patch
parse :: T.Text -> Patch
parse = either (throw . E.InvalidDiff) Patch . D.parseDiff
-render :: Patch -> P.Doc P.AnsiStyle
-render (Patch {..}) =
- P.vsep $ map prettyFileDelta fileDeltas
- where
- prettyFileDelta (D.FileDelta {..}) = prettyContent fileDeltaContent
- prettyContent D.Binary = P.emptyDoc
- prettyContent (D.Hunks hunks) = P.vsep (map prettyHunk hunks)
- prettyHunk (D.Hunk {..}) = P.vsep $ map prettyLine hunkLines
- prettyLine (D.Line {..}) =
- case lineAnnotation of
- D.Added -> P.annotate (P.color P.Green) $ P.pretty ("+" :: T.Text) <> pretty lineContent
- D.Removed -> P.annotate (P.color P.Red) $ P.pretty ("-" :: T.Text) <> pretty lineContent
- D.Context -> P.annotate (P.color P.White) $ P.pretty (" " :: T.Text) <> pretty lineContent
+instance P.Render Patch where
+ render = P.render . P.Detailed
+
+instance P.Render (P.Detailed Patch) where
+ render (P.Detailed (Patch {..})) =
+ P.vsep $ map prettyFileDelta fileDeltas
+ where
+ prettyFileDelta (D.FileDelta {..}) = prettyContent fileDeltaContent
+ prettyContent D.Binary = P.emptyDoc
+ prettyContent (D.Hunks hunks) = P.vsep (map prettyHunk hunks)
+ prettyHunk (D.Hunk {..}) = P.vsep $ map prettyLine hunkLines
+ prettyLine (D.Line {..}) =
+ case lineAnnotation of
+ D.Added -> P.styled [P.color P.Green] $ P.plus @P.AnsiStyle <<< lineContent
+ D.Removed -> P.styled [P.color P.Red] $ P.minus @P.AnsiStyle <<< lineContent
+ D.Context -> P.styled [P.color P.White] $ P.space @P.AnsiStyle <<< lineContent
diff --git a/app/Render.hs b/app/Render.hs
new file mode 100644
index 0000000..2220fb8
--- /dev/null
+++ b/app/Render.hs
@@ -0,0 +1,196 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | This module is an experimental wrapper around the prettyprinter module.
+module Render
+ ( -- * Re-exports
+ module Prettyprinter,
+ module Prettyprinter.Render.Terminal,
+
+ -- * Render
+ Render (..),
+ (<<<),
+ styled,
+
+ -- * Reporting styles
+ Detailed (..),
+ Summarized (..),
+ Linked (..),
+
+ -- * Markdown
+ Markdown (..),
+ renderAsMarkdown,
+
+ -- * Additional symbols
+ plus,
+ minus,
+ )
+where
+
+import CMark qualified as D
+import Data.List (isPrefixOf, isSuffixOf, intersperse)
+import Data.Maybe (catMaybes)
+import Data.Text qualified as T
+import Data.Time.Calendar (Day)
+import Prettyprinter
+import Prettyprinter.Render.Terminal
+
+-- | The render class is a superclass of `Pretty`. It exists to facilitate
+-- reporting styles (see below), as well as decomposing aggregate entities into composable parts (for instance `IssueTitle`, `IssueTags` of `Issue`).
+--
+-- Renderable entities are expected to define `Render (Detailed a)` and default `Render a` to that instance.
+class Render a where
+ render :: a -> Doc AnsiStyle
+ default render :: Pretty a => a -> Doc AnsiStyle
+ render = pretty
+
+instance Render (Doc AnsiStyle) where
+ render = id
+
+instance Render T.Text
+
+instance Render String
+
+instance Render Day where
+ render = render . show
+
+-- | The `(<<<)` combinator concatenates renderables. It takes care of inserting spaces between non-empty renderables automatically, obsoleting prettyprinter's `(<+>)` and `(<>)`.
+(<<<) :: (Render a, Render b) => a -> b -> Doc AnsiStyle
+(<<<) a' b' =
+ case (nonEmpty a', nonEmpty b') of
+ (Nothing, Nothing) -> emptyDoc
+ (Just a, Nothing) -> a
+ (Nothing, Just b) -> b
+ (Just a, Just b) ->
+ if endsWithNL a || startsWithNL b
+ then a <> b
+ else a <> space <> b
+ where
+ nonEmpty x' =
+ let x = render x'
+ in if not (null (show x)) then Just (render x) else Nothing
+ startsWithNL = ("\n" `isPrefixOf`) . show . render
+ endsWithNL = ("\n" `isSuffixOf`) . show . render
+
+-- | `styled` allows to annotate a document with multiple annotations. It obsoletes prettyprinter's `annotate`.
+styled :: [AnsiStyle] -> Doc AnsiStyle -> Doc AnsiStyle
+styled [] doc = doc
+styled as doc = foldl1 (.) (map annotate as) $ doc
+
+-- | The detailed report should present all information, corresponding to the semantics of the `show` command.
+--
+-- It should be the default instance for all data types.
+newtype Detailed a = Detailed {unDetailed :: a}
+
+-- | The summarized report should present most relevant information in a concise way, corresponding to the semantics of the `list` command.
+newtype Summarized a = Summarized {unSummarized :: a}
+
+-- | The linked report should present strictly necessary information. It should be used when one entity refers to another.
+newtype Linked a = Linked {unLinked :: a}
+
+newtype Markdown = Markdown {unMarkdown :: D.Node}
+
+renderAsMarkdown :: T.Text -> Doc AnsiStyle
+renderAsMarkdown = render . Markdown . D.commonmarkToNode []
+
+instance Render Markdown where
+ render = maybe emptyDoc go . rec . unMarkdown
+ where
+ rec (D.Node _ D.SOFTBREAK _) = Nothing
+ rec (D.Node p t ns) = Just $ D.Node p t (catMaybes $ map rec ns)
+
+ go (D.Node _ D.DOCUMENT ns) = vsep (intersperse (pretty ("" :: T.Text)) (map go ns))
+ go (D.Node _ D.THEMATIC_BREAK _) = pretty ("***" :: T.Text)
+ go (D.Node _ D.PARAGRAPH ns) = fillSep $ map go ns
+ go (D.Node _ D.BLOCK_QUOTE ns) =
+ styled [color Black] . fillSep $
+ pretty (">" :: T.Text)
+ : [ align . fillSep $
+ map go ns
+ ++ [pretty ("\n" :: T.Text)]
+ ]
+ go (D.Node _ (D.HTML_BLOCK s) _) =
+ styled [color Yellow] $
+ hsep
+ [ pretty (T.strip s),
+ pretty ("\n" :: T.Text)
+ ]
+ go (D.Node _ (D.CUSTOM_BLOCK _ _) ns) =
+ styled [color Yellow] $
+ hsep $
+ map go ns ++ [pretty ("\n" :: T.Text)]
+ go (D.Node _ (D.CODE_BLOCK _ s) _) =
+ hcat
+ [ styled [color Green] (pretty ("────────────────────\n" :: T.Text)),
+ styled [color Yellow]
+ . vsep
+ . map (styled [color Yellow] . pretty)
+ $ T.lines s,
+ pretty ("\n" :: T.Text),
+ styled [color Green] (pretty ("────────────────────" :: T.Text))
+ ]
+ go (D.Node _ (D.HEADING c) ns) =
+ styled [color Magenta] . fillSep $
+ pretty (T.replicate c "#") : map go ns
+ go (D.Node _ (D.LIST _) ns) =
+ hsep (map ((pretty ("- " :: T.Text)) <>) (map go ns))
+ go (D.Node _ D.ITEM ns) = fillSep (map go ns)
+ go (D.Node _ (D.TEXT s) _) =
+ fillSep . map (pretty . T.strip) $
+ T.words s
+ go (D.Node _ D.LINEBREAK _) = hardline
+ go (D.Node _ (D.HTML_INLINE s) _) =
+ styled [color Yellow] $ pretty (T.strip s)
+ go (D.Node _ (D.CUSTOM_INLINE _ _) ns) =
+ styled [color Yellow] . fillSep $ map go ns
+ go (D.Node _ (D.CODE s) _) =
+ styled [color Yellow] $ pretty (T.strip s)
+ go (D.Node _ D.EMPH ns) = styled [italicized] $ fillSep (map go ns)
+ go (D.Node _ D.STRONG ns) = styled [bold] $ fillSep (map go ns)
+ go (D.Node _ D.SOFTBREAK _) = emptyDoc
+ go (D.Node _ (D.LINK url "") ns) =
+ styled [color Blue] $
+ hcat
+ [ pretty ("[" :: T.Text),
+ hsep (map go ns),
+ pretty ("](" :: T.Text),
+ pretty url,
+ pretty (")" :: T.Text)
+ ]
+ go (D.Node _ (D.LINK url title) ns) =
+ styled [color Blue] $
+ hcat
+ [ pretty ("[" :: T.Text),
+ hsep (map go ns),
+ pretty ("](" :: T.Text),
+ pretty url,
+ pretty (" \"" :: T.Text),
+ pretty title,
+ pretty ("\")" :: T.Text)
+ ]
+ go (D.Node _ (D.IMAGE url "") ns) =
+ styled [color Blue] $
+ hcat
+ [ pretty ("![" :: T.Text),
+ hsep (map go ns),
+ pretty ("](" :: T.Text),
+ pretty url,
+ pretty (")" :: T.Text)
+ ]
+ go (D.Node _ (D.IMAGE url title) ns) =
+ styled [color Blue] $
+ hcat
+ [ pretty ("![" :: T.Text),
+ hsep (map go ns),
+ pretty ("](" :: T.Text),
+ pretty url,
+ pretty (" \"" :: T.Text),
+ pretty title,
+ pretty ("\")" :: T.Text)
+ ]
+
+plus :: Doc ann
+plus = pretty ("+" :: T.Text)
+
+minus :: Doc ann
+minus = pretty ("-" :: T.Text)
generated by cgit v1.2.3 (git 2.25.1) at 2025-01-23 15:24:37 +0000