vervis/src/Vervis/Render.hs

{- This file is part of Vervis.
 -
 - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

{-# Language CPP #-}

-- | Tools for rendering repository file contents and other source files.
--
-- There are several ways to render a file:
--
-- (1) As a source file, plain text and with line numbers
-- (2) As a source file, syntax highlighted and with line numbers
-- (3) As a plain text document
-- (4) As a document rendered to HTML, e.g. Markdown is a popular format
-- (5) As a document rendered to a custom format, e.g. presentation
--
-- The difference between 3 and 5 is line numbers and font (3 would use regular
-- text font, while 5 would use monospaced font).
--
-- At the time of writing, not all rendering modes are implemented. The current
-- status, assuming I'm keeping it updated, is:
--
-- (1) Partially implemented: No line numbers
-- (2) Implemented, using line numbers generated by @highlighter2@ formatter
-- (3) Not implemented
-- (4) Not implemented
-- (5) Not implmented
module Vervis.Render
    ( --renderPlain
    --, renderHighlight
      renderSource
    )
where

import Prelude

import Control.Monad.Logger (logDebug, logWarn)
import Data.Foldable (for_)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
--import Formatting hiding (format)
import Text.Blaze.Html (preEscapedToMarkup)
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.Highlighter (lexerFromFilename, runLexer, Lexer (lName))
import Text.Highlighter.Formatters.Html (format)
import Text.Highlighting.Kate.Styles (tango)
import Text.HTML.SanitizeXSS (sanitizeBalance)
import Text.Pandoc.Definition (Pandoc)
import Text.Pandoc.Options
import Text.Pandoc.Readers.Markdown
import Text.Pandoc.Writers.HTML
import Yesod.Core.Widget (whamlet, toWidget)

import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.Text.Encoding.Error as TE
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Text.Highlighter.Lexers.Haskell as L.Haskell

import Vervis.Foundation (Widget)
import Vervis.MediaType (MediaType (..))

renderPlain :: BL.ByteString -> Widget
renderPlain content =
    [whamlet|
        <pre>
            <code>#{TLE.decodeUtf8With TE.lenientDecode content}
    |]

{-renderHighlight
    :: FilePath -> BL.ByteString -> Either (Maybe Lexer) (Lexer, Widget)
renderHighlight name content =
    case lexerFromFilename name of
        Nothing    -> Left Nothing
        Just lexer ->
            case runLexer lexer $ BL.toStrict content of
                Left err     -> Left $ Just lexer
                Right tokens -> Right (lexer, toWidget $ format True tokens)
-}

-- * File uploads and wiki attachments
-- * Wiki pages
-- * READMEs
-- * Source files which happen to be documents, e.g. Markdown, manpages,
--   OrgMode, LaTeX, and
-- * Literate Haskell files
--
-- For now, let's ignore the first two. Which source files, README or other, do
-- we want to offer to display as HTML rendering?
--
-- * [ ] native
-- * [ ] json
-- * [x] markdown
-- * [ ] markdown_strict
-- * [ ] markdown_phpextra
-- * [ ] markdown_github
-- * [ ] markdown_mmd
-- * [ ] commonmark
-- * [ ] rst
-- * [ ] mediawiki
-- * [ ] docbook
-- * [ ] opml
-- * [ ] org
-- * [ ] textile
-- * [ ] html
-- * [ ] latex
-- * [ ] haddock
-- * [ ] twiki
-- * [ ] docx
-- * [ ] odt
-- * [ ] t2t
-- * [ ] epub
--
-- Any others not in this list, maybe using other libraries?
--
-- * [ ] asciidoc
-- * [ ] groff manpage

renderHighlight :: Lexer -> BL.ByteString -> Maybe Widget
renderHighlight lexer content =
    case runLexer lexer $ BL.toStrict content of
        Left err     -> Nothing
        Right tokens -> Just $ toWidget $ format True tokens

renderCode :: Lexer -> BL.ByteString -> Widget
renderCode lexer content =
    fromMaybe (renderPlain content) $ renderHighlight lexer content

readerOptions :: ReaderOptions
readerOptions = def
    { readerExtensions            = pandocExtensions
    , readerSmart                 = True
    , readerStandalone            = False
    , readerParseRaw              = True
    , readerColumns               = 80
    , readerTabStop               = 4
--  , readerOldDashes             = False
--  , readerApplyMacros           = True
--  , readerIndentedCodeClasses   = []
--  , readerDefaultImageExtension = ""
    , readerTrace                 =
#if DEVELOPMENT
        True
#else
        False
#endif
--  , readerTrackChanges          = AcceptChanges
--  , readerFileScope             = False
    }

writerOptions :: WriterOptions
writerOptions = def
    { writerStandalone       = False
--  , writerTemplate         = ""
--  , writerVariables        = []
    , writerTabStop          = 4
    , writerTableOfContents  = True
--  , writerSlideVariant     = NoSlides
--  , writerIncremental      = False
--  , writerHTMLMathMethod   = PlainMath
--  , writerIgnoreNotes      = False
--  , writerNumberSections   = False
--  , writerNumberOffset     = [0,0,0,0,0,0]
--  , writerSectionDivs      = False
    , writerExtensions       = pandocExtensions
--  , writerReferenceLinks   = False
--  , writerDpi              = 96
    , writerWrapText         = WrapAuto
    , writerColumns          = 79
    , writerEmailObfuscation = ReferenceObfuscation
--  , writerIdentifierPrefix = ""
--  , writerSourceURL        = Nothing
--  , writerUserDataDir      = Nothing
--  , writerCiteMethod       = Citeproc
    , writerHtml5            = True
--  , writerHtmlQTags        = False
--  , writerBeamer           = False
--  , writerSlideLevel       = Nothing
--  , writerChapters         = False
--  , writerListings         = False
    , writerHighlight        = True
    , writerHighlightStyle   = tango
--  , writerSetextHeaders    = True
--  , writerTeXLigatures     = True
--  , writerEpubVersion      = Nothing
--  , writerEpubMetadata     = ""
--  , writerEpubStylesheet   = Nothing
--  , writerEpubFonts        = []
--  , writerEpubChapterLevel = 1
--  , writerTOCDepth         = 3
--  , writerReferenceODT     = Nothing
--  , writerReferenceDocx    = Nothing
--  , writerMediaBag         = mempty
    , writerVerbose          =
#if DEVELOPMENT
        True
#else
        False
#endif
--  , writerLaTeXArgs        = []
    }

renderPandoc :: Pandoc -> Widget
renderPandoc =
    toWidget .
    preEscapedToMarkup .
    sanitizeBalance .
    TL.toStrict .
    renderHtml .
    writeHtml writerOptions

renderSource :: MediaType -> BL.ByteString -> Widget
renderSource mt content =
    let contentBL = content
        contentTL = TLE.decodeUtf8With TE.lenientDecode contentBL
        contentS = TL.unpack contentTL

        mtName = T.pack $ show mt

        failed e =
            "Failed to parse " <> mtName <> "content: " <> T.pack (show e)

        -- Plain text with line numbers
        plain = renderPlain content
        -- Syntax highlighted source code with line numbers
        code l = renderCode l content
        -- Rendered document from String source
        docS r =
            case r readerOptions contentS of
                Left err  -> $logWarn (failed err) >> plain
                Right doc -> renderPandoc doc
        -- Rendered document from String source, with warnings
        docSW r =
            case r readerOptions contentS of
                Left err           -> $logWarn (failed err) >> plain
                Right (doc, warns) -> do
                    for_ warns $ \ warn ->
                        $logDebug $ mtName <> " reader warning: " <> T.pack warn
                    renderPandoc doc
    in  case mt of
            -- * Documents
            PlainText -> plain
            Markdown  -> docSW readMarkdownWithWarnings
            -- * Programming languages
            -- ** Haskell
            Haskell   -> code L.Haskell.lexer
            -- * Misc
            _         -> plain

{-renderSource :: FilePath -> BL.ByteString -> Widget
renderSource name content =
    let plain = renderPlain content
    in  case renderHighlight name content of
            Left Nothing -> do
                $logDebug $ "No lexer found for " <> pack name
                plain
            Left (Just lexer) -> do
                $logWarn $ sformat
                    ( "Failed to highlight " % string % " with lexer "
                    % string
                    )
                    name (lName lexer)
                plain
            Right (lexer, widget) -> do
                $logDebug $ sformat
                    ("Lexed " % string % " with " % string) name (lName lexer)
                widget
-}