feat: parse issues as markdown

4 files changed, 92 insertions, 44 deletions

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