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/Rendering.hs | 375 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 375 insertions(+) create mode 100644 Pancake/Rendering.hs (limited to 'Pancake/Rendering.hs') 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