{-# LANGUAGE CPP                #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric      #-}

#include "version-compatibility-macros.h"

-- | Conversion of the linked-list-like 'SimpleDocStream' to a tree-like
-- 'SimpleDocTree'.
module Prettyprinter.Render.Util.SimpleDocTree (

    -- * Type and conversion
    SimpleDocTree(..),
    treeForm,

    -- * Manipulating annotations
    unAnnotateST,
    reAnnotateST,
    alterAnnotationsST,

    -- * Common use case shortcut definitions
    renderSimplyDecorated,
    renderSimplyDecoratedA,
) where



import           Control.Applicative
import           Data.Text           (Text)
import qualified Data.Text           as T
import           Data.Typeable       (Typeable)
import           GHC.Generics

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

import qualified Control.Monad.Fail as Fail

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

#if !(FOLDABLE_TRAVERSABLE_IN_PRELUDE)
import Data.Foldable    (Foldable (..))
import Data.Traversable (Traversable (..))
#endif

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



-- | Simplest possible tree-based renderer.
--
-- For example, here is a document annotated with @()@, and the behaviour is to
-- surround annotated regions with »>>>« and »<<<«:
--
-- >>> let doc = "hello" <+> annotate () "world" <> "!"
-- >>> let stdoc = treeForm (layoutPretty defaultLayoutOptions doc)
-- >>> T.putStrLn (renderSimplyDecorated id (\() x -> ">>>" <> x <> "<<<") stdoc)
-- hello >>>world<<<!
renderSimplyDecorated
    :: Monoid out
    => (Text -> out)       -- ^ Render plain 'Text'
    -> (ann -> out -> out) -- ^ How to modify an element with an annotation
    -> SimpleDocTree ann
    -> out
renderSimplyDecorated :: (Text -> out) -> (ann -> out -> out) -> SimpleDocTree ann -> out
renderSimplyDecorated Text -> out
text ann -> out -> out
renderAnn = SimpleDocTree ann -> out
go
  where
    go :: SimpleDocTree ann -> out
go = \SimpleDocTree ann
sdt -> case SimpleDocTree ann
sdt of
        SimpleDocTree ann
STEmpty        -> out
forall a. Monoid a => a
mempty
        STChar Char
c       -> Text -> out
text (Char -> Text
T.singleton Char
c)
        STText Int
_ Text
t     -> Text -> out
text Text
t
        STLine Int
i       -> Text -> out
text (Char -> Text
T.singleton Char
'\n') out -> out -> out
forall a. Monoid a => a -> a -> a
`mappend` Text -> out
text (Int -> Text
textSpaces Int
i)
        STAnn ann
ann SimpleDocTree ann
rest -> ann -> out -> out
renderAnn ann
ann (SimpleDocTree ann -> out
go SimpleDocTree ann
rest)
        STConcat [SimpleDocTree ann]
xs    -> (SimpleDocTree ann -> out) -> [SimpleDocTree ann] -> out
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap SimpleDocTree ann -> out
go [SimpleDocTree ann]
xs
{-# INLINE renderSimplyDecorated #-}

-- | Version of 'renderSimplyDecoratedA' that allows for 'Applicative' effects.
renderSimplyDecoratedA
    :: (Applicative f, Monoid out)
    => (Text -> f out)         -- ^ Render plain 'Text'
    -> (ann -> f out -> f out) -- ^ How to modify an element with an annotation
    -> SimpleDocTree ann
    -> f out
renderSimplyDecoratedA :: (Text -> f out)
-> (ann -> f out -> f out) -> SimpleDocTree ann -> f out
renderSimplyDecoratedA Text -> f out
text ann -> f out -> f out
renderAnn = SimpleDocTree ann -> f out
go
  where
    go :: SimpleDocTree ann -> f out
go = \SimpleDocTree ann
sdt -> case SimpleDocTree ann
sdt of
        SimpleDocTree ann
STEmpty        -> out -> f out
forall (f :: * -> *) a. Applicative f => a -> f a
pure out
forall a. Monoid a => a
mempty
        STChar Char
c       -> Text -> f out
text (Char -> Text
T.singleton Char
c)
        STText Int
_ Text
t     -> Text -> f out
text Text
t
        STLine Int
i       -> Text -> f out
text (Char -> Text -> Text
T.cons Char
'\n' (Int -> Text
textSpaces Int
i))
        STAnn ann
ann SimpleDocTree ann
rest -> ann -> f out -> f out
renderAnn ann
ann (SimpleDocTree ann -> f out
go SimpleDocTree ann
rest)
        STConcat [SimpleDocTree ann]
xs    -> ([out] -> out) -> f [out] -> f out
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [out] -> out
forall a. Monoid a => [a] -> a
mconcat ((SimpleDocTree ann -> f out) -> [SimpleDocTree ann] -> f [out]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse SimpleDocTree ann -> f out
go [SimpleDocTree ann]
xs)
{-# INLINE renderSimplyDecoratedA #-}



-- | A type for parsers of unique results. Token stream »s«, results »a«.
--
-- Hand-written to avoid a dependency on a parser lib.
newtype UniqueParser s a = UniqueParser { UniqueParser s a -> s -> Maybe (a, s)
runParser :: s -> Maybe (a, s) }
  deriving Typeable

instance Functor (UniqueParser s) where
    fmap :: (a -> b) -> UniqueParser s a -> UniqueParser s b
fmap a -> b
f (UniqueParser s -> Maybe (a, s)
mx) = (s -> Maybe (b, s)) -> UniqueParser s b
forall s a. (s -> Maybe (a, s)) -> UniqueParser s a
UniqueParser (\s
s ->
        ((a, s) -> (b, s)) -> Maybe (a, s) -> Maybe (b, s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(a
x,s
s') -> (a -> b
f a
x, s
s')) (s -> Maybe (a, s)
mx s
s))

instance Applicative (UniqueParser s) where
    pure :: a -> UniqueParser s a
pure a
x = (s -> Maybe (a, s)) -> UniqueParser s a
forall s a. (s -> Maybe (a, s)) -> UniqueParser s a
UniqueParser (\s
rest -> (a, s) -> Maybe (a, s)
forall a. a -> Maybe a
Just (a
x, s
rest))
    UniqueParser s -> Maybe (a -> b, s)
mf <*> :: UniqueParser s (a -> b) -> UniqueParser s a -> UniqueParser s b
<*> UniqueParser s -> Maybe (a, s)
mx = (s -> Maybe (b, s)) -> UniqueParser s b
forall s a. (s -> Maybe (a, s)) -> UniqueParser s a
UniqueParser (\s
s -> do
        (a -> b
f, s
s') <- s -> Maybe (a -> b, s)
mf s
s
        (a
x, s
s'') <- s -> Maybe (a, s)
mx s
s'
        (b, s) -> Maybe (b, s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> b
f a
x, s
s'') )

instance Monad (UniqueParser s) where
    UniqueParser s -> Maybe (a, s)
p >>= :: UniqueParser s a -> (a -> UniqueParser s b) -> UniqueParser s b
>>= a -> UniqueParser s b
f = (s -> Maybe (b, s)) -> UniqueParser s b
forall s a. (s -> Maybe (a, s)) -> UniqueParser s a
UniqueParser (\s
s -> do
        (a
a', s
s') <- s -> Maybe (a, s)
p s
s
        let UniqueParser s -> Maybe (b, s)
p' = a -> UniqueParser s b
f a
a'
        s -> Maybe (b, s)
p' s
s' )

#if !(APPLICATIVE_MONAD)
    return = pure
#endif
#if FAIL_IN_MONAD
    fail = Fail.fail
#endif

instance Fail.MonadFail (UniqueParser s) where
    fail :: String -> UniqueParser s a
fail String
_err = UniqueParser s a
forall (f :: * -> *) a. Alternative f => f a
empty

instance Alternative (UniqueParser s) where
    empty :: UniqueParser s a
empty = (s -> Maybe (a, s)) -> UniqueParser s a
forall s a. (s -> Maybe (a, s)) -> UniqueParser s a
UniqueParser (Maybe (a, s) -> s -> Maybe (a, s)
forall a b. a -> b -> a
const Maybe (a, s)
forall (f :: * -> *) a. Alternative f => f a
empty)
    UniqueParser s -> Maybe (a, s)
p <|> :: UniqueParser s a -> UniqueParser s a -> UniqueParser s a
<|> UniqueParser s -> Maybe (a, s)
q = (s -> Maybe (a, s)) -> UniqueParser s a
forall s a. (s -> Maybe (a, s)) -> UniqueParser s a
UniqueParser (\s
s -> s -> Maybe (a, s)
p s
s Maybe (a, s) -> Maybe (a, s) -> Maybe (a, s)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> s -> Maybe (a, s)
q s
s)

data SimpleDocTok ann
    = TokEmpty
    | TokChar Char
    | TokText !Int Text
    | TokLine Int
    | TokAnnPush ann
    | TokAnnPop
    deriving (SimpleDocTok ann -> SimpleDocTok ann -> Bool
(SimpleDocTok ann -> SimpleDocTok ann -> Bool)
-> (SimpleDocTok ann -> SimpleDocTok ann -> Bool)
-> Eq (SimpleDocTok ann)
forall ann. Eq ann => SimpleDocTok ann -> SimpleDocTok ann -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SimpleDocTok ann -> SimpleDocTok ann -> Bool
$c/= :: forall ann. Eq ann => SimpleDocTok ann -> SimpleDocTok ann -> Bool
== :: SimpleDocTok ann -> SimpleDocTok ann -> Bool
$c== :: forall ann. Eq ann => SimpleDocTok ann -> SimpleDocTok ann -> Bool
Eq, Eq (SimpleDocTok ann)
Eq (SimpleDocTok ann)
-> (SimpleDocTok ann -> SimpleDocTok ann -> Ordering)
-> (SimpleDocTok ann -> SimpleDocTok ann -> Bool)
-> (SimpleDocTok ann -> SimpleDocTok ann -> Bool)
-> (SimpleDocTok ann -> SimpleDocTok ann -> Bool)
-> (SimpleDocTok ann -> SimpleDocTok ann -> Bool)
-> (SimpleDocTok ann -> SimpleDocTok ann -> SimpleDocTok ann)
-> (SimpleDocTok ann -> SimpleDocTok ann -> SimpleDocTok ann)
-> Ord (SimpleDocTok ann)
SimpleDocTok ann -> SimpleDocTok ann -> Bool
SimpleDocTok ann -> SimpleDocTok ann -> Ordering
SimpleDocTok ann -> SimpleDocTok ann -> SimpleDocTok ann
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall ann. Ord ann => Eq (SimpleDocTok ann)
forall ann. Ord ann => SimpleDocTok ann -> SimpleDocTok ann -> Bool
forall ann.
Ord ann =>
SimpleDocTok ann -> SimpleDocTok ann -> Ordering
forall ann.
Ord ann =>
SimpleDocTok ann -> SimpleDocTok ann -> SimpleDocTok ann
min :: SimpleDocTok ann -> SimpleDocTok ann -> SimpleDocTok ann
$cmin :: forall ann.
Ord ann =>
SimpleDocTok ann -> SimpleDocTok ann -> SimpleDocTok ann
max :: SimpleDocTok ann -> SimpleDocTok ann -> SimpleDocTok ann
$cmax :: forall ann.
Ord ann =>
SimpleDocTok ann -> SimpleDocTok ann -> SimpleDocTok ann
>= :: SimpleDocTok ann -> SimpleDocTok ann -> Bool
$c>= :: forall ann. Ord ann => SimpleDocTok ann -> SimpleDocTok ann -> Bool
> :: SimpleDocTok ann -> SimpleDocTok ann -> Bool
$c> :: forall ann. Ord ann => SimpleDocTok ann -> SimpleDocTok ann -> Bool
<= :: SimpleDocTok ann -> SimpleDocTok ann -> Bool
$c<= :: forall ann. Ord ann => SimpleDocTok ann -> SimpleDocTok ann -> Bool
< :: SimpleDocTok ann -> SimpleDocTok ann -> Bool
$c< :: forall ann. Ord ann => SimpleDocTok ann -> SimpleDocTok ann -> Bool
compare :: SimpleDocTok ann -> SimpleDocTok ann -> Ordering
$ccompare :: forall ann.
Ord ann =>
SimpleDocTok ann -> SimpleDocTok ann -> Ordering
$cp1Ord :: forall ann. Ord ann => Eq (SimpleDocTok ann)
Ord, Int -> SimpleDocTok ann -> ShowS
[SimpleDocTok ann] -> ShowS
SimpleDocTok ann -> String
(Int -> SimpleDocTok ann -> ShowS)
-> (SimpleDocTok ann -> String)
-> ([SimpleDocTok ann] -> ShowS)
-> Show (SimpleDocTok ann)
forall ann. Show ann => Int -> SimpleDocTok ann -> ShowS
forall ann. Show ann => [SimpleDocTok ann] -> ShowS
forall ann. Show ann => SimpleDocTok ann -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SimpleDocTok ann] -> ShowS
$cshowList :: forall ann. Show ann => [SimpleDocTok ann] -> ShowS
show :: SimpleDocTok ann -> String
$cshow :: forall ann. Show ann => SimpleDocTok ann -> String
showsPrec :: Int -> SimpleDocTok ann -> ShowS
$cshowsPrec :: forall ann. Show ann => Int -> SimpleDocTok ann -> ShowS
Show, Typeable)

-- | A 'SimpleDocStream' is a linked list of different annotated cons cells
-- ('SText' and then some further 'SimpleDocStream', 'SLine' and then some
-- further 'SimpleDocStream', …). This format is very suitable as a target for a
-- layout engine, but not very useful for rendering to a structured format such
-- as HTML, where we don’t want to do a lookahead until the end of some markup.
-- These formats benefit from a tree-like structure that explicitly marks its
-- contents as annotated. 'SimpleDocTree' is that format.
data SimpleDocTree ann
    = STEmpty
    | STChar Char

    -- | 'Data.Text.length' is /O(n)/, so we cache it in the 'Int' field.
    | STText !Int Text

    -- | @Int@ = indentation level for the (next) line
    | STLine !Int

    -- | Annotate the contained document.
    | STAnn ann (SimpleDocTree ann)

    -- | Horizontal concatenation of multiple documents.
    | STConcat [SimpleDocTree ann]
    deriving (SimpleDocTree ann -> SimpleDocTree ann -> Bool
(SimpleDocTree ann -> SimpleDocTree ann -> Bool)
-> (SimpleDocTree ann -> SimpleDocTree ann -> Bool)
-> Eq (SimpleDocTree ann)
forall ann.
Eq ann =>
SimpleDocTree ann -> SimpleDocTree ann -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SimpleDocTree ann -> SimpleDocTree ann -> Bool
$c/= :: forall ann.
Eq ann =>
SimpleDocTree ann -> SimpleDocTree ann -> Bool
== :: SimpleDocTree ann -> SimpleDocTree ann -> Bool
$c== :: forall ann.
Eq ann =>
SimpleDocTree ann -> SimpleDocTree ann -> Bool
Eq, Eq (SimpleDocTree ann)
Eq (SimpleDocTree ann)
-> (SimpleDocTree ann -> SimpleDocTree ann -> Ordering)
-> (SimpleDocTree ann -> SimpleDocTree ann -> Bool)
-> (SimpleDocTree ann -> SimpleDocTree ann -> Bool)
-> (SimpleDocTree ann -> SimpleDocTree ann -> Bool)
-> (SimpleDocTree ann -> SimpleDocTree ann -> Bool)
-> (SimpleDocTree ann -> SimpleDocTree ann -> SimpleDocTree ann)
-> (SimpleDocTree ann -> SimpleDocTree ann -> SimpleDocTree ann)
-> Ord (SimpleDocTree ann)
SimpleDocTree ann -> SimpleDocTree ann -> Bool
SimpleDocTree ann -> SimpleDocTree ann -> Ordering
SimpleDocTree ann -> SimpleDocTree ann -> SimpleDocTree ann
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall ann. Ord ann => Eq (SimpleDocTree ann)
forall ann.
Ord ann =>
SimpleDocTree ann -> SimpleDocTree ann -> Bool
forall ann.
Ord ann =>
SimpleDocTree ann -> SimpleDocTree ann -> Ordering
forall ann.
Ord ann =>
SimpleDocTree ann -> SimpleDocTree ann -> SimpleDocTree ann
min :: SimpleDocTree ann -> SimpleDocTree ann -> SimpleDocTree ann
$cmin :: forall ann.
Ord ann =>
SimpleDocTree ann -> SimpleDocTree ann -> SimpleDocTree ann
max :: SimpleDocTree ann -> SimpleDocTree ann -> SimpleDocTree ann
$cmax :: forall ann.
Ord ann =>
SimpleDocTree ann -> SimpleDocTree ann -> SimpleDocTree ann
>= :: SimpleDocTree ann -> SimpleDocTree ann -> Bool
$c>= :: forall ann.
Ord ann =>
SimpleDocTree ann -> SimpleDocTree ann -> Bool
> :: SimpleDocTree ann -> SimpleDocTree ann -> Bool
$c> :: forall ann.
Ord ann =>
SimpleDocTree ann -> SimpleDocTree ann -> Bool
<= :: SimpleDocTree ann -> SimpleDocTree ann -> Bool
$c<= :: forall ann.
Ord ann =>
SimpleDocTree ann -> SimpleDocTree ann -> Bool
< :: SimpleDocTree ann -> SimpleDocTree ann -> Bool
$c< :: forall ann.
Ord ann =>
SimpleDocTree ann -> SimpleDocTree ann -> Bool
compare :: SimpleDocTree ann -> SimpleDocTree ann -> Ordering
$ccompare :: forall ann.
Ord ann =>
SimpleDocTree ann -> SimpleDocTree ann -> Ordering
$cp1Ord :: forall ann. Ord ann => Eq (SimpleDocTree ann)
Ord, Int -> SimpleDocTree ann -> ShowS
[SimpleDocTree ann] -> ShowS
SimpleDocTree ann -> String
(Int -> SimpleDocTree ann -> ShowS)
-> (SimpleDocTree ann -> String)
-> ([SimpleDocTree ann] -> ShowS)
-> Show (SimpleDocTree ann)
forall ann. Show ann => Int -> SimpleDocTree ann -> ShowS
forall ann. Show ann => [SimpleDocTree ann] -> ShowS
forall ann. Show ann => SimpleDocTree ann -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SimpleDocTree ann] -> ShowS
$cshowList :: forall ann. Show ann => [SimpleDocTree ann] -> ShowS
show :: SimpleDocTree ann -> String
$cshow :: forall ann. Show ann => SimpleDocTree ann -> String
showsPrec :: Int -> SimpleDocTree ann -> ShowS
$cshowsPrec :: forall ann. Show ann => Int -> SimpleDocTree ann -> ShowS
Show, (forall x. SimpleDocTree ann -> Rep (SimpleDocTree ann) x)
-> (forall x. Rep (SimpleDocTree ann) x -> SimpleDocTree ann)
-> Generic (SimpleDocTree ann)
forall x. Rep (SimpleDocTree ann) x -> SimpleDocTree ann
forall x. SimpleDocTree ann -> Rep (SimpleDocTree ann) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall ann x. Rep (SimpleDocTree ann) x -> SimpleDocTree ann
forall ann x. SimpleDocTree ann -> Rep (SimpleDocTree ann) x
$cto :: forall ann x. Rep (SimpleDocTree ann) x -> SimpleDocTree ann
$cfrom :: forall ann x. SimpleDocTree ann -> Rep (SimpleDocTree ann) x
Generic, Typeable)

-- | Alter the document’s annotations.
--
-- This instance makes 'SimpleDocTree' more flexible (because it can be used in
-- 'Functor'-polymorphic values), but @'fmap'@ is much less readable compared to
-- using @'reAnnotateST'@ in code that only works for @'SimpleDocTree'@ anyway.
-- Consider using the latter when the type does not matter.
instance Functor SimpleDocTree where
    fmap :: (a -> b) -> SimpleDocTree a -> SimpleDocTree b
fmap = (a -> b) -> SimpleDocTree a -> SimpleDocTree b
forall a b. (a -> b) -> SimpleDocTree a -> SimpleDocTree b
reAnnotateST

-- | Get the next token, consuming it in the process.
nextToken :: UniqueParser (SimpleDocStream ann) (SimpleDocTok ann)
nextToken :: UniqueParser (SimpleDocStream ann) (SimpleDocTok ann)
nextToken = (SimpleDocStream ann
 -> Maybe (SimpleDocTok ann, SimpleDocStream ann))
-> UniqueParser (SimpleDocStream ann) (SimpleDocTok ann)
forall s a. (s -> Maybe (a, s)) -> UniqueParser s a
UniqueParser (\SimpleDocStream ann
sds -> case SimpleDocStream ann
sds of
    SimpleDocStream ann
SFail             -> Maybe (SimpleDocTok ann, SimpleDocStream ann)
forall void. void
panicUncaughtFail
    SimpleDocStream ann
SEmpty            -> Maybe (SimpleDocTok ann, SimpleDocStream ann)
forall (f :: * -> *) a. Alternative f => f a
empty
    SChar Char
c SimpleDocStream ann
rest      -> (SimpleDocTok ann, SimpleDocStream ann)
-> Maybe (SimpleDocTok ann, SimpleDocStream ann)
forall a. a -> Maybe a
Just (Char -> SimpleDocTok ann
forall ann. Char -> SimpleDocTok ann
TokChar Char
c      , SimpleDocStream ann
rest)
    SText Int
l Text
t SimpleDocStream ann
rest    -> (SimpleDocTok ann, SimpleDocStream ann)
-> Maybe (SimpleDocTok ann, SimpleDocStream ann)
forall a. a -> Maybe a
Just (Int -> Text -> SimpleDocTok ann
forall ann. Int -> Text -> SimpleDocTok ann
TokText Int
l Text
t    , SimpleDocStream ann
rest)
    SLine Int
i SimpleDocStream ann
rest      -> (SimpleDocTok ann, SimpleDocStream ann)
-> Maybe (SimpleDocTok ann, SimpleDocStream ann)
forall a. a -> Maybe a
Just (Int -> SimpleDocTok ann
forall ann. Int -> SimpleDocTok ann
TokLine Int
i      , SimpleDocStream ann
rest)
    SAnnPush ann
ann SimpleDocStream ann
rest -> (SimpleDocTok ann, SimpleDocStream ann)
-> Maybe (SimpleDocTok ann, SimpleDocStream ann)
forall a. a -> Maybe a
Just (ann -> SimpleDocTok ann
forall ann. ann -> SimpleDocTok ann
TokAnnPush ann
ann , SimpleDocStream ann
rest)
    SAnnPop SimpleDocStream ann
rest      -> (SimpleDocTok ann, SimpleDocStream ann)
-> Maybe (SimpleDocTok ann, SimpleDocStream ann)
forall a. a -> Maybe a
Just (SimpleDocTok ann
forall ann. SimpleDocTok ann
TokAnnPop      , SimpleDocStream ann
rest) )

sdocToTreeParser :: UniqueParser (SimpleDocStream ann) (SimpleDocTree ann)
sdocToTreeParser :: UniqueParser (SimpleDocStream ann) (SimpleDocTree ann)
sdocToTreeParser = ([SimpleDocTree ann] -> SimpleDocTree ann)
-> UniqueParser (SimpleDocStream ann) [SimpleDocTree ann]
-> UniqueParser (SimpleDocStream ann) (SimpleDocTree ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [SimpleDocTree ann] -> SimpleDocTree ann
forall ann. [SimpleDocTree ann] -> SimpleDocTree ann
wrap (UniqueParser (SimpleDocStream ann) (SimpleDocTree ann)
-> UniqueParser (SimpleDocStream ann) [SimpleDocTree ann]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many UniqueParser (SimpleDocStream ann) (SimpleDocTree ann)
forall ann. UniqueParser (SimpleDocStream ann) (SimpleDocTree ann)
contentPiece)

  where

    wrap :: [SimpleDocTree ann] -> SimpleDocTree ann
    wrap :: [SimpleDocTree ann] -> SimpleDocTree ann
wrap = \[SimpleDocTree ann]
sdts -> case [SimpleDocTree ann]
sdts of
        []  -> SimpleDocTree ann
forall ann. SimpleDocTree ann
STEmpty
        [SimpleDocTree ann
x] -> SimpleDocTree ann
x
        [SimpleDocTree ann]
xs  -> [SimpleDocTree ann] -> SimpleDocTree ann
forall ann. [SimpleDocTree ann] -> SimpleDocTree ann
STConcat [SimpleDocTree ann]
xs

    contentPiece :: UniqueParser (SimpleDocStream ann) (SimpleDocTree ann)
contentPiece = UniqueParser (SimpleDocStream ann) (SimpleDocTok ann)
forall ann. UniqueParser (SimpleDocStream ann) (SimpleDocTok ann)
nextToken UniqueParser (SimpleDocStream ann) (SimpleDocTok ann)
-> (SimpleDocTok ann
    -> UniqueParser (SimpleDocStream ann) (SimpleDocTree ann))
-> UniqueParser (SimpleDocStream ann) (SimpleDocTree ann)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \SimpleDocTok ann
tok -> case SimpleDocTok ann
tok of
        SimpleDocTok ann
TokEmpty       -> SimpleDocTree ann
-> UniqueParser (SimpleDocStream ann) (SimpleDocTree ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure SimpleDocTree ann
forall ann. SimpleDocTree ann
STEmpty
        TokChar Char
c      -> SimpleDocTree ann
-> UniqueParser (SimpleDocStream ann) (SimpleDocTree ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> SimpleDocTree ann
forall ann. Char -> SimpleDocTree ann
STChar Char
c)
        TokText Int
l Text
t    -> SimpleDocTree ann
-> UniqueParser (SimpleDocStream ann) (SimpleDocTree ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Text -> SimpleDocTree ann
forall ann. Int -> Text -> SimpleDocTree ann
STText Int
l Text
t)
        TokLine Int
i      -> SimpleDocTree ann
-> UniqueParser (SimpleDocStream ann) (SimpleDocTree ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> SimpleDocTree ann
forall ann. Int -> SimpleDocTree ann
STLine Int
i)
        SimpleDocTok ann
TokAnnPop      -> UniqueParser (SimpleDocStream ann) (SimpleDocTree ann)
forall (f :: * -> *) a. Alternative f => f a
empty
        TokAnnPush ann
ann -> do SimpleDocTree ann
annotatedContents <- UniqueParser (SimpleDocStream ann) (SimpleDocTree ann)
forall ann. UniqueParser (SimpleDocStream ann) (SimpleDocTree ann)
sdocToTreeParser
                             SimpleDocTok ann
TokAnnPop <- UniqueParser (SimpleDocStream ann) (SimpleDocTok ann)
forall ann. UniqueParser (SimpleDocStream ann) (SimpleDocTok ann)
nextToken
                             SimpleDocTree ann
-> UniqueParser (SimpleDocStream ann) (SimpleDocTree ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ann -> SimpleDocTree ann -> SimpleDocTree ann
forall ann. ann -> SimpleDocTree ann -> SimpleDocTree ann
STAnn ann
ann SimpleDocTree ann
annotatedContents)

-- | Convert a 'SimpleDocStream' to its 'SimpleDocTree' representation.
treeForm :: SimpleDocStream ann -> SimpleDocTree ann
treeForm :: SimpleDocStream ann -> SimpleDocTree ann
treeForm SimpleDocStream ann
sdoc = case UniqueParser (SimpleDocStream ann) (SimpleDocTree ann)
-> SimpleDocStream ann
-> Maybe (SimpleDocTree ann, SimpleDocStream ann)
forall s a. UniqueParser s a -> s -> Maybe (a, s)
runParser UniqueParser (SimpleDocStream ann) (SimpleDocTree ann)
forall ann. UniqueParser (SimpleDocStream ann) (SimpleDocTree ann)
sdocToTreeParser SimpleDocStream ann
sdoc of
    Maybe (SimpleDocTree ann, SimpleDocStream ann)
Nothing               -> SimpleDocTree ann
forall void. void
panicSimpleDocTreeConversionFailed
    Just (SimpleDocTree ann
sdoct, SimpleDocStream ann
SEmpty)  -> SimpleDocTree ann
sdoct
    Just (SimpleDocTree ann
_, SimpleDocStream ann
_unconsumed) -> SimpleDocTree ann
forall void. void
panicInputNotFullyConsumed

-- $
--
-- >>> :set -XOverloadedStrings
-- >>> treeForm (layoutPretty defaultLayoutOptions ("lorem" <+> "ipsum" <+> annotate True ("TRUE" <+> annotate False "FALSE") <+> "dolor"))
-- STConcat [STText 5 "lorem",STChar ' ',STText 5 "ipsum",STChar ' ',STAnn True (STConcat [STText 4 "TRUE",STChar ' ',STAnn False (STText 5 "FALSE")]),STChar ' ',STText 5 "dolor"]

-- | Remove all annotations. 'unAnnotate' for 'SimpleDocTree'.
unAnnotateST :: SimpleDocTree ann -> SimpleDocTree xxx
unAnnotateST :: SimpleDocTree ann -> SimpleDocTree xxx
unAnnotateST = (ann -> [xxx]) -> SimpleDocTree ann -> SimpleDocTree xxx
forall ann ann'.
(ann -> [ann']) -> SimpleDocTree ann -> SimpleDocTree ann'
alterAnnotationsST ([xxx] -> ann -> [xxx]
forall a b. a -> b -> a
const [])

-- | Change the annotation of a document. 'reAnnotate' for 'SimpleDocTree'.
reAnnotateST :: (ann -> ann') -> SimpleDocTree ann -> SimpleDocTree ann'
reAnnotateST :: (ann -> ann') -> SimpleDocTree ann -> SimpleDocTree ann'
reAnnotateST ann -> ann'
f = (ann -> [ann']) -> SimpleDocTree ann -> SimpleDocTree ann'
forall ann ann'.
(ann -> [ann']) -> SimpleDocTree ann -> SimpleDocTree ann'
alterAnnotationsST (ann' -> [ann']
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ann' -> [ann']) -> (ann -> ann') -> ann -> [ann']
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ann -> ann'
f)

-- | Change the annotation of a document to a different annotation, or none at
-- all. 'alterAnnotations' for 'SimpleDocTree'.
--
-- Note that this is as powerful as 'alterAnnotations', allowing one annotation
-- to become multiple ones, contrary to 'alterAnnotationsS', which cannot do
-- this.
alterAnnotationsST :: (ann -> [ann']) -> SimpleDocTree ann -> SimpleDocTree ann'
alterAnnotationsST :: (ann -> [ann']) -> SimpleDocTree ann -> SimpleDocTree ann'
alterAnnotationsST ann -> [ann']
re = SimpleDocTree ann -> SimpleDocTree ann'
go
  where
    go :: SimpleDocTree ann -> SimpleDocTree ann'
go = \SimpleDocTree ann
sdt -> case SimpleDocTree ann
sdt of
        SimpleDocTree ann
STEmpty        -> SimpleDocTree ann'
forall ann. SimpleDocTree ann
STEmpty
        STChar Char
c       -> Char -> SimpleDocTree ann'
forall ann. Char -> SimpleDocTree ann
STChar Char
c
        STText Int
l Text
t     -> Int -> Text -> SimpleDocTree ann'
forall ann. Int -> Text -> SimpleDocTree ann
STText Int
l Text
t
        STLine Int
i       -> Int -> SimpleDocTree ann'
forall ann. Int -> SimpleDocTree ann
STLine Int
i
        STConcat [SimpleDocTree ann]
xs    -> [SimpleDocTree ann'] -> SimpleDocTree ann'
forall ann. [SimpleDocTree ann] -> SimpleDocTree ann
STConcat ((SimpleDocTree ann -> SimpleDocTree ann')
-> [SimpleDocTree ann] -> [SimpleDocTree ann']
forall a b. (a -> b) -> [a] -> [b]
map SimpleDocTree ann -> SimpleDocTree ann'
go [SimpleDocTree ann]
xs)
        STAnn ann
ann SimpleDocTree ann
rest -> (ann' -> SimpleDocTree ann' -> SimpleDocTree ann')
-> SimpleDocTree ann' -> [ann'] -> SimpleDocTree ann'
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
Prelude.foldr ann' -> SimpleDocTree ann' -> SimpleDocTree ann'
forall ann. ann -> SimpleDocTree ann -> SimpleDocTree ann
STAnn (SimpleDocTree ann -> SimpleDocTree ann'
go SimpleDocTree ann
rest) (ann -> [ann']
re ann
ann)

-- | Collect all annotations from a document.
instance Foldable SimpleDocTree where
    foldMap :: (a -> m) -> SimpleDocTree a -> m
foldMap a -> m
f = SimpleDocTree a -> m
go
      where
        go :: SimpleDocTree a -> m
go = \SimpleDocTree a
sdt -> case SimpleDocTree a
sdt of
            SimpleDocTree a
STEmpty        -> m
forall a. Monoid a => a
mempty
            STChar Char
_       -> m
forall a. Monoid a => a
mempty
            STText Int
_ Text
_     -> m
forall a. Monoid a => a
mempty
            STLine Int
_       -> m
forall a. Monoid a => a
mempty
            STAnn a
ann SimpleDocTree a
rest -> a -> m
f a
ann m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` SimpleDocTree a -> m
go SimpleDocTree a
rest
            STConcat [SimpleDocTree a]
xs    -> [m] -> m
forall a. Monoid a => [a] -> a
mconcat ((SimpleDocTree a -> m) -> [SimpleDocTree a] -> [m]
forall a b. (a -> b) -> [a] -> [b]
map SimpleDocTree a -> m
go [SimpleDocTree a]
xs)

-- | Transform a document based on its annotations, possibly leveraging
-- 'Applicative' effects.
instance Traversable SimpleDocTree where
    traverse :: (a -> f b) -> SimpleDocTree a -> f (SimpleDocTree b)
traverse a -> f b
f = SimpleDocTree a -> f (SimpleDocTree b)
go
      where
        go :: SimpleDocTree a -> f (SimpleDocTree b)
go = \SimpleDocTree a
sdt -> case SimpleDocTree a
sdt of
            SimpleDocTree a
STEmpty        -> SimpleDocTree b -> f (SimpleDocTree b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure SimpleDocTree b
forall ann. SimpleDocTree ann
STEmpty
            STChar Char
c       -> SimpleDocTree b -> f (SimpleDocTree b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> SimpleDocTree b
forall ann. Char -> SimpleDocTree ann
STChar Char
c)
            STText Int
l Text
t     -> SimpleDocTree b -> f (SimpleDocTree b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Text -> SimpleDocTree b
forall ann. Int -> Text -> SimpleDocTree ann
STText Int
l Text
t)
            STLine Int
i       -> SimpleDocTree b -> f (SimpleDocTree b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> SimpleDocTree b
forall ann. Int -> SimpleDocTree ann
STLine Int
i)
            STAnn a
ann SimpleDocTree a
rest -> b -> SimpleDocTree b -> SimpleDocTree b
forall ann. ann -> SimpleDocTree ann -> SimpleDocTree ann
STAnn (b -> SimpleDocTree b -> SimpleDocTree b)
-> f b -> f (SimpleDocTree b -> SimpleDocTree b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
ann f (SimpleDocTree b -> SimpleDocTree b)
-> f (SimpleDocTree b) -> f (SimpleDocTree b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SimpleDocTree a -> f (SimpleDocTree b)
go SimpleDocTree a
rest
            STConcat [SimpleDocTree a]
xs    -> [SimpleDocTree b] -> SimpleDocTree b
forall ann. [SimpleDocTree ann] -> SimpleDocTree ann
STConcat ([SimpleDocTree b] -> SimpleDocTree b)
-> f [SimpleDocTree b] -> f (SimpleDocTree b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SimpleDocTree a -> f (SimpleDocTree b))
-> [SimpleDocTree a] -> f [SimpleDocTree b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse SimpleDocTree a -> f (SimpleDocTree b)
go [SimpleDocTree a]
xs