Trammel: add background color support

2 files changed, 169 insertions, 57 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 747b269..ddb5e31 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -161,11 +161,11 @@ instance Error ExecError where
 prettyError :: ExecError -> String
 
 prettyError (UnhandledInputError s) =
-    pp $ Gaudy [31] $
-        "unhandled input: <" <> Gaudy [1] (gaudySpecial [35,1] s) <> ">"
+    pp $ SGR [31] $
+        "unhandled input: <" <> SGR [1] (gaudySpecial [35,1] s) <> ">"
 
 prettyError (OtherError s) =
-    pp $ Gaudy [31] $ gaudySpecial [35] s
+    pp $ SGR [31] $ gaudySpecial [35] s
 
 
 modifyBuffer :: (Buffer -> Buffer) -> VT ()
@@ -245,7 +245,9 @@ execCommand ExecuteInputBuffer = do
 
     case showBuffer (buffer st) of
       ":c" -> do
-          tell [intercalate " " $ map (\i -> pp $ Gaudy [38,5,i] $ Plain $ padl 3 '0' $ show i) [0..255] ]
+          let f i = pp $ SGR [38,5,i] $ Plain $ padl 3 '0' $ show i
+          tell [ intercalate " " $ map f [0..255]
+               ]
       ":r" -> do
           tell [ "--- Registers ---" ]
           tell $ map (\(r, s) -> ['"', r] ++ "  " ++ s) -- TODO pp
@@ -266,8 +268,10 @@ execCommand ExecuteInputBuffer = do
       "" -> do
           liftIO ringBell
       s -> do
-          let s' = pp $ "input: <" <> (Gaudy [32] (gaudySpecial [1] s)) <> ">"
-          tell [ s', show s' ]
+          let s' = SGR [32] $ gaudySpecial [1] s
+          tell [ pp $ "input: <" <> s' <> ">"
+               , pp $ SGR [35,1] $ Plain $ init $ tail $ show $ pp s'
+               ]
 
     modifyBuffer (const emptyBuffer)
 
@@ -343,10 +347,10 @@ execCommand DeleteEntireLine = modify $ \q ->
 renderInputLine :: Maybe Int -> Mode -> Buffer -> IO ()
 renderInputLine mb_cnt m (lhs, rhs) = do
     renderRight $
-        Gaudy [30,1] $
+        SGR [30,1] $
         Plain (show m) <>
             maybe Empty
-                  (("["<>) . (<>"]") . Gaudy [33,1] . Plain . show)
+                  (("["<>) . (<>"]") . SGR [33,1] . Plain . show)
                   mb_cnt
     renderLeft $ promptString m <> gaudySpecial [35] (lhs ++ rhs)
     moveCursorLeft $ length $ lit rhs
@@ -367,11 +371,11 @@ renderRight a = do
 
 
 promptString :: Mode -> Trammel String
-promptString NormalMode = Gaudy [33,1] "@ "
+promptString NormalMode = SGR [33,1] "@ "
 promptString InsertMode = "> "
 promptString SelectRegisterMode = "\" "
-promptString DeleteMode = Gaudy [31,1] "> "
-promptString VerbatimMode = Gaudy [34,1] "^ "
+promptString DeleteMode = SGR [31,1] "> "
+promptString VerbatimMode = SGR [34,1] "^ "
 
 
 spans :: (a -> Bool) -> [a] -> [Either [a] [a]]
@@ -385,7 +389,7 @@ spans p xs = f_r (span p_r xs)
 
 gaudySpans :: [Int] -> (Char -> Bool) -> String -> Trammel String
 gaudySpans c p =
-    mconcat . map (either (Gaudy c . Plain . lit) Plain) . spans p
+    mconcat . map (either (SGR c . Plain . lit) Plain) . spans p
 
 
 gaudySpecial :: [Int] -> String -> Trammel String
diff --git a/src/Trammel.hs b/src/Trammel.hs
index 41f0117..36c1140 100644
--- a/src/Trammel.hs
+++ b/src/Trammel.hs
@@ -3,18 +3,21 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 module Trammel where
 
+import Control.Applicative
 import Data.List
 import Data.String
 import Data.Monoid
