From 23bacb83e6ea67ffdd62be630626ab50ff665abf Mon Sep 17 00:00:00 2001 From: Alexander Foremny Date: Tue, 5 Dec 2023 10:11:54 +0100 Subject: feat: parse issues as markdown --- app/Exception.hs | 10 +++++++ app/History/PartialCommitInfo.hs | 25 ++++++++-------- app/Issue.hs | 18 ++++++++++-- app/Issue/Parser.hs | 61 ++++++++++++++++++++++++++++++++++++++++ app/Issue/Render.hs | 29 +++++++++++++++++-- app/Issue/Tag.hs | 4 +-- app/Issue/Text.hs | 42 ++------------------------- app/Main.hs | 24 ---------------- app/Render.hs | 19 +++++++++++-- 9 files changed, 146 insertions(+), 86 deletions(-) create mode 100644 app/Issue/Parser.hs (limited to 'app') diff --git a/app/Exception.hs b/app/Exception.hs index 49c9cb6..a809616 100644 --- a/app/Exception.hs +++ b/app/Exception.hs @@ -5,12 +5,16 @@ module Exception ProcessException (..), UnknownFileExtension (..), InvalidDiff (..), + InvalidIssue (..), ) where +import CMark qualified as D import Control.Exception import Data.ByteString.Lazy.Char8 as LB +import Data.Void (Void) import System.Exit (ExitCode) +import Text.Megaparsec qualified as P data AnyException = InvalidTreeGrepperResult' InvalidTreeGrepperResult @@ -18,6 +22,7 @@ data AnyException | ProcessException' ProcessException | UnknownFileExtension' UnknownFileExtension | InvalidDiff' InvalidDiff + | InvalidIssue' InvalidIssue deriving (Show) instance Exception AnyException @@ -50,3 +55,8 @@ data InvalidDiff = InvalidDiff String deriving (Show) instance Exception InvalidDiff + +data InvalidIssue = InvalidIssue (P.ParseErrorBundle [D.Node] Void) + deriving (Show) + +instance Exception InvalidIssue diff --git a/app/History/PartialCommitInfo.hs b/app/History/PartialCommitInfo.hs index 21a890a..6d93e88 100644 --- a/app/History/PartialCommitInfo.hs +++ b/app/History/PartialCommitInfo.hs @@ -4,7 +4,7 @@ module History.PartialCommitInfo ) where -import Control.Arrow (second) +import CMark qualified as D import Control.Exception (catch, handle) import Data.Binary (Binary) import Data.ByteString.Lazy.Char8 qualified as LB8 @@ -19,11 +19,13 @@ import Git qualified import History.Cache (cached) import History.CommitHash (CommitHash (..)) import Issue (Issue (..)) +import Issue.Parser qualified as I import Issue.Provenance qualified as I import Issue.Tag qualified as I import Issue.Text qualified as I import Parallel (parMapM) import Process (proc, sh) +import Render qualified as P import System.Directory (getCurrentDirectory) import System.FilePath (()) import System.IO.Temp (withSystemTempDirectory) @@ -85,31 +87,28 @@ fromComment cwd comment = do commit <- I.commitFromHEAD cwd let provenance = I.Provenance commit commit - pure - ( if any (\marker -> T.isPrefixOf marker title') I.issueMarkers - then - Just - Issue + pure $ + ( \parseResult -> + let (markers, title) = + I.stripIssueMarkers (T.pack (show (P.render parseResult.heading))) + in Issue { title = title, - description = description, + description = N.nonEmpty parseResult.paragraphs, file = comment.file, provenance = provenance, start = comment.start, end = comment.end, - tags = maybe [] I.extractTags description, + tags = I.extractTags parseResult.tags, markers = markers, rawText = rawText, commentStyle = commentStyle, - comments = comments, + comments = N.nonEmpty parseResult.comments, closed = False } - else Nothing ) + <$> I.parse I.issueMarkers (D.commonmarkToNode [] rawText) where (commentStyle, rawText) = G.uncomment comment.file_type comment.text - (title', description') = I.extractText rawText - (markers, title) = I.stripIssueMarkers title' - (comments, description) = maybe ([], Nothing) (second Just . I.extractComments) description' dieOfInvalidTreeGrepperResult :: E.InvalidTreeGrepperResult -> IO a dieOfInvalidTreeGrepperResult (E.InvalidTreeGrepperResult e) = diff --git a/app/Issue.hs b/app/Issue.hs index 65afdd6..303862d 100644 --- a/app/Issue.hs +++ b/app/Issue.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Issue ( Issue (..), Provenance (..), @@ -7,7 +9,9 @@ module Issue ) where -import Data.Binary (Binary) +import CMark qualified as D +import Data.Binary (Binary (..)) +import Data.List.NonEmpty (NonEmpty) import Data.Text qualified as T import Data.Text.IO qualified as T import Data.Time.Clock (UTCTime (utctDay)) @@ -15,13 +19,14 @@ import GHC.Generics (Generic) import GHC.Records (HasField (..)) import Issue.Provenance (Author (..), Commit (..), Provenance (..)) import Issue.Tag (Tag (..)) +import Render qualified as P import TreeGrepper.Comment qualified as G import TreeGrepper.Match qualified as G import Prelude hiding (id) data Issue = Issue { title :: T.Text, - description :: Maybe T.Text, + description :: Maybe (NonEmpty D.Node), file :: String, provenance :: Provenance, start :: G.Position, @@ -30,11 +35,18 @@ data Issue = Issue markers :: [T.Text], rawText :: T.Text, commentStyle :: G.CommentStyle, - comments :: [T.Text], + comments :: Maybe (NonEmpty [D.Node]), closed :: Bool } deriving (Show, Binary, Generic, Eq) +-- TODO Resolve Binary D.Node instance +-- +-- @related reduce-cached-data-size +instance Binary D.Node where + put = put . show . P.render + get = D.commonmarkToNode [] <$> get + id :: Issue -> T.Text id issue = toSpinalCase issue.title where diff --git a/app/Issue/Parser.hs b/app/Issue/Parser.hs new file mode 100644 index 0000000..b7cfa4b --- /dev/null +++ b/app/Issue/Parser.hs @@ -0,0 +1,61 @@ +module Issue.Parser + ( ParseResult (..), + parse, + ) +where + +import CMark qualified as D +import Control.Exception (throw) +import Control.Monad (liftM2) +import Data.Text qualified as T +import Data.Void (Void) +import Exception qualified as E +import Text.Megaparsec qualified as P + +data ParseResult = ParseResult + { heading :: D.Node, + paragraphs :: [D.Node], + tags :: [D.Node], + comments :: [[D.Node]] + } + deriving (Show) + +parse :: [T.Text] -> D.Node -> Maybe ParseResult +parse markers (D.Node _ D.DOCUMENT ns) = + either (throw . E.InvalidIssue) id $ + P.parse (parser markers) "" ns +parse _ _ = error "parse: input is no markdown document" + +parser :: [T.Text] -> P.Parsec Void [D.Node] (Maybe ParseResult) +parser markers = + P.optional (P.satisfy (isMarkerNode markers)) >>= \case + Just heading -> + Just + <$> ( ParseResult heading + <$> P.takeWhileP + Nothing + (not . liftM2 (||) isCommentNode isTagNode) + <*> P.takeWhileP Nothing isTagNode + <*> P.many + ( (:) + <$> P.satisfy isCommentNode + <*> P.takeWhileP Nothing (not . isCommentNode) + ) + <* P.eof + ) + Nothing -> pure Nothing + +isCommentNode :: D.Node -> Bool +isCommentNode (D.Node _ D.PARAGRAPH (D.Node _ (D.TEXT s) _ : _)) = + "COMMENT" `T.isPrefixOf` s +isCommentNode _ = False + +isTagNode :: D.Node -> Bool +isTagNode (D.Node _ D.PARAGRAPH (D.Node _ (D.TEXT s) _ : _)) = + "@" `T.isPrefixOf` s +isTagNode _ = False + +isMarkerNode :: [T.Text] -> D.Node -> Bool +isMarkerNode markers (D.Node _ D.PARAGRAPH (D.Node _ (D.TEXT s) _ : _)) = + any (`T.isPrefixOf` s) markers +isMarkerNode _ _ = False diff --git a/app/Issue/Render.hs b/app/Issue/Render.hs index ea504d5..ed40ed7 100644 --- a/app/Issue/Render.hs +++ b/app/Issue/Render.hs @@ -4,12 +4,14 @@ module Issue.Render ( IssueTitle (..), IssueDescription (..), IssueTags (..), + IssueComments (..), IssueOpenedOn (..), IssueOpenedBy (..), ) where import Data.List (intersperse) +import Data.List.NonEmpty qualified as N import Data.Map qualified as M import Data.Text qualified as T import Data.Time.Clock (UTCTime (utctDay)) @@ -18,8 +20,22 @@ import Issue.Provenance (Author (..), Commit (..), Provenance (..)) import Render ((<<<)) import Render qualified as P +-- TODO Easily separate renderables by newlines +-- +-- For convenience, the (<<<) combinator adds spaces between renderable entities, **if** those renderables are non-empty. +-- +-- We should similarly allow for a combinator that similarly adds empty lines between renderable entities. +-- +-- @topic rendering instance P.Render (P.Detailed Issue) where - render (P.Detailed issue) = P.renderAsMarkdown issue.rawText + render (P.Detailed issue) = + IssueTitle issue + <<< P.hardline @P.AnsiStyle + <<< IssueDescription issue + <<< P.hardline @P.AnsiStyle + <<< IssueTags issue + <<< P.hardline @P.AnsiStyle + <<< IssueComments issue instance P.Render Issue where render = P.render . P.Detailed @@ -34,7 +50,9 @@ instance P.Render IssueTitle where newtype IssueDescription = IssueDescription {unIssueDescription :: Issue} instance P.Render IssueDescription where - render (IssueDescription issue) = maybe P.emptyDoc P.pretty issue.description + render (IssueDescription issue) = + maybe P.emptyDoc (P.render . N.toList) $ + issue.description instance P.Render (P.Linked Issue) where render (P.Linked issue) @@ -58,6 +76,13 @@ newtype IssueTags = IssueTags {unIssueTags :: Issue} instance P.Render IssueTags where render (IssueTags issue) = P.render issue.tags +newtype IssueComments = IssueComments {unIssueComments :: Issue} + +instance P.Render IssueComments where + render (IssueComments issue) = + maybe P.emptyDoc (P.vsep . map P.render . N.toList) $ + issue.comments + newtype IssueOpenedBy = IssueOpenedBy {unIssueOpenedBy :: Issue} instance P.Render IssueOpenedBy where diff --git a/app/Issue/Tag.hs b/app/Issue/Tag.hs index b0d4d3c..96051cd 100644 --- a/app/Issue/Tag.hs +++ b/app/Issue/Tag.hs @@ -38,8 +38,8 @@ tagValuesOf key = else Nothing ) -extractTags :: Text -> [Tag] -extractTags = collect . D.commonmarkToNode [] +extractTags :: [D.Node] -> [Tag] +extractTags = concatMap collect where collect (D.Node _ (D.CODE _) _) = [] collect (D.Node _ (D.CODE_BLOCK _ _) _) = [] diff --git a/app/Issue/Text.hs b/app/Issue/Text.hs index cb4ae47..a7697d5 100644 --- a/app/Issue/Text.hs +++ b/app/Issue/Text.hs @@ -1,24 +1,12 @@ module Issue.Text - ( extractText, - stripIssueMarkers, + ( stripIssueMarkers, issueMarkers, - extractComments, ) where -import CMark qualified as D -import Control.Arrow (first, second, (***)) -import Data.Text (Text) +import Control.Arrow (first) import Data.Text qualified as T -extractText :: Text -> (Text, Maybe Text) -extractText text = (title, description) - where - (title, description') = second T.stripStart $ T.breakOn "\n" text - description - | T.null description' = Nothing - | otherwise = Just description' - issueMarkers :: [T.Text] issueMarkers = [ "TODO", @@ -34,29 +22,3 @@ stripIssueMarkers text = T.stripStart (T.drop (T.length marker) text) [] -> ([], text) - -extractComments :: T.Text -> ([T.Text], T.Text) -extractComments text = collect (D.commonmarkToNode [] text) - where - collect :: D.Node -> ([T.Text], T.Text) - collect (D.Node _ D.DOCUMENT ns) = - (map (toText . reverse) . reverse) - *** (toText . reverse) - $ collect' ([], []) ns - collect _ = error "commonmarkToNode: no document" - - collect' :: ([[D.Node]], [D.Node]) -> [D.Node] -> ([[D.Node]], [D.Node]) - collect' (as, rs) [] = (as, rs) - collect' ([], rs) (n@(D.Node _ D.PARAGRAPH (n' : _)) : ns) - | D.Node _ (D.TEXT s) _ <- n', - T.isPrefixOf "COMMENT" s = - collect' ([[n]], rs) ns - | otherwise = collect' ([], n : rs) ns - collect' (ass@(a : as), rs) (n@(D.Node _ D.PARAGRAPH (n' : _)) : ns) - | D.Node _ (D.TEXT s) _ <- n', - T.isPrefixOf "COMMENT" s = - collect' (([n] : ass), rs) ns - | otherwise = collect' (((n : a) : as), rs) ns - collect' (as, rs) (_ : ns) = collect' (as, rs) ns - - toText = D.nodeToCommonmark [] Nothing . D.Node Nothing D.DOCUMENT diff --git a/app/Main.hs b/app/Main.hs index 8a043f7..fdbe4ae 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,27 +1,3 @@ --- TODO Parse issues as markdown --- --- There are several issues related to the fact that we are not parsing --- issues as markdown. --- --- (1) We cannot easily page `show` output, as we are mixing direct output --- with shell commands highlighting markdown. --- --- (2) We cannot easily ignore markup (tags) in code blocks. --- --- (3) We cannot easily determine the first and last markdown content when --- augmenting the issue body with meta information. --- --- I am neither for nor against replacing `mdcat` with our own markdown --- rendering. --- --- @supersedes make-show-page-able --- @supersedes only-separate-generated-tags-with-a-blank-line-when-description-does-not-end-with-tags --- --- @difficulty medium --- @priority medium --- @topic markdown --- @topic tags - -- TODO Tag improvements (OR-filtering) -- -- Currently it is not possible to filter for an issue satisfying one filter or another. We could add the following syntax allowing it: diff --git a/app/Render.hs b/app/Render.hs index 2220fb8..f63a3bc 100644 --- a/app/Render.hs +++ b/app/Render.hs @@ -28,7 +28,7 @@ module Render where import CMark qualified as D -import Data.List (isPrefixOf, isSuffixOf, intersperse) +import Data.List (intersperse, isPrefixOf, isSuffixOf) import Data.Maybe (catMaybes) import Data.Text qualified as T import Data.Time.Calendar (Day) @@ -94,7 +94,22 @@ renderAsMarkdown :: T.Text -> Doc AnsiStyle renderAsMarkdown = render . Markdown . D.commonmarkToNode [] instance Render Markdown where - render = maybe emptyDoc go . rec . unMarkdown + render = render . unMarkdown + +instance Render [D.Node] where + render = render . D.Node Nothing D.DOCUMENT + +-- TODO Fix spacing between markdown nodes +-- +-- The following code suffers from the problem that inline code such as `foo` is not separated correctly when surrounded by non-whitespace characters, ie. `foo`, or `foo`s. +-- +-- The reason for that is that we generally trim words within `TEXT` nodes, and then add the spaces back. +-- +-- Thus, we should not trim words. But we should still replace whitespace by `P.softline`s (ie. `P.fillSep`) for automatic paragraph wrapping. +-- +-- @topic markdown +instance Render D.Node where + render = maybe emptyDoc go . rec where rec (D.Node _ D.SOFTBREAK _) = Nothing rec (D.Node p t ns) = Just $ D.Node p t (catMaybes $ map rec ns) -- cgit v1.2.3