add Trammel - stack-based colorizer

2 files changed, 166 insertions, 76 deletions

diff --git a/src/Main.hs b/src/Main.hs
index ed52ba1..747b269 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Main where
 
 import Control.Applicative
@@ -24,6 +25,7 @@ import qualified Data.Map as Map
 import Buffer
 import Process
 import Scanner (scan, runScanner, toChar)
+import Trammel
 
 
 data VTConfig = VTConfig
@@ -155,27 +157,15 @@ data ExecError
 instance Error ExecError where
   noMsg = OtherError "something went wrong"
 
-prettyError :: ExecError -> String
-prettyError e = rec e
-  where
-    color cc s = "\x1b[" ++ cc ++ "m" ++ s ++ "\x1b[m"
-
-    rec (UnhandledInputError s) =
-      color "31" $ "unhandled input: <" ++ (s >>= pp "31;1") ++ "\x1b[;31m>"
 
-    rec (OtherError s) =
-      color "31" $ "error: " ++ s
-
-    -- TODO cc is ColorCode
-    pp cc c
-      | isPrint c = [c]
-      | otherwise = specialChar cc $
-        case c of
-          '\x1b' -> "^["
-          _ -> charToCode c
-    specialChar cc s = "\x1b[1;35m" ++ s ++ "\x1b[;" ++ cc ++ "m"
+prettyError :: ExecError -> String
 
+prettyError (UnhandledInputError s) =
+    pp $ Gaudy [31] $
+        "unhandled input: <" <> Gaudy [1] (gaudySpecial [35,1] s) <> ">"
 
+prettyError (OtherError s) =
+    pp $ Gaudy [31] $ gaudySpecial [35] s
 
 
 modifyBuffer :: (Buffer -> Buffer) -> VT ()
@@ -254,6 +244,8 @@ execCommand ExecuteInputBuffer = do
     st <- get
 
     case showBuffer (buffer st) of
+      ":c" -> do
+          tell [intercalate " " $ map (\i -> pp $ Gaudy [38,5,i] $ Plain $ padl 3 '0' $ show i) [0..255] ]
       ":r" -> do
           tell [ "--- Registers ---" ]
           tell $ map (\(r, s) -> ['"', r] ++ "  " ++ s) -- TODO pp
@@ -274,7 +266,8 @@ execCommand ExecuteInputBuffer = do
       "" -> do
           liftIO ringBell
       s -> do
-          tell [ "input: <" ++ (s >>= reform 32) ++ ">" ]
+          let s' = pp $ "input: <" <> (Gaudy [32] (gaudySpecial [1] s)) <> ">"
+          tell [ s', show s' ]
 
     modifyBuffer (const emptyBuffer)
 
@@ -344,78 +337,63 @@ execCommand DeleteEntireLine = modify $ \q ->
          }
 
 
-reform :: Int -> Char -> String
-reform colorCode c =
-    if isPrint c
-      then normal colorCode [c]
-      else
-        special colorCode $
-          case ord c of
-            27 -> "^["
-            _ -> charToCode c
-
-normal :: Int -> String -> String
-normal colorCode s = "\x1b[" ++ show colorCode ++ "m" ++ s ++ "\x1b[m"
-
-special :: Int -> String -> String
-special colorCode s = "\x1b[1;" ++ show colorCode ++ "m" ++ s ++ "\x1b[m"
-
-
 
 -- XXX assumes that the cursor is already at the (cleared) input line
 -- TODO renderInputLine looks like it wants to be -> VT ()
 renderInputLine :: Maybe Int -> Mode -> Buffer -> IO ()
 renderInputLine mb_cnt m (lhs, rhs) = do
-    clearLine -- TODO this is required for drawing the mode on the right side
+    renderRight $
+        Gaudy [30,1] $
+        Plain (show m) <>
+            maybe Empty
+                  (("["<>) . (<>"]") . Gaudy [33,1] . Plain . show)
+                  mb_cnt
+    renderLeft $ promptString m <> gaudySpecial [35] (lhs ++ rhs)
+    moveCursorLeft $ length $ lit rhs
+
+
+renderLeft :: Trammel String -> IO ()
+renderLeft = putStr . pp
+
+
+renderRight :: Trammel String -> IO ()
+renderRight a = do
     saveCursor
-    moveCursorRight 1024
-    let (infoLen, info) =
-          case mb_cnt of
-              Nothing ->
-                  let gaudy = "\x1b[1;30m" ++ show m ++ "\x1b[m"
-                      plain = show m
-                  in (length plain, gaudy)
-              Just cnt ->
-                  let gaudy = "\x1b[1;30m" ++ show m ++
-                              "[\x1b[33m" ++ show cnt ++ "\x1b[30m]\x1b[m"
-                      plain = show m ++ "[" ++ show cnt ++ "]"
-                  in (length plain, gaudy)
-    moveCursorLeft $ infoLen - 1
-    putStr info
+    moveCursorRight 1024 -- XXX obviously, this is a hack..^_^
+    moveCursorLeft $ len a - 1
+    renderLeft a
     unsaveCursor
 
-    let promptString = case m of
-                        NormalMode -> "\x1b[33;1m@\x1b[m "
-                        InsertMode -> "> "
-                        VerbatimMode -> "\x1b[34;1m^\x1b[m "
-                        SelectRegisterMode -> "\" "
-                        DeleteMode -> "\x1b[31;1m>\x1b[m "
 
-    putStr $ promptString ++ (lhs >>= reform') ++ (rhs >>= reform')
-    moveCursorLeft (length $ rhs >>= reformVis)
+
+promptString :: Mode -> Trammel String
+promptString NormalMode = Gaudy [33,1] "@ "
+promptString InsertMode = "> "
+promptString SelectRegisterMode = "\" "
+promptString DeleteMode = Gaudy [31,1] "> "
+promptString VerbatimMode = Gaudy [34,1] "^ "
+
+
+spans :: (a -> Bool) -> [a] -> [Either [a] [a]]
+spans p xs = f_r (span p_r xs)
   where
-    -- TODO unify reform and reform'
-    reform' c =
-      if isPrint c
-        then [c]
-        else
-          "\x1b[35m" ++ (
-            case ord c of
-              27 -> "^["
-              _ -> charToCode c
-          ) ++ "\x1b[m"
+    p_r = not . p
+    p_l = p
+    f_r (as, bs) = Right as : if null bs then [] else f_l (span p_l bs)
+    f_l (as, bs) = Left  as : if null bs then [] else f_r (span p_r bs)
+
 
-    reformVis c =
-      if isPrint c
-        then [c]
-        else
-            case ord c of
-              27 -> "^["
-              _ -> charToCode c
+gaudySpans :: [Int] -> (Char -> Bool) -> String -> Trammel String
+gaudySpans c p =
+    mconcat . map (either (Gaudy c . Plain . lit) Plain) . spans p
 
 
+gaudySpecial :: [Int] -> String -> Trammel String
+gaudySpecial c = gaudySpans c (not . isPrint)
 
 
+lit :: String -> String
+lit = (>>= flip showLitChar "")
 
 
 clearLine :: IO ()
@@ -564,3 +542,7 @@ whenLeft (Left x) f = f x
 whenLeft _ _ = return ()
 
 
+padl :: Int -> a -> [a] -> [a]
+padl n c s
+  | length s < n = padl n c (c : s)
+  | otherwise = s
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