-import Data.Maybe (catMaybes)
 import Data.Ix (inRange)
 
+type Ps = Int
+type Pm = [Ps]
 
 data Trammel a
     = Plain a
-    | Gaudy [Int] (Trammel a)
+    | SGR Pm (Trammel a)
     | Append (Trammel a) (Trammel a)
     | Empty
   deriving (Eq, Show)
@@ -29,60 +32,165 @@ instance IsString a => IsString (Trammel a) where
     fromString = Plain . fromString
 
 
-data Color = AnsiColor Int | Xterm256 Int | XtermRGB Int Int Int
+class IsPm a where
+    toPm :: a -> Pm
+    fromPm :: Pm -> Maybe a
+
+
+data FColor = ECMA48FColor Ps   -- ECMA-48 / ISO 6429 / ANSI X3.64
+            | Xterm256FColor Ps
+            | ISO8613_3FColor Ps Ps Ps
+  deriving (Eq, Show)
+
+instance IsPm FColor where
+    toPm (ECMA48FColor i) = [i]
+    toPm (Xterm256FColor i) = [38,5,i]
+    toPm (ISO8613_3FColor r g b) = [38,2,r,g,b]
+    fromPm = fromSGRPm SGRPm
+               { def8Ps = 39
+               , extPs = 38
+               , lo8Ps = 30
+               , hi8Ps = 37
+               , makeECMA48Color = ECMA48FColor
+               , makeXterm256Color = Xterm256FColor
+               , makeISO8613_3Color = ISO8613_3FColor
+               }
+           . filterPm sgrBColor
+
+
+data BColor = ECMA48BColor Ps
+            | Xterm256BColor Ps
+            | ISO8613_3BColor Ps Ps Ps
+  deriving (Eq, Show)
+
+
+instance IsPm BColor where
+    toPm (ECMA48BColor i) = [i]
+    toPm (Xterm256BColor i) = [48,5,i]
+    toPm (ISO8613_3BColor r g b) = [48,2,r,g,b]
+    fromPm = fromSGRPm SGRPm
+                 { def8Ps = 49
+                 , extPs = 48
+                 , lo8Ps = 40
+                 , hi8Ps = 47
+                 , makeECMA48Color = ECMA48BColor
+                 , makeXterm256Color = Xterm256BColor
+                 , makeISO8613_3Color = ISO8613_3BColor
+               }
+           . filterPm sgrFColor
+
+
+data Bold = Bold | NoBold
   deriving (Eq, Show)
 
+instance IsPm Bold where
+    toPm Bold = [1]
+    toPm NoBold = [22]
+    fromPm = rec . filterPm sgrColor
+      where
+        rec xs = case filter (`elem`[1,22]) xs of
+            [] -> Nothing
+            xs' -> case last xs' of
+                1 -> Just Bold
+                22 -> Just NoBold
+                _ -> error "filter broken in fromPm :: Pm -> Maybe Bold"
 
-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
 
