Trammel: add background color support

1 files changed, 16 insertions, 12 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