{-# 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.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

defConsoleSetting :: ConsoleSetting
defConsoleSetting :: ConsoleSetting
defConsoleSetting =
  ConsoleSetting :: Bool
-> Underlining
-> BlinkSpeed
-> ColorIntensity
-> Color
-> ColorIntensity
-> ConsoleIntensity
-> ConsoleSetting
ConsoleSetting
    { italic :: Bool
italic = Bool
False
    , underline :: Underlining
underline = Underlining
NoUnderline
    , blink :: BlinkSpeed
blink = BlinkSpeed
NoBlink
    , fgIntensity :: ColorIntensity
fgIntensity = ColorIntensity
Dull
    , fgColor :: Color
fgColor = Color
White
    , bgIntensity :: ColorIntensity
bgIntensity = ColorIntensity
Dull
    , consoleIntensity :: ConsoleIntensity
consoleIntensity = ConsoleIntensity
NormalIntensity
    }

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

toSGR :: ColorSetting -> ConsoleSetting -> [SGR]
toSGR :: ColorSetting -> ConsoleSetting -> [SGR]
toSGR ColorSetting
color ConsoleSetting
cons = case ColorSetting
color of
  ColorSetting
NoColor -> [SGR]
def
  ColorSetting
UseColor -> ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground (ConsoleSetting -> ColorIntensity
fgIntensity ConsoleSetting
cons) (ConsoleSetting -> Color
fgColor ConsoleSetting
cons) SGR -> [SGR] -> [SGR]
forall a. a -> [a] -> [a]
: [SGR]
def
  where
    def :: [SGR]
def =
      [ Bool -> SGR
SetItalicized (ConsoleSetting -> Bool
italic ConsoleSetting
cons)
      , ConsoleIntensity -> SGR
SetConsoleIntensity (ConsoleSetting -> ConsoleIntensity
consoleIntensity ConsoleSetting
cons)
      , Underlining -> SGR
SetUnderlining (ConsoleSetting -> Underlining
underline ConsoleSetting
cons)
      , BlinkSpeed -> SGR
SetBlinkSpeed (ConsoleSetting -> BlinkSpeed
blink ConsoleSetting
cons)
      ]

reset :: ColorSetting -> IO ()
reset :: ColorSetting -> IO ()
reset ColorSetting
color = case ColorSetting
color of
  ColorSetting
NoColor -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  ColorSetting
UseColor -> [SGR] -> IO ()
setSGR [SGR
Reset]

renderNode :: NodeType -> ColorSetting -> Handle -> IO ()
renderNode :: NodeType -> ColorSetting -> Handle -> IO ()
renderNode nt :: NodeType
nt@(TEXT Text
txt) ColorSetting
color Handle
handle = ColorSetting -> NodeType -> IO ()
changeConsoleSetting ColorSetting
color NodeType
nt IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> Text -> IO ()
TIO.hPutStrLn Handle
handle (Text
txt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n") IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ColorSetting -> IO ()
reset ColorSetting
color
renderNode nt :: NodeType
nt@(HTML_BLOCK Text
txt) ColorSetting
color Handle
handle = ColorSetting -> NodeType -> IO ()
changeConsoleSetting ColorSetting
color NodeType
nt IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> Text -> IO ()
TIO.hPutStrLn Handle
handle Text
txt IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ColorSetting -> IO ()
reset ColorSetting
color
renderNode nt :: NodeType
nt@(CODE_BLOCK Text
_ Text
txt) ColorSetting
color Handle
handle = ColorSetting -> NodeType -> IO ()
changeConsoleSetting ColorSetting
color NodeType
nt IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> Text -> IO ()
TIO.hPutStrLn Handle
handle Text
txt IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ColorSetting -> IO ()
reset ColorSetting
color
renderNode nt :: NodeType
nt@(HTML_INLINE Text
txt) ColorSetting
color Handle
handle = ColorSetting -> NodeType -> IO ()
changeConsoleSetting ColorSetting
color NodeType
nt IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> Text -> IO ()
TIO.hPutStrLn Handle
handle Text
txt IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ColorSetting -> IO ()
reset ColorSetting
color
renderNode (CODE Text
txt) ColorSetting
color Handle
handle = ColorSetting -> Text -> Handle -> IO ()
renderCode ColorSetting
color Text
txt Handle
handle
renderNode nt :: NodeType
nt@NodeType
LINEBREAK ColorSetting
color Handle
handle = ColorSetting -> NodeType -> IO ()
changeConsoleSetting ColorSetting
color NodeType
nt IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> Text -> IO ()
TIO.hPutStrLn Handle
handle Text
"" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ColorSetting -> IO ()
reset ColorSetting
color
renderNode nt :: NodeType
nt@(LIST ListAttributes
_) ColorSetting
color Handle
handle = ColorSetting -> NodeType -> IO ()
changeConsoleSetting ColorSetting
color NodeType
nt IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> Text -> IO ()
TIO.hPutStrLn Handle
handle Text
"" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> Text -> IO ()
TIO.hPutStr Handle
handle Text
" - " IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ColorSetting -> IO ()
reset ColorSetting
color
renderNode NodeType
_ ColorSetting
_ Handle
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

renderCode :: ColorSetting -> Text -> Handle -> IO ()
renderCode :: ColorSetting -> Text -> Handle -> IO ()
renderCode ColorSetting
color Text
txt Handle
handle = do
  Handle -> Text -> IO ()
TIO.hPutStr Handle
handle (Text
"   ")
  case Parser [Either Text Text]
-> Text -> Either String [Either Text Text]
forall a. Parser a -> Text -> Either String a
parseOnly Parser [Either Text Text]
codeParser Text
txt of
    Right [Either Text Text]
xs -> do
      [Either Text Text] -> (Either Text Text -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Either Text Text]
xs ((Either Text Text -> IO ()) -> IO ())
-> (Either Text Text -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
        Left Text
x -> ColorSetting -> NodeType -> IO ()
changeConsoleSetting ColorSetting
color (Text -> NodeType
CODE Text
txt) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> Text -> IO ()
TIO.hPutStr Handle
handle Text
x IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ColorSetting -> IO ()
reset ColorSetting
color
        Right Text
x -> Handle -> Text -> IO ()
TIO.hPutStr Handle
handle Text
x
    Left String
_ -> ColorSetting -> NodeType -> IO ()
changeConsoleSetting ColorSetting
color (Text -> NodeType
CODE Text
txt) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> Text -> IO ()
TIO.hPutStr Handle
handle Text
txt IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ColorSetting -> IO ()
reset ColorSetting
color
  Handle -> Text -> IO ()
TIO.hPutStr Handle
handle (Text
"\n")

changeConsoleSetting :: ColorSetting -> NodeType -> IO ()
changeConsoleSetting :: ColorSetting -> NodeType -> IO ()
changeConsoleSetting ColorSetting
color (HEADING Level
_) = [SGR] -> IO ()
setSGR ([SGR] -> IO ()) -> [SGR] -> IO ()
forall a b. (a -> b) -> a -> b
$ ColorSetting -> ConsoleSetting -> [SGR]
toSGR ColorSetting
color ConsoleSetting
headingSetting
changeConsoleSetting ColorSetting
color NodeType
BLOCK_QUOTE = [SGR] -> IO ()
setSGR ([SGR] -> IO ()) -> [SGR] -> IO ()
forall a b. (a -> b) -> a -> b
$ ColorSetting -> ConsoleSetting -> [SGR]
toSGR ColorSetting
color ConsoleSetting
headingSetting
changeConsoleSetting ColorSetting
color NodeType
ITEM = [SGR] -> IO ()
setSGR ([SGR] -> IO ()) -> [SGR] -> IO ()
forall a b. (a -> b) -> a -> b
$ ColorSetting -> ConsoleSetting -> [SGR]
toSGR ColorSetting
color (ConsoleSetting -> [SGR]) -> ConsoleSetting -> [SGR]
forall a b. (a -> b) -> a -> b
$ ConsoleSetting
defConsoleSetting {fgColor :: Color
fgColor = Color
Green}
changeConsoleSetting ColorSetting
color (CODE Text
_) =
  [SGR] -> IO ()
setSGR ([SGR] -> IO ()) -> [SGR] -> IO ()
forall a b. (a -> b) -> a -> b
$ ColorSetting -> ConsoleSetting -> [SGR]
toSGR ColorSetting
color (ConsoleSetting -> [SGR]) -> ConsoleSetting -> [SGR]
forall a b. (a -> b) -> a -> b
$ ConsoleSetting
defConsoleSetting {fgColor :: Color
fgColor = Color
Yellow}
changeConsoleSetting ColorSetting
_ NodeType
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

handleSubsetNodeType :: NodeType -> Text
handleSubsetNodeType :: NodeType -> Text
handleSubsetNodeType (HTML_BLOCK Text
txt) = Text
txt
handleSubsetNodeType (CODE_BLOCK Text
_ Text
txt) = Text
txt
handleSubsetNodeType (TEXT Text
txt) = Text
txt
handleSubsetNodeType (HTML_INLINE Text
txt) = Text
txt
handleSubsetNodeType (CODE Text
txt) = Text
txt
handleSubsetNodeType NodeType
_ = Text
forall a. Monoid a => a
mempty

handleSubsetNode :: Node -> Text
handleSubsetNode :: Node -> Text
handleSubsetNode (Node Maybe PosInfo
_ NodeType
SOFTBREAK [Node]
_) = Text
"\n"
handleSubsetNode (Node Maybe PosInfo
_ NodeType
ntype [Node]
xs) =
  NodeType -> Text
handleSubsetNodeType NodeType
ntype Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.concat ((Node -> Text) -> [Node] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map Node -> Text
handleSubsetNode [Node]
xs)

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

handleNode :: Node -> Handle -> ColorSetting -> IO ()
handleNode :: Node -> Handle -> ColorSetting -> IO ()
handleNode (Node Maybe PosInfo
_ NodeType
PARAGRAPH [Node]
xs) Handle
handle ColorSetting
_ = [Node] -> Handle -> IO ()
handleParagraph [Node]
xs Handle
handle
handleNode (Node Maybe PosInfo
_ NodeType
ITEM [Node]
xs) Handle
handle ColorSetting
color =
  ColorSetting -> NodeType -> IO ()
changeConsoleSetting ColorSetting
color NodeType
ITEM IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Node] -> Handle -> IO ()
handleParagraph [Node]
xs Handle
handle
handleNode (Node Maybe PosInfo
_ NodeType
ntype [Node]
xs) Handle
handle ColorSetting
color = do
  NodeType -> ColorSetting -> Handle -> IO ()
renderNode NodeType
ntype ColorSetting
color Handle
handle
  (Node -> IO ()) -> [Node] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
    (\(Node Maybe PosInfo
_ NodeType
ntype' [Node]
ns) ->
       NodeType -> ColorSetting -> Handle -> IO ()
renderNode NodeType
ntype' ColorSetting
color Handle
handle IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Node -> IO ()) -> [Node] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Node
n -> Node -> Handle -> ColorSetting -> IO ()
handleNode Node
n Handle
handle ColorSetting
color) [Node]
ns)
    [Node]
xs
  ColorSetting -> IO ()
reset ColorSetting
color

parsePage :: FilePath -> IO Node
parsePage :: String -> IO Node
parsePage String
fname = do
  Text
page <- String -> IO Text
TIO.readFile String
fname
  let node :: Node
node = [CMarkOption] -> Text -> Node
commonmarkToNode [] Text
page
  Node -> IO Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node

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