add Trammel - stack-based colorizer

1 files changed, 58 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