summaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
authortv <tv@shackspace.de>2014-08-02 12:49:46 +0000
committertv <tv@shackspace.de>2014-08-02 15:33:07 +0200
commitadaca318897dd6966c5cd3a00094c3fdda9b5d96 (patch)
tree1629ce87e6b65858c224c48511c7ebd7b4e2de84 /src
parentd67d12e5b5678d005e8d5e02d70e79c68b58b45f (diff)
Trammel: add background color support
Diffstat (limited to 'src')
-rw-r--r--src/Main.hs28
-rw-r--r--src/Trammel.hs198
2 files changed, 169 insertions, 57 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
diff --git a/src/Trammel.hs b/src/Trammel.hs
index 41f0117..36c1140 100644
--- a/src/Trammel.hs
+++ b/src/Trammel.hs
@@ -3,18 +3,21 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
module Trammel where
+import Control.Applicative
import Data.List
import Data.String
import Data.Monoid
-import Data.Maybe (catMaybes)
import Data.Ix (inRange)
+type Ps = Int
+type Pm = [Ps]
data Trammel a
= Plain a
- | Gaudy [Int] (Trammel a)
+ | SGR Pm (Trammel a)
| Append (Trammel a) (Trammel a)
| Empty
deriving (Eq, Show)
@@ -29,60 +32,165 @@ instance IsString a => IsString (Trammel a) where
fromString = Plain . fromString
-data Color = AnsiColor Int | Xterm256 Int | XtermRGB Int Int Int
+class IsPm a where
+ toPm :: a -> Pm
+ fromPm :: Pm -> Maybe a
+
+
+data FColor = ECMA48FColor Ps -- ECMA-48 / ISO 6429 / ANSI X3.64
+ | Xterm256FColor Ps
+ | ISO8613_3FColor Ps Ps Ps
+ deriving (Eq, Show)
+
+instance IsPm FColor where
+ toPm (ECMA48FColor i) = [i]
+ toPm (Xterm256FColor i) = [38,5,i]
+ toPm (ISO8613_3FColor r g b) = [38,2,r,g,b]
+ fromPm = fromSGRPm SGRPm
+ { def8Ps = 39
+ , extPs = 38
+ , lo8Ps = 30
+ , hi8Ps = 37
+ , makeECMA48Color = ECMA48FColor
+ , makeXterm256Color = Xterm256FColor
+ , makeISO8613_3Color = ISO8613_3FColor
+ }
+ . filterPm sgrBColor
+
+
+data BColor = ECMA48BColor Ps
+ | Xterm256BColor Ps
+ | ISO8613_3BColor Ps Ps Ps
+ deriving (Eq, Show)
+
+
+instance IsPm BColor where
+ toPm (ECMA48BColor i) = [i]
+ toPm (Xterm256BColor i) = [48,5,i]
+ toPm (ISO8613_3BColor r g b) = [48,2,r,g,b]
+ fromPm = fromSGRPm SGRPm
+ { def8Ps = 49
+ , extPs = 48
+ , lo8Ps = 40
+ , hi8Ps = 47
+ , makeECMA48Color = ECMA48BColor
+ , makeXterm256Color = Xterm256BColor
+ , makeISO8613_3Color = ISO8613_3BColor
+ }
+ . filterPm sgrFColor
+
+
+data Bold = Bold | NoBold
deriving (Eq, Show)
+instance IsPm Bold where
+ toPm Bold = [1]
+ toPm NoBold = [22]
+ fromPm = rec . filterPm sgrColor
+ where
+ rec xs = case filter (`elem`[1,22]) xs of
+ [] -> Nothing
+ xs' -> case last xs' of
+ 1 -> Just Bold
+ 22 -> Just NoBold
+ _ -> error "filter broken in fromPm :: Pm -> Maybe Bold"
-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
+data Underline = Underline | NoUnderline
+ deriving (Eq, Show)
+
+instance IsPm Underline where
+ toPm Underline = [4]
+ toPm NoUnderline = [24]
+ fromPm = rec . filterPm sgrColor
+ where
+ rec xs = case filter (`elem`[4,24]) xs of
+ [] -> Nothing
+ xs' -> case last xs' of
+ 1 -> Just Underline
+ 22 -> Just NoUnderline
+ _ -> error "filter broken in fromPm :: Pm -> Maybe Underline"
+
+
+data SGRPm c = SGRPm
+ { def8Ps :: Ps
+ , extPs :: Ps
+ , lo8Ps :: Ps
+ , hi8Ps :: Ps
+ , makeECMA48Color :: Ps -> c
+ , makeXterm256Color :: Ps -> c
+ , makeISO8613_3Color :: Ps -> Ps -> Ps -> c
+ }
+
+
+fromSGRPm :: IsPm c => SGRPm c -> Pm -> Maybe c
+fromSGRPm SGRPm{..} = rec Nothing
+ where
+ rec mb_c (x:xs)
+ | x == extPs = case xs of
+ (2:r:g:b:xs') -> rec (Just $ makeISO8613_3Color r g b) xs'
+ (5:i:xs') -> rec (Just $ makeXterm256Color i) xs'
+ _ -> rec mb_c xs
+ | x == def8Ps = rec (Just $ makeECMA48Color def8Ps) xs
+ | inRange (lo8Ps, hi8Ps) x = rec (Just $ makeECMA48Color x) xs
+ | otherwise = rec mb_c xs
+ rec mb_c _ = mb_c
+
+
+-- filterPm is used to preprocess Pm before searching with fromPm in
+-- order to remove (longer) sequences that could contain subsequences
+-- that look like the (shorter) sequences we're searching.
+-- E.g. we could find [1] (bold) in any extended color sequence.
+-- TODO Can we combine this whole from*Pm with Scanner?
+filterPm :: (Pm -> Maybe Int) -> Pm -> Pm
+filterPm f = rec []
+ where
+ rec ys xs@(xhead:xtail) = maybe (rec (ys ++ [xhead]) xtail)
+ (rec ys . flip drop xs)
+ (f xs)
+ rec ys _ = ys
+
+sgrColor, sgrFColor, sgrBColor :: Pm -> Maybe Int
-toGR :: Color -> [Int]
-toGR (AnsiColor i) = [i]
-toGR (Xterm256 i) = [38,5,i]
-toGR (XtermRGB r g b) = [38,2,r,g,b]
+sgrColor xs = sgrFColor xs <|> sgrBColor xs
+sgrFColor (38:5:_) = Just 3
+sgrFColor (38:2:_) = Just 5
+sgrFColor _ = Nothing
+
+sgrBColor (48:5:_) = Just 3
+sgrBColor (48:2:_) = Just 5
+sgrBColor _ = Nothing
+
+
+type RenderState = [(FColor, BColor, Bold, Underline)]
--- TODO maybe bold and underline could be simply Bools
-type RenderState = [(Color,Int,Int)]
emptyRenderState :: RenderState
-emptyRenderState = [(AnsiColor 39,22,24)]
+emptyRenderState = [(ECMA48FColor 39, ECMA48BColor 49, NoBold, NoUnderline)]
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)
+-- TODO merge successive sequences: \ESC[32m\ESC[1m -> \ESC[31;1m
+renderString rs@((fc, bc, b, u):_) (SGR c t) y =
+ renderSGR bra ++ renderString rs' t (renderSGR ket ++ y)
where
- f p alt xs =
- case filter p xs of
- [] -> alt
- xs' -> last xs'
-
-renderString _ (Gaudy _ _) _ =
+ fc' = maybe fc id $ fromPm c
+ bc' = maybe bc id $ fromPm c
+ b' = maybe b id $ fromPm c
+ u' = maybe u id $ fromPm c
+ rs' = (fc', bc', b', u') : rs
+ bra = braket >>= fst
+ ket = braket >>= snd
+ braket =
+ (if fc' /= fc then (toPm fc', toPm fc) else ([],[])) :
+ (if bc' /= bc then (toPm bc', toPm bc) else ([],[])) :
+ (if b' /= b then (toPm b', toPm b) else ([],[])) :
+ (if u' /= u then (toPm u', toPm u) else ([],[])) : []
+
+renderString _ (SGR _ _) _ =
error "renderString called w/o proper initial state"
-- where a proper initial state is s.th. like emptyRenderState
@@ -94,7 +202,7 @@ renderString _ Empty y = y
len :: Trammel String -> Int
len (Plain x) = length x
-len (Gaudy _ x) = len x
+len (SGR _ x) = len x
len (Append t1 t2) = len t1 + len t2
len Empty = 0
@@ -103,6 +211,6 @@ pp :: Trammel String -> String
pp t = renderString emptyRenderState t ""
-sgr :: [Int] -> String
-sgr [] = []
-sgr xs = ("\ESC["++) . (++"m") . intercalate ";" $ map show xs
+renderSGR :: Pm -> String
+renderSGR [] = []
+renderSGR xs = ("\ESC["++) . (++"m") . intercalate ";" $ map show xs