aboutsummaryrefslogtreecommitdiffstats
path: root/app/Issue
diff options
context:
space:
mode:
Diffstat (limited to 'app/Issue')
-rw-r--r--app/Issue/Parser.hs61
-rw-r--r--app/Issue/Render.hs29
-rw-r--r--app/Issue/Tag.hs4
-rw-r--r--app/Issue/Text.hs42
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
generated by cgit v1.2.3 (git 2.25.1) at 2025-01-23 14:24:49 +0000