feat: add experimental render api

1 files changed, 41 insertions, 311 deletions

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_