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