+data Underline = Underline | NoUnderline
+  deriving (Eq, Show)
+
+instance IsPm Underline where
+    toPm Underline = [4]
+    toPm NoUnderline = [24]
+    fromPm = rec . filterPm sgrColor
+      where
+        rec xs = case filter (`elem`[4,24]) xs of
+            [] -> Nothing
+            xs' -> case last xs' of
+                1 -> Just Underline
+                22 -> Just NoUnderline
+                _ -> error "filter broken in fromPm :: Pm -> Maybe Underline"
+
+
+data SGRPm c = SGRPm
+    { def8Ps :: Ps
+    , extPs :: Ps
+    , lo8Ps :: Ps
+    , hi8Ps :: Ps
+    , makeECMA48Color :: Ps -> c
+    , makeXterm256Color :: Ps -> c
+    , makeISO8613_3Color :: Ps -> Ps -> Ps -> c
+    }
+
+
+fromSGRPm :: IsPm c => SGRPm c -> Pm -> Maybe c
+fromSGRPm SGRPm{..} = rec Nothing
+  where
+    rec mb_c (x:xs)
+        | x == extPs = case xs of
+            (2:r:g:b:xs') -> rec (Just $ makeISO8613_3Color r g b) xs'
+            (5:i:xs')     -> rec (Just $ makeXterm256Color i) xs'
+            _             -> rec mb_c xs
+        | x == def8Ps = rec (Just $ makeECMA48Color def8Ps) xs
+        | inRange (lo8Ps, hi8Ps) x = rec (Just $ makeECMA48Color x) xs
+        | otherwise = rec mb_c xs
+    rec mb_c _ = mb_c
+
+
+-- filterPm is used to preprocess Pm before searching with fromPm in
+-- order to remove (longer) sequences that could contain subsequences
+-- that look like the (shorter) sequences we're searching.
+-- E.g. we could find [1] (bold) in any extended color sequence.
+-- TODO Can we combine this whole from*Pm with Scanner?
+filterPm :: (Pm -> Maybe Int) -> Pm -> Pm
+filterPm f = rec []
+  where
+    rec ys xs@(xhead:xtail) = maybe (rec (ys ++ [xhead]) xtail)
+                                    (rec ys . flip drop xs)
+                                    (f xs)
+    rec ys _ = ys
+
+sgrColor, sgrFColor, sgrBColor :: Pm -> Maybe Int
 
-toGR :: Color -> [Int]
-toGR (AnsiColor i) = [i]
-toGR (Xterm256 i) = [38,5,i]
-toGR (XtermRGB r g b) = [38,2,r,g,b]
+sgrColor xs = sgrFColor xs <|> sgrBColor xs
 
+sgrFColor (38:5:_) = Just 3
+sgrFColor (38:2:_) = Just 5
+sgrFColor _ = Nothing
+
+sgrBColor (48:5:_) = Just 3
+sgrBColor (48:2:_) = Just 5
+sgrBColor _ = Nothing
+
+
+type RenderState = [(FColor, BColor, Bold, Underline)]
 
--- TODO maybe bold and underline could be simply Bools
-type RenderState = [(Color,Int,Int)]
 
 emptyRenderState :: RenderState
-emptyRenderState = [(AnsiColor 39,22,24)]
+emptyRenderState = [(ECMA48FColor 39, ECMA48BColor 49, NoBold, NoUnderline)]
 
 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)
+-- TODO merge successive sequences: \ESC[32m\ESC[1m -> \ESC[31;1m
+renderString rs@((fc, bc, b, u):_) (SGR c t) y =
+    renderSGR bra ++ renderString rs' t (renderSGR ket ++ y)
   where
-    f p alt xs =
-        case filter p xs of
-            [] -> alt
-            xs' -> last xs'
-
-renderString _ (Gaudy _ _) _ =
+    fc' = maybe fc id $ fromPm c
+    bc' = maybe bc id $ fromPm c
+    b'  = maybe  b id $ fromPm c
+    u'  = maybe  u id $ fromPm c
+    rs' = (fc', bc', b', u') : rs
+    bra = braket >>= fst
+    ket = braket >>= snd
+    braket =
+        (if fc' /= fc then (toPm fc', toPm fc) else ([],[])) :
+        (if bc' /= bc then (toPm bc', toPm bc) else ([],[])) :
+        (if b'  /=  b then (toPm  b', toPm  b) else ([],[])) :
+        (if u'  /=  u then (toPm  u', toPm  u) else ([],[])) : []
+
+renderString _ (SGR _ _) _ =
     error "renderString called w/o proper initial state"
     -- where a proper initial state is s.th. like emptyRenderState
 
@@ -94,7 +202,7 @@ renderString _ Empty y = y
 
 len :: Trammel String -> Int
 len (Plain x) = length x
-len (Gaudy _ x) = len x
+len (SGR _ x) = len x
 len (Append t1 t2) = len t1 + len t2
 len Empty = 0
 
@@ -103,6 +211,6 @@ pp :: Trammel String -> String
 pp t = renderString emptyRenderState t ""
 
 
-sgr :: [Int] -> String
-sgr [] = []
-sgr xs = ("\ESC["++) . (++"m") . intercalate ";" $ map show xs
+renderSGR :: Pm -> String
+renderSGR [] = []
+renderSGR xs = ("\ESC["++) . (++"m") . intercalate ";" $ map show xs