From d67d12e5b5678d005e8d5e02d70e79c68b58b45f Mon Sep 17 00:00:00 2001
From: tv <tv@shackspace.de>
Date: Sat, 2 Aug 2014 03:19:06 +0000
Subject: add Trammel - stack-based colorizer
---
src/Main.hs | 134 ++++++++++++++++++++++++++----------------------------------
1 file changed, 58 insertions(+), 76 deletions(-)
(limited to 'src/Main.hs')
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
--
cgit v1.2.3