packages feed

safe-coloured-text (empty) → 0.0.0.0

raw patch · 6 files changed

+599/−0 lines, 6 filesdep +basedep +bytestringdep +terminfo

Dependencies added: base, bytestring, terminfo, text

Files

+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2021 Tom Sydney Kerckhove++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.
+ safe-coloured-text.cabal view
@@ -0,0 +1,39 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           safe-coloured-text+version:        0.0.0.0+synopsis:       Safely output coloured text+category:       User Interfaces+homepage:       https://github.com/NorfairKing/safe-coloured-text#readme+bug-reports:    https://github.com/NorfairKing/safe-coloured-text/issues+author:         Tom Sydney Kerckhove+maintainer:     syd@cs-syd.eu+copyright:      Copyright (c) 2020 Tom Sydney Kerckhove+license:        MIT+license-file:   LICENSE+build-type:     Simple++source-repository head+  type: git+  location: https://github.com/NorfairKing/safe-coloured-text++library+  exposed-modules:+      Text.Colour+      Text.Colour.Capabilities+      Text.Colour.Chunk+      Text.Colour.Code+  other-modules:+      Paths_safe_coloured_text+  hs-source-dirs:+      src+  build-depends:+      base >=4.7 && <5+    , bytestring+    , terminfo+    , text+  default-language: Haskell2010
+ src/Text/Colour.hs view
@@ -0,0 +1,113 @@+-- | Safe Coloured Text+--+-- This module is responsible for defining, building, and rendering coloured text.+--+-- The text to be coloured is 'Text', but the rendered text, while technically still (probably) valid Utf8, will be a 'ByteString' builder.+module Text.Colour+  ( -- * Building chunks+    chunk,+    Chunk (..),++    -- ** Styling++    -- *** Setting colour++    --+    -- These will only be rendered if the given 'TerminalCapabilities' supports them.+    fore,+    back,++    -- *** Setting non-colour attributes++    --+    -- These will be rendered for any 'TerminalCapabilities'+    bold,+    faint,+    italic,+    underline,+    doubleUnderline,++    -- ** Colours+    Colour (..),++    -- *** 8-colour++    -- **** Dull+    black,+    red,+    green,+    yellow,+    blue,+    magenta,+    cyan,+    white,++    -- **** Bright+    brightBlack,+    brightRed,+    brightGreen,+    brightYellow,+    brightBlue,+    brightMagenta,+    brightCyan,+    brightWhite,++    -- *** 8-bit+    color256,+    colour256,++    -- *** 24-bit+    colorRGB,+    colourRGB,++    -- * Rendering++    -- ** Rendering chunks to bytestring builders+    renderChunks,+    renderChunk,++    -- ** Rendering chunks to strict bytestring+    renderChunksBS,+    renderChunkBS,++    -- * IO+    TerminalCapabilities (..),+    getTerminalCapabilitiesFromEnv,+    getTerminalCapabilitiesFromHandle,++    -- ** Outputting chunks directly+    putChunks,+    hPutChunks,+    putChunksWith,+    hPutChunksWith,+  )+where++import qualified Data.ByteString.Builder as SBB+import System.IO+import Text.Colour.Capabilities+import Text.Colour.Chunk++-- | Print a list of chunks to 'stdout'.+--+-- This function will use 'getTerminalCapabilitiesHandle' on 'stdout'.+-- If you intend to use this function more than once, it is more efficient to use 'getTerminalCapabilitiesFromEnv' first and then use 'putChunksWith'.+putChunks :: [Chunk] -> IO ()+putChunks = hPutChunks stdout++-- | Print a list of chunks to the given 'Handle'+--+-- This function will use 'getTerminalCapabilitiesHandle' on the given handle.+-- If you intend to use this function more than once, it is more efficient to use 'getTerminalCapabilitiesHandle' first and then use 'hPutChunksWith'.+hPutChunks :: Handle -> [Chunk] -> IO ()+hPutChunks h cs = do+  tc <- getTerminalCapabilitiesFromHandle h+  hPutChunksWith tc h cs++-- | Print a list of chunks to stdout with given 'TerminalCapabilities'.+putChunksWith :: TerminalCapabilities -> [Chunk] -> IO ()+putChunksWith tc = hPutChunksWith tc stdout++-- | Print a list of chunks to the given 'Handle' with given 'TerminalCapabilities'.+hPutChunksWith :: TerminalCapabilities -> Handle -> [Chunk] -> IO ()+hPutChunksWith tc h cs = SBB.hPutBuilder h $ renderChunks tc cs
+ src/Text/Colour/Capabilities.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Text.Colour.Capabilities where++import Control.Exception+import GHC.Generics (Generic)+import qualified System.Console.Terminfo as Terminfo+import System.Environment (lookupEnv)+import System.IO++-- Note that the order of these constructors matters!+data TerminalCapabilities+  = -- | No colours+    WithoutColours+  | -- | Only 8 colours+    With8Colours+  | -- | Only 8-bit colours+    With8BitColours+  | -- | All 24-bit colours+    With24BitColours+  deriving (Show, Eq, Ord, Generic)++-- | Try to detect how many colours the terminal can handle.+--+-- This is based on the @colors@ capability of the terminfo detected based on the @TERM@ environment variable.+-- If the terminal can handle 8-bit colours and also has the @COLORTERM@ environment variable set to @24bit@ or @truecolor@, then this function will return 'With24BitColours'.+getTerminalCapabilitiesFromEnv :: IO TerminalCapabilities+getTerminalCapabilitiesFromEnv = do+  mTerm <- (Just <$> Terminfo.setupTermFromEnv) `catch` (\(_ :: Terminfo.SetupTermError) -> pure Nothing)+  case mTerm of+    Nothing -> pure WithoutColours+    Just term -> do+      -- To support 24-bit colour:+      -- https://unix.stackexchange.com/questions/450365/check-if-terminal-supports-24-bit-true-color+      mct <- lookupEnv "COLORTERM"+      pure $ case mct of+        Just "truecolor" -> With24BitColours+        Just "24bit" -> With24BitColours+        _ ->+          case Terminfo.getCapability term (Terminfo.tiGetNum "colors") of+            Nothing -> WithoutColours+            Just c+              | c > 256 -> With24BitColours+              | c >= 256 -> With8BitColours+              | c >= 8 -> With8Colours+              | otherwise -> WithoutColours++-- | Try to detect how many colours a given handle can handle.+--+-- This function does the same as 'getTerminalCapabilitiesFromEnv' but returns 'WithoutColours' is not a terminal device.+getTerminalCapabilitiesFromHandle :: Handle -> IO TerminalCapabilities+getTerminalCapabilitiesFromHandle h = do+  isTerm <- hIsTerminalDevice h+  if isTerm+    then getTerminalCapabilitiesFromEnv+    else pure WithoutColours
+ src/Text/Colour/Chunk.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++module Text.Colour.Chunk where++import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as SBB+import qualified Data.ByteString.Lazy as LB+import Data.Maybe+import Data.String+import Data.Text (Text)+import qualified Data.Text.Encoding as TE+import Data.Word+import GHC.Generics (Generic)+import Text.Colour.Capabilities+import Text.Colour.Code++data Chunk = Chunk+  { chunkText :: !Text,+    chunkItalic :: !(Maybe Bool),+    chunkConsoleIntensity :: !(Maybe ConsoleIntensity),+    chunkUnderlining :: !(Maybe Underlining),+    chunkForeground :: !(Maybe Colour),+    chunkBackground :: !(Maybe Colour)+  }+  deriving (Show, Eq, Generic)++instance IsString Chunk where+  fromString = chunk . fromString++plainChunk :: TerminalCapabilities -> Chunk -> Bool+plainChunk tc Chunk {..} =+  and+    [ isNothing chunkItalic,+      isNothing chunkConsoleIntensity,+      isNothing chunkUnderlining,+      maybe True (plainColour tc) chunkForeground,+      maybe True (plainColour tc) chunkBackground+    ]++plainColour :: TerminalCapabilities -> Colour -> Bool+plainColour tc = \case+  Colour8 {} -> tc < With8Colours+  Colour8Bit {} -> tc < With8BitColours+  Colour24Bit {} -> tc < With24BitColours++-- | Render a chunk directly to bytestring.+renderChunksBS :: Foldable f => TerminalCapabilities -> f Chunk -> ByteString+renderChunksBS tc = LB.toStrict . SBB.toLazyByteString . renderChunks tc++-- | Render chunks to a bytestring builder+renderChunks :: Foldable f => TerminalCapabilities -> f Chunk -> Builder+renderChunks tc = foldMap (renderChunk tc)++-- | Render a chunk directly to bytestring.+renderChunkBS :: TerminalCapabilities -> Chunk -> ByteString+renderChunkBS tc = LB.toStrict . SBB.toLazyByteString . renderChunk tc++-- | Render a chunk to a bytestring builder+renderChunk :: TerminalCapabilities -> Chunk -> Builder+renderChunk tc c@Chunk {..} =+  if plainChunk tc c+    then SBB.byteString (TE.encodeUtf8 chunkText)+    else+      mconcat+        [ renderCSI (SGR $ chunkSGR tc c),+          SBB.byteString (TE.encodeUtf8 chunkText),+          renderCSI (SGR [Reset])+        ]++chunkSGR :: TerminalCapabilities -> Chunk -> [SGR]+chunkSGR tc Chunk {..} =+  catMaybes+    [ SetItalic <$> chunkItalic,+      SetUnderlining <$> chunkUnderlining,+      SetConsoleIntensity <$> chunkConsoleIntensity,+      chunkForeground >>= colourSGR tc Foreground,+      chunkBackground >>= colourSGR tc Background+    ]++-- Turn a text into a plain chunk, without any styling+chunk :: Text -> Chunk+chunk t =+  Chunk+    { chunkText = t,+      chunkItalic = Nothing,+      chunkConsoleIntensity = Nothing,+      chunkUnderlining = Nothing,+      chunkForeground = Nothing,+      chunkBackground = Nothing+    }++fore :: Colour -> Chunk -> Chunk+fore col chu = chu {chunkForeground = Just col}++back :: Colour -> Chunk -> Chunk+back col chu = chu {chunkBackground = Just col}++bold :: Chunk -> Chunk+bold chu = chu {chunkConsoleIntensity = Just BoldIntensity}++faint :: Chunk -> Chunk+faint chu = chu {chunkConsoleIntensity = Just FaintIntensity}++italic :: Chunk -> Chunk+italic chu = chu {chunkItalic = Just True}++underline :: Chunk -> Chunk+underline chu = chu {chunkUnderlining = Just SingleUnderline}++doubleUnderline :: Chunk -> Chunk+doubleUnderline chu = chu {chunkUnderlining = Just DoubleUnderline}++-- TODO consider allowing an 8-colour alternative to a given 256-colour+data Colour+  = Colour8 !ColourIntensity !TerminalColour+  | Colour8Bit !Word8 -- The 8-bit colour+  | Colour24Bit !Word8 !Word8 !Word8+  deriving (Show, Eq, Generic)++colourSGR :: TerminalCapabilities -> ConsoleLayer -> Colour -> Maybe SGR+colourSGR tc layer =+  let cap tc' sgr = if tc >= tc' then Just sgr else Nothing+   in \case+        Colour8 intensity terminalColour -> cap With8Colours $ SetColour intensity layer terminalColour+        Colour8Bit w -> cap With8BitColours $ Set8BitColour layer w+        Colour24Bit r g b -> cap With24BitColours $ Set24BitColour layer r g b++black :: Colour+black = Colour8 Dull Black++red :: Colour+red = Colour8 Dull Red++green :: Colour+green = Colour8 Dull Green++yellow :: Colour+yellow = Colour8 Dull Yellow++blue :: Colour+blue = Colour8 Dull Blue++magenta :: Colour+magenta = Colour8 Dull Magenta++cyan :: Colour+cyan = Colour8 Dull Cyan++white :: Colour+white = Colour8 Dull White++brightBlack :: Colour+brightBlack = Colour8 Bright Black++brightRed :: Colour+brightRed = Colour8 Bright Red++brightGreen :: Colour+brightGreen = Colour8 Bright Green++brightYellow :: Colour+brightYellow = Colour8 Bright Yellow++brightBlue :: Colour+brightBlue = Colour8 Bright Blue++brightMagenta :: Colour+brightMagenta = Colour8 Bright Magenta++brightCyan :: Colour+brightCyan = Colour8 Bright Cyan++brightWhite :: Colour+brightWhite = Colour8 Bright White++-- | Bulid an 8-bit RGB Colour+--+-- This will not be rendered unless 'With8BitColours' is used.+colour256 :: Word8 -> Colour+colour256 = Colour8Bit++-- | Alias for 'colour256', bloody americans...+color256 :: Word8 -> Colour+color256 = colour256++-- | Bulid a 24-bit RGB Colour+--+-- This will not be rendered unless 'With24BitColours' is used.+colourRGB :: Word8 -> Word8 -> Word8 -> Colour+colourRGB = Colour24Bit++-- | Alias for 'colourRGB', bloody americans...+colorRGB :: Word8 -> Word8 -> Word8 -> Colour+colorRGB = Colour24Bit
+ src/Text/Colour/Code.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}++module Text.Colour.Code where++import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as SBB+import qualified Data.ByteString.Internal as SBI+import qualified Data.ByteString.Lazy as LB+import Data.List+import Data.Word+import GHC.Generics (Generic)++-- https://en.wikipedia.org/wiki/Escape_character#ASCII_escape_character+asciiEscape :: Word8+asciiEscape = SBI.c2w '\ESC'++csiStart :: Word8+csiStart = SBI.c2w '['++csiDelimiter :: Word8+csiDelimiter = SBI.c2w ';'++newtype CSI+  = SGR [SGR]+  deriving (Show, Eq, Generic)++-- | Render a CSI directly to bytestring.+-- You probably want to use 'renderCSI' instead.+-- This is just for testing.+renderCSIBS :: CSI -> ByteString+renderCSIBS = LB.toStrict . SBB.toLazyByteString . renderCSI++-- https://en.wikipedia.org/wiki/ANSI_escape_code#CSI_(Control_Sequence_Introducer)_sequences+renderCSI :: CSI -> Builder+renderCSI =+  let csi ps c =+        mconcat+          [ SBB.word8 asciiEscape,+            SBB.word8 csiStart,+            csiParamsToWords ps,+            SBB.word8 c+          ]+   in \case+        SGR sgrs -> csi (concatMap sgrToCSIParams sgrs) (SBI.c2w 'm')++-- https://en.wikipedia.org/wiki/ANSI_escape_code#SGR_(Select_Graphic_Rendition)_parameters+data SGR+  = Reset+  | SetItalic !Bool+  | SetUnderlining !Underlining+  | SetConsoleIntensity !ConsoleIntensity+  | SetColour !ColourIntensity !ConsoleLayer !TerminalColour+  | Set8BitColour !ConsoleLayer !Word8+  | Set24BitColour+      !ConsoleLayer+      !Word8 -- Red+      !Word8 -- Green+      !Word8 -- Blue+  deriving (Show, Eq, Generic)++csiParamsToWords :: [Word8] -> Builder+csiParamsToWords = mconcat . intersperse (SBB.word8 csiDelimiter) . map csiParamToWord++csiParamToWord :: Word8 -> Builder+csiParamToWord = \case+  0 -> mempty+  w -> SBB.word8Dec w++sgrToCSIParams :: SGR -> [Word8]+sgrToCSIParams = \case+  Reset -> [] -- [0] would be fine too+  SetItalic b -> [if b then 3 else 23]+  SetUnderlining u ->+    [ case u of+        SingleUnderline -> 4+        DoubleUnderline -> 21+        NoUnderline -> 24+    ]+  SetConsoleIntensity ci ->+    [ case ci of+        BoldIntensity -> 1+        FaintIntensity -> 2+        NormalIntensity -> 22+    ]+  SetColour i l c ->+    [ case i of+        Dull -> case l of+          Foreground -> 30 + terminalColourSGRParameter c+          Background -> 40 + terminalColourSGRParameter c+        Bright -> case l of+          Foreground -> 90 + terminalColourSGRParameter c+          Background -> 100 + terminalColourSGRParameter c+    ]+  Set8BitColour l w ->+    [ case l of+        Foreground -> 38+        Background -> 48,+      5,+      w+    ]+  Set24BitColour l r g b ->+    [ case l of+        Foreground -> 38+        Background -> 48,+      2,+      r,+      g,+      b+    ]++-- | ANSI text underlining+data Underlining+  = SingleUnderline+  | DoubleUnderline+  | NoUnderline+  deriving (Show, Eq, Generic, Bounded, Enum)++-- | ANSI general console intensity: usually treated as setting the font style+-- (e.g. 'BoldIntensity' causes text to be bold)+data ConsoleIntensity+  = BoldIntensity+  | FaintIntensity+  | NormalIntensity+  deriving (Show, Eq, Generic, Bounded, Enum)++-- | ANSI's standard colours come in two intensities+data ColourIntensity+  = Dull+  | Bright+  deriving (Show, Eq, Generic, Enum, Bounded)++-- | ANSI colours can be set on two different layers+data ConsoleLayer+  = Foreground+  | Background+  deriving (Show, Eq, Generic, Enum, Bounded)++data TerminalColour+  = Black+  | Red+  | Green+  | Yellow+  | Blue+  | Magenta+  | Cyan+  | White+  deriving (Show, Eq, Generic, Enum, Bounded)++terminalColourSGRParameter :: TerminalColour -> Word8+terminalColourSGRParameter = \case+  Black -> 0+  Red -> 1+  Green -> 2+  Yellow -> 3+  Blue -> 4+  Magenta -> 5+  Cyan -> 6+  White -> 7++terminalColourFromIndex :: Word8 -> Maybe TerminalColour+terminalColourFromIndex = \case+  0 -> Just Black+  1 -> Just Red+  2 -> Just Green+  3 -> Just Yellow+  4 -> Just Blue+  5 -> Just Magenta+  6 -> Just Cyan+  7 -> Just White+  _ -> Nothing