From 6740a349caa6c20513191bbf213570448352093f Mon Sep 17 00:00:00 2001 From: defanor Date: Sun, 5 Nov 2017 04:57:09 +0300 Subject: Split into modules --- Pancake/Common.hs | 19 +++ Pancake/Configuration.hs | 92 ++++++++++++ Pancake/Printing.hs | 77 ++++++++++ Pancake/Reading.hs | 132 +++++++++++++++++ Pancake/Rendering.hs | 375 +++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 695 insertions(+) create mode 100644 Pancake/Common.hs create mode 100644 Pancake/Configuration.hs create mode 100644 Pancake/Printing.hs create mode 100644 Pancake/Reading.hs create mode 100644 Pancake/Rendering.hs (limited to 'Pancake') diff --git a/Pancake/Common.hs b/Pancake/Common.hs new file mode 100644 index 0000000..a93fea1 --- /dev/null +++ b/Pancake/Common.hs @@ -0,0 +1,19 @@ +{- | +Module : Pancake.Common +Maintainer : defanor +Stability : unstable +Portability : portable + +Utility functions. +-} + +module Pancake.Common ( putErrLn ) where +import System.IO +import Control.Monad.IO.Class + + +-- | Prints a line into stderr. +putErrLn :: MonadIO m => String -> m () +putErrLn s = liftIO $ do + hPutStrLn stderr s + hFlush stderr diff --git a/Pancake/Configuration.hs b/Pancake/Configuration.hs new file mode 100644 index 0000000..fa33d52 --- /dev/null +++ b/Pancake/Configuration.hs @@ -0,0 +1,92 @@ +{- | +Module : Pancake.Configuration +Maintainer : defanor +Stability : unstable +Portability : non-portable (GHC extensions are used) + +Pancake configuration facilities. +-} + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Pancake.Configuration ( Config(..) + , loadConfig + ) where + +import Data.Yaml +import Data.Default +import Control.Monad.State +import System.Directory +import System.FilePath +import qualified Data.Map as M +import GHC.Generics + +import Pancake.Common + + +-- | Application configuration. +data Config = Config { commands :: M.Map String String + -- ^ URI schemes and corresponding shell commands + -- for downloading. + , defaultCommand :: String + -- ^ A command to use if no other command + -- applies. + , externalViewers :: M.Map String String + -- ^ File extensions and corresponding external + -- applications. + , shortcuts :: M.Map String String + -- ^ Shortcuts to use (search engines, + -- dictionaries, etc). + , paginate :: Bool + -- ^ Enable pagination in non-embedded mode; + -- print everything at once otherwise. + , historyDepth :: Int + -- ^ The amount of history entries (into either + -- direction) to keep. + } deriving (Generic, Show) + +-- | For configuration parsing. +instance FromJSON Config +-- | For configuration writing, particularly that of default +-- configuration if it is missing. +instance ToJSON Config +-- | The default configuration to use if user configuration is +-- missing. +instance Default Config where + def = Config { + commands = M.fromList + [ ("ssh", "scp \"${URI_REGNAME}:${URI_PATH}\" /dev/stdout") + , ("gopher", "curl \"${URI}\"")] + , defaultCommand = "curl -4 -L \"${URI}\"" + , externalViewers = M.fromList $ + map (flip (,) "emacsclient -n \"${FILE}\"") + ["hs", "cabal", "c", "h", "el", "scm", "idr"] + ++ map (flip (,) "xdg-open \"${FILE}\"") + [ "svg", "png", "jpg", "jpeg", "gif", "pdf", "ogg", "ogv" + , "webm", "mp3", "mp4", "mkv", "mpeg", "wav" ] + , shortcuts = M.fromList + [ ("ddg", "https://duckduckgo.com/lite/?q=") + , ("wp", "https://en.m.wikipedia.org/wiki/Special:Search?search=") + , ("wt", "https://en.m.wiktionary.org/w/index.php?search=") + , ("gp", "gopher://gopherpedia.com:70/7/lookup?") + , ("vs", "gopher://gopher.floodgap.com/7/v2/vs?")] + , paginate = True + , historyDepth = 100 + } + +-- | Loads configuration from an XDG config directory. +loadConfig :: MonadIO m => m Config +loadConfig = liftIO $ do + dir <- getXdgDirectory XdgConfig "pancake" + createDirectoryIfMissing True dir + let configPath = dir "config.yaml" + exists <- doesFileExist configPath + if exists + then do + c <- decodeFile configPath + case c of + Just config -> pure config + Nothing -> putErrLn "Failed to read the configuration, using defaults" + >> pure def + else encodeFile configPath (def :: Config) >> pure def diff --git a/Pancake/Printing.hs b/Pancake/Printing.hs new file mode 100644 index 0000000..9790a6b --- /dev/null +++ b/Pancake/Printing.hs @@ -0,0 +1,77 @@ +{- | +Module : Pancake.Printing +Maintainer : defanor +Stability : unstable +Portability : portable + +Renderer output printing facilities. +-} + +module Pancake.Printing ( showLines + , putSexpLn + , showSexps + ) where + +import Control.Monad.State +import System.IO +import System.Console.Terminfo +import Network.URI +import Data.List +import Pancake.Rendering + + +-- | Propertizes a styled string for a given terminal. +propertize :: Terminal -> Styled -> TermOutput +propertize _ (Plain s) = termText s +propertize t (Fg clr s) = maybe id (\f -> f clr) + (getCapability t withForegroundColor) $ propertize t s +propertize t (Pancake.Rendering.Bold s) = + maybe id id (getCapability t withBold) $ propertize t s +propertize t (Pancake.Rendering.Emph s) = + maybe id id (getCapability t withStandout) $ propertize t s +propertize t (Pancake.Rendering.Underline s) = + maybe id id (getCapability t withUnderline) $ propertize t s + +-- | Prints rendered lines. +showLines :: MonadIO m => [StyledLine] -> m () +showLines ls = liftIO $ do + term <- setupTermFromEnv + let nl = maybe (termText "\n") id $ getCapability term newline + runTermOutput term . mconcat $ + map (\l -> mconcat (map (propertize term) l) <#> nl) ls + +-- | Shows a list of strings as an s-expression +list :: [String] -> String +list l = "(" ++ intercalate " " l ++ ")" + +-- | Prints a list of strings as an s-expression. +putSexpLn :: MonadIO m => [String] -> m () +putSexpLn s = liftIO $ do + putStrLn $ list s + hFlush stdout + +-- | Prints rendered lines as s-expressions. +showSexps :: MonadIO m => [RendererOutput] -> m () +showSexps ro = + -- would be nicer to use some library for this, but they tend to be + -- abandoned, and the task is simple enough to do it here + putSexpLn [ "render" + , list $ "lines" : + map (list . pure . concat . intersperse " " . map showSexp) + (rLines ro) + , list $ "identifiers" + : map (\(i, l) -> list [encodeStr i, show l]) (rIdentifiers ro) + , list $ "links" + : map (\uri -> encodeStr $ uriToString id uri "") (rLinks ro)] + where + encodeStr s = concat ["\"", concatMap escape s, "\""] + escape '\\' = "\\\\" + escape '"' = "\\\"" + escape '\n' = "\\n" + escape other = pure other + showSexp :: Styled -> String + showSexp (Plain s) = encodeStr s + showSexp (Fg clr s) = list ["fg", show clr, showSexp s] + showSexp (Bold s) = list ["style", "bold", showSexp s] + showSexp (Underline s) = list ["style", "underline", showSexp s] + showSexp (Emph s) = list ["style", "italic", showSexp s] diff --git a/Pancake/Reading.hs b/Pancake/Reading.hs new file mode 100644 index 0000000..801cf43 --- /dev/null +++ b/Pancake/Reading.hs @@ -0,0 +1,132 @@ +{- | +Module : Pancake.Reading +Maintainer : defanor +Stability : unstable +Portability : non-portable (GHC extensions are used) + +Document retrieval and parsing. +-} + +{-# LANGUAGE ScopedTypeVariables #-} + +module Pancake.Reading ( retrieve + , readDoc + ) where + +import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.ByteString.Char8 as BS +import Network.URI +import qualified Text.Pandoc as P +import System.Process +import Control.Exception +import Control.Applicative +import Data.Text.Encoding (decodeUtf8', decodeLatin1) +import Data.Default +import System.Console.Terminfo +import System.FilePath +import Data.Char +import System.Exit +import System.Environment +import GHC.IO.Handle + +import Text.Pandoc.Readers.Plain +import Text.Pandoc.Readers.Gopher +import Pancake.Common + + +-- | Retrieves a document. Prints an error message and returns an +-- empty string on failure. +retrieve :: String + -- ^ Shell command to use for retrieval. + -> URI + -- ^ Document URI. + -> IO BS.ByteString + -- ^ Document contents. +retrieve cmd uri = do + putErrLn $ "Retrieving " ++ show uri + curEnv <- getEnvironment + let envAuthority = maybe [] (\x -> [ ("URI_USERINFO", uriUserInfo x) + , ("URI_REGNAME", uriRegName x) + , ("URI_PORT", uriPort x) ]) + (uriAuthority uri) + environment = ("URI", uriToString id uri "") + : ("URI_SCHEME", uriScheme uri) + : ("URI_PATH", uriPath uri) + : ("URI_QUERY", uriQuery uri) + : ("URI_FRAGMENT", uriFragment uri) + : curEnv + ++ envAuthority + handle (\(e :: SomeException) -> + putErrLn (concat ["Failed to run `", cmd, "`: ", show e]) + >> pure BS.empty) $ + withCreateProcess ((shell cmd) { env = Just environment + , std_out = CreatePipe + , std_err = CreatePipe + , delegate_ctlc = True }) $ + \_ stdout stderr ph -> case stdout of + Nothing -> putErrLn "No stdout" >> pure BS.empty + Just stdout' -> do + hSetBinaryMode stdout' True + out <- BS.hGetContents stdout' + ec <- waitForProcess ph + if (ec /= ExitSuccess) + then do + putErrLn $ concat ["An error occured. Exit code: ", show ec] + case stderr of + Nothing -> pure () + Just stderr' -> do + err <- BS.hGetContents stderr' + putErrLn $ "stderr:\n" ++ BS.unpack err + else putErrLn $ show uri + pure out + +-- | Reads a document: retrieves it and parses into a Pandoc +-- structure. The parser is chosen depending on the URI. +readDoc :: String + -- ^ Shell command to use for retrieval. + -> URI + -- ^ Document URI. + -> IO (Either P.PandocError P.Pandoc) + -- ^ A parsed document. +readDoc cmd uri = do + out <- retrieve cmd uri + term <- setupTermFromEnv + let reader = either (const plain) id $ + case (uriScheme uri, map toLower $ takeExtension $ uriPath uri) of + -- some exceptions and special cases (might be better to make + -- this configurable) + ("http:", ext) -> http ext + ("https:", ext) -> http ext + ("gopher:", ext) -> case uriPath uri of + ('/':'1':_) -> gopher + ('/':'h':_) -> html + -- "0" should indicate plain text, but it's also the most + -- suitable option for non-html markup. Not sure about this + -- approach, but it's similar to ignoring HTTP content-type, + -- and will do for now: better to render documents nicely + -- when possible. + ('/':'0':_) -> byExtension ext + -- unknown or unrecognized item type + _ -> byExtension ext <|> gopher + (_, ext) -> byExtension ext + cols = maybe 80 id $ getCapability term termColumns + opts = def { P.readerColumns = cols } + case reader of + (P.TextReader f, _) -> case decodeUtf8' out of + Left err -> do + putErrLn $ show err + P.runIO $ f opts $ decodeLatin1 out + Right r -> P.runIO $ f opts r + (P.ByteStringReader f, _) -> P.runIO $ f opts $ BL.fromStrict out + where + http ext = byExtension ext <|> html + html = P.getReader "html" + plain = (P.TextReader . const $ readPlain, P.emptyExtensions) + gopher = pure (P.TextReader . const $ readGopher, P.emptyExtensions) + byExtension "" = Left "No extension" + byExtension ".md" = P.getReader "markdown" + byExtension ".htm" = html + byExtension ".ltx" = P.getReader "latex" + byExtension ".tex" = P.getReader "latex" + byExtension ".txt" = pure plain + byExtension ext = P.getReader $ tail ext diff --git a/Pancake/Rendering.hs b/Pancake/Rendering.hs new file mode 100644 index 0000000..e48c52b --- /dev/null +++ b/Pancake/Rendering.hs @@ -0,0 +1,375 @@ +{- | +Module : Pancake.Rendering +Maintainer : defanor +Stability : unstable +Portability : portable + +Document rendering: conversion from 'Pandoc' to 'RendererOutput'. +-} + +{-# LANGUAGE OverloadedStrings #-} + +module Pancake.Rendering ( Styled(..) + , StyledLine + , RendererOutput(..) + , rLinks + , rLines + , rIdentifiers + , renderDoc + ) where + +import qualified Text.Pandoc as P +import Network.URI +import Data.List +import System.Console.Terminfo.Color +import Data.String +import Control.Monad.Writer +import Control.Monad.State +import System.FilePath +import Data.Char + + +-- | The type of a list item that should be rendered next. +data Listing = Bulleted + | Ordered Int + deriving (Show, Eq) + +-- | A styled string. +data Styled = Plain String + | Underline Styled + | Bold Styled + | Emph Styled + | Fg Color Styled + deriving (Show, Eq) + +-- | Just for convenience. +instance IsString Styled where + fromString = Plain + +-- | A line of styled elements. +type StyledLine = [Styled] + +-- | Renderer state. +data RS = RS { indentationLevel :: Int + , linkCount :: Int + , lineNumber :: Int + , listing :: Maybe Listing + , columns :: Int + } deriving (Show, Eq) + +-- | This is what gets rendered. +data RendererOutput = RLink URI + | RLine StyledLine + | RIdentifier String Int + deriving (Show, Eq) + +-- | Extracts links. +rLinks :: [RendererOutput] -> [URI] +rLinks [] = [] +rLinks ((RLink l):xs) = l : rLinks xs +rLinks (_:xs) = rLinks xs + +-- | Extracts text lines. +rLines :: [RendererOutput] -> [StyledLine] +rLines [] = [] +rLines ((RLine l):xs) = l : rLines xs +rLines (_:xs) = rLines xs + +-- | Extracts identifiers. +rIdentifiers :: [RendererOutput] -> [(String, Int)] +rIdentifiers [] = [] +rIdentifiers ((RIdentifier s i):xs) = (s, i) : rIdentifiers xs +rIdentifiers (_:xs) = rIdentifiers xs + +-- | Used to render 'Pandoc' docs by writing text lines and collected +-- links using 'Writer'. +type Renderer a = WriterT [RendererOutput] (State RS) a + +-- | Runs a 'Renderer'. +runRenderer :: Int + -- ^ Column count (line width). + -> Int + -- ^ Link number to start with. + -> Int + -- ^ Line number to start with. + -> Renderer a + -- ^ A renderer. + -> [RendererOutput] + -- ^ Collected links and text lines. +runRenderer cols ls ln r = snd $ fst $ runState (runWriterT r) + (RS 0 ls ln Nothing cols) + +-- | Stores a link, increasing the counter +storeLink :: URI -> Renderer Int +storeLink u = do + tell [RLink u] + st <- get + put (st { linkCount = linkCount st + 1 }) + pure $ linkCount st + +-- | Stores text lines. +storeLines :: [StyledLine] -> Renderer () +storeLines l = do + modify (\s -> s { lineNumber = lineNumber s + length l }) + tell $ map RLine l + +-- | Stores attributes (identifier and line number). +storeAttr :: P.Attr -> Renderer () +storeAttr ("", _, _) = pure () +storeAttr (i, _, _) = do + l <- get + tell [RIdentifier i (lineNumber l)] + +-- | Increases indentation level, runs a renderer, decreases +-- indentation level. +withIndent :: Renderer a -> Renderer a +withIndent x = do + modify (\s -> s { indentationLevel = indentationLevel s + 1 }) + r <- x + modify (\s -> s { indentationLevel = indentationLevel s - 1 }) + pure r + +-- | Reads indentation level, runs a renderer, restores the original +-- indentation level. +keepIndent :: Renderer a -> Renderer a +keepIndent r = do + st <- get + ret <- r + modify $ \s -> s { indentationLevel = indentationLevel st } + pure ret + +-- | Renders indented (with the current indent level) lines. +indented :: [StyledLine] -> Renderer () +indented slines = do + st <- get + -- The following blocks of the same list item should not be marked. + modify $ \s -> s { listing = Nothing } + let il = indentationLevel st + prefix = case listing st of + Nothing -> "" + (Just Bulleted) -> Fg Yellow "* " + (Just (Ordered n)) -> Fg Yellow $ fromString $ show n ++ ". " + prefixLen = length $ unstyled [prefix] + indent = il + prefixLen + fittedLines = fitLines (columns st - indent) slines + pad = (fromString (replicate indent ' ') :) + padFirst = (\x -> fromString (replicate il ' ') : prefix : x) + -- The following blocks of the same list item should be indented + -- with the same level. This should be reset to the original value + -- where the listing type is getting set. + modify $ \s -> s { indentationLevel = indent } + case fittedLines of + [] -> pure () + (l:ls) -> storeLines $ padFirst l : map pad ls + +-- This may be unreliable, especially for resulting length estimation, +-- but usually works. Maybe improve someday. +-- | Returns a string as it would be shown on a dumb terminal. +unstyled :: StyledLine -> String +unstyled = concatMap unstyled' + where + unstyled' (Plain s) = s + unstyled' (Underline s) = unstyled' s + unstyled' (Bold s) = unstyled' s + unstyled' (Emph s) = unstyled' s + unstyled' (Fg _ s) = unstyled' s + +-- | Fits words into terminal lines of a given width. +fitLines :: Int + -- ^ Line width. + -> [[Styled]] + -- ^ Strings: usually words and similar short elements. + -> [StyledLine] + -- ^ Fitted lines. +fitLines maxLen inlineBits = concatMap (map reverse . fitWords [] 0) inlineBits + where + fitWords :: [Styled] -> Int -> [Styled] -> [StyledLine] + -- fitWords curLine curLen (w:ws) = [[fromString $ show (w:ws)]] + fitWords curLine curLen (w:ws) + -- handle newline characters + | unstyled [w] == "\n" = curLine : fitWords [] 0 ws + -- a new line + | curLen == 0 = fitWords [w] (length $ unstyled [w]) ws + -- add a word to a line + | otherwise = let wLen = length (unstyled [w]) + spaceAhead = case ws of + (" " : _) -> True + _ -> False + in if curLen + wLen <= maxLen + then fitWords (w:curLine) (curLen + wLen) $ + -- if there's an unnecessary space ahead, skip it + if (curLen + wLen + 1 > maxLen && spaceAhead) + then tail ws + else ws + else curLine : fitWords [] 0 (w:ws) + -- end, no words pending + fitWords _ 0 [] = [] + -- end, with words pending + fitWords curLine _ [] = [curLine] + +-- | A helper function to put inline elements between two strings +-- (such as parens or quotes). +wrappedInlines :: Styled + -- ^ String on the left. + -> Styled + -- ^ String on the right. + -> [P.Inline] + -- ^ Inlines to wrap. + -> Renderer [Styled] + -- ^ Resulting inlines. +wrappedInlines s e r = do + r' <- concat <$> mapM readInline r + pure $ s : r' ++ [e] + +-- | Reads an inline element, producing styled strings. Doesn't render +-- them (i.e., using 'Writer') on its own, but collects links. +readInline :: P.Inline -> Renderer [Styled] +readInline (P.Str s) + | all isSpace s = pure [] + | otherwise = pure [fromString s] +readInline (P.Emph s) = concatMap (map Emph) <$> mapM readInline s +readInline (P.Strong s) = concatMap (map Bold) <$> mapM readInline s +readInline (P.Strikeout s) = wrappedInlines "-" "-" s +readInline (P.Superscript s) = wrappedInlines "^{" "}" s +readInline (P.Subscript s) = wrappedInlines "_{" "}" s +readInline (P.SmallCaps s) = wrappedInlines "\\sc{" "}" s +readInline (P.Quoted P.SingleQuote s) = wrappedInlines "‘" "’" s +readInline (P.Quoted P.DoubleQuote s) = wrappedInlines "“" "”" s +readInline (P.Cite _ s) = concat <$> mapM readInline s +readInline (P.Code attr s) = do + storeAttr attr + pure . map fromString $ intersperse "\n" $ lines s +readInline P.Space = pure [" "] +readInline P.SoftBreak = pure [" "] +readInline P.LineBreak = pure ["\n"] +readInline (P.Math _ s) = pure [fromString s] +readInline (P.RawInline _ s) = pure [fromString s] +readInline (P.Link attr alt (url, title)) = do + storeAttr attr + case parseURIReference url of + Just uri -> do + a <- mapM readInline alt + let t = case (title, concat a) of + ("", []) -> [fromString url] + ("", alt') -> alt' + (title', []) -> [fromString title'] + (_, alt') -> alt' + cnt <- storeLink uri + let color = case uri of + (URI "" Nothing "" "" ('#':_)) -> Magenta + _ -> Cyan + pure $ (map $ Fg color) t ++ + [Fg Blue $ fromString (concat ["[", show cnt, "]"])] + Nothing -> pure [fromString title] +readInline (P.Image attr alt (url, title)) = do + storeAttr attr + (Fg Red "img:" :) <$> case parseURIReference url of + Nothing -> pure [fromString title] + Just uri -> do + a <- mapM readInline alt + let t = case (title, concat a) of + ("", []) -> [fromString $ takeFileName $ uriPath uri] + ("", alt') -> alt' + (title', []) -> [fromString title'] + (_, alt') -> alt' + cnt <- storeLink uri + pure $ (map $ Fg Cyan) t ++ + [Fg Blue $ fromString (concat ["[", show cnt, "]"])] +readInline (P.Note _) = pure . pure $ "(note: todo)" +readInline (P.Span attr i) = do + storeAttr attr + concat <$> mapM readInline i + +-- | Reads lines of inline elements. +readInlines :: [P.Inline] -> Renderer [StyledLine] +readInlines i = pure . concat <$> mapM readInline i + +-- | Renders a block element. +renderBlock :: P.Block -> Renderer () +renderBlock (P.Plain i) = indented =<< readInlines i +renderBlock (P.Para i) = (indented =<< readInlines i) >> storeLines [[""]] +renderBlock (P.LineBlock i) = + indented =<< concat <$> mapM (mapM readInline) i +renderBlock (P.CodeBlock attr s) = do + storeAttr attr + indented $ map (pure . fromString) $ lines s +renderBlock (P.RawBlock _ s) = + indented $ map (pure . fromString) $ lines s +renderBlock (P.BlockQuote bs) = renderBlocks bs +renderBlock (P.OrderedList _ bs) = do + zipWithM_ (\b n -> modify (\s -> s { listing = Just (Ordered n) }) + >> keepIndent (mapM_ renderBlock b)) bs [1..] + modify $ \s -> s { listing = Nothing } +renderBlock (P.BulletList bs) = do + mapM_ (\b -> modify (\s -> s { listing = Just Bulleted }) + >> keepIndent (mapM_ renderBlock b)) bs + modify $ \s -> s { listing = Nothing } +renderBlock (P.DefinitionList dl) = + let renderDefinition (term, definition) = do + indented =<< readInlines term + mapM_ renderBlocks definition + in mapM_ renderDefinition dl +renderBlock (P.Header level attr i) = do + storeAttr attr + strings <- readInlines i + storeLines [[""]] + indented $ map (map (Fg Green) . ([fromString (replicate level '#'), " "] ++) + . (map (Bold . Underline))) strings + storeLines [[""]] +renderBlock P.HorizontalRule = do + st <- get + indented [[Fg Black $ + fromString $ replicate (columns st - indentationLevel st * 2) '-']] +renderBlock (P.Table caption _ widths headers rows) = do + -- todo: don't ignore alignments + indented =<< readInlines caption + -- Use pandoc-provided widths if they are set, calculate them + -- otherwise. + let widthsAreSet = case widths of + [] -> False + w -> minimum w /= maximum w + ws <- if widthsAreSet then pure widths else do + lens <- map sum . transpose <$> + mapM (mapM (\c -> (length . unstyled . concat) <$> tableCell 80 c)) rows + pure $ map (\l -> fromIntegral l / fromIntegral (sum lens)) lens + mapM_ (\r -> renderBlock P.HorizontalRule >> tableRow ws r) (headers : rows) + renderBlock P.HorizontalRule + where + tableCell :: Int -> [P.Block] -> Renderer [StyledLine] + tableCell w blocks = do + st <- get + let l = runRenderer w (linkCount st) (lineNumber st) $ + mapM_ renderBlock blocks + mapM_ storeLink $ rLinks l + pure $ map + (\x -> x ++ [fromString (replicate (w - length (unstyled x)) ' ')]) + $ rLines l + tableRow :: [Double] -> [[P.Block]] -> Renderer () + tableRow ws cols = do + st <- get + let maxWidth = columns st - indentationLevel st - ((length cols - 1) * 3) + widths' = map (\w -> floor (fromIntegral maxWidth * w)) ws + cells <- zipWithM tableCell widths' cols + let maxLines = foldr (max . length) 0 cells + padded = zipWith (\w c -> c ++ replicate (maxLines - length c) + [fromString $ replicate w ' ']) widths' cells + indented $ map (mconcat . intersperse (pure $ Fg Black " | ")) + $ transpose padded +renderBlock (P.Div attr b) = do + storeAttr attr + renderBlocks b +renderBlock P.Null = pure () + +-- | Renders multiple block elements. +renderBlocks :: [P.Block] -> Renderer () +renderBlocks b = withIndent $ mapM_ renderBlock b + +-- | Renders a document. +renderDoc :: Int + -- ^ Number of columns. + -> P.Pandoc + -- ^ Document to render. + -> [RendererOutput] + -- ^ Rendered document. +renderDoc cols (P.Pandoc _ blocks) = + runRenderer cols 0 1 $ mapM_ renderBlock blocks -- cgit v1.2.3