summaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
authortv <tv@shackspace.de>2014-08-02 03:19:06 +0000
committertv <tv@shackspace.de>2014-08-02 03:19:06 +0000
commitd67d12e5b5678d005e8d5e02d70e79c68b58b45f (patch)
tree8306fa2043f9331beffff03243c80f3dd944d353 /src
parent1e1ab1b1808fa152845ab46403b35dc34ac28e96 (diff)
add Trammel - stack-based colorizer
Diffstat (limited to 'src')
-rw-r--r--src/Main.hs134
-rw-r--r--src/Trammel.hs108
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