diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Main.hs | 28 | ||||
| -rw-r--r-- | src/Trammel.hs | 198 |
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 |