{-# LANGUAGE OverloadedStrings #-}

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

import CMark
import Data.Monoid ((<>))
import Data.Text hiding (cons)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import GHC.IO.Handle (Handle)
import System.Console.ANSI

data ConsoleSetting =
  ConsoleSetting
    { ConsoleSetting -> Bool
italic :: Bool
    , ConsoleSetting -> Underlining
underline :: Underlining
    , ConsoleSetting -> BlinkSpeed
blink :: BlinkSpeed
    , ConsoleSetting -> ColorIntensity
fgIntensity :: ColorIntensity
    , ConsoleSetting -> Color
fgColor :: Color
    , ConsoleSetting -> ColorIntensity
bgIntensity :: ColorIntensity
    , ConsoleSetting -> ConsoleIntensity
consoleIntensity :: ConsoleIntensity
    }

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 :: ConsoleSetting -> [SGR]
toSGR :: ConsoleSetting -> [SGR]
toSGR cons :: ConsoleSetting
cons =
  [ 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)
  , ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground (ConsoleSetting -> ColorIntensity
fgIntensity ConsoleSetting
cons) (ConsoleSetting -> Color
fgColor ConsoleSetting
cons)
  ]

renderNode :: NodeType -> Handle -> IO ()
renderNode :: NodeType -> Handle -> IO ()
renderNode (TEXT txt :: Text
txt) handle :: Handle
handle = Handle -> Text -> IO ()
TIO.hPutStrLn Handle
handle Text
txt
renderNode (HTML_BLOCK txt :: Text
txt) handle :: Handle
handle = Handle -> Text -> IO ()
TIO.hPutStrLn Handle
handle Text
txt
renderNode (CODE_BLOCK _ txt :: Text
txt) handle :: Handle
handle = Handle -> Text -> IO ()
TIO.hPutStrLn Handle
handle Text
txt
renderNode (HTML_INLINE txt :: Text
txt) handle :: Handle
handle = Handle -> Text -> IO ()
TIO.hPutStrLn Handle
handle Text
txt
renderNode (CODE txt :: Text
txt) handle :: Handle
handle = Handle -> Text -> IO ()
TIO.hPutStrLn Handle
handle ("   " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txt)
renderNode LINEBREAK handle :: Handle
handle = Handle -> Text -> IO ()
TIO.hPutStrLn Handle
handle ""
renderNode (LIST _) handle :: Handle
handle = Handle -> Text -> IO ()
TIO.hPutStrLn Handle
handle "" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> Text -> IO ()
TIO.hPutStr Handle
handle " - "
renderNode _ _ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

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

handleSubsetNode :: Node -> Text
handleSubsetNode :: Node -> Text
handleSubsetNode (Node _ ntype :: NodeType
ntype xs :: [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 xs :: [Node]
xs handle :: 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 -> IO ()
handleNode :: Node -> Handle -> IO ()
handleNode (Node _ PARAGRAPH xs :: [Node]
xs) handle :: Handle
handle = [Node] -> Handle -> IO ()
handleParagraph [Node]
xs Handle
handle
handleNode (Node _ ITEM xs :: [Node]
xs) handle :: Handle
handle =
  NodeType -> IO ()
changeConsoleSetting 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 _ ntype :: NodeType
ntype xs :: [Node]
xs) handle :: Handle
handle = do
  NodeType -> IO ()
changeConsoleSetting NodeType
ntype
  NodeType -> Handle -> IO ()
renderNode NodeType
ntype Handle
handle
  (Node -> IO ()) -> [Node] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
    (\(Node _ ntype' :: NodeType
ntype' ns :: [Node]
ns) ->
       NodeType -> Handle -> IO ()
renderNode NodeType
ntype' 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 -> Handle -> IO ()
`handleNode` Handle
handle) [Node]
ns)
    [Node]
xs
  [SGR] -> IO ()
setSGR [SGR
Reset]

parsePage :: FilePath -> IO Node
parsePage :: FilePath -> IO Node
parsePage fname :: FilePath
fname = do
  Text
page <- FilePath -> IO Text
TIO.readFile FilePath
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 -> IO ()
renderPage :: FilePath -> Handle -> IO ()
renderPage fname :: FilePath
fname handle :: Handle
handle = do
  Node
node <- FilePath -> IO Node
parsePage FilePath
fname
  Node -> Handle -> IO ()
handleNode Node
node Handle
handle