    {-# 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 Data.Text.Prettyprint.Doc.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 Data.Text.Prettyprint.Doc.Internal
    import Data.Text.Prettyprint.Doc.Render.Util.Panic

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

    -- $setup
    --
    -- (Definitions for the doctests)
    --
    -- >>> import Data.Text.Prettyprint.Doc 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 :: Text -> out
    text push :: ann -> out
    push pop :: ann -> out
    pop = [ann] -> SimpleDocStream ann -> out
    go []
      where
        go :: [ann] -> SimpleDocStream ann -> out
    go _           SFail               = out
    forall void. void
    panicUncaughtFail
        go []          SEmpty              = out
    forall a. Monoid a => a
    mempty
        go (_:_)       SEmpty              = out
    forall void. void
    panicInputNotFullyConsumed
        go stack :: [ann]
    stack       (SChar c :: Char
    c rest :: 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 stack :: [ann]
    stack       (SText _l :: Int
    _l t :: Text
    t rest :: 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 stack :: [ann]
    stack       (SLine i :: Int
    i rest :: SimpleDocStream ann
    rest)      = Text -> out
    text (Char -> Text
    T.singleton '\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 stack :: [ann]
    stack       (SAnnPush ann :: ann
    ann rest :: 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 :: [ann]
    stack) (SAnnPop rest :: 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 :: Text -> f out
    text push :: ann -> f out
    push pop :: ann -> f out
    pop = [ann] -> SimpleDocStream ann -> f out
    go []
      where
        go :: [ann] -> SimpleDocStream ann -> f out
    go _           SFail               = f out
    forall void. void
    panicUncaughtFail
        go []          SEmpty              = out -> f out
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure out
    forall a. Monoid a => a
    mempty
        go (_:_)       SEmpty              = f out
    forall void. void
    panicInputNotFullyConsumed
        go stack :: [ann]
    stack       (SChar c :: Char
    c rest :: 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 stack :: [ann]
    stack       (SText _l :: Int
    _l t :: Text
    t rest :: 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 stack :: [ann]
    stack       (SLine i :: Int
    i rest :: SimpleDocStream ann
    rest)      = Text -> f out
    text (Char -> Text
    T.singleton '\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 stack :: [ann]
    stack       (SAnnPush ann :: ann
    ann rest :: 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 :: [ann]
    stack) (SAnnPop rest :: 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 f :: a -> b
    f (StackMachine r :: [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 (\s :: [style]
    s ->
            let (x1 :: a
    x1, w1 :: output
    w1, s1 :: [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 x :: a
    x = ([style] -> (a, output, [style])) -> StackMachine output style a
    forall output style a.
    ([style] -> (a, output, [style])) -> StackMachine output style a
    StackMachine (\s :: [style]
    s -> (a
    x, output
    forall a. Monoid a => a
    mempty, [style]
    s))
        StackMachine f :: [style] -> (a -> b, output, [style])
    f <*> :: StackMachine output style (a -> b)
    -> StackMachine output style a -> StackMachine output style b
    <*> StackMachine x :: [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 (\s :: [style]
    s ->
            let (f1 :: a -> b
    f1, w1 :: output
    w1, s1 :: [style]
    s1) = [style] -> (a -> b, output, [style])
    f [style]
    s
                (x2 :: a
    x2, w2 :: output
    w2, s2 :: [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 r :: [style] -> (a, output, [style])
    r >>= :: StackMachine output style a
    -> (a -> StackMachine output style b)
    -> StackMachine output style b
    >>= f :: 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 (\s :: [style]
    s ->
            let (x1 :: a
    x1, w1 :: output
    w1, s1 :: [style]
    s1) = [style] -> (a, output, [style])
    r [style]
    s
                StackMachine r1 :: [style] -> (b, output, [style])
    r1 = a -> StackMachine output style b
    f a
    x1
                (x2 :: b
    x2, w2 :: output
    w2, s2 :: [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 = ([style] -> ((), output, [style])) -> StackMachine output style ()
    forall output style a.
    ([style] -> (a, output, [style])) -> StackMachine output style a
    StackMachine (\styles :: [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 (\stack :: [style]
    stack -> case [style]
    stack of
        x :: style
    x:xs :: [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 (\styles :: [style]
    styles -> case [style]
    styles of
        x :: style
    x:_ -> (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 w :: output
    w = ([style] -> ((), output, [style])) -> StackMachine output style ()
    forall output style a.
    ([style] -> (a, output, [style])) -> StackMachine output style a
    StackMachine (\styles :: [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]
    styles (StackMachine r :: [styles] -> (a, output, [styles])
    r) = let (_, w :: output
    w, s :: [styles]
    s) = [styles] -> (a, output, [styles])
    r [styles]
    styles in (output
    w, [styles]
    s)