From 5e9e4888aaf6380383dd07dc9a8d348dc5b875d0 Mon Sep 17 00:00:00 2001 From: tv Date: Sat, 17 Oct 2015 00:49:51 +0200 Subject: rename Trammel to Blessings --- src/Blessings.hs | 250 +++++++++++++++++++++++++++++++++++++++++++++++++++++ src/Trammel.hs | 255 ------------------------------------------------------- 2 files changed, 250 insertions(+), 255 deletions(-) create mode 100644 src/Blessings.hs delete mode 100644 src/Trammel.hs (limited to 'src') diff --git a/src/Blessings.hs b/src/Blessings.hs new file mode 100644 index 0000000..753b560 --- /dev/null +++ b/src/Blessings.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +module Blessings where + +import Control.Applicative +import Data.List +import Data.String +import Data.Ix (inRange) + +type Ps = Int +type Pm = [Ps] + +data Blessings a + = Plain a + | SGR Pm (Blessings a) + | Append (Blessings a) (Blessings a) + | Empty + deriving (Eq, Show) + + +instance Functor Blessings where + fmap f = \case + Append t1 t2 -> Append (fmap f t1) (fmap f t2) + Plain s -> Plain (f s) + SGR pm t -> SGR pm (fmap f t) + Empty -> Empty + + +instance Monoid (Blessings a) where + mappend = Append + mempty = Empty + + +instance IsString a => IsString (Blessings a) where + fromString = Plain . fromString + + +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] :: [Int])) xs of + [] -> Nothing + xs' -> case last xs' of + 1 -> Just Bold + 22 -> Just NoBold + _ -> error "filter broken in fromPm :: Pm -> Maybe Bold" + + +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] :: [Int])) 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 + +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)] + + +emptyRenderState :: RenderState +emptyRenderState = [(ECMA48FColor 39, ECMA48BColor 49, NoBold, NoUnderline)] + +renderString :: RenderState -> Blessings String -> String -> String + +renderString _ (Plain s) y = s ++ 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 + 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 + +renderString r (Append t1 t2) y = + renderString r t1 $ renderString r t2 y + +renderString _ Empty y = y + + +len :: Blessings String -> Int +len (Plain x) = length x +len (SGR _ x) = len x +len (Append t1 t2) = len t1 + len t2 +len Empty = 0 + + +pp :: Blessings String -> String +pp t = renderString emptyRenderState t "" + + +renderSGR :: Pm -> String +renderSGR [] = [] +renderSGR xs = ("\ESC["++) . (++"m") . intercalate ";" $ map show xs + + +blessingsDrop :: Int -> Blessings String -> Blessings String +blessingsDrop n = \case + Append t1 t2 -> + case compare n (len t1) of + LT -> Append (blessingsDrop n t1) t2 + EQ -> t2 + GT -> blessingsDrop (n - len t1) t2 + Plain s -> + Plain (drop n s) + SGR pm t -> + SGR pm (blessingsDrop n t) + Empty -> + Empty + + +blessingsTake :: Int -> Blessings String -> Blessings String +blessingsTake n = \case + Append t1 t2 -> + case compare n (len t1) of + LT -> blessingsTake n t1 + EQ -> t1 + GT -> Append t1 (blessingsTake (n - len t1) t2) + Plain s -> + Plain (take n s) + SGR pm t -> + SGR pm (blessingsTake n t) + Empty -> + Empty diff --git a/src/Trammel.hs b/src/Trammel.hs deleted file mode 100644 index d1abedb..0000000 --- a/src/Trammel.hs +++ /dev/null @@ -1,255 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE LambdaCase #-} -module Trammel where - -import Control.Applicative -import Data.List -import Data.String -import Data.Monoid -import Data.Ix (inRange) - -type Ps = Int -type Pm = [Ps] - -data Trammel a - = Plain a - | SGR Pm (Trammel a) - | Append (Trammel a) (Trammel a) - | Empty - deriving (Eq, Show) - - -instance Functor Trammel where - fmap f = \case - Append t1 t2 -> Append (fmap f t1) (fmap f t2) - Plain s -> Plain (f s) - SGR pm t -> SGR pm (fmap f t) - Empty -> Empty - - -instance Monoid (Trammel a) where - mappend = Append - mempty = Empty - - -instance IsString a => IsString (Trammel a) where - fromString = Plain . fromString - - -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] :: [Int])) xs of - [] -> Nothing - xs' -> case last xs' of - 1 -> Just Bold - 22 -> Just NoBold - _ -> error "filter broken in fromPm :: Pm -> Maybe Bold" - - -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] :: [Int])) 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 - -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)] - - -emptyRenderState :: RenderState -emptyRenderState = [(ECMA48FColor 39, ECMA48BColor 49, NoBold, NoUnderline)] - -renderString :: RenderState -> Trammel String -> String -> String - -renderString _ (Plain s) y = s ++ 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 - 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 - -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 (SGR _ x) = len x -len (Append t1 t2) = len t1 + len t2 -len Empty = 0 - - -pp :: Trammel String -> String -pp t = renderString emptyRenderState t "" - - -renderSGR :: Pm -> String -renderSGR [] = [] -renderSGR xs = ("\ESC["++) . (++"m") . intercalate ";" $ map show xs - - -trammelDrop :: Int -> Trammel String -> Trammel String -trammelDrop n = \case - Append t1 t2 -> - case compare n (len t1) of - LT -> Append (trammelDrop n t1) t2 - EQ -> t2 - GT -> trammelDrop (n - len t1) t2 - Plain s -> - Plain (drop n s) - SGR pm t -> - SGR pm (trammelDrop n t) - Empty -> - Empty - - -trammelTake :: Int -> Trammel String -> Trammel String -trammelTake n = \case - Append t1 t2 -> - case compare n (len t1) of - LT -> trammelTake n t1 - EQ -> t1 - GT -> Append t1 (trammelTake (n - len t1) t2) - Plain s -> - Plain (take n s) - SGR pm t -> - SGR pm (trammelTake n t) - Empty -> - Empty -- cgit v1.2.3