packages feed

colorful-monoids (empty) → 0.1.0.0

raw patch · 12 files changed

+733/−0 lines, 12 filesdep +basedep +colorful-monoidsdep +semigroupssetup-changed

Dependencies added: base, colorful-monoids, semigroups

Files

+ LICENSE view
@@ -0,0 +1,22 @@+The MIT License (MIT)++Copyright (c) 2017 Daniel Mendler++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ colorful-monoids.cabal view
@@ -0,0 +1,58 @@+-- This file has been generated from package.yaml by hpack version 0.15.0.+--+-- see: https://github.com/sol/hpack++name:           colorful-monoids+version:        0.1.0.0+synopsis:       Styled console text output using ANSI escape sequences.+description:    Styled console text output using ANSI escape sequences.+category:       Text, User Interfaces, Monad+stability:      experimental+homepage:       https://github.com/minad/colorful-monoids#readme+bug-reports:    https://github.com/minad/colorful-monoids/issues+author:         Daniel Mendler <mail@daniel-mendler.de>+maintainer:     Daniel Mendler <mail@daniel-mendler.de>+copyright:      2017 Daniel Mendler+license:        MIT+license-file:   LICENSE+tested-with:    GHC == 7.10.3, GHC == 8.0.1+build-type:     Simple+cabal-version:  >= 1.10++source-repository head+  type: git+  location: https://github.com/minad/colorful-monoids++library+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base >= 4.8 && < 5+  if impl(ghc < 8.0)+    build-depends:+        semigroups >= 0.9 && < 1+  exposed-modules:+      Data.Monoid.Colorful+      Data.Monoid.Colorful.Flat+  other-modules:+      Data.Monoid.Colorful.Color+      Data.Monoid.Colorful.Nested+      Data.Monoid.Colorful.Settings+      Data.Monoid.Colorful.SGR+      Data.Monoid.Colorful.Term+      Data.Monoid.Colorful.Trustworthy+      Paths_colorful_monoids+  default-language: Haskell2010++test-suite example+  type: exitcode-stdio-1.0+  main-is: example.hs+  ghc-options: -Wall+  build-depends:+      base >= 4.8 && < 5+    , colorful-monoids+  if impl(ghc < 8.0)+    build-depends:+        semigroups >= 0.9 && < 1+  default-language: Haskell2010
+ example.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Data.Monoid.Colorful+import Data.Foldable+import Text.Printf+import Data.Monoid ((<>))++ansiColors :: [Color]+ansiColors = [ DefaultColor+             , Black+             , Red+             , Green+             , Yellow+             , Blue+             , Magenta+             , Cyan+             , White+             , DullBlack+             , DullRed+             , DullGreen+             , DullYellow+             , DullBlue+             , DullMagenta+             , DullCyan+             , DullWhite+             ]++ansiColorsExample :: IO ()+ansiColorsExample = do+  term <- getTerm+  printColoredS term $ Style Under $ Style Bold "ANSI Example\n"+  for_ ansiColors $ \c -> do+    printColoredIO term $ Bg c $ Value $ printf "%-15s" $ show c+    printColoredIO term $ Fg c $ Value $ printf "%-15s" $ show c+    printColoredIO term $ Bg c $ Style Invert $ Value $ printf " %-15s" $ show c+    printColoredIO term $ Fg c $ Style Invert $ Value $ printf " %-15s" $ show c+    printColoredS term $ Bg c $ Value $ printf "%-15s" $ show c+    printColoredS term $ Fg c $ Value $ printf "%-15s" $ show c+    printColoredS term $ Bg c $ Style Invert $ Value $ printf " %-15s" $ show c+    printColoredS term $ Fg c $ Style Invert $ Value $ printf " %-15s" $ show c+    putChar '\n'++colors256Example :: IO ()+colors256Example = do+  term <- getTerm+  printColoredS term $ Style Under $ Style Bold "Color256 Example\n"+  for_ [0..255] $ \c -> do+    printColoredS term $ Bg (Color256 c) $ Value $ printf "%02x" c+    printColoredS term $ Fg (Color256 c) $ Value $ printf " %02x" c+    printColoredS term $ Bg (Color256 c) $ Style Invert $ Value $ printf " %02x" c+    printColoredS term $ Fg (Color256 c) $ Style Invert $ Value $ printf " %02x" c+    putChar '\n'++rgbExample :: IO ()+rgbExample = do+  term <- getTerm+  printColoredS term $ Style Under $ Style Bold "RGB Example\n"+  for_ [0,64..255] $ \r ->+    for_ [0,64..255] $ \g ->+      for_ [0,64..255] $ \b -> do+        let c = RGB r g b+        printColoredS term $ Bg c $ Value $ printf "%-20s" $ show c+        printColoredS term $ Fg c $ Value $ printf " %-20s" $ show c+        printColoredS term $ Bg c $ Style Invert $ Value $ printf " %-20s" $ show c+        printColoredS term $ Fg c $ Style Invert $ Value $ printf " %-20s" $ show c+        putChar '\n'++specialExample :: IO ()+specialExample = do+  term <- getTerm+  printColoredS term $ Style Under $ Style Bold "Special Example\n"+  for_ [Bold,Italic,Under,Invert,Blink] $ \a -> do+    printColoredS term $+      Style a (Value (printf "%-20s" $ show a) <>+               Unstyle a (Value $ printf " %-20s" $ "Not" ++ show a) <>+               Value (printf "%-20s" $ show a))+    putChar '\n'++stackExample :: IO ()+stackExample = do+  term <- getTerm+  printColoredS term $ Style Under $ Style Bold "Stack Example\n"+  printColoredS term $ loop 0+  putChar '\n'+  where+    loop 8 = mempty+    loop n =+      Bg (Color256 n) $+        Value (replicate (fromIntegral n) ' ') <>+        loop (n + 1) <>+        Value (replicate (fromIntegral n) ' ')++basicExample :: IO ()+basicExample = do+  term <- getTerm+  printColoredS term $ Style Under $ Style Bold "Basic Example\n"+  printColoredS term $ Style Bold "Bold"+  printColoredS term $ Style Italic $ Bg Red "Italic Red"+  printColoredS term $ Style Under "Under"+  putChar '\n'++reduceExample :: IO ()+reduceExample = do+  printColoredS Term8 $ Style Under $ Style Bold "Reduction Example\n"+  for_ [0..255] $ \c -> do+    printColoredS Term256 $ Bg (Color256 c) $ Value $ printf "%02x" c+    printColoredS Term8   $ Bg (Color256 c) $ Value $ printf "%02x" c+    putChar '\n'+  for_ [0,64..255] $ \r ->+    for_ [0,64..255] $ \g ->+      for_ [0,64..255] $ \b -> do+        let c = RGB r g b+        printColoredS TermRGB $ Bg c $ Value $ printf "%20s" $ show c+        printColoredS Term256 $ Bg c $ Value $ printf "%20s" $ show c+        printColoredS Term8   $ Bg c $ Value $ printf "%20s" $ show c+        putChar '\n'++main :: IO ()+main = do+  putStrLn "\n"+  ansiColorsExample+  colors256Example+  rgbExample+  specialExample+  stackExample+  basicExample+  reduceExample+  putStrLn "\n"
+ src/Data/Monoid/Colorful.hs view
@@ -0,0 +1,53 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Monoid.Colorful+-- Copyright   :  Daniel Mendler (c) 2017,+-- License     :  MIT (see the file LICENSE)+--+-- Maintainer  :  mail@daniel-mendler.de+-- Stability   :  experimental+-- Portability :  portable+--+-- This library provides styled text output using ANSI+-- escape sequences. The main feature is that the library+-- keeps track of a stack of the active styles using a state monad.+-- This makes it easy to use this library for a pretty printer with+-- nested annotations, e.g., wl-pprint-console.+--+-- Warning: Windows support is currently not implemented, but+-- is planned (by using ansi-terminal or the ffi).+--+-- Example:+--+-- > basicExample :: IO ()+-- > basicExample = do+-- >  term <- getTerm+-- >  printColoredS term $ Style Under $ Style Bold "Basic Example\n"+-- >  printColoredS term $ Style Bold "Bold"+-- >  printColoredS term $ Style Italic $ Bg Red "Italic Red"+-- >  printColoredS term $ Style Under "Under"+-- >  putChar '\n'+--+-- For many more examples, see the+-- <https://github.com/minad/colored-monoids/blob/master/example.hs example.hs> file.+-----------------------------------------------------------++module Data.Monoid.Colorful (+  Style(..)+  , Color(..)+  , Term(..)+  , Colored(..)+  , hGetTerm+  , getTerm+  , hPrintColored+  , printColored+  , hPrintColoredIO+  , printColoredIO+  , hPrintColoredS+  , printColoredS+  , showColored+  , showColoredA+  , showColoredS+) where++import Data.Monoid.Colorful.Nested
+ src/Data/Monoid/Colorful/Color.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE DeriveGeneric #-}++module Data.Monoid.Colorful.Color (+  Color(..)+  , Style(..)+  , reduceColor+) where++import Data.Word (Word8)+import Data.Bool (bool)+import Data.Monoid.Colorful.Term+import GHC.Generics (Generic)++-- | Rendering style+data Style+  = Bold     -- ^ Bold font+  | Italic   -- ^ Italic font+  | Under    -- ^ Underlined text+  | Invert   -- ^ Invert foreground and background color+  | Blink    -- ^ Blinking+  deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic)++-- | Named colors, 256 and RGB colors for more capable terminals.+data Color+  = DefaultColor                  -- ^ Default terminal color (terminal specific)+  | Black+  | Red+  | Green+  | Yellow+  | Blue+  | Magenta+  | Cyan+  | White+  | DullBlack+  | DullRed+  | DullGreen+  | DullYellow+  | DullBlue+  | DullMagenta+  | DullCyan+  | DullWhite+  | Color256 !Word8               -- ^ Color from 256 color scheme. Color is automatically reduced to 8 colors for less capable terminals.+  | RGB      !Word8 !Word8 !Word8 -- ^ True color. Color is automatically reduced to 256 or 8 colors for less capable terminals.+  deriving (Eq, Ord, Show, Read, Generic)++reduceColor :: Term -> Color -> Color+reduceColor Term8    = reduceColor8+reduceColor Term256  = reduceColor256+reduceColor _        = id++rgbToWord8 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8+rgbToWord8 base q r g b = base * (base * (r `div` q) + (g `div` q)) + (b `div` q)++gray24ToANSI :: Word8 -> Color+gray24ToANSI x+  | x < 6             = DullBlack+  | x >= 6 && x < 12  = Black+  | x >= 12 && x < 18 = DullWhite+  | otherwise         = White++color216ToANSI :: Word8 -> Color+color216ToANSI x = rgbToANSI 3 r g b+  where (r,gb) = divMod x 36+        (g,b)  = divMod gb 6++color16ToANSI :: Word8 -> Color+color16ToANSI 0  = DullBlack+color16ToANSI 1  = DullRed+color16ToANSI 2  = DullGreen+color16ToANSI 3  = DullYellow+color16ToANSI 4  = DullBlue+color16ToANSI 5  = DullMagenta+color16ToANSI 6  = DullCyan+color16ToANSI 7  = DullWhite+color16ToANSI 8  = Black+color16ToANSI 9  = Red+color16ToANSI 10 = Green+color16ToANSI 11 = Yellow+color16ToANSI 12 = Blue+color16ToANSI 13 = Magenta+color16ToANSI 14 = Cyan+color16ToANSI _  = White++squareNorm :: Integral a => a -> a -> a -> a+squareNorm r g b = ri*ri + bi*bi * gi*gi+  where ri = fromIntegral r+        gi = fromIntegral g+        bi = fromIntegral b++rgbToANSI :: Word8 -> Word8 -> Word8 -> Word8 -> Color+rgbToANSI q r g b = color16ToANSI $ bool 0 8 (squareNorm r g b >= squareNorm q q q) + rgbToWord8 2 q b g r++reduceColor8 :: Color -> Color+reduceColor8 (Color256 x)+  | x < 16    = color16ToANSI x+  | x < 232   = color216ToANSI $ x - 16+  | otherwise = gray24ToANSI $ x - 232+reduceColor8 (RGB r g b) = rgbToANSI 128 r g b+reduceColor8 x = x++reduceColor256 :: Color -> Color+reduceColor256 (RGB r g b)+  | r == g && r == b = Color256 $ 232 + r `div` 11+  | otherwise = Color256 $ 16 + rgbToWord8 6 43 r g b+reduceColor256 x = x
+ src/Data/Monoid/Colorful/Flat.hs view
@@ -0,0 +1,97 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Monoid.Colorful.Flat+-- Copyright   :  Daniel Mendler (c) 2017,+-- License     :  MIT (see the file LICENSE)+--+-- Maintainer  :  mail@daniel-mendler.de+-- Stability   :  experimental+-- Portability :  portable+--+-- This module provides the flat 'Colored' type,+-- which is used internally for rendering the+-- nested 'Data.Monoid.Colorful.Colored' but is+-- also useful on its own. The API resembles+-- the API of 'Data.Monoid.Colorful'.+--+-----------------------------------------------------------++{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveGeneric #-}++module Data.Monoid.Colorful.Flat (+  Style(..)+  , Color(..)+  , Term(..)+  , Colored(..)+  , hGetTerm+  , getTerm+  , hPrintColored+  , printColored+  , hPrintColoredIO+  , printColoredIO+  , hPrintColoredS+  , printColoredS+  , showColored+  , showColoredA+  , showColoredS+) where++import System.IO (Handle, stdout, hPutStr)+import Data.Monoid.Colorful.Term+import Data.Monoid.Colorful.Settings+import Data.Monoid.Colorful.Color+import Data.Monoid.Colorful.SGR+import Data.Functor.Identity+import Data.Bifunctor (first, second)+import GHC.Generics (Generic, Generic1)++data Colored a+  = Value a+  | Style   !Style+  | Unstyle !Style+  | Fg      !Color+  | Bg      !Color+  | Push+  | Pop+  | Reset+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic, Generic1)++hPrintColoredIO :: Handle -> Term -> [Colored (IO ())] -> IO ()+hPrintColoredIO h = showColoredA id (hPutStr h)++printColoredIO :: Term -> [Colored (IO ())] -> IO ()+printColoredIO = hPrintColoredIO stdout++hPrintColored :: (Handle -> a -> IO ()) -> Handle -> Term -> [Colored a] -> IO ()+hPrintColored f h = showColoredA (f h) (hPutStr h)++printColored :: (a -> IO ()) -> Term -> [Colored a] -> IO ()+printColored f = hPrintColored (const f) stdout++hPrintColoredS :: Handle -> Term -> [Colored String] -> IO ()+hPrintColoredS h = showColoredA (hPutStr h) (hPutStr h)++printColoredS :: Term -> [Colored String] -> IO ()+printColoredS = hPrintColoredS stdout++showColoredS :: Term -> [Colored String] -> ShowS+showColoredS = showColored (++) (++)++showColored :: Monoid o => (a -> o) -> (SGRCode -> o) -> Term -> [Colored a] -> o+showColored str code term flat = runIdentity $ showColoredA (pure . str) (pure . code) term flat++showColoredA :: (Applicative f, Monoid o) => (a -> f o) -> (SGRCode -> f o) -> Term -> [Colored a] -> f o+showColoredA str code term = go (defaultSettings, (defaultSettings, []))+  where go s (Style   a:b) = go ((second.first) (setStyle a True) s) b+        go s (Unstyle a:b) = go ((second.first) (setStyle a False) s) b+        go s (Fg      a:b) = go ((second.first) (setFg a) s) b+        go s (Bg      a:b) = go ((second.first) (setBg a) s) b+        go s (Push     :b) = go (second pushStack s) b+        go s (Pop      :b) = go (second popStack s) b+        go s (Reset    :b) = go (second resetStack s) b+        go s (Value   a:b) = let (old, stack@(new, _)) = s in+          mappend <$> (mappend <$> code (sgrCode term old new) <*> str a) <*> go (new, stack) b+        go s [] = let (old, (new, _)) = s in code (sgrCode term old new)
+ src/Data/Monoid/Colorful/Nested.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Monoid.Colorful.Nested (+  Style(..)+  , Color(..)+  , Term(..)+  , Colored(..)+  , hGetTerm+  , getTerm+  , hPrintColored+  , printColored+  , hPrintColoredIO+  , printColoredIO+  , hPrintColoredS+  , printColoredS+  , showColored+  , showColoredA+  , showColoredS+) where++import System.IO (Handle)+import Data.Monoid.Colorful.Term+import Data.Monoid.Colorful.Color+import Data.Monoid.Colorful.SGR+import Data.Monoid.Colorful.Trustworthy+import Data.String (IsString(..))+import Data.Semigroup (Semigroup)+import GHC.Generics (Generic, Generic1)+import qualified Data.Monoid.Colorful.Flat as Flat+import Control.Monad (ap)++data Colored a+  = Nil+  | Value a+  | Style   !Style (Colored a)+  | Unstyle !Style (Colored a)+  | Fg      !Color (Colored a)+  | Bg      !Color (Colored a)+  | Pair    (Colored a) (Colored a)+  deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable, Generic, Generic1)++instance Applicative Colored where+  pure = Value+  (<*>) = ap++instance Monad Colored where+  Nil         >>= _ = Nil+  Value     x >>= f = f x+  Style   a x >>= f = Style   a (x >>= f)+  Unstyle a x >>= f = Unstyle a (x >>= f)+  Fg      a x >>= f = Fg      a (x >>= f)+  Bg      a x >>= f = Bg      a (x >>= f)+  Pair    x y >>= f = Pair      (x >>= f) (y >>= f)++instance Semigroup (Colored a)+instance Monoid (Colored a) where+  mempty = Nil+  mappend = Pair++instance IsString a => IsString (Colored a) where+  fromString = Value . fromString++instance IsList (Colored a) where+  type Item (Colored a) = Colored a+  fromList = foldr Pair Nil+  toList   = (:[]) -- TODO, invalid++flatten :: Colored a -> [Flat.Colored a]+flatten s = go s []+  where go (Value   a)      = (Flat.Value a:)+        go (Style   a b)    = (Flat.Push:) . (Flat.Style   a:) . go b . (Flat.Pop:)+        go (Unstyle a b)    = (Flat.Push:) . (Flat.Unstyle a:) . go b . (Flat.Pop:)+        go (Fg      a b)    = (Flat.Push:) . (Flat.Fg      a:) . go b . (Flat.Pop:)+        go (Bg      a b)    = (Flat.Push:) . (Flat.Bg      a:) . go b . (Flat.Pop:)+        go Nil              = id+        go (Pair    a b)    = go a . go b++hPrintColoredIO :: Handle -> Term -> Colored (IO ()) -> IO ()+hPrintColoredIO h t = Flat.hPrintColoredIO h t . flatten++printColoredIO :: Term -> Colored (IO ()) -> IO ()+printColoredIO t = Flat.printColoredIO t . flatten++hPrintColored :: (Handle -> a -> IO ()) -> Handle -> Term -> Colored a -> IO ()+hPrintColored f h t = Flat.hPrintColored f h t . flatten++printColored :: (a -> IO ()) -> Term -> Colored a -> IO ()+printColored f t = Flat.printColored f t . flatten++hPrintColoredS :: Handle -> Term -> Colored String -> IO ()+hPrintColoredS h t = Flat.hPrintColoredS h t . flatten++printColoredS :: Term -> Colored String -> IO ()+printColoredS t = Flat.printColoredS t . flatten++showColoredA :: (Applicative f, Monoid o) => (a -> f o) -> (SGRCode -> f o) -> Term -> Colored a -> f o+showColoredA f g t = Flat.showColoredA f g t . flatten++showColored :: Monoid o => (a -> o) -> (SGRCode -> o) -> Term -> Colored a -> o+showColored f g t = Flat.showColored f g t . flatten++showColoredS :: Term -> Colored String -> ShowS+showColoredS t = Flat.showColoredS t . flatten
+ src/Data/Monoid/Colorful/SGR.hs view
@@ -0,0 +1,61 @@+module Data.Monoid.Colorful.SGR (+  SGRCode,+  sgrCode+) where++import Data.Monoid.Colorful.Term+import Data.Monoid.Colorful.Settings+import Data.Monoid.Colorful.Color+import Data.Word (Word8)+import Data.List.NonEmpty (NonEmpty(..))+import Data.Bool (bool)+import Data.List (intercalate)++type SGRCode = String++csi :: Char -> [Word8] -> SGRCode+csi cmd args = "\ESC[" ++ intercalate ";" (map show args) ++ pure cmd++sgrCode :: Term -> Settings -> Settings -> SGRCode+sgrCode TermDumb _ _ = ""+sgrCode TermWin  _ _ = ""+sgrCode t old new+  | old == new = ""+  | new == defaultSettings = csi 'm' []+  | otherwise = csi 'm' $+    flag  styleBlink  5  +++    flag  styleBold   1  +++    flag  styleItalic 3  +++    flag  styleUnder  4  +++    flag  styleInvert 7  +++    color styleFg     0  +++    color styleBg     10++  where++  update :: Eq a => (Settings -> a) -> (a -> [Word8]) -> [Word8]+  update f g = let new' = f new in bool [] (g new') (new' /= f old)++  flag  f n = update f $ bool [20 + n] [n]+  color f n = update (reduceColor t . f) (\x -> let (c:|cs) = sgrColorArgs x in c + n : cs)++sgrColorArgs :: Color -> NonEmpty Word8+sgrColorArgs (Color256 n) = 38 :| [5, n]+sgrColorArgs (RGB r g b)  = 38 :| [2, r, g, b]+sgrColorArgs Black        = pure 90+sgrColorArgs Red          = pure 91+sgrColorArgs Green        = pure 92+sgrColorArgs Yellow       = pure 93+sgrColorArgs Blue         = pure 94+sgrColorArgs Magenta      = pure 95+sgrColorArgs Cyan         = pure 96+sgrColorArgs White        = pure 97+sgrColorArgs DullBlack    = pure 30+sgrColorArgs DullRed      = pure 31+sgrColorArgs DullGreen    = pure 32+sgrColorArgs DullYellow   = pure 33+sgrColorArgs DullBlue     = pure 34+sgrColorArgs DullMagenta  = pure 35+sgrColorArgs DullCyan     = pure 36+sgrColorArgs DullWhite    = pure 37+sgrColorArgs DefaultColor = pure 39
+ src/Data/Monoid/Colorful/Settings.hs view
@@ -0,0 +1,48 @@+module Data.Monoid.Colorful.Settings (+  Settings(..)+  , defaultSettings+  , setStyle, setBg, setFg+  , resetStack, pushStack, popStack+) where++import Data.Monoid.Colorful.Color++data Settings = Settings+  { styleBold   :: !Bool+  , styleItalic :: !Bool+  , styleUnder  :: !Bool+  , styleInvert :: !Bool+  , styleBlink  :: !Bool+  , styleFg     :: !Color+  , styleBg     :: !Color+  } deriving (Eq)++type SettingsStack = (Settings, [Settings])++defaultSettings :: Settings+defaultSettings = Settings+  { styleBold   = False+  , styleItalic = False+  , styleInvert = False+  , styleUnder  = False+  , styleBlink  = False+  , styleFg     = DefaultColor+  , styleBg     = DefaultColor+  }++setStyle :: Style -> Bool -> Settings -> Settings+setStyle Bold   b s = s { styleBold   = b }+setStyle Italic b s = s { styleItalic = b }+setStyle Under  b s = s { styleUnder  = b }+setStyle Invert b s = s { styleInvert = b }+setStyle Blink  b s = s { styleBlink  = b }++setBg, setFg :: Color -> Settings -> Settings+setBg c s = s { styleBg = c }+setFg c s = s { styleFg = c }++resetStack, pushStack, popStack :: SettingsStack -> SettingsStack+resetStack (_, ys)     = (defaultSettings, ys)+pushStack  (y, ys)     = (y, y:ys)+popStack   (_, [])     = (defaultSettings, [])+popStack   (_, z : zs) = (z, zs)
+ src/Data/Monoid/Colorful/Term.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE DeriveGeneric #-}++module Data.Monoid.Colorful.Term (+  Term(..)+  , getTerm+  , hGetTerm+) where++import Data.List (isPrefixOf, isInfixOf)+import System.Environment (getEnv)+import System.IO (Handle, hIsTerminalDevice, stdout)+import GHC.Generics (Generic)++-- | Terminal type. For less capable terminals the color depth is automatically reduced.+data Term+  = TermDumb -- ^ Dumb terminal - no color output+  | Term8    -- ^ 8 colors supported+  | Term256  -- ^ 256 colors supported+  | TermRGB  -- ^ True colors supported+  | TermWin  -- ^ Windows terminal. Will use emulation (Not yet implemented).+  deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic)++getTerm :: IO Term+getTerm = hGetTerm stdout++-- | The action @(hGetTerm handle)@ determines the terminal type of the file @handle@.+--+-- The terminal type is determined by checking if the file handle points to a device+-- and by looking at the @$TERM@ environment variable.+hGetTerm :: Handle -> IO Term+hGetTerm h = do+  term <- hIsTerminalDevice h+  if term+    then envToTerm  <$> getEnv "TERM"+    else pure TermDumb++-- | Determine the terminal type from the value of the @$TERM@ environment variable.+-- TODO improve this+envToTerm :: String -> Term+envToTerm "dumb" = TermDumb+envToTerm term | any (`isPrefixOf` term) rgbTerminals = TermRGB+               | "256" `isInfixOf` term = Term256+               | otherwise = Term8+  where rgbTerminals = ["xterm", "konsole", "gnome", "st", "linux"]
+ src/Data/Monoid/Colorful/Trustworthy.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE Trustworthy #-}++module Data.Monoid.Colorful.Trustworthy (+  IsList(..)+) where++import GHC.Exts (IsList(..))