feat: parse issues as markdown

10 files changed, 148 insertions, 86 deletions

diff --git a/anissue.cabal b/anissue.cabal
index 4d49014..dbd32ed 100644
--- a/anissue.cabal
+++ b/anissue.cabal
@@ -81,6 +81,7 @@ executable anissue
       Issue.Filter
       Issue.Group
       Issue.Meta
+      Issue.Parser
       Issue.Provenance
       Issue.Render
       Issue.Sort
@@ -112,6 +113,7 @@ executable anissue
                       diff-parse,
                       directory,
                       filepath,
+                      megaparsec,
                       optparse-applicative,
                       parallel-io,
                       prettyprinter,
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)