diff options
Diffstat (limited to 'app/Render.hs')
| -rw-r--r-- | app/Render.hs | 196 |
1 files changed, 196 insertions, 0 deletions
diff --git a/app/Render.hs b/app/Render.hs new file mode 100644 index 0000000..2220fb8 --- /dev/null +++ b/app/Render.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module is an experimental wrapper around the prettyprinter module. +module Render + ( -- * Re-exports + module Prettyprinter, + module Prettyprinter.Render.Terminal, + + -- * Render + Render (..), + (<<<), + styled, + + -- * Reporting styles + Detailed (..), + Summarized (..), + Linked (..), + + -- * Markdown + Markdown (..), + renderAsMarkdown, + + -- * Additional symbols + plus, + minus, + ) +where + +import CMark qualified as D +import Data.List (isPrefixOf, isSuffixOf, intersperse) +import Data.Maybe (catMaybes) +import Data.Text qualified as T +import Data.Time.Calendar (Day) +import Prettyprinter +import Prettyprinter.Render.Terminal + +-- | The render class is a superclass of `Pretty`. It exists to facilitate +-- reporting styles (see below), as well as decomposing aggregate entities into composable parts (for instance `IssueTitle`, `IssueTags` of `Issue`). +-- +-- Renderable entities are expected to define `Render (Detailed a)` and default `Render a` to that instance. +class Render a where + render :: a -> Doc AnsiStyle + default render :: Pretty a => a -> Doc AnsiStyle + render = pretty + +instance Render (Doc AnsiStyle) where + render = id + +instance Render T.Text + +instance Render String + +instance Render Day where + render = render . show + +-- | The `(<<<)` combinator concatenates renderables. It takes care of inserting spaces between non-empty renderables automatically, obsoleting prettyprinter's `(<+>)` and `(<>)`. +(<<<) :: (Render a, Render b) => a -> b -> Doc AnsiStyle +(<<<) a' b' = + case (nonEmpty a', nonEmpty b') of + (Nothing, Nothing) -> emptyDoc + (Just a, Nothing) -> a + (Nothing, Just b) -> b + (Just a, Just b) -> + if endsWithNL a || startsWithNL b + then a <> b + else a <> space <> b + where + nonEmpty x' = + let x = render x' + in if not (null (show x)) then Just (render x) else Nothing + startsWithNL = ("\n" `isPrefixOf`) . show . render + endsWithNL = ("\n" `isSuffixOf`) . show . render + +-- | `styled` allows to annotate a document with multiple annotations. It obsoletes prettyprinter's `annotate`. +styled :: [AnsiStyle] -> Doc AnsiStyle -> Doc AnsiStyle +styled [] doc = doc +styled as doc = foldl1 (.) (map annotate as) $ doc + +-- | The detailed report should present all information, corresponding to the semantics of the `show` command. +-- +-- It should be the default instance for all data types. +newtype Detailed a = Detailed {unDetailed :: a} + +-- | The summarized report should present most relevant information in a concise way, corresponding to the semantics of the `list` command. +newtype Summarized a = Summarized {unSummarized :: a} + +-- | The linked report should present strictly necessary information. It should be used when one entity refers to another. +newtype Linked a = Linked {unLinked :: a} + +newtype Markdown = Markdown {unMarkdown :: D.Node} + +renderAsMarkdown :: T.Text -> Doc AnsiStyle +renderAsMarkdown = render . Markdown . D.commonmarkToNode [] + +instance Render Markdown where + render = maybe emptyDoc go . rec . unMarkdown + where + rec (D.Node _ D.SOFTBREAK _) = Nothing + rec (D.Node p t ns) = Just $ D.Node p t (catMaybes $ map rec ns) + + go (D.Node _ D.DOCUMENT ns) = vsep (intersperse (pretty ("" :: T.Text)) (map go ns)) + go (D.Node _ D.THEMATIC_BREAK _) = pretty ("***" :: T.Text) + go (D.Node _ D.PARAGRAPH ns) = fillSep $ map go ns + go (D.Node _ D.BLOCK_QUOTE ns) = + styled [color Black] . fillSep $ + pretty (">" :: T.Text) + : [ align . fillSep $ + map go ns + ++ [pretty ("\n" :: T.Text)] + ] + go (D.Node _ (D.HTML_BLOCK s) _) = + styled [color Yellow] $ + hsep + [ pretty (T.strip s), + pretty ("\n" :: T.Text) + ] + go (D.Node _ (D.CUSTOM_BLOCK _ _) ns) = + styled [color Yellow] $ + hsep $ + map go ns ++ [pretty ("\n" :: T.Text)] + go (D.Node _ (D.CODE_BLOCK _ s) _) = + hcat + [ styled [color Green] (pretty ("────────────────────\n" :: T.Text)), + styled [color Yellow] + . vsep + . map (styled [color Yellow] . pretty) + $ T.lines s, + pretty ("\n" :: T.Text), + styled [color Green] (pretty ("────────────────────" :: T.Text)) + ] + go (D.Node _ (D.HEADING c) ns) = + styled [color Magenta] . fillSep $ + pretty (T.replicate c "#") : map go ns + go (D.Node _ (D.LIST _) ns) = + hsep (map ((pretty ("- " :: T.Text)) <>) (map go ns)) + go (D.Node _ D.ITEM ns) = fillSep (map go ns) + go (D.Node _ (D.TEXT s) _) = + fillSep . map (pretty . T.strip) $ + T.words s + go (D.Node _ D.LINEBREAK _) = hardline + go (D.Node _ (D.HTML_INLINE s) _) = + styled [color Yellow] $ pretty (T.strip s) + go (D.Node _ (D.CUSTOM_INLINE _ _) ns) = + styled [color Yellow] . fillSep $ map go ns + go (D.Node _ (D.CODE s) _) = + styled [color Yellow] $ pretty (T.strip s) + go (D.Node _ D.EMPH ns) = styled [italicized] $ fillSep (map go ns) + go (D.Node _ D.STRONG ns) = styled [bold] $ fillSep (map go ns) + go (D.Node _ D.SOFTBREAK _) = emptyDoc + go (D.Node _ (D.LINK url "") ns) = + styled [color Blue] $ + hcat + [ pretty ("[" :: T.Text), + hsep (map go ns), + pretty ("](" :: T.Text), + pretty url, + pretty (")" :: T.Text) + ] + go (D.Node _ (D.LINK url title) ns) = + styled [color Blue] $ + hcat + [ pretty ("[" :: T.Text), + hsep (map go ns), + pretty ("](" :: T.Text), + pretty url, + pretty (" \"" :: T.Text), + pretty title, + pretty ("\")" :: T.Text) + ] + go (D.Node _ (D.IMAGE url "") ns) = + styled [color Blue] $ + hcat + [ pretty ("![" :: T.Text), + hsep (map go ns), + pretty ("](" :: T.Text), + pretty url, + pretty (")" :: T.Text) + ] + go (D.Node _ (D.IMAGE url title) ns) = + styled [color Blue] $ + hcat + [ pretty ("![" :: T.Text), + hsep (map go ns), + pretty ("](" :: T.Text), + pretty url, + pretty (" \"" :: T.Text), + pretty title, + pretty ("\")" :: T.Text) + ] + +plus :: Doc ann +plus = pretty ("+" :: T.Text) + +minus :: Doc ann +minus = pretty ("-" :: T.Text) |