module Rainbow.Types where
import qualified Data.String as Str
import Data.Monoid
import Data.Text (Text)
import Data.Maybe (fromMaybe)
import qualified Data.Text as X
import qualified Data.Text.Lazy as XL
import qualified System.Console.Terminfo as T
import System.IO as IO
import System.Environment as Env
import Data.Word (Word8)
data Term
= Dumb
| TermName String
deriving (Eq, Show)
termFromEnv :: IO Term
termFromEnv = do
t <- fmap (lookup "TERM") Env.getEnvironment
return $ maybe Dumb TermName t
smartTermFromEnv
:: IO.Handle
-> IO Term
smartTermFromEnv h = IO.hIsTerminalDevice h >>= f
where
f isTerm | isTerm = termFromEnv
| otherwise = return Dumb
type Background8 = Last Color8
type Background256 = Last Color256
type Foreground8 = Last Color8
type Foreground256 = Last Color256
data Enum8
= E0
| E1
| E2
| E3
| E4
| E5
| E6
| E7
deriving (Eq, Ord, Show, Bounded, Enum)
enum8toWord8 :: Enum8 -> Word8
enum8toWord8 e = case e of
E0 -> 0
E1 -> 1
E2 -> 2
E3 -> 3
E4 -> 4
E5 -> 5
E6 -> 6
E7 -> 7
newtype Color8 = Color8
{ unColor8 :: Maybe Enum8
} deriving (Eq, Ord, Show)
color8toTerminfo :: Color8 -> Maybe T.Color
color8toTerminfo = fmap (T.ColorNumber . fromIntegral . enum8toWord8)
. unColor8
newtype Color256 = Color256
{ unColor256 :: Maybe Word8
} deriving (Eq, Ord, Show)
color256toTerminfo :: Color256 -> Maybe T.Color
color256toTerminfo = fmap (T.ColorNumber . fromIntegral)
. unColor256
to256 :: Color8 -> Color256
to256 (Color8 mayE) = Color256 $ fmap enum8toWord8 mayE
data StyleCommon = StyleCommon
{ scBold :: Last Bool
, scUnderline :: Last Bool
, scFlash :: Last Bool
, scInverse :: Last Bool
} deriving (Show, Eq, Ord)
instance Monoid StyleCommon where
mempty = StyleCommon (Last Nothing) (Last Nothing)
(Last Nothing) (Last Nothing)
mappend (StyleCommon b1 u1 f1 i1) (StyleCommon b2 u2 f2 i2)
= StyleCommon (b1 <> b2) (u1 <> u2) (f1 <> f2) (i1 <> i2)
data Style8 = Style8
{ foreground8 :: Foreground8
, background8 :: Background8
, common8 :: StyleCommon
} deriving (Show, Eq, Ord)
instance Monoid Style8 where
mappend (Style8 fx bx cx) (Style8 fy by cy)
= Style8 (fx <> fy) (bx <> by) (cx <> cy)
mempty = Style8 mempty mempty mempty
data Style256 = Style256
{ foreground256 :: Foreground256
, background256 :: Background256
, common256 :: StyleCommon
} deriving (Show, Eq, Ord)
instance Monoid Style256 where
mappend (Style256 fx bx cx) (Style256 fy by cy)
= Style256 (fx <> fy) (bx <> by) (cx <> cy)
mempty = Style256 mempty mempty mempty
data TextSpec = TextSpec
{ style8 :: Style8
, style256 :: Style256
} deriving (Show, Eq, Ord)
instance Monoid TextSpec where
mappend (TextSpec x1 x2) (TextSpec y1 y2)
= TextSpec (x1 <> y1) (x2 <> y2)
mempty = TextSpec mempty mempty
data Chunk = Chunk
{ textSpec :: TextSpec
, text :: [Text]
} deriving (Eq, Show, Ord)
instance Str.IsString Chunk where
fromString s = Chunk mempty [(X.pack s)]
fromText :: Text -> Chunk
fromText = Chunk mempty . (:[])
fromLazyText :: XL.Text -> Chunk
fromLazyText = Chunk mempty . XL.toChunks
instance Monoid Chunk where
mempty = Chunk mempty mempty
mappend (Chunk s1 t1) (Chunk s2 t2) = Chunk (s1 <> s2) (t1 <> t2)
defaultColors :: T.Terminal -> T.TermOutput
defaultColors term =
fromMaybe mempty (T.getCapability term T.restoreDefaultColors)
commonAttrs :: T.Terminal -> StyleCommon -> T.TermOutput
commonAttrs t s =
let a = T.Attributes
{ T.standoutAttr = False
, T.underlineAttr = fromMaybe False
. getLast . scUnderline $ s
, T.reverseAttr = fromMaybe False
. getLast . scInverse $ s
, T.blinkAttr = fromMaybe False
. getLast . scFlash $ s
, T.dimAttr = False
, T.boldAttr = fromMaybe False
. getLast . scBold $ s
, T.invisibleAttr = False
, T.protectedAttr = False
}
in case T.getCapability t (T.setAttributes) of
Nothing -> error $ "Rainbow: commonAttrs: "
++ "capability failed; should never happen"
Just f -> f a
getTermCodes
:: T.Terminal
-> TextSpec
-> T.TermOutput
getTermCodes t ts = fromMaybe mempty $ do
cols <- T.getCapability t T.termColors
let TextSpec s8 s256 = ts
Style8 f8 b8 c8 = s8
Style256 f256 b256 c256 = s256
setFg <- T.getCapability t T.setForegroundColor
setBg <- T.getCapability t T.setBackgroundColor
(fg, bg, cm) <- case () of
_ | cols >= 256 -> Just $ ( fmap color256toTerminfo $ getLast f256
, fmap color256toTerminfo $ getLast b256
, c256)
| cols >= 8 -> Just ( fmap color8toTerminfo $ getLast f8
, fmap color8toTerminfo $ getLast b8
, c8)
| otherwise -> Nothing
let oFg = maybe mempty (maybe mempty setFg) fg
oBg = maybe mempty (maybe mempty setBg) bg
oCm = commonAttrs t cm
return $ mconcat [oCm, oFg, oBg]
hPrintChunk :: IO.Handle -> T.Terminal -> Chunk -> IO ()
hPrintChunk h t (Chunk ts xs) =
T.hRunTermOutput h t
. mconcat
$ defaultColors t : codes : (map (T.termText . X.unpack) $ xs)
where
codes = getTermCodes t ts
hPutChunks :: IO.Handle -> Term -> [Chunk] -> IO ()
hPutChunks h t cs = do
let setup = case t of
Dumb -> T.setupTerm "dumb"
TermName s -> T.setupTerm s
term <- setup
mapM_ (hPrintChunk h term) cs
T.hRunTermOutput h term (defaultColors term)
T.hRunTermOutput h term
$ case T.getCapability term T.allAttributesOff of
Nothing -> error $ "Rainbow.putChunks: error: "
++ "allAttributesOff failed"
Just s -> s
putChunks :: Term -> [Chunk] -> IO ()
putChunks = hPutChunks IO.stdout
hPutChunk :: IO.Handle -> Chunk -> IO ()
hPutChunk h c = do
t <- termFromEnv
hPutChunks h t [c]
putChunk :: Chunk -> IO ()
putChunk = hPutChunk IO.stdout
hPutChunkLn :: IO.Handle -> Chunk -> IO ()
hPutChunkLn h c = hPutChunk h c >> IO.hPutStr h "\n"
putChunkLn :: Chunk -> IO ()
putChunkLn c = putChunk c >> putStr "\n"
bold8 :: Chunk
bold8 = x {
textSpec = (textSpec x) {
style8 = (style8 (textSpec x)) {
common8 = (common8 (style8 (textSpec x))) {
scBold = Last (Just True) }}}}
where
x = mempty
bold8off :: Chunk
bold8off = x {
textSpec = (textSpec x) {
style8 = (style8 (textSpec x)) {
common8 = (common8 (style8 (textSpec x))) {
scBold = Last (Just False) }}}}
where
x = mempty
underline8 :: Chunk
underline8 = x {
textSpec = (textSpec x) {
style8 = (style8 (textSpec x)) {
common8 = (common8 (style8 (textSpec x))) {
scUnderline = Last (Just True) }}}}
where
x = mempty
underline8off :: Chunk
underline8off = x {
textSpec = (textSpec x) {
style8 = (style8 (textSpec x)) {
common8 = (common8 (style8 (textSpec x))) {
scUnderline = Last (Just False) }}}}
where
x = mempty
flash8 :: Chunk
flash8 = x {
textSpec = (textSpec x) {
style8 = (style8 (textSpec x)) {
common8 = (common8 (style8 (textSpec x))) {
scFlash = Last (Just True) }}}}
where
x = mempty
flash8off :: Chunk
flash8off = x {
textSpec = (textSpec x) {
style8 = (style8 (textSpec x)) {
common8 = (common8 (style8 (textSpec x))) {
scFlash = Last (Just False) }}}}
where
x = mempty
inverse8 :: Chunk
inverse8 = x {
textSpec = (textSpec x) {
style8 = (style8 (textSpec x)) {
common8 = (common8 (style8 (textSpec x))) {
scInverse = Last (Just True) }}}}
where
x = mempty
inverse8off :: Chunk
inverse8off = x {
textSpec = (textSpec x) {
style8 = (style8 (textSpec x)) {
common8 = (common8 (style8 (textSpec x))) {
scInverse = Last (Just False) }}}}
where
x = mempty
underline256 :: Chunk
underline256 = x {
textSpec = (textSpec x) {
style256 = (style256 (textSpec x)) {
common256 = (common256 (style256 (textSpec x))) {
scUnderline = Last (Just True) }}}}
where
x = mempty
underline256off :: Chunk
underline256off = x {
textSpec = (textSpec x) {
style256 = (style256 (textSpec x)) {
common256 = (common256 (style256 (textSpec x))) {
scUnderline = Last (Just False) }}}}
where
x = mempty
bold256 :: Chunk
bold256 = x {
textSpec = (textSpec x) {
style256 = (style256 (textSpec x)) {
common256 = (common256 (style256 (textSpec x))) {
scBold = Last (Just True) }}}}
where
x = mempty
bold256off :: Chunk
bold256off = x {
textSpec = (textSpec x) {
style256 = (style256 (textSpec x)) {
common256 = (common256 (style256 (textSpec x))) {
scBold = Last (Just False) }}}}
where
x = mempty
inverse256 :: Chunk
inverse256 = x {
textSpec = (textSpec x) {
style256 = (style256 (textSpec x)) {
common256 = (common256 (style256 (textSpec x))) {
scInverse = Last (Just True) }}}}
where
x = mempty
inverse256off :: Chunk
inverse256off = x {
textSpec = (textSpec x) {
style256 = (style256 (textSpec x)) {
common256 = (common256 (style256 (textSpec x))) {
scInverse = Last (Just False) }}}}
where
x = mempty
flash256 :: Chunk
flash256 = x {
textSpec = (textSpec x) {
style256 = (style256 (textSpec x)) {
common256 = (common256 (style256 (textSpec x))) {
scFlash = Last (Just True) }}}}
where
x = mempty
flash256off :: Chunk
flash256off = x {
textSpec = (textSpec x) {
style256 = (style256 (textSpec x)) {
common256 = (common256 (style256 (textSpec x))) {
scFlash = Last (Just False) }}}}
where
x = mempty
bold :: Chunk
bold = bold8 <> bold256
boldOff :: Chunk
boldOff = bold8off <> bold256off
inverse :: Chunk
inverse = inverse8 <> inverse256
inverseOff :: Chunk
inverseOff = inverse8off <> inverse256off
flash :: Chunk
flash = flash8 <> flash256
flashOff :: Chunk
flashOff = flash8off <> flash256off
underline :: Chunk
underline = underline8 <> underline256
underlineOff :: Chunk
underlineOff = underline8off <> underline256off