{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}

{-# OPTIONS_GHC -fno-warn-deprecations #-}

#include "version-compatibility-macros.h"

-- | This module shows how to write a custom prettyprinter backend, based on
-- directly converting a 'SimpleDocStream' to an output format using a stack
-- machine. For a tree serialization approach, which may be more suitable for
-- certain output formats, see
-- "Prettyprinter.Render.Tutorials.TreeRenderingTutorial".
--
-- Rendering to ANSI terminal with colors is an important use case for stack
-- machine based rendering.
--
-- The module is written to be readable top-to-bottom in both Haddock and raw
-- source form.
module Prettyprinter.Render.Tutorials.StackMachineTutorial
    {-# DEPRECATED "Writing your own stack machine is probably more efficient and customizable; also consider using »renderSimplyDecorated(A)« instead" #-}
    where

import qualified Data.Text.Lazy         as TL
import qualified Data.Text.Lazy.Builder as TLB

import Prettyprinter
import Prettyprinter.Internal
import Prettyprinter.Render.Util.Panic
import Prettyprinter.Render.Util.StackMachine

#if !(APPLICATIVE_MONAD)
import Control.Applicative
#endif

-- * The type of available markup
--
-- $standalone-text
--
-- First, we define a set of valid annotations must be defined, with the goal of
-- defining a @'Doc' 'SimpleHtml'@. We will later define how to convert this to
-- the output format ('TL.Text').

data SimpleHtml = Bold | Italics | Color Color | Paragraph | Headline
data Color = Red | Green | Blue

-- ** Convenience definitions

bold, italics, paragraph, headline :: Doc SimpleHtml -> Doc SimpleHtml
bold :: Doc SimpleHtml -> Doc SimpleHtml
bold = SimpleHtml -> Doc SimpleHtml -> Doc SimpleHtml
forall ann. ann -> Doc ann -> Doc ann
annotate SimpleHtml
Bold
italics :: Doc SimpleHtml -> Doc SimpleHtml
italics = SimpleHtml -> Doc SimpleHtml -> Doc SimpleHtml
forall ann. ann -> Doc ann -> Doc ann
annotate SimpleHtml
Italics
paragraph :: Doc SimpleHtml -> Doc SimpleHtml
paragraph = SimpleHtml -> Doc SimpleHtml -> Doc SimpleHtml
forall ann. ann -> Doc ann -> Doc ann
annotate SimpleHtml
Paragraph
headline :: Doc SimpleHtml -> Doc SimpleHtml
headline = SimpleHtml -> Doc SimpleHtml -> Doc SimpleHtml
forall ann. ann -> Doc ann -> Doc ann
annotate SimpleHtml
Headline

color :: Color -> Doc SimpleHtml -> Doc SimpleHtml
color :: Color -> Doc SimpleHtml -> Doc SimpleHtml
color Color
c = SimpleHtml -> Doc SimpleHtml -> Doc SimpleHtml
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> SimpleHtml
Color Color
c)

-- * The rendering algorithm
--
-- $standalone-text
--
-- With the annotation definitions out of the way, we can now define a
-- conversion function from 'SimpleDocStream' annotated with our 'SimpleHtml' to the
-- final 'TL.Text' representation.
--
-- There are two ways to render this; the simpler one is just using
-- 'renderSimplyDecorated'. However, some output formats require more
-- complicated functionality, so we explore this explicitly with a simple
-- example below. An example for something more complicated is ANSI terminal
-- rendering, where on popping we need to regenerate the previous style,
-- requiring a pop (discard current style) followed by a peek (regenerate
-- previous style).

-- | The 'StackMachine' type defines a stack machine suitable for many rendering
-- needs. It has two auxiliary parameters: the type of the end result, and the
-- type of the document’s annotations.
--
-- Most 'StackMachine' creations will look like this definition: a recursive
-- walk through the 'SimpleDocStream', pushing styles on the stack and popping
-- them off again, and writing raw output.
--
-- The equivalent to this in the tree based rendering approach is
-- 'Prettyprinter.Render.Tutorials.TreeRenderingTutorial.renderTree'.
renderStackMachine :: SimpleDocStream SimpleHtml -> StackMachine TLB.Builder SimpleHtml ()
renderStackMachine :: SimpleDocStream SimpleHtml -> StackMachine Builder SimpleHtml ()
renderStackMachine = \SimpleDocStream SimpleHtml
sds -> case SimpleDocStream SimpleHtml
sds of
    SimpleDocStream SimpleHtml
SFail -> StackMachine Builder SimpleHtml ()
forall void. void
panicUncaughtFail
    SimpleDocStream SimpleHtml
SEmpty -> () -> StackMachine Builder SimpleHtml ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    SChar Char
c SimpleDocStream SimpleHtml
x -> do
        Builder -> StackMachine Builder SimpleHtml ()
forall output style. output -> StackMachine output style ()
writeOutput (Char -> Builder
TLB.singleton Char
c)
        SimpleDocStream SimpleHtml -> StackMachine Builder SimpleHtml ()
renderStackMachine SimpleDocStream SimpleHtml
x
    SText Int
_l Text
t SimpleDocStream SimpleHtml
x -> do
        Builder -> StackMachine Builder SimpleHtml ()
forall output style. output -> StackMachine output style ()
writeOutput (Text -> Builder
TLB.fromText Text
t)
        SimpleDocStream SimpleHtml -> StackMachine Builder SimpleHtml ()
renderStackMachine SimpleDocStream SimpleHtml
x
    SLine Int
i SimpleDocStream SimpleHtml
x -> do
        Builder -> StackMachine Builder SimpleHtml ()
forall output style. output -> StackMachine output style ()
writeOutput (Char -> Builder
TLB.singleton Char
'\n')
        Builder -> StackMachine Builder SimpleHtml ()
forall output style. output -> StackMachine output style ()
writeOutput (Text -> Builder
TLB.fromText (Int -> Text
textSpaces Int
i))
        SimpleDocStream SimpleHtml -> StackMachine Builder SimpleHtml ()
renderStackMachine SimpleDocStream SimpleHtml
x
    SAnnPush SimpleHtml
s SimpleDocStream SimpleHtml
x -> do
        SimpleHtml -> StackMachine Builder SimpleHtml ()
forall output style.
Monoid output =>
style -> StackMachine output style ()
pushStyle SimpleHtml
s
        Builder -> StackMachine Builder SimpleHtml ()
forall output style. output -> StackMachine output style ()
writeOutput ((Builder, Builder) -> Builder
forall a b. (a, b) -> a
fst (SimpleHtml -> (Builder, Builder)
htmlTag SimpleHtml
s))
        SimpleDocStream SimpleHtml -> StackMachine Builder SimpleHtml ()
renderStackMachine SimpleDocStream SimpleHtml
x
    SAnnPop SimpleDocStream SimpleHtml
x -> do
        SimpleHtml
s <- StackMachine Builder SimpleHtml SimpleHtml
forall output style.
Monoid output =>
StackMachine output style style
unsafePopStyle
        Builder -> StackMachine Builder SimpleHtml ()
forall output style. output -> StackMachine output style ()
writeOutput ((Builder, Builder) -> Builder
forall a b. (a, b) -> b
snd (SimpleHtml -> (Builder, Builder)
htmlTag SimpleHtml
s))
        SimpleDocStream SimpleHtml -> StackMachine Builder SimpleHtml ()
renderStackMachine SimpleDocStream SimpleHtml
x

-- | Convert a 'SimpleHtml' annotation to a pair of opening and closing tags.
-- This is where the translation of style to raw output happens.
htmlTag :: SimpleHtml -> (TLB.Builder, TLB.Builder)
htmlTag :: SimpleHtml -> (Builder, Builder)
htmlTag = \SimpleHtml
sh -> case SimpleHtml
sh of
    SimpleHtml
Bold      -> (Builder
"<strong>", Builder
"</strong>")
    SimpleHtml
Italics   -> (Builder
"<em>", Builder
"</em>")
    Color Color
c   -> (Builder
"<span style=\"color: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Color -> Builder
hexCode Color
c Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\">", Builder
"</span>")
    SimpleHtml
Paragraph -> (Builder
"<p>", Builder
"</p>")
    SimpleHtml
Headline  -> (Builder
"<h1>", Builder
"</h1>")
  where
    hexCode :: Color -> TLB.Builder
    hexCode :: Color -> Builder
hexCode = \Color
c -> case Color
c of
        Color
Red   -> Builder
"#f00"
        Color
Green -> Builder
"#0f0"
        Color
Blue  -> Builder
"#00f"

-- | We can now wrap our stack machine definition from 'renderStackMachine' in a
-- nicer interface; on successful conversion, we run the builder to give us the
-- final 'TL.Text', and before we do that we check that the style stack is empty
-- (i.e. there are no unmatched style applications) after the machine is run.
--
-- This function does only a bit of plumbing around 'renderStackMachine', and is
-- the main API function of a stack machine renderer. The tree renderer
-- equivalent to this is
-- 'Prettyprinter.Render.Tutorials.TreeRenderingTutorial.render'.
render :: SimpleDocStream SimpleHtml -> TL.Text
render :: SimpleDocStream SimpleHtml -> Text
render SimpleDocStream SimpleHtml
doc
  = let (Builder
resultBuilder, [SimpleHtml]
remainingStyles) = [SimpleHtml]
-> StackMachine Builder SimpleHtml () -> (Builder, [SimpleHtml])
forall styles output a.
[styles] -> StackMachine output styles a -> (output, [styles])
execStackMachine [] (SimpleDocStream SimpleHtml -> StackMachine Builder SimpleHtml ()
renderStackMachine SimpleDocStream SimpleHtml
doc)
    in if [SimpleHtml] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SimpleHtml]
remainingStyles
        then Builder -> Text
TLB.toLazyText Builder
resultBuilder
        else [Char] -> Text
forall a. HasCallStack => [Char] -> a
error ([Char]
"There are "
                    [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show ([SimpleHtml] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SimpleHtml]
remainingStyles)
                    [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" unpaired styles! Please report this as a bug.")

-- * Example invocation
--
-- $standalone-text
--
-- We can now render an example document using our definitions:
--
-- >>> :set -XOverloadedStrings
-- >>> import qualified Data.Text.Lazy.IO as TL
-- >>> :{
-- >>> let go = TL.putStrLn . render . layoutPretty defaultLayoutOptions
-- >>> in go (vsep
-- >>>     [ headline "Example document"
-- >>>     , paragraph ("This is a" <+> color Red "paragraph" <> comma)
-- >>>     , paragraph ("and" <+> bold "this text is bold.")
-- >>>     ])
-- >>> :}
-- <h1>Example document</h1>
-- <p>This is a <span style="color: #f00">paragraph</span>,</p>
-- <p>and <strong>this text is bold.</strong></p>