From 1b1c3faabae530229eb675a2e70e744c2f45cbbe Mon Sep 17 00:00:00 2001
From: Alexander Foremny <aforemny@posteo.de>
Date: Mon, 4 Dec 2023 08:36:02 +0100
Subject: feat: add experimental render api

---
 app/Issue/Tag.hs | 54 +++++++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 53 insertions(+), 1 deletion(-)

(limited to 'app/Issue/Tag.hs')

diff --git a/app/Issue/Tag.hs b/app/Issue/Tag.hs
index ca550aa..b0d4d3c 100644
--- a/app/Issue/Tag.hs
+++ b/app/Issue/Tag.hs
@@ -4,15 +4,22 @@ module Issue.Tag
     tagKey,
     tagValue,
     tagValuesOf,
+    TagKey (..),
+    TagValue (..),
   )
 where
 
 import CMark qualified as D
 import Data.Binary (Binary)
-import Data.Maybe (catMaybes, mapMaybe)
+import Data.List (intersperse)
+import Data.Map qualified as M
+import Data.Maybe (catMaybes, isJust, mapMaybe)
+import Data.Set qualified as S
 import Data.Text (Text)
 import Data.Text qualified as T
 import GHC.Generics (Generic)
+import Render ((<<<))
+import Render qualified as P
 
 data Tag = Tag Text (Maybe Text) deriving (Show, Generic, Binary, Eq)
 
@@ -53,3 +60,48 @@ extractTags = collect . D.commonmarkToNode []
               . T.words
           )
         . T.lines
+
+instance P.Render Tag where
+  render tag
+    | isJust (tagValue tag) = TagKey tag <<< (" " :: T.Text) <<< TagValue tag
+    | otherwise = P.render (TagKey tag)
+
+newtype TagKey = TagKey {unTagKey :: Tag}
+
+instance P.Render TagKey where
+  render (TagKey tag) =
+    P.styled [P.bold, P.color P.Yellow] $
+      P.render ("@" <> tagKey tag)
+
+newtype TagValue = TagValue {unTagValue :: Tag}
+
+instance P.Render TagValue where
+  render (TagValue tag) =
+    maybe P.emptyDoc (P.styled [P.color P.Yellow] . P.render) $
+      tagValue tag
+
+instance P.Render [Tag] where
+  render tags =
+    P.vsep $
+      map
+        ( \(tagKey, tagValues) ->
+            TagKey (Tag tagKey Nothing)
+              <<< (P.hcat . intersperse P.comma)
+                (map (P.render . TagValue) (map (Tag tagKey . Just) tagValues))
+        )
+        tagsAndValues
+    where
+      tagsAndValues :: [(T.Text, [T.Text])]
+      tagsAndValues =
+        (M.toList . M.map S.toList)
+          . foldl
+            ( flip
+                ( \tag ->
+                    let vs = maybe S.empty S.singleton (tagValue tag)
+                     in M.alter
+                          (Just . maybe vs (S.union vs))
+                          (tagKey tag)
+                )
+            )
+            M.empty
+          $ tags
-- 
cgit v1.2.3