summaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Trammel.hs198
1 files changed, 153 insertions, 45 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-23 21:12:54 +0000