From 76b3f100d90cd87e103ca83d84a925505c6ccba2 Mon Sep 17 00:00:00 2001
From: Dmitry Zuikov <dzuikov@gmail.com>
Date: Mon, 13 May 2024 18:39:04 +0300
Subject: [PATCH] wip, some-colors

---
 .fixme-new/config            |  2 +-
 fixme-new/lib/Fixme/Run.hs   |  2 +-
 fixme-new/lib/Fixme/Types.hs | 68 ++++++++++++++++++++++++++++++++++--
 3 files changed, 67 insertions(+), 5 deletions(-)

diff --git a/.fixme-new/config b/.fixme-new/config
index 205b162e..acda16bd 100644
--- a/.fixme-new/config
+++ b/.fixme-new/config
@@ -43,7 +43,7 @@ fixme-comments ";" "--"
 (define-template short
   (simple
      (trim 10  $fixme-key) " "
-     (align 6  $fixme-tag) " "
+     (fg green (align 6  $fixme-tag)) " "
      (align 8  ("[" $workflow "]"))  " "
      (align 12 $assigned)  " "
      (trim 50  ($fixme-title))
diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs
index ebc6e9dd..4a7a447f 100644
--- a/fixme-new/lib/Fixme/Run.hs
+++ b/fixme-new/lib/Fixme/Run.hs
@@ -506,7 +506,7 @@ list_ tpl a = do
         let what = render (SimpleTemplate (inject  subst simple))
                       & fromRight "render error"
 
-        liftIO $ Text.putStr what
+        liftIO $ hPutDoc stdout what
 
   where
     mksym (k :: FixmeAttrName) = Id ("$" <> coerce k)
diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs
index 13eacb05..336d7862 100644
--- a/fixme-new/lib/Fixme/Types.hs
+++ b/fixme-new/lib/Fixme/Types.hs
@@ -11,6 +11,7 @@ import HBS2.Git.Local
 
 import Data.Config.Suckless
 
+import Prettyprinter.Render.Terminal
 import Control.Applicative
 import Data.Aeson
 import Data.HashMap.Strict (HashMap)
@@ -142,8 +143,8 @@ data FixmeTemplate =
 data RenderError = RenderError String
                    deriving stock (Eq,Show,Typeable)
 
-class FixmeRenderTemplate a where
-  render :: a -> Either RenderError Text
+class FixmeRenderTemplate a b where
+  render :: a -> Either RenderError b
 
 data FixmeEnv =
   FixmeEnv
@@ -306,7 +307,68 @@ inject repl target =
 pattern NL :: forall {c}. Syntax c
 pattern NL <- ListVal [SymbolVal "nl"]
 
-instance FixmeRenderTemplate SimpleTemplate where
+
+instance FixmeRenderTemplate SimpleTemplate (Doc AnsiStyle) where
+
+  render (SimpleTemplate syn) = Right $ mconcat $
+      flip fix (mempty,syn) $ \next -> \case
+        (acc, NL : rest)    -> next (acc <> nl, rest)
+        (acc, ListVal [StringLike w] : rest) -> next (acc <> txt w, rest)
+        (acc, StringLike w : rest) -> next (acc <> txt w, rest)
+        (acc, ListVal [SymbolVal "trim", LitIntVal n, e] : rest) -> next (acc <> trim n (deep [e]), rest)
+        (acc, ListVal [SymbolVal "align", LitIntVal n, e] : rest) -> next (acc <> align n (deep [e]), rest)
+        (acc, ListVal [SymbolVal "fg", SymbolVal co, e] : rest) -> next (acc <> fmap (fg_ (color_ co)) (deep [e]), rest)
+        (acc, ListVal [SymbolVal "bg", SymbolVal co, e] : rest) -> next (acc <> fmap (bg_ (color_ co)) (deep [e]), rest)
+        (acc, ListVal [SymbolVal "fgd", SymbolVal co, e] : rest) -> next (acc <> fmap (fgd_ (color_ co)) (deep [e]), rest)
+        (acc, ListVal [SymbolVal "bgd", SymbolVal co, e] : rest) -> next (acc <> fmap (bgd_ (color_ co)) (deep [e]), rest)
+        (acc, ListVal es : rest) ->  next (acc <> deep es, rest)
+        (acc, e : rest) -> next (acc <> p e, rest)
+        (acc, []) -> acc
+
+    where
+
+      color_ = \case
+        "black"   -> Just Black
+        "red"     -> Just Red
+        "green"   -> Just Green
+        "yellow"  -> Just Yellow
+        "blue"    -> Just Blue
+        "magenta" -> Just Magenta
+        "cyan"    -> Just Cyan
+        "white"   -> Just White
+        _         -> Nothing
+
+
+      fg_ = maybe id (annotate . color)
+      bg_ = maybe id (annotate . bgColor)
+
+      fgd_ = maybe id (annotate . colorDull)
+      bgd_ = maybe id (annotate . bgColorDull)
+
+      untxt = fmap pretty
+
+      align n0 s0 | n > 0     = untxt [Text.justifyLeft n ' ' s]
+                  | otherwise = untxt [Text.justifyRight (abs n) ' ' s]
+
+        where
+          n = fromIntegral n0
+          s = mconcat s0
+
+      trim n0 s0 | n >= 0     = untxt [ Text.take n s ]
+                 | otherwise  = untxt [ Text.takeEnd (abs n) s ]
+        where
+          n = fromIntegral n0
+          s = mconcat s0
+
+      -- deep :: forall c . (IsContext c, Data (Context c), Data c) => [Syntax c] -> [Text]
+      deep sy = either mempty List.singleton (render (SimpleTemplate sy))
+
+      nl = [ line ]
+      txt s = [fromString s]
+      p e = untxt [Text.pack (show $ pretty e)]
+
+
+instance FixmeRenderTemplate SimpleTemplate Text where
   render (SimpleTemplate syn) = Right $ Text.concat $
       flip fix (mempty,syn) $ \next -> \case
         (acc, NL : rest)    -> next (acc <> nl, rest)