add Trammel - stack-based colorizer

1 files changed, 108 insertions, 0 deletions

diff --git a/src/Trammel.hs b/src/Trammel.hs
new file mode 100644
index 0000000..41f0117
--- /dev/null
+++ b/src/Trammel.hs
@@ -0,0 +1,108 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Trammel where
+
+import Data.List
+import Data.String
+import Data.Monoid
+import Data.Maybe (catMaybes)
+import Data.Ix (inRange)
+
+
+data Trammel a
+    = Plain a
+    | Gaudy [Int] (Trammel a)
+    | Append (Trammel a) (Trammel a)
+    | Empty
+  deriving (Eq, Show)
+
+
+instance Monoid (Trammel a) where
+    mappend = Append
+    mempty = Empty
+
+
+instance IsString a => IsString (Trammel a) where
+    fromString = Plain . fromString
+
+
+data Color = AnsiColor Int | Xterm256 Int | XtermRGB Int Int Int
+  deriving (Eq, Show)
+
+
+getColor :: Color -> [Int] -> Color
+getColor c0 [] = c0
+getColor c0 (c:s)
+    | inRange (30, 37) c = getColor (AnsiColor c) s
+    | c == 38 = case s of
+                  (5:i:s')     -> getColor (Xterm256 i) s'
+                  (2:r:g:b:s') -> getColor (XtermRGB r g b) s'
+                  _            -> getColor c0 s
+    | c == 39 = getColor (AnsiColor 39) s
+    | otherwise = getColor c0 s
+
+
+toGR :: Color -> [Int]
+toGR (AnsiColor i) = [i]
+toGR (Xterm256 i) = [38,5,i]
+toGR (XtermRGB r g b) = [38,2,r,g,b]
+
+
+-- TODO maybe bold and underline could be simply Bools
+type RenderState = [(Color,Int,Int)]
+
+emptyRenderState :: RenderState
+emptyRenderState = [(AnsiColor 39,22,24)]
+
+renderString :: RenderState -> Trammel String -> String -> String
+
+renderString _ (Plain s) y = s ++ y
+
+renderString rs@((fc0, b0, u0):_) (Gaudy c t) y =
+    let fc = getColor fc0 c
+        b  = f (`elem`[1,22]) b0 c
+        u  = f (`elem`[4,24]) u0 c
+        gr = catMaybes $
+              ( if fc /= fc0 then map Just (toGR fc) else [] ) ++
+              [ if b /= b0 then Just b else Nothing
+              , if u /= u0 then Just u else Nothing
+              ]
+        ungr = catMaybes $
+              ( if fc /= fc0 then map Just (toGR fc0) else [] ) ++
+              [ if b /= b0 then Just b0 else Nothing
+              , if u /= u0 then Just u0 else Nothing
+              ]
+    in sgr gr ++ renderString ((fc, b, u):rs) t (sgr ungr ++ y)
+  where
+    f p alt xs =
+        case filter p xs of
+            [] -> alt
+            xs' -> last xs'
+
+renderString _ (Gaudy _ _) _ =
+    error "renderString called w/o proper initial state"
+    -- where a proper initial state is s.th. like emptyRenderState
+
+renderString r (Append t1 t2) y =
+    renderString r t1 $ renderString r t2 y
+
+renderString _ Empty y = y
+
+
+len :: Trammel String -> Int
+len (Plain x) = length x
+len (Gaudy _ x) = len x
+len (Append t1 t2) = len t1 + len t2
+len Empty = 0
+
+
+pp :: Trammel String -> String
+pp t = renderString emptyRenderState t ""
+
+
+sgr :: [Int] -> String
+sgr [] = []
+sgr xs = ("\ESC["++) . (++"m") . intercalate ";" $ map show xs