Merge pull request #43 from hasufell/better-coloring

Apply better coloring

package.yaml

@@ -26,6 +26,7 @@ flags:
 library:
   source-dirs: src
   dependencies:
+  - attoparsec
   - base >=4.7 && <5
   - cmark
   - text

src/Tldr.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Tldr
   ( parsePage
@@ -12,10 +13,13 @@ module Tldr
   ) 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,15 +51,31 @@ toSGR color cons = case color of
       , 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
@@ -87,13 +107,12 @@ 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
+  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

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)

test/data/grep.golden

@@ -4,25 +4,25 @@ Matches patterns in input text.
 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

test/data/ps.golden

@@ -9,7 +9,7 @@ Information about running processes.
    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 @@ Information about running processes.
    ps --user $(id -u) f
 
  - Get the parent pid of a process:
-   ps -o ppid= -p {{pid}}
+   ps -o ppid= -p pid

tldr.cabal

@@ -45,6 +45,7 @@ library
       Tldr.App
       Tldr.App.Constant
       Tldr.App.Handler
+      Tldr.Parser
       Tldr.Types
   other-modules:
       Paths_tldr
@@ -53,6 +54,7 @@ library
   ghc-options: -Wall -O2
   build-depends:
       ansi-terminal
+    , attoparsec
     , base >=4.7 && <5
     , bytestring
     , cmark