summaryrefslogtreecommitdiffstats
path: root/src/Trammel.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Trammel.hs')
-rw-r--r--src/Trammel.hs108
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