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