{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
#include "version-compatibility-macros.h"
module Data.Text.Prettyprint.Doc.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 Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Internal
import Data.Text.Prettyprint.Doc.Render.Util.Panic
import Data.Text.Prettyprint.Doc.Render.Util.StackMachine
#if !(APPLICATIVE_MONAD)
import Control.Applicative
#endif
data SimpleHtml = Bold | Italics | Color Color | Paragraph | Headline
data Color = Red | Green | Blue
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 c :: Color
c = SimpleHtml -> Doc SimpleHtml -> Doc SimpleHtml
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> SimpleHtml
Color Color
c)
renderStackMachine :: SimpleDocStream SimpleHtml -> StackMachine TLB.Builder SimpleHtml ()
renderStackMachine :: SimpleDocStream SimpleHtml -> StackMachine Builder SimpleHtml ()
renderStackMachine = \sds :: SimpleDocStream SimpleHtml
sds -> case SimpleDocStream SimpleHtml
sds of
SFail -> StackMachine Builder SimpleHtml ()
forall void. void
panicUncaughtFail
SEmpty -> () -> StackMachine Builder SimpleHtml ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
SChar c :: Char
c x :: 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 _l :: Int
_l t :: Text
t x :: 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 i :: Int
i x :: SimpleDocStream SimpleHtml
x -> do
Builder -> StackMachine Builder SimpleHtml ()
forall output style. output -> StackMachine output style ()
writeOutput (Char -> Builder
TLB.singleton '\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 s :: SimpleHtml
s x :: 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 x :: 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
htmlTag :: SimpleHtml -> (TLB.Builder, TLB.Builder)
htmlTag :: SimpleHtml -> (Builder, Builder)
htmlTag = \sh :: SimpleHtml
sh -> case SimpleHtml
sh of
Bold -> ("<strong>", "</strong>")
Italics -> ("<em>", "</em>")
Color c :: Color
c -> ("<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
<> "\">", "</span>")
Paragraph -> ("<p>", "</p>")
Headline -> ("<h1>", "</h1>")
where
hexCode :: Color -> TLB.Builder
hexCode :: Color -> Builder
hexCode = \c :: Color
c -> case Color
c of
Red -> "#f00"
Green -> "#0f0"
Blue -> "#00f"
render :: SimpleDocStream SimpleHtml -> TL.Text
render :: SimpleDocStream SimpleHtml -> Text
render doc :: SimpleDocStream SimpleHtml
doc
= let (resultBuilder :: Builder
resultBuilder, remainingStyles :: [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 ("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
<> " unpaired styles! Please report this as a bug.")