{-# LANGUAGE OverloadedStrings #-}

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

import CMark
import Data.Monoid ((<>))
import Data.Text hiding (cons)
import GHC.IO.Handle (Handle)
import System.Console.ANSI
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)
      ]

renderNode :: NodeType -> Handle -> IO ()
renderNode :: NodeType -> Handle -> IO ()
renderNode (TEXT Text
txt) Handle
handle = Handle -> Text -> IO ()
TIO.hPutStrLn Handle
handle (Text
txt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n")
renderNode (HTML_BLOCK Text
txt) Handle
handle = Handle -> Text -> IO ()
TIO.hPutStrLn Handle
handle Text
txt
renderNode (CODE_BLOCK Text
_ Text
txt) Handle
handle = Handle -> Text -> IO ()
TIO.hPutStrLn Handle
handle Text
txt
renderNode (HTML_INLINE Text
txt) Handle
handle = Handle -> Text -> IO ()
TIO.hPutStrLn Handle
handle Text
txt
renderNode (CODE Text
txt) Handle
handle = Handle -> Text -> IO ()
TIO.hPutStrLn Handle
handle (Text
"   " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txt)
renderNode NodeType
LINEBREAK Handle
handle = Handle -> Text -> IO ()
TIO.hPutStrLn Handle
handle Text
""
renderNode (LIST ListAttributes
_) Handle
handle = 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
" - "
renderNode NodeType
_ Handle
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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
  ColorSetting -> NodeType -> IO ()
changeConsoleSetting ColorSetting
color 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 Maybe PosInfo
_ NodeType
ntype' [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
n -> Node -> Handle -> ColorSetting -> IO ()
handleNode Node
n Handle
handle ColorSetting
color) [Node]
ns)
    [Node]
xs
  [SGR] -> IO ()
setSGR [SGR
Reset]

parsePage :: FilePath -> IO Node
parsePage :: FilePath -> IO Node
parsePage 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 -> ColorSetting -> IO ()
renderPage :: FilePath -> Handle -> ColorSetting -> IO ()
renderPage FilePath
fname Handle
handle ColorSetting
color = do
  Node
node <- FilePath -> IO Node
parsePage FilePath
fname
  Node -> Handle -> ColorSetting -> IO ()
handleNode Node
node Handle
handle ColorSetting
color