tldr-0.9.3: src/Tldr.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}

module Tldr
  ( parsePage
  , renderPage
  , ConsoleSetting(..)
  , defConsoleSetting
  , headingSetting
  , toSGR
  , renderNode
  , changeConsoleSetting
  ) where

import CMark
import Control.Monad (forM_)
import Data.Attoparsec.Text
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

defConsoleSetting :: ConsoleSetting
defConsoleSetting =
  ConsoleSetting
    { italic = False
    , underline = NoUnderline
    , blink = NoBlink
    , fgIntensity = Dull
    , fgColor = White
    , bgIntensity = Dull
    , consoleIntensity = NormalIntensity
    }

headingSetting :: ConsoleSetting
headingSetting = defConsoleSetting {consoleIntensity = BoldIntensity}

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)
      ]

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
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
handleSubsetNodeType (CODE_BLOCK _ txt) = txt
handleSubsetNodeType (TEXT txt) = txt
handleSubsetNodeType (HTML_INLINE txt) = txt
handleSubsetNodeType (CODE txt) = txt
handleSubsetNodeType _ = mempty

handleSubsetNode :: Node -> Text
handleSubsetNode (Node _ SOFTBREAK _) = "\n"
handleSubsetNode (Node _ ntype xs) =
  handleSubsetNodeType ntype <> T.concat (Prelude.map handleSubsetNode xs)

handleParagraph :: [Node] -> Handle -> IO ()
handleParagraph xs handle =
  TIO.hPutStrLn handle $ T.concat $ Prelude.map handleSubsetNode xs

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
  renderNode ntype color handle
  mapM_
    (\(Node _ ntype' ns) ->
       renderNode ntype' color handle >> mapM_ (\n -> handleNode n handle color) ns)
    xs
  reset color

parsePage :: FilePath -> IO Node
parsePage fname = do
  page <- TIO.readFile fname
  let node = commonmarkToNode [] page
  return node

renderPage :: FilePath -> Handle -> ColorSetting -> IO ()
renderPage fname handle color = do
  node <- parsePage fname
  handleNode node handle color