{-# 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 (intersperse, isPrefixOf, isSuffixOf)
import Data.Maybe (catMaybes)
import Data.Text qualified as T
import Data.Time.Calendar (Day)
import Prettyprinter
import Prettyprinter.Render.Terminal
import System.IO.Unsafe (unsafePerformIO)

-- | 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

-- TODO Resolve `performUnsafeIO`
--
-- We want `Renderable a => IO a` in our data structures so that we can defer potentially expensive computation until it is actually required to be rendered.
--
-- We should be able to eliminate `unsafePerformIO` by lifting `render` to `a -> IO (Doc AnsiStyle)`.
--
-- @backlog
instance Render a => Render (IO a) where
  render = render . unsafePerformIO

-- | 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

(===) :: (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 -> a <> b
          | endsWithNL a || startsWithNL b -> a <> hardline <> b
          | otherwise -> a <> hardline <> hardline <> 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 = render . unMarkdown

instance Render [D.Node] where
  render = render . D.Node Nothing D.DOCUMENT

-- TODO Fix spacing between markdown nodes
--
-- The following code suffers from the problem that inline code such as `foo` is not separated correctly when surrounded by non-whitespace characters, ie. `foo`, or `foo`s.
--
-- The reason for that is that we generally trim words within `TEXT` nodes, and then add the spaces back.
--
-- Thus, we should not trim words. But we should still replace whitespace by `P.softline`s (ie. `P.fillSep`) for automatic paragraph wrapping.
--
-- @topic markdown
instance Render D.Node where
  render = maybe emptyDoc go . rec
    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)