Merge pull request #40 from MorrowM/no-color

Allow disabling colors (#29)

CHANGELOG.md

@@ -1,3 +1,8 @@
+# 0.9.1
+
+* When the [`NO_COLOR`](https://no-color.org/) environment variable is set, the client will not color the output.
+* Added `--[no-]color` options which enable/disable output coloring (overrides `NO_COLOR`).
+
 # 0.9.0
 
 * When pages are updated, the client now shows the download location.

package.yaml

@@ -1,5 +1,5 @@
 name: tldr
-version: '0.9.0'
+version: '0.9.1'
 synopsis: Haskell tldr client
 description: |
   Haskell tldr client with support for viewing tldr pages. Has offline

src/Tldr.hs

@@ -16,7 +16,7 @@ import Data.Monoid ((<>))
 import Data.Text hiding (cons)
 import GHC.IO.Handle (Handle)
 import System.Console.ANSI
-import Tldr.Types (ConsoleSetting(..))
+import Tldr.Types (ConsoleSetting(..), ColorSetting (..))
 import qualified Data.Text as T
 import qualified Data.Text.IO as TIO
 
@@ -35,14 +35,17 @@ defConsoleSetting =
 headingSetting :: ConsoleSetting
 headingSetting = defConsoleSetting {consoleIntensity = BoldIntensity}
 
-toSGR :: ConsoleSetting -> [SGR]
-toSGR cons =
-  [ SetItalicized (italic cons)
-  , SetConsoleIntensity (consoleIntensity cons)
-  , SetUnderlining (underline cons)
-  , SetBlinkSpeed (blink cons)
-  , SetColor Foreground (fgIntensity cons) (fgColor cons)
-  ]
+toSGR :: ColorSetting -> ConsoleSetting -> [SGR]
+toSGR color cons = case color of
+  NoColor -> def
+  UseColor -> SetColor Foreground (fgIntensity cons) (fgColor cons) : def
+  where
+    def =
+      [ SetItalicized (italic cons)
+      , SetConsoleIntensity (consoleIntensity cons)
+      , SetUnderlining (underline cons)
+      , SetBlinkSpeed (blink cons)
+      ]
 
 renderNode :: NodeType -> Handle -> IO ()
 renderNode (TEXT txt) handle = TIO.hPutStrLn handle (txt <> "\n")
@@ -54,13 +57,13 @@ renderNode LINEBREAK handle = TIO.hPutStrLn handle ""
 renderNode (LIST _) handle = TIO.hPutStrLn handle "" >> TIO.hPutStr handle " - "
 renderNode _ _ = return ()
 
-changeConsoleSetting :: NodeType -> IO ()
-changeConsoleSetting (HEADING _) = setSGR $ toSGR headingSetting
-changeConsoleSetting BLOCK_QUOTE = setSGR $ toSGR headingSetting
-changeConsoleSetting ITEM = setSGR $ toSGR $ defConsoleSetting {fgColor = Green}
-changeConsoleSetting (CODE _) =
-  setSGR $ toSGR $ defConsoleSetting {fgColor = Yellow}
-changeConsoleSetting _ = return ()
+changeConsoleSetting :: ColorSetting -> NodeType -> IO ()
+changeConsoleSetting color (HEADING _) = setSGR $ toSGR color headingSetting
+changeConsoleSetting color BLOCK_QUOTE = setSGR $ toSGR color headingSetting
+changeConsoleSetting color ITEM = setSGR $ toSGR color $ defConsoleSetting {fgColor = Green}
+changeConsoleSetting color (CODE _) =
+  setSGR $ toSGR color $ defConsoleSetting {fgColor = Yellow}
+changeConsoleSetting _ _ = return ()
 
 handleSubsetNodeType :: NodeType -> Text
 handleSubsetNodeType (HTML_BLOCK txt) = txt
@@ -79,16 +82,16 @@ handleParagraph :: [Node] -> Handle -> IO ()
 handleParagraph xs handle =
   TIO.hPutStrLn handle $ T.concat $ Prelude.map handleSubsetNode xs
 
-handleNode :: Node -> Handle -> IO ()
-handleNode (Node _ PARAGRAPH xs) handle = handleParagraph xs handle
-handleNode (Node _ ITEM xs) handle =
-  changeConsoleSetting ITEM >> handleParagraph xs handle
-handleNode (Node _ ntype xs) handle = do
-  changeConsoleSetting ntype
+handleNode :: Node -> Handle -> ColorSetting -> IO ()
+handleNode (Node _ PARAGRAPH xs) handle _ = handleParagraph xs handle
+handleNode (Node _ ITEM xs) handle color =
+  changeConsoleSetting color ITEM >> handleParagraph xs handle
+handleNode (Node _ ntype xs) handle color = do
+  changeConsoleSetting color ntype
   renderNode ntype handle
   mapM_
     (\(Node _ ntype' ns) ->
-       renderNode ntype' handle >> mapM_ (`handleNode` handle) ns)
+       renderNode ntype' handle >> mapM_ (\n -> handleNode n handle color) ns)
     xs
   setSGR [Reset]
 
@@ -98,7 +101,7 @@ parsePage fname = do
   let node = commonmarkToNode [] page
   return node
 
-renderPage :: FilePath -> Handle -> IO ()
-renderPage fname handle = do
+renderPage :: FilePath -> Handle -> ColorSetting -> IO ()
+renderPage fname handle color = do
   node <- parsePage fname
-  handleNode node handle
+  handleNode node handle color

src/Tldr/App.hs

@@ -17,7 +17,7 @@ import Control.Monad (void)
 
 programOptions :: Parser TldrOpts
 programOptions =
-  TldrOpts <$> (updateIndexCommand <|> viewPageCommand <|> aboutFlag) <*> autoUpdateIntervalOpt
+  TldrOpts <$> (updateIndexCommand <|> viewPageCommand <|> aboutFlag) <*> autoUpdateIntervalOpt <*> colorFlags
 
 updateIndexCommand :: Parser TldrCommand
 updateIndexCommand =
@@ -64,6 +64,25 @@ languageFlag =
         help
           "Preferred language for the page returned"))
 
+useColorFlag :: Parser (Maybe ColorSetting)
+useColorFlag =
+  optional
+    (flag' UseColor
+        (long "color" <>
+        help
+          "Force colored output, overriding the NO_COLOR environment variable"))
+
+noColorFlag :: Parser (Maybe ColorSetting)
+noColorFlag =
+  optional
+    (flag' NoColor
+        (long "no-color" <>
+        help
+          "Disable colored output")) 
+
+colorFlags :: Parser (Maybe ColorSetting)
+colorFlags = useColorFlag <|> noColorFlag
+
 tldrParserInfo :: ParserInfo TldrOpts
 tldrParserInfo =
   info

src/Tldr/App/Handler.hs

@@ -15,6 +15,7 @@ module Tldr.App.Handler
 
 import Data.Char (toLower)
 import Data.List (intercalate)
+import Data.Maybe (fromMaybe)
 import Data.Semigroup ((<>))
 import qualified Data.Set as Set
 import Data.Version (showVersion)
@@ -79,7 +80,10 @@ handleTldrOpts opts@TldrOpts {..} =
           Just lg -> pure $ computeLocale (Just lg)
       fname <- getPagePath locale npage (getCheckDirs voptions)
       case fname of
-        Just path -> renderPage path stdout
+        Just path -> do
+          defColor <- getNoColorEnv
+          let color = fromMaybe defColor colorSetting 
+          renderPage path stdout color
         Nothing ->
           if checkLocale locale
             then do
@@ -149,6 +153,12 @@ getCheckDirs voptions =
     Nothing -> checkDirs
     Just platform -> nubOrd $ ["common", platform] <> checkDirs
 
+getNoColorEnv :: IO ColorSetting
+getNoColorEnv = do
+  noColorSet <- lookupEnv "NO_COLOR"
+  return $ case noColorSet of
+    Just _ -> NoColor
+    Nothing -> UseColor
 
 -- | Strip out duplicates
 nubOrd :: Ord a => [a] -> [a]

src/Tldr/Types.hs

@@ -4,6 +4,9 @@ import System.Console.ANSI
 
 data Locale = English | Missing | Other String | Unknown String
 
+data ColorSetting = NoColor | UseColor 
+  deriving (Eq, Show, Ord, Enum, Bounded)
+
 data ConsoleSetting =
   ConsoleSetting
     { italic :: Bool
@@ -18,6 +21,7 @@ data ConsoleSetting =
 data TldrOpts = TldrOpts
   { tldrAction :: TldrCommand
   , autoUpdateInterval :: Maybe Int
+  , colorSetting :: Maybe ColorSetting
   } deriving (Show)
 
 data TldrCommand

test/Spec.hs

@@ -1,4 +1,5 @@
 import Tldr
+import Tldr.Types (ColorSetting(..))
 import Test.Tasty
 import Test.Tasty.Golden (goldenVsFile)
 import System.IO (withBinaryFile, IOMode(..))
@@ -12,7 +13,7 @@ goldenTests = testGroup "Golden tests" [gtests]
 
 renderPageToFile :: FilePath -> FilePath -> IO ()
 renderPageToFile mdfile opfile = do
-  withBinaryFile opfile WriteMode (\handle -> renderPage mdfile handle)
+  withBinaryFile opfile WriteMode (\handle -> renderPage mdfile handle UseColor)
 
 -- For adding new command, you need to add:
 -- A new ".md" file for that command

tldr.cabal

@@ -1,13 +1,13 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.33.0.
+-- This file has been generated from package.yaml by hpack version 0.34.4.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 8f1a3267eb79f7615c0d4cc731807ebde3d23a3dea7fc605e0dd77b39c458d9e
+-- hash: 86d07459291589175c3f2f48f7b55186411b1b57c3a9b1e89abc1df51c9c7f38
 
 name:           tldr
-version:        0.9.0
+version:        0.9.1
 synopsis:       Haskell tldr client
 description:    Haskell tldr client with support for viewing tldr pages. Has offline
                 cache for accessing pages. Visit https://tldr.sh for more details.