feat(Rendering): Render to an cmark tree before printing

shift.cabal

@@ -47,6 +47,7 @@ library
                      , vector
                      , exceptions
                      , semigroups
+                     , cmark-gfm
   default-language:    Haskell2010
 
 executable shift

src/Shift/Git.hs

@@ -14,8 +14,15 @@ import qualified Data.ByteString.Char8 as BS
 import Data.Default (def)
 import Data.Either (rights)
 import Data.Git
+    ( tagList,
+      getObject,
+      withRepo,
+      RefName(refNameRaw),
+      Ref,
+      Git,
+      Commit(commitMessage) )
 import Data.Git.Ref (HashAlgorithm, fromHex, isHex)
-import Data.Git.Storage.Object
+import Data.Git.Storage.Object ( Object(ObjCommit) )
 import Data.List (sortBy)
 import Data.Maybe (catMaybes)
 import Data.Set as S (toList)
@@ -30,13 +37,14 @@ import GitHub.Auth (Auth (OAuth))
 import Network.HTTP.Client (newManager)
 import Network.HTTP.Client.TLS (tlsManagerSettings)
 import Shift.CLI
-import Shift.Processing
-import Shift.Rendering
+import Shift.Processing ( generateReport, parseCommit )
+import Shift.Rendering ( printReport )
 import Shift.Types
 import Shift.Utilities (orError, pairs)
-import System.Process
+import System.Process ( readCreateProcess, shell )
 import Text.Megaparsec (ParseError)
 import Text.Megaparsec.Error (ParseErrorBundle)
+import CMarkGFM (NodeType(DOCUMENT), NodeType(DOCUMENT), nodeToCommonmark, nodeToCommonmark, Node(Node))
 
 parseTag :: RefName -> Either (ParseErrorBundle Text Void) TagRef
 parseTag ref = case versioning . cs . refNameRaw $ ref of
@@ -44,23 +52,31 @@ parseTag ref = case versioning . cs . refNameRaw $ ref of
   Right v -> Right (TagRef ref v)
 
 tempMain :: ShiftOptions -> IO ()
-tempMain opts = withRepo ".git" $ \repo -> do
+tempMain opts = do
+  node <- renderToNode opts
+
+  liftIO $ TIO.putStr $ nodeToCommonmark [] Nothing node
+
+renderToNode :: ShiftOptions -> IO Node
+renderToNode opts = withRepo ".git" $ \repo -> do
   tags <- tagList repo
 
   let sortedVersions = sortBy (flip compare) . rights $ parseTag <$> toList tags
       pairedTags = swap <$> pairs sortedVersions
 
-  case opts ^. soHostingType of
+  nodes <- case opts ^. soHostingType of
     GitHubType -> do
       state <- initGitHubState
 
-      runReaderT
-        (void $ runStateT (mapM_ (renderDiff repo) pairedTags) state)
+      fst <$> runReaderT
+        (runStateT (mapM (renderDiff repo) pairedTags) state)
         opts
     GitType ->
-      runReaderT
-        (void $ runStateT (mapM_ (renderDiff repo) pairedTags) GitClientState)
+      fst <$> runReaderT
+        (runStateT (mapM (renderDiff repo) pairedTags) GitClientState)
         opts
+
+  pure (Node Nothing DOCUMENT (concat nodes))
   where
     initGitHubState = do
       manager <- newManager tlsManagerSettings
@@ -80,15 +96,13 @@ tempMain opts = withRepo ".git" $ \repo -> do
             _gcsRepository = cs repositoryName
           }
 
-renderDiff :: (ClientState s, HashAlgorithm hash) => Git hash -> (TagRef, TagRef) -> GitM s ()
+renderDiff :: (ClientState s, HashAlgorithm hash) => Git hash -> (TagRef, TagRef) -> GitM s [Node]
 renderDiff repo (tx, ty) = do
-  liftIO . TIO.putStrLn . headerOne $ renderRange tx ty
-
   diff <- lookupCommitsDiff repo tx ty
 
   case diff of
     [] -> throwM SEUnableToComputeDiff
-    diff_ -> printReport (generateReport . rights $ parseCommit <$> diff_)
+    diff_ -> printReport (tx, ty) (generateReport . rights $ parseCommit <$> diff_)
 
 lookupCommitsDiff :: (HashAlgorithm hash) => Git hash -> TagRef -> TagRef -> GitM s [(Ref hash, Commit hash)]
 lookupCommitsDiff repo x y = do

src/Shift/Rendering.hs

