{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE CPP               #-}

#include "version-compatibility-macros.h"

-- | Definitions to write renderers based on looking at a 'SimpleDocStream' as
-- an instruction tape for a stack machine: text is written, annotations are
-- added (pushed) and later removed (popped).
module Prettyprinter.Render.Util.StackMachine (

    -- * Simple, pre-defined stack machines
    --
    -- | These cover most basic use cases where there is not too much special
    -- logic, and all that’s important is how to render text, and how to
    -- add/remove an annotation.
    renderSimplyDecorated,
    renderSimplyDecoratedA,

    -- * General stack machine
    --
    -- | These definitions allow defining a full-blown stack machine renderer,
    -- allowing for arbitrary peeking, popping and what not.
    StackMachine,
    execStackMachine,

    pushStyle,
    unsafePopStyle,
    unsafePeekStyle,
    writeOutput,
) where



import           Control.Applicative
import           Data.Text           (Text)
import qualified Data.Text           as T

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

#if !(SEMIGROUP_MONOID_SUPERCLASS)
import Data.Monoid
#endif


-- $setup
--
-- (Definitions for the doctests)
--
-- >>> import Prettyprinter hiding ((<>))
-- >>> import qualified Data.Text.IO as T



-- | Simplest possible stack-based renderer.
--
-- For example, here is a document annotated with @()@, and the behaviour is to
-- write »>>>« at the beginning, and »<<<« at the end of the annotated region:
--
-- >>> let doc = "hello" <+> annotate () "world" <> "!"
-- >>> let sdoc = layoutPretty defaultLayoutOptions doc
-- >>> T.putStrLn (renderSimplyDecorated id (\() -> ">>>") (\() -> "<<<") sdoc)
-- hello >>>world<<<!
--
-- The monoid will be concatenated in a /right associative/ fashion.
renderSimplyDecorated
    :: Monoid out
    => (Text -> out) -- ^ Render plain 'Text'
    -> (ann -> out)  -- ^ How to render an annotation
    -> (ann -> out)  -- ^ How to render the removed annotation
    -> SimpleDocStream ann
    -> out
renderSimplyDecorated :: (Text -> out)
-> (ann -> out) -> (ann -> out) -> SimpleDocStream ann -> out
renderSimplyDecorated Text -> out
text ann -> out
push ann -> out
pop = [ann] -> SimpleDocStream ann -> out
go []
  where
    go :: [ann] -> SimpleDocStream ann -> out
go [ann]
_           SimpleDocStream ann
SFail               = out
forall void. void
panicUncaughtFail
    go []          SimpleDocStream ann
SEmpty              = out
forall a. Monoid a => a
mempty
    go (ann
_:[ann]
_)       SimpleDocStream ann
SEmpty              = out
forall void. void
panicInputNotFullyConsumed
    go [ann]
stack       (SChar Char
c SimpleDocStream ann
rest)      = Text -> out
text (Char -> Text
T.singleton Char
c) out -> out -> out
forall a. Semigroup a => a -> a -> a
<> [ann] -> SimpleDocStream ann -> out
go [ann]
stack SimpleDocStream ann
rest
    go [ann]
stack       (SText Int
_l Text
t SimpleDocStream ann
rest)   = Text -> out
text Text
t out -> out -> out
forall a. Semigroup a => a -> a -> a
<> [ann] -> SimpleDocStream ann -> out
go [ann]
stack SimpleDocStream ann
rest
    go [ann]
stack       (SLine Int
i SimpleDocStream ann
rest)      = Text -> out
text (Char -> Text
T.singleton Char
'\n') out -> out -> out
forall a. Semigroup a => a -> a -> a
<> Text -> out
text (Int -> Text
textSpaces Int
i) out -> out -> out
forall a. Semigroup a => a -> a -> a
<> [ann] -> SimpleDocStream ann -> out
go [ann]
stack SimpleDocStream ann
rest
    go [ann]
stack       (SAnnPush ann
ann SimpleDocStream ann
rest) = ann -> out
push ann
ann out -> out -> out
forall a. Semigroup a => a -> a -> a
<> [ann] -> SimpleDocStream ann -> out
go (ann
ann ann -> [ann] -> [ann]
forall a. a -> [a] -> [a]
: [ann]
stack) SimpleDocStream ann
rest
    go (ann
ann:[ann]
stack) (SAnnPop SimpleDocStream ann
rest)      = ann -> out
pop ann
ann out -> out -> out
forall a. Semigroup a => a -> a -> a
<> [ann] -> SimpleDocStream ann -> out
go [ann]
stack SimpleDocStream ann
rest
    go []          SAnnPop{}           = out
forall void. void
panicUnpairedPop
{-# INLINE renderSimplyDecorated #-}

-- | Version of 'renderSimplyDecoratedA' that allows for 'Applicative' effects.
renderSimplyDecoratedA
    :: (Applicative f, Monoid out)
    => (Text -> f out) -- ^ Render plain 'Text'
    -> (ann -> f out)  -- ^ How to render an annotation
    -> (ann -> f out)  -- ^ How to render the removed annotation
    -> SimpleDocStream ann
    -> f out
renderSimplyDecoratedA :: (Text -> f out)
-> (ann -> f out) -> (ann -> f out) -> SimpleDocStream ann -> f out
renderSimplyDecoratedA Text -> f out
text ann -> f out
push ann -> f out
pop = [ann] -> SimpleDocStream ann -> f out
go []
  where
    go :: [ann] -> SimpleDocStream ann -> f out
go [ann]
_           SimpleDocStream ann
SFail               = f out
forall void. void
panicUncaughtFail
    go []          SimpleDocStream ann
SEmpty              = out -> f out
forall (f :: * -> *) a. Applicative f => a -> f a
pure out
forall a. Monoid a => a
mempty
    go (ann
_:[ann]
_)       SimpleDocStream ann
SEmpty              = f out
forall void. void
panicInputNotFullyConsumed
    go [ann]
stack       (SChar Char
c SimpleDocStream ann
rest)      = Text -> f out
text (Char -> Text
T.singleton Char
c) f out -> f out -> f out
<++> [ann] -> SimpleDocStream ann -> f out
go [ann]
stack SimpleDocStream ann
rest
    go [ann]
stack       (SText Int
_l Text
t SimpleDocStream ann
rest)   = Text -> f out
text Text
t f out -> f out -> f out
<++> [ann] -> SimpleDocStream ann -> f out
go [ann]
stack SimpleDocStream ann
rest
    go [ann]
stack       (SLine Int
i SimpleDocStream ann
rest)      = Text -> f out
text (Char -> Text
T.singleton Char
'\n') f out -> f out -> f out
<++> Text -> f out
text (Int -> Text
textSpaces Int
i) f out -> f out -> f out
<++> [ann] -> SimpleDocStream ann -> f out
go [ann]
stack SimpleDocStream ann
rest
    go [ann]
stack       (SAnnPush ann
ann SimpleDocStream ann
rest) = ann -> f out
push ann
ann f out -> f out -> f out
<++> [ann] -> SimpleDocStream ann -> f out
go (ann
ann ann -> [ann] -> [ann]
forall a. a -> [a] -> [a]
: [ann]
stack) SimpleDocStream ann
rest
    go (ann
ann:[ann]
stack) (SAnnPop SimpleDocStream ann
rest)      = ann -> f out
pop ann
ann f out -> f out -> f out
<++> [ann] -> SimpleDocStream ann -> f out
go [ann]
stack SimpleDocStream ann
rest
    go []          SAnnPop{}           = f out
forall void. void
panicUnpairedPop

    <++> :: f out -> f out -> f out
(<++>) = (out -> out -> out) -> f out -> f out -> f out
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 out -> out -> out
forall a. Monoid a => a -> a -> a
mappend
{-# INLINE renderSimplyDecoratedA #-}



-- | @WriterT output StateT [style] a@, but with a strict Writer value.
--
-- The @output@ type is used to append data chunks to, the @style@ is the member
-- of a stack of styles to model nested styles with.
newtype StackMachine output style a = StackMachine ([style] -> (a, output, [style]))
{-# DEPRECATED StackMachine "Writing your own stack machine is probably more efficient and customizable; also consider using »renderSimplyDecorated(A)« instead" #-}

instance Functor (StackMachine output style) where
    fmap :: (a -> b)
-> StackMachine output style a -> StackMachine output style b
fmap a -> b
f (StackMachine [style] -> (a, output, [style])
r) = ([style] -> (b, output, [style])) -> StackMachine output style b
forall output style a.
([style] -> (a, output, [style])) -> StackMachine output style a
StackMachine (\[style]
s ->
        let (a
x1, output
w1, [style]
s1) = [style] -> (a, output, [style])
r [style]
s
        in (a -> b
f a
x1, output
w1, [style]
s1))

instance Monoid output => Applicative (StackMachine output style) where
    pure :: a -> StackMachine output style a
pure a
x = ([style] -> (a, output, [style])) -> StackMachine output style a
forall output style a.
([style] -> (a, output, [style])) -> StackMachine output style a
StackMachine (\[style]
s -> (a
x, output
forall a. Monoid a => a
mempty, [style]
s))
    StackMachine [style] -> (a -> b, output, [style])
f <*> :: StackMachine output style (a -> b)
-> StackMachine output style a -> StackMachine output style b
<*> StackMachine [style] -> (a, output, [style])
x = ([style] -> (b, output, [style])) -> StackMachine output style b
forall output style a.
([style] -> (a, output, [style])) -> StackMachine output style a
StackMachine (\[style]
s ->
        let (a -> b
f1, output
w1, [style]
s1) = [style] -> (a -> b, output, [style])
f [style]
s
            (a
x2, output
w2, [style]
s2) = [style] -> (a, output, [style])
x [style]
s1
            !w12 :: output
w12 = output
w1 output -> output -> output
forall a. Semigroup a => a -> a -> a
<> output
w2
        in (a -> b
f1 a
x2, output
w12, [style]
s2))

instance Monoid output => Monad (StackMachine output style) where
#if !(APPLICATIVE_MONAD)
    return = pure
#endif
    StackMachine [style] -> (a, output, [style])
r >>= :: StackMachine output style a
-> (a -> StackMachine output style b)
-> StackMachine output style b
>>= a -> StackMachine output style b
f = ([style] -> (b, output, [style])) -> StackMachine output style b
forall output style a.
([style] -> (a, output, [style])) -> StackMachine output style a
StackMachine (\[style]
s ->
        let (a
x1, output
w1, [style]
s1) = [style] -> (a, output, [style])
r [style]
s
            StackMachine [style] -> (b, output, [style])
r1 = a -> StackMachine output style b
f a
x1
            (b
x2, output
w2, [style]
s2) = [style] -> (b, output, [style])
r1 [style]
s1
            !w12 :: output
w12 = output
w1 output -> output -> output
forall a. Semigroup a => a -> a -> a
<> output
w2
        in (b
x2, output
w12, [style]
s2))

-- | Add a new style to the style stack.
pushStyle :: Monoid output => style -> StackMachine output style ()
pushStyle :: style -> StackMachine output style ()
pushStyle style
style = ([style] -> ((), output, [style])) -> StackMachine output style ()
forall output style a.
([style] -> (a, output, [style])) -> StackMachine output style a
StackMachine (\[style]
styles -> ((), output
forall a. Monoid a => a
mempty, style
style style -> [style] -> [style]
forall a. a -> [a] -> [a]
: [style]
styles))

-- | Get the topmost style.
--
-- If the stack is empty, this raises an 'error'.
unsafePopStyle :: Monoid output => StackMachine output style style
unsafePopStyle :: StackMachine output style style
unsafePopStyle = ([style] -> (style, output, [style]))
-> StackMachine output style style
forall output style a.
([style] -> (a, output, [style])) -> StackMachine output style a
StackMachine (\[style]
stack -> case [style]
stack of
    style
x:[style]
xs -> (style
x, output
forall a. Monoid a => a
mempty, [style]
xs)
    [] -> (style, output, [style])
forall void. void
panicPoppedEmpty )

-- | View the topmost style, but do not modify the stack.
--
-- If the stack is empty, this raises an 'error'.
unsafePeekStyle :: Monoid output => StackMachine output style style
unsafePeekStyle :: StackMachine output style style
unsafePeekStyle = ([style] -> (style, output, [style]))
-> StackMachine output style style
forall output style a.
([style] -> (a, output, [style])) -> StackMachine output style a
StackMachine (\[style]
styles -> case [style]
styles of
    style
x:[style]
_ -> (style
x, output
forall a. Monoid a => a
mempty, [style]
styles)
    [] -> (style, output, [style])
forall void. void
panicPeekedEmpty )

-- | Append a value to the output end.
writeOutput :: output -> StackMachine output style ()
writeOutput :: output -> StackMachine output style ()
writeOutput output
w = ([style] -> ((), output, [style])) -> StackMachine output style ()
forall output style a.
([style] -> (a, output, [style])) -> StackMachine output style a
StackMachine (\[style]
styles -> ((), output
w, [style]
styles))

-- | Run the renderer and retrive the writing end
execStackMachine :: [styles] -> StackMachine output styles a -> (output, [styles])
execStackMachine :: [styles] -> StackMachine output styles a -> (output, [styles])
execStackMachine [styles]
styles (StackMachine [styles] -> (a, output, [styles])
r) = let (a
_, output
w, [styles]
s) = [styles] -> (a, output, [styles])
r [styles]
styles in (output
w, [styles]
s)