diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# 0.9.2 + +* [Apply better coloring](https://github.com/psibi/tldr-hs/pull/43 "https://github.com/psibi/tldr-hs/pull/43") + # 0.9.1 * When the [`NO_COLOR`](https://no-color.org/) environment variable is set, the client will not color the output. diff --git a/src/Tldr.hs b/src/Tldr.hs --- a/src/Tldr.hs +++ b/src/Tldr.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} module Tldr ( parsePage @@ -12,10 +13,13 @@ ) where import CMark +import Control.Monad (forM_) +import Data.Attoparsec.Text import Data.Monoid ((<>)) import Data.Text hiding (cons) import GHC.IO.Handle (Handle) import System.Console.ANSI +import Tldr.Parser import Tldr.Types (ConsoleSetting(..), ColorSetting (..)) import qualified Data.Text as T import qualified Data.Text.IO as TIO @@ -47,16 +51,32 @@ , SetBlinkSpeed (blink cons) ] -renderNode :: NodeType -> Handle -> IO () -renderNode (TEXT txt) handle = TIO.hPutStrLn handle (txt <> "\n") -renderNode (HTML_BLOCK txt) handle = TIO.hPutStrLn handle txt -renderNode (CODE_BLOCK _ txt) handle = TIO.hPutStrLn handle txt -renderNode (HTML_INLINE txt) handle = TIO.hPutStrLn handle txt -renderNode (CODE txt) handle = TIO.hPutStrLn handle (" " <> txt) -renderNode LINEBREAK handle = TIO.hPutStrLn handle "" -renderNode (LIST _) handle = TIO.hPutStrLn handle "" >> TIO.hPutStr handle " - " -renderNode _ _ = return () +reset :: ColorSetting -> IO () +reset color = case color of + NoColor -> pure () + UseColor -> setSGR [Reset] +renderNode :: NodeType -> ColorSetting -> Handle -> IO () +renderNode nt@(TEXT txt) color handle = changeConsoleSetting color nt >> TIO.hPutStrLn handle (txt <> "\n") >> reset color +renderNode nt@(HTML_BLOCK txt) color handle = changeConsoleSetting color nt >> TIO.hPutStrLn handle txt >> reset color +renderNode nt@(CODE_BLOCK _ txt) color handle = changeConsoleSetting color nt >> TIO.hPutStrLn handle txt >> reset color +renderNode nt@(HTML_INLINE txt) color handle = changeConsoleSetting color nt >> TIO.hPutStrLn handle txt >> reset color +renderNode (CODE txt) color handle = renderCode color txt handle +renderNode nt@LINEBREAK color handle = changeConsoleSetting color nt >> TIO.hPutStrLn handle "" >> reset color +renderNode nt@(LIST _) color handle = changeConsoleSetting color nt >> TIO.hPutStrLn handle "" >> TIO.hPutStr handle " - " >> reset color +renderNode _ _ _ = return () + +renderCode :: ColorSetting -> Text -> Handle -> IO () +renderCode color txt handle = do + TIO.hPutStr handle (" ") + case parseOnly codeParser txt of + Right xs -> do + forM_ xs $ \case + Left x -> changeConsoleSetting color (CODE txt) >> TIO.hPutStr handle x >> reset color + Right x -> TIO.hPutStr handle x + Left _ -> changeConsoleSetting color (CODE txt) >> TIO.hPutStr handle txt >> reset color + TIO.hPutStr handle ("\n") + changeConsoleSetting :: ColorSetting -> NodeType -> IO () changeConsoleSetting color (HEADING _) = setSGR $ toSGR color headingSetting changeConsoleSetting color BLOCK_QUOTE = setSGR $ toSGR color headingSetting @@ -87,13 +107,12 @@ 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 + renderNode ntype color handle mapM_ (\(Node _ ntype' ns) -> - renderNode ntype' handle >> mapM_ (\n -> handleNode n handle color) ns) + renderNode ntype' color handle >> mapM_ (\n -> handleNode n handle color) ns) xs - setSGR [Reset] + reset color parsePage :: FilePath -> IO Node parsePage fname = do diff --git a/src/Tldr/App.hs b/src/Tldr/App.hs --- a/src/Tldr/App.hs +++ b/src/Tldr/App.hs @@ -78,7 +78,7 @@ (flag' NoColor (long "no-color" <> help - "Disable colored output")) + "Disable colored output")) colorFlags :: Parser (Maybe ColorSetting) colorFlags = useColorFlag <|> noColorFlag diff --git a/src/Tldr/App/Handler.hs b/src/Tldr/App/Handler.hs --- a/src/Tldr/App/Handler.hs +++ b/src/Tldr/App/Handler.hs @@ -72,7 +72,7 @@ About -> handleAboutFlag ViewPage voptions pages -> do shouldPerformUpdate <- updateNecessary opts - when shouldPerformUpdate updateTldrPages + when shouldPerformUpdate updateTldrPages let npage = intercalate "-" pages locale <- case languageOption voptions of @@ -82,7 +82,7 @@ case fname of Just path -> do defColor <- getNoColorEnv - let color = fromMaybe defColor colorSetting + let color = fromMaybe defColor colorSetting renderPage path stdout color Nothing -> if checkLocale locale @@ -99,13 +99,13 @@ updateNecessary TldrOpts{..} = do dataDir <- getXdgDirectory XdgData tldrDirName dataDirExists <- doesDirectoryExist dataDir - if not dataDirExists + if not dataDirExists then return True else do lastCachedTime <- getModificationTime dataDir currentTime <- getCurrentTime - let diffExceedsLimit limit - = currentTime `diffUTCTime` lastCachedTime + let diffExceedsLimit limit + = currentTime `diffUTCTime` lastCachedTime > fromIntegral limit * nominalDay return $ maybe False diffExceedsLimit autoUpdateInterval diff --git a/src/Tldr/Parser.hs b/src/Tldr/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Tldr/Parser.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} + +module Tldr.Parser where + +import Prelude hiding (takeWhile) +import Control.Applicative +import Data.Attoparsec.Combinator +import Data.Attoparsec.Text +import Data.Text (Text) + +import qualified Data.Text as T + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Data.Attoparsec.Text + + +-- | Parses '{{foo}}' blocks in CommonMark Code, such that: +-- +-- * `ls {{foo}} bar` -> `[Left "ls ", Right "foo", Left " bar"]` +-- +-- >>> parseOnly codeParser "" +-- Right [] +-- >>> parseOnly codeParser "tar" +-- Right [Left "tar"] +-- >>> parseOnly codeParser "tar{" +-- Right [Left "tar{"] +-- >>> parseOnly codeParser "tar{{" +-- Right [Left "tar{{"] +-- >>> parseOnly codeParser "tar{{{" +-- Right [Left "tar{{{"] +-- >>> parseOnly codeParser "tar}" +-- Right [Left "tar}"] +-- >>> parseOnly codeParser "tar{{{b}" +-- Right [Left "tar{{{b}"] +-- >>> parseOnly codeParser "tar{{{b}}" +-- Right [Left "tar",Right "{b"] +-- >>> parseOnly codeParser "tar{{b}}}" +-- Right [Left "tar",Right "b}"] +-- >>> parseOnly codeParser "tar xf {{source.tar[.gz|.bz2|.xz]}} --directory={{directory}}" +-- Right [Left "tar xf ",Right "source.tar[.gz|.bz2|.xz]",Left " --directory=",Right "directory"] +codeParser :: Parser [Either Text Text] +codeParser = collectEither <$> outer + where + inner :: Parser [Either Text Text] + inner = do + _ <- char '{' + _ <- char '{' + l <- takeWhile (/= '}') + e <- optional findEnd + case e of + Just e' -> (\o -> [Right (l <> e') ] <> o) <$> (outer <|> pure []) + Nothing -> (\o -> [Left (T.pack "{{" <> l)] <> o) <$> (outer <|> pure []) + where + findEnd :: Parser Text + findEnd = do + c1 <- anyChar + (p2, p3) <- peek2Chars + case (c1, p2, p3) of + ('}', Just '}', Just '}') -> (T.singleton '}' <>) <$> findEnd + ('}', Just '}', _) -> mempty <$ anyChar + _ -> fail ("Couldn't find end: " <> show (c1, p2, p3)) + + outer :: Parser [Either Text Text] + outer = do + o <- takeWhile (/= '{') + (p1, p2) <- peek2Chars + case (p1, p2) of + (Just '{', Just '{') -> (\i -> [Left o ] <> i) <$> (inner <|> ((\t -> [Left t]) <$> takeText)) + (Just '{', _) -> (\a b -> [Left (o <> T.singleton a)] <> b) <$> anyChar <*> outer + _ -> pure [Left o] + + +-- | Collect both Lefts and Rights, mappending them to zore or one item per connected sublist. +-- +-- >>> collectEither [] +-- [] +-- >>> collectEither [Right "abc", Right "def", Left "x", Left "z", Right "end"] +-- [Right "abcdef",Left "xz",Right "end"] +-- >>> collectEither [Right "", Right "def", Left "x", Left "", Right ""] +-- [Right "def",Left "x"] +collectEither :: (Eq a, Eq b, Monoid a, Monoid b) => [Either a b] -> [Either a b] +collectEither = go Nothing + where + go Nothing [] = [] + go (Just !x) [] + | x == Right mempty || x == Left mempty = [] + | otherwise = [x] + go Nothing (Left b:br) = go (Just (Left b)) br + go Nothing (Right b:br) = go (Just (Right b)) br + go (Just (Left !a)) (Left b:br) = go (Just (Left (a <> b))) br + go (Just (Right !a)) (Right b:br) = go (Just (Right (a <> b))) br + go (Just !a) xs + | a == Right mempty || a == Left mempty = go Nothing xs + | otherwise = a:go Nothing xs + + +-- | Peek 2 characters, not consuming any input. +peek2Chars :: Parser (Maybe Char, Maybe Char) +peek2Chars = lookAhead ((,) <$> optional anyChar <*> optional anyChar) diff --git a/src/Tldr/Types.hs b/src/Tldr/Types.hs --- a/src/Tldr/Types.hs +++ b/src/Tldr/Types.hs @@ -4,7 +4,7 @@ data Locale = English | Missing | Other String | Unknown String -data ColorSetting = NoColor | UseColor +data ColorSetting = NoColor | UseColor deriving (Eq, Show, Ord, Enum, Bounded) data ConsoleSetting = diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -28,7 +28,7 @@ md cmd = prefix <> cmd <> ".md" gtests :: TestTree -gtests = testGroup "(render test)" +gtests = testGroup "(render test)" [ commandTest "ls" , commandTest "ps" diff --git a/test/data/grep.golden b/test/data/grep.golden --- a/test/data/grep.golden +++ b/test/data/grep.golden @@ -4,25 +4,25 @@ Supports simple patterns and regular expressions. - Search for an exact string: - grep {{search_string}} {{path/to/file}} + grep search_string path/to/file - Search in case-insensitive mode: - grep -i {{search_string}} {{path/to/file}} + grep -i search_string path/to/file - Search recursively (ignoring non-text files) in current directory for an exact string: - grep -RI {{search_string}} . + grep -RI search_string . - Use extended regular expressions (supporting ?, +, {}, () and |): - grep -E {{^regex$}} {{path/to/file}} + grep -E ^regex$ path/to/file - Print 3 lines of [C]ontext around, [B]efore, or [A]fter each match: - grep -{{C|B|A}} 3 {{search_string}} {{path/to/file}} + grep -C|B|A 3 search_string path/to/file - Print file name with the corresponding line number for each match: - grep -Hn {{search_string}} {{path/to/file}} + grep -Hn search_string path/to/file - Use the standard input instead of a file: - cat {{path/to/file}} | grep {{search_string}} + cat path/to/file | grep search_string - Invert match for excluding specific strings: - grep -v {{search_string}} + grep -v search_string diff --git a/test/data/ps.golden b/test/data/ps.golden --- a/test/data/ps.golden +++ b/test/data/ps.golden @@ -9,7 +9,7 @@ ps auxww - Search for a process that matches a string: - ps aux | grep {{string}} + ps aux | grep string - List all processes of the current user in extra full format: ps --user $(id -u) -F @@ -18,4 +18,4 @@ ps --user $(id -u) f - Get the parent pid of a process: - ps -o ppid= -p {{pid}} + ps -o ppid= -p pid diff --git a/tldr.cabal b/tldr.cabal --- a/tldr.cabal +++ b/tldr.cabal @@ -3,11 +3,9 @@ -- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: 86d07459291589175c3f2f48f7b55186411b1b57c3a9b1e89abc1df51c9c7f38 name: tldr -version: 0.9.1 +version: 0.9.2 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. @@ -45,6 +43,7 @@ Tldr.App Tldr.App.Constant Tldr.App.Handler + Tldr.Parser Tldr.Types other-modules: Paths_tldr @@ -53,6 +52,7 @@ ghc-options: -Wall -O2 build-depends: ansi-terminal + , attoparsec , base >=4.7 && <5 , bytestring , cmark