-{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Shift.Rendering where
 
+import CMarkGFM as M
+import Control.Lens ((^.))
+import Control.Monad.Catch (MonadThrow)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.State (MonadState)
+import Control.Monad.Trans.Writer (WriterT (runWriterT), execWriterT, runWriter)
+import Control.Monad.Trans.Writer.Lazy (tell)
+import Data.Git (Commit, Ref, commitAuthor)
 import Data.List (sortOn)
-
-import           Control.Lens            ((^.))
-import           Control.Monad.Catch     (MonadThrow)
-import           Control.Monad.IO.Class  (MonadIO, liftIO)
-import           Control.Monad.State     (MonadState)
-import           Data.Git                (Commit, Ref, commitAuthor)
-import           Data.Monoid             ((<>))
-import           Data.String.Conversions (cs)
-import           Data.Text               (Text)
-import qualified Data.Text               as T (take)
-import qualified Data.Text.IO            as TIO (putStrLn)
-import           Data.Versions           (prettyV)
-
+import Data.Maybe (catMaybes)
+import Data.Monoid ((<>))
+import Data.String.Conversions (cs)
+import Data.Text (Text)
+import qualified Data.Text as T (take)
+import qualified Data.Text.IO as TIO (putStr, putStrLn)
+import Data.Versions (prettyV)
 import Shift.Types
 
-renderRef
-  :: (MonadIO m, MonadState s m, ClientState s, MonadThrow m)
-  => Ref hash
-  -> m Text
+renderRef ::
+  (MonadIO m, MonadState s m, ClientState s, MonadThrow m) =>
+  Ref hash ->
+  m [Node]
 renderRef ref = do
   url <- getRefURL ref
 
   let shortRef = T.take 7 . cs . show $ ref
+  let shortRefNode = leafNode (CODE shortRef)
 
   pure $ case url of
-    Just url_ -> "[[`" <> shortRef <> "`](" <> url_ <> ")]"
-    Nothing -> "[`" <> shortRef <> "`]"
+    Just url_ -> [textNode "[", parentNode (LINK url_ shortRef) [shortRefNode], textNode "]"]
+    Nothing -> [textNode "[", shortRefNode, textNode "]"]
 
-renderConventionalCommit
-  :: (MonadIO m, MonadState s m, ClientState s, MonadThrow m)
-  => ConventionalGroup hash
-  -> m Text
+renderConventionalCommit ::
+  (MonadIO m, MonadState s m, ClientState s, MonadThrow m) =>
+  ConventionalGroup hash ->
+  m Node
 renderConventionalCommit (ref, commit, pc) = do
   renderedRef <- renderRef ref
   authorText <- renderAuthor commit ref
 
-  pure . mconcat $
-    [ "- "
-    , renderedRef
-    , " "
-    , bold $ pc ^. ccScope <> ":"
-    , " "
-    , pc ^. ccSubject
-    , authorText
-    ]
-
-renderAuthor
-  :: (MonadIO m, MonadState s m, ClientState s, MonadThrow m)
-  => Commit hash
-  -> Ref hash
-  -> m Text
+  pure $
+    listItemNode
+      [ paragraphNode $
+          renderedRef
+            <> catMaybes
+              [ Just $ textNode " ",
+                Just . bold $ pc ^. ccScope <> ":",
+                Just $ textNode " ",
+                Just . textNode $ pc ^. ccSubject,
+                Just $ textNode " ",
+                authorText
+              ]
+      ]
+
+renderAuthor ::
+  (MonadIO m, MonadState s m, ClientState s, MonadThrow m) =>
+  Commit hash ->
+  Ref hash ->
+  m (Maybe Node)
 renderAuthor commit ref = do
   authorInfo <- getAuthorInfo (commitAuthor commit) ref
 
   pure $ case authorInfo of
-    Just (username, authorUrl) -> " [(" <> username <> ")](" <> authorUrl <> ")"
-    Nothing -> ""
+    Just (username, authorUrl) -> Just $ parentNode (LINK authorUrl username) [textNode username]
+    Nothing -> Nothing
 
-renderMiscCommit
-  :: (MonadIO m, MonadState s m, ClientState s, MonadThrow m)
-  => MiscGroup hash
-  -> m Text
+renderMiscCommit ::
+  (MonadIO m, MonadState s m, ClientState s, MonadThrow m) =>
+  MiscGroup hash ->
+  m Node
 renderMiscCommit (ref, commit, MiscCommit subject) = do
   renderedRef <- renderRef ref
   authorText <- renderAuthor commit ref
 
-  pure $ "- " <> renderedRef <> " " <> subject <> authorText
-
-renderMergeCommit
-  :: (MonadIO m, MonadState s m, ClientState s, MonadThrow m)
-  => MergeGroup hash
-  -> m Text
+  pure $
+    listItemNode
+      [ paragraphNode $
+          renderedRef
+            <> catMaybes
+              [ Just $ textNode subject,
+                Just $ textNode " ",
+                authorText
+              ]
+      ]
+
+renderMergeCommit ::
+  (MonadIO m, MonadState s m, ClientState s, MonadThrow m) =>
+  MergeGroup hash ->
+  m Node
 renderMergeCommit (ref, commit, MergeCommit subject) = do
   renderedRef <- renderRef ref
   authorText <- renderAuthor commit ref
 
-  pure $ "- " <> renderedRef <> " Merge " <> subject <> authorText
+  pure $
+    listItemNode
+      [ paragraphNode $
+          renderedRef
+            <> catMaybes
+              [ Just $ textNode $ "Merge " <> subject,
+                authorText
+              ]
+      ]
 
 renderRange :: TagRef -> TagRef -> Text
-renderRange tx ty = mconcat
-  [prettyV . _tVersioning $ tx, " to ", prettyV . _tVersioning $ ty]
+renderRange tx ty =
+  mconcat
+    [prettyV . _tVersioning $ tx, " to ", prettyV . _tVersioning $ ty]
 
-bold :: Text -> Text
-bold x = "**" <> x <> "**"
+bold :: Text -> Node
+bold x = parentNode STRONG [textNode x]
 
 indented :: Int -> Text -> Text
-indented levels x = foldl (\acc _ -> acc <> "  ") "" [1..levels] <> x
+indented levels x = foldl (\acc _ -> acc <> "  ") "" [1 .. levels] <> x
 
 indentedL :: Int -> Text -> Text
-indentedL levels x = "\\" <> foldl (\acc _ -> acc <> "-") "" [1..levels] <> x
+indentedL levels x = "\\" <> foldl (\acc _ -> acc <> "-") "" [1 .. levels] <> x
+
+headerOne :: Text -> Node
+headerOne t = parentNode (HEADING 1) [textNode t]
+
+headerTwo :: Text -> Node
+headerTwo t = parentNode (HEADING 2) [textNode t]
 
-linePadded :: Text -> Text
-linePadded x = "\n" <> x <> "\n"
+headerThree :: Text -> Node
+headerThree t = parentNode (HEADING 3) [textNode t]
 
-headerOne :: Text -> Text
-headerOne = linePadded . (<>) "# "
+textNode :: Text -> Node
+textNode t = Node Nothing (TEXT t) []
 
-headerTwo :: Text -> Text
-headerTwo = linePadded . (<>) "## "
+leafNode :: NodeType -> Node
+leafNode n = Node Nothing n []
 
-headerThree :: Text -> Text
-headerThree = linePadded . (<>) "### "
+parentNode :: NodeType -> [Node] -> Node
+parentNode = Node Nothing
+
+listItemNode :: [Node] -> Node
+listItemNode = parentNode ITEM
+
+paragraphNode :: [Node] -> Node
+paragraphNode = parentNode PARAGRAPH
+
+printReport ::
+  (MonadIO m, MonadState s m, ClientState s, MonadThrow m) =>
+  (TagRef, TagRef) ->
+  ChangeReport hash ->
+  m [Node]
+printReport (rangeStart, rangeEnd) report = execWriterT $ do
+  tell [headerOne $ renderRange rangeStart rangeEnd]
 
-printReport
-  :: (MonadIO m, MonadState s m, ClientState s, MonadThrow m)
-  => ChangeReport hash
-  -> m ()
-printReport report = do
   -- Print conventional commits
   conventionalSection "New features:" crFeatures
   conventionalSection "Fixes:" crFixes
@@ -129,7 +169,7 @@ printReport report = do
   textSection "Merge commits:" mergeCommits
   where
     conventionalSection label sectionLens = do
-      let rawCommits = sortOn (\(_,_,pc) -> pc ^. ccScope) (report ^. sectionLens)
+      let rawCommits = sortOn (\(_, _, pc) -> pc ^. ccScope) (report ^. sectionLens)
 
       commits <- mapM renderConventionalCommit rawCommits
       textSection label commits
@@ -137,7 +177,6 @@ printReport report = do
     textSection label commits = case commits of
       [] -> pure ()
       _ -> do
-        liftIO . TIO.putStrLn . headerTwo $ label
-
-        liftIO $ mapM_ (TIO.putStrLn . indented 1) commits
+        tell [headerTwo label]
 
+        tell [parentNode (LIST (ListAttributes BULLET_LIST False 0 PAREN_DELIM)) commits]

src/Shift/Types.hs

@@ -43,7 +43,6 @@ import GitHub (URL(URL))
 import GitHub (getUrl)
 import GitHub (getUrl)
 import Data.Aeson (FromJSON)
-import Data.Aeson (FromJSON)
 
 class ClientState s where
   getRefURL