Split into modules

5 files changed, 695 insertions, 0 deletions

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