module Rainbow.Translate where
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text as X
import qualified Data.Text.Encoding as X
import qualified Data.Text.Lazy as XL
import Data.ByteString (ByteString)
import Data.Word
import Data.List (intersperse)
import qualified Rainbow.Types as T
import System.Process
import Text.Read
import System.Exit
import Control.Monad
import Control.Exception
import qualified System.IO as IO
class Renderable a where
render :: a -> [ByteString] -> [ByteString]
instance Renderable X.Text where
render x = (X.encodeUtf8 x :)
instance Renderable XL.Text where
render = foldr (.) id . map render . XL.toChunks
instance Renderable BS.ByteString where
render x = (x :)
instance Renderable BSL.ByteString where
render x = (BSL.toChunks x ++)
instance Renderable String where
render x = ((X.encodeUtf8 . X.pack $ x):)
single :: Char -> [ByteString] -> [ByteString]
single c = ((BS8.singleton c):)
escape :: [ByteString] -> [ByteString]
escape = single '\x1B'
csi :: [ByteString] -> [ByteString]
csi = escape . single '['
sgr :: ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
sgr sq = csi . sq . single 'm'
params :: Show a => [a] -> [ByteString] -> [ByteString]
params cs = ((intersperse semi . map (BS8.pack . show) $ cs) ++)
where
semi = BS8.singleton ';'
sgrSingle :: Word -> [ByteString] -> [ByteString]
sgrSingle w = sgr $ params [w]
sgrDouble :: Word -> Word -> [ByteString] -> [ByteString]
sgrDouble x y = sgr $ params [x, y]
normalDefault :: [ByteString] -> [ByteString]
normalDefault = sgrSingle 0
bold :: [ByteString] -> [ByteString]
bold = sgrSingle 1
faint :: [ByteString] -> [ByteString]
faint = sgrSingle 2
italic :: [ByteString] -> [ByteString]
italic = sgrSingle 3
underline :: [ByteString] -> [ByteString]
underline = sgrSingle 4
blink :: [ByteString] -> [ByteString]
blink = sgrSingle 5
inverse :: [ByteString] -> [ByteString]
inverse = sgrSingle 7
invisible :: [ByteString] -> [ByteString]
invisible = sgrSingle 8
strikeout :: [ByteString] -> [ByteString]
strikeout = sgrSingle 9
foreBlack :: [ByteString] -> [ByteString]
foreBlack = sgrSingle 30
foreRed :: [ByteString] -> [ByteString]
foreRed = sgrSingle 31
foreGreen :: [ByteString] -> [ByteString]
foreGreen = sgrSingle 32
foreYellow :: [ByteString] -> [ByteString]
foreYellow = sgrSingle 33
foreBlue :: [ByteString] -> [ByteString]
foreBlue = sgrSingle 34
foreMagenta :: [ByteString] -> [ByteString]
foreMagenta = sgrSingle 35
foreCyan :: [ByteString] -> [ByteString]
foreCyan = sgrSingle 36
foreWhite :: [ByteString] -> [ByteString]
foreWhite = sgrSingle 37
foreDefault :: [ByteString] -> [ByteString]
foreDefault = sgrSingle 39
backBlack :: [ByteString] -> [ByteString]
backBlack = sgrSingle 40
backRed :: [ByteString] -> [ByteString]
backRed = sgrSingle 41
backGreen :: [ByteString] -> [ByteString]
backGreen = sgrSingle 42
backYellow :: [ByteString] -> [ByteString]
backYellow = sgrSingle 43
backBlue :: [ByteString] -> [ByteString]
backBlue = sgrSingle 44
backMagenta :: [ByteString] -> [ByteString]
backMagenta = sgrSingle 45
backCyan :: [ByteString] -> [ByteString]
backCyan = sgrSingle 46
backWhite :: [ByteString] -> [ByteString]
backWhite = sgrSingle 47
backDefault :: [ByteString] -> [ByteString]
backDefault = sgrSingle 49
fore256 :: Word8 -> [ByteString] -> [ByteString]
fore256 c = sgr $ params [38,5,c]
back256 :: Word8 -> [ByteString] -> [ByteString]
back256 c = sgr $ params [48,5,c]
foreColor8 :: T.Enum8 -> [ByteString] -> [ByteString]
foreColor8 e8 = case e8 of
T.E0 -> foreBlack
T.E1 -> foreRed
T.E2 -> foreGreen
T.E3 -> foreYellow
T.E4 -> foreBlue
T.E5 -> foreMagenta
T.E6 -> foreCyan
T.E7 -> foreWhite
backColor8 :: T.Enum8 -> [ByteString] -> [ByteString]
backColor8 e8 = case e8 of
T.E0 -> backBlack
T.E1 -> backRed
T.E2 -> backGreen
T.E3 -> backYellow
T.E4 -> backBlue
T.E5 -> backMagenta
T.E6 -> backCyan
T.E7 -> backWhite
renderFormat :: T.Format -> [ByteString] -> [ByteString]
renderFormat (T.Format bld fnt ita und bli ivr isb stk)
= effect bold bld
. effect faint fnt
. effect italic ita
. effect underline und
. effect blink bli
. effect inverse ivr
. effect invisible isb
. effect strikeout stk
where
effect on x = if x then on else id
renderStyle8 :: T.Style T.Enum8 -> [ByteString] -> [ByteString]
renderStyle8 (T.Style fore back format)
= effect foreColor8 fore
. effect backColor8 back
. renderFormat format
where
effect on (T.Color may) = maybe id on may
renderStyle256 :: T.Style Word8 -> [ByteString] -> [ByteString]
renderStyle256 (T.Style fore back format)
= effect fore256 fore
. effect back256 back
. renderFormat format
where
effect on (T.Color may) = maybe id on may
toByteStringsColors0
:: Renderable a
=> T.Chunk a
-> [ByteString]
-> [ByteString]
toByteStringsColors0 (T.Chunk _ _ yn) = render yn
toByteStringsColors8
:: Renderable a
=> T.Chunk a
-> [ByteString]
-> [ByteString]
toByteStringsColors8 (T.Chunk s8 _ yn)
= normalDefault
. renderStyle8 s8
. render yn
. normalDefault
toByteStringsColors256
:: Renderable a
=> T.Chunk a
-> [ByteString]
-> [ByteString]
toByteStringsColors256 (T.Chunk _ s256 yn)
= normalDefault
. renderStyle256 s256
. render yn
. normalDefault
byteStringMakerFromEnvironment
:: Renderable a
=> IO (T.Chunk a -> [ByteString] -> [ByteString])
byteStringMakerFromEnvironment
= catcher (fmap f $ readProcessWithExitCode "tput" ["colors"] "")
where
f (code, stdOut, _) = maybe toByteStringsColors0 id $ do
case code of
ExitFailure _ -> mzero
_ -> return ()
numColors <- readMaybe stdOut
return $ numColorsToFunc numColors
numColorsToFunc i
| i >= (256 :: Int) = toByteStringsColors256
| i >= 8 = toByteStringsColors8
| otherwise = toByteStringsColors0
catcher act = fmap g (try act)
where
g (Left e) = toByteStringsColors0
where _types = e :: IOException
g (Right good) = good
byteStringMakerFromHandle
:: Renderable a
=> IO.Handle
-> IO (T.Chunk a -> [ByteString] -> [ByteString])
byteStringMakerFromHandle h = IO.hIsTerminalDevice h >>= f
where
f isTerm | isTerm = byteStringMakerFromEnvironment
| otherwise = return toByteStringsColors0
chunksToByteStrings
:: (T.Chunk a -> [ByteString] -> [ByteString])
-> [T.Chunk a]
-> [ByteString]
chunksToByteStrings mk = ($ []) . foldr (.) id . map mk
putChunk :: Renderable a => T.Chunk a -> IO ()
putChunk ck = do
mkr <- byteStringMakerFromEnvironment
mapM_ BS.putStr . chunksToByteStrings mkr $ [ck]
putChunkLn :: Renderable a => T.Chunk a -> IO ()
putChunkLn ck = putChunk ck >> putStrLn ""