    {-# LANGUAGE BangPatterns      #-}
    {-# LANGUAGE CPP               #-}
    {-# LANGUAGE LambdaCase        #-}
    {-# LANGUAGE OverloadedStrings #-}

    #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.Monoid
    import           Data.Text           (Text)
    import qualified Data.Text           as T

    import Data.Text.Prettyprint.Doc                   (SimpleDocStream (..))
    import Data.Text.Prettyprint.Doc.Render.Util.Panic

    -- $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 push pop = go []
      where
        go _           SFail               = panicUncaughtFail
        go []          SEmpty              = mempty
        go (_:_)       SEmpty              = panicInputNotFullyConsumed
        go stack       (SChar c rest)      = text (T.singleton c) <> go stack rest
        go stack       (SText _l t rest)   = text t <> go stack rest
        go stack       (SLine i rest)      = text (T.singleton '\n') <> text (T.replicate i " ") <> go stack rest
        go stack       (SAnnPush ann rest) = push ann <> go (ann : stack) rest
        go (ann:stack) (SAnnPop rest)      = pop ann <> go stack rest
        go []          SAnnPop{}           = 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 push pop = go []
      where
        go _           SFail               = panicUncaughtFail
        go []          SEmpty              = pure mempty
        go (_:_)       SEmpty              = panicInputNotFullyConsumed
        go stack       (SChar c rest)      = text (T.singleton c) <++> go stack rest
        go stack       (SText _l t rest)   = text t <++> go stack rest
        go stack       (SLine i rest)      = text (T.singleton '\n') <++> text (T.replicate i " ") <++> go stack rest
        go stack       (SAnnPush ann rest) = push ann <++> go (ann : stack) rest
        go (ann:stack) (SAnnPop rest)      = pop ann <++> go stack rest
        go []          SAnnPop{}           = panicUnpairedPop

        (<++>) = liftA2 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 f (StackMachine r) = StackMachine (\s ->
            let (x1, w1, s1) = r s
            in (f x1, w1, s1))

    instance Monoid output => Applicative (StackMachine output style) where
        pure x = StackMachine (\s -> (x, mempty, s))
        StackMachine f <*> StackMachine x = StackMachine (\s ->
            let (f1, w1, s1) = f s
                (x2, w2, s2) = x s1
                !w12 = w1 <> w2
            in (f1 x2, w12, s2))

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

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

    -- | Get the topmost style.
    --
    -- If the stack is empty, this raises an 'error'.
    unsafePopStyle :: Monoid output => StackMachine output style style
    unsafePopStyle = StackMachine (\case
        x:xs -> (x, mempty, xs)
        [] -> 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 (\styles -> case styles of
        x:_ -> (x, mempty, styles)
        [] -> panicPeekedEmpty )

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

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