diff options
| -rw-r--r-- | Pancake.hs | 648 | ||||
| -rw-r--r-- | Pancake/Common.hs | 19 | ||||
| -rw-r--r-- | Pancake/Configuration.hs | 92 | ||||
| -rw-r--r-- | Pancake/Printing.hs | 77 | ||||
| -rw-r--r-- | Pancake/Reading.hs | 132 | ||||
| -rw-r--r-- | Pancake/Rendering.hs | 375 | ||||
| -rw-r--r-- | pancake.cabal | 5 |
7 files changed, 736 insertions, 612 deletions
@@ -9,575 +9,34 @@ A CLI web\/gopher\/file browser inspired by -} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where import qualified Text.Pandoc as P import System.FilePath -import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.ByteString.Char8 as BS import Data.Default import Network.URI import System.Process -import Control.Monad.Writer hiding ((<>)) +import Control.Monad.Writer import Control.Monad.State import Data.Maybe import Data.List -import Data.String import System.Console.Terminfo import System.Environment -import Data.Yaml -import GHC.Generics import qualified Data.Map as M import System.Directory import System.Exit -import GHC.IO.Handle import Control.Exception -import Text.Pandoc.Readers.Plain -import Text.Pandoc.Readers.Gopher -import Control.Applicative -import qualified System.IO as SIO import Data.Char -import Data.Text.Encoding (decodeUtf8', decodeLatin1) import System.IO.Error - --- | Prints a line into stderr. -putErrLn :: MonadIO m => String -> m () -putErrLn s = liftIO $ do - SIO.hPutStrLn SIO.stderr s - SIO.hFlush SIO.stderr - - --- * Document reading - --- | 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 - - --- * Rendering - --- | The type of a list item that should be rendered next. -data Listing = Bulleted - | Ordered Int - deriving (Show, Eq) - --- | Renderer state. -data RS = RS { indentationLevel :: Int - , linkCount :: Int - , lineNumber :: Int - , listing :: Maybe Listing - , columns :: 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] - --- | 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' (Main.Underline s) = unstyled' s - unstyled' (Main.Bold s) = unstyled' s - unstyled' (Main.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 Main.Emph) <$> mapM readInline s -readInline (P.Strong s) = concatMap (map Main.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 (Main.Bold . Main.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 - - --- * Configuration - --- | 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 => StateT LoopState m () -loadConfig = do - c <- 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 - modify $ \s -> s {conf = c} - - --- * Control - --- | Interactive user command. -data Command = Quit - | Follow Int - | More - | GoTo URI - | Reload - | Back - | Forward - | Help - | Show Int - | ShowCurrent - | Shortcut String String - | ReloadConfig - deriving (Show, Eq) +import Pancake.Common +import Pancake.Configuration +import Pancake.Reading +import Pancake.Rendering +import Pancake.Printing -- | A zipper kind of thing, for scrolling and history traversal. type Sliding a = ([a], [a]) @@ -590,69 +49,13 @@ data LoopState = LS { history :: Sliding (URI, P.Pandoc) , embedded :: Bool } deriving (Show) --- | 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 (Main.Bold s) = - maybe id id (getCapability t withBold) $ propertize t s -propertize t (Main.Emph s) = - maybe id id (getCapability t withStandout) $ propertize t s -propertize t (Main.Underline s) = - maybe id id (getCapability t withUnderline) $ propertize t s - --- | Prints rendered lines. -showLines :: MonadIO m => [StyledLine] -> StateT LoopState 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] -> StateT LoopState m () -putSexpLn s = liftIO $ do - putStrLn $ list s - SIO.hFlush SIO.stdout - --- | Prints rendered lines as s-expressions. -showSexps :: MonadIO m => [RendererOutput] -> StateT LoopState 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] - -- | Renders a parsed document. -renderDoc :: MonadIO m => P.Pandoc -> StateT LoopState m () -renderDoc (P.Pandoc _ blocks) = do +printDoc :: MonadIO m => P.Pandoc -> StateT LoopState m () +printDoc doc = do term <- liftIO setupTermFromEnv st <- get let cols = maybe 80 id $ getCapability term termColumns - l = runRenderer cols 0 1 $ mapM_ renderBlock blocks + l = renderDoc cols doc textLines = rLines l modify (\s -> s { rendered = l }) if embedded st @@ -664,6 +67,12 @@ renderDoc (P.Pandoc _ blocks) = do else textLines modify (\s -> s { position = rows }) +-- | Updates 'LoopState' with user configuration. +updateConfig :: MonadIO m => StateT LoopState m () +updateConfig = do + c <- loadConfig + modify $ \s -> s { conf = c } + -- | Decides what to do with a given URI; either returns a document or -- runs an external viewer. Used by both 'GoTo' and 'Reload'. loadDocument :: MonadIO m => URI -> StateT LoopState m (URI, Maybe P.Pandoc) @@ -720,11 +129,26 @@ goTo u' = do case d of Nothing -> pure () Just doc -> do - renderDoc doc + printDoc doc modify $ \s -> let (prev, _) = history s in s { history = (take (historyDepth $ conf s) $ (u, doc) : prev, []) } +-- | Interactive user command. +data Command = Quit + | Follow Int + | More + | GoTo URI + | Reload + | Back + | Forward + | Help + | Show Int + | ShowCurrent + | Shortcut String String + | ReloadConfig + deriving (Show, Eq) + -- | Evaluates user commands. command :: MonadIO m => Command -> StateT LoopState m () command (GoTo u@(URI _ _ _ _ ('#':xs))) = do @@ -755,7 +179,7 @@ command Back = do st <- get case history st of (cur:p@(_, d):prev, next) -> do - renderDoc d + printDoc d modify $ \s -> s { history = (p:prev, take (historyDepth $ conf s) $ cur : next) } _ -> liftIO $ putErrLn "There's nothing back there" @@ -763,7 +187,7 @@ command Forward = do st <- get case history st of (prev, n@(_, d):next) -> do - renderDoc d + printDoc d modify $ \s -> s { history = (take (historyDepth $ conf s) $ n : prev, next) } _ -> liftIO $ putErrLn "Nowhere to go" @@ -783,7 +207,7 @@ command Reload = do case d of Nothing -> pure () Just doc -> do - renderDoc doc + printDoc doc modify $ \s -> s { history = ( (u, doc):prev, next ) } _ -> putErrLn "There's nothing to reload" command Help = do @@ -805,7 +229,7 @@ command ShowCurrent = do _ -> pure () command (Shortcut u q) = command . GoTo . fromJust . parseURI $ u ++ escapeURIString isReserved q -command ReloadConfig = loadConfig +command ReloadConfig = updateConfig command Quit = liftIO $ do dir <- getXdgDirectory XdgCache "pancake" exists <- doesDirectoryExist dir @@ -845,6 +269,6 @@ eventLoop = do main :: IO () main = do args <- getArgs - _ <- runStateT (loadConfig >> eventLoop) $ + _ <- runStateT (updateConfig >> eventLoop) $ LS ([],[]) 0 [] def ("--embedded" `elem` args) pure () 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 <defanor@uberspace.net> +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 <defanor@uberspace.net> +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 <defanor@uberspace.net> +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 <defanor@uberspace.net> +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 <defanor@uberspace.net> +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 diff --git a/pancake.cabal b/pancake.cabal index 234855c..a6c5a1a 100644 --- a/pancake.cabal +++ b/pancake.cabal @@ -27,6 +27,11 @@ executable pancake main-is: Pancake.hs other-modules: Text.Pandoc.Readers.Plain , Text.Pandoc.Readers.Gopher + , Pancake.Common + , Pancake.Configuration + , Pancake.Reading + , Pancake.Rendering + , Pancake.Printing build-depends: base >= 4.9 && < 5 , bytestring >= 0.10.8.1 && < 1 , containers >= 0.5.7.1 && < 1 |