-- | Pretty-print GraphViz labels
module Data.Text.Prettyprint.Doc.Render.GraphViz (
    render,
    render',
) where

import qualified Data.Text.Lazy as TL
import qualified Data.Text as T

import Data.GraphViz.Attributes.Complete (Label(HtmlLabel))
import qualified Data.GraphViz.Attributes.HTML as H
import Data.Text (Text)
import Data.Text.Prettyprint.Doc (
    Doc,
    SimpleDocStream(
        SFail,
        SEmpty,
        SChar,
        SText,
        SLine,
        SAnnPush,
        SAnnPop),
    layoutPretty, defaultLayoutOptions,
    )
import Data.Text.Prettyprint.Doc.Internal (textSpaces)
import Data.Text.Prettyprint.Doc.Render.Util.Panic (
    panicUnpairedPop, panicInputNotFullyConsumed, panicUncaughtFail
    )

-- | Render a document as a GraphViz label, using sensible defaults.
render :: Doc H.Attribute -> Label
render :: Doc Attribute -> Label
render = Label -> Label
HtmlLabel (Label -> Label)
-> (Doc Attribute -> Label) -> Doc Attribute -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Label
H.Text (Text -> Label)
-> (Doc Attribute -> Text) -> Doc Attribute -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDocStream Attribute -> Text
render' (SimpleDocStream Attribute -> Text)
-> (Doc Attribute -> SimpleDocStream Attribute)
-> Doc Attribute
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Attribute -> SimpleDocStream Attribute
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions

-- | Render a document stream as HTML text for GraphViz. This provides more fine-grained control than 'render'.
render' :: SimpleDocStream H.Attribute -> H.Text
render' :: SimpleDocStream Attribute -> Text
render' = ([Attribute] -> Text -> Text)
-> (Attribute -> Text)
-> (Attribute -> Text)
-> SimpleDocStream Attribute
-> Text
forall out ann.
Monoid out =>
([ann] -> Text -> out)
-> (ann -> out) -> (ann -> out) -> SimpleDocStream ann -> out
renderSimplyDecorated' (TextItem -> Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TextItem -> Text)
-> ([Attribute] -> Text -> TextItem) -> [Attribute] -> Text -> Text
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: [Attribute] -> Text -> TextItem
renderText) Attribute -> Text
forall a. Monoid a => a
mempty Attribute -> Text
forall a. Monoid a => a
mempty


{- Util -}

(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
.: :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(.:) = ((b -> c) -> b -> d) -> (a -> b -> c) -> a -> b -> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (((b -> c) -> b -> d) -> (a -> b -> c) -> a -> b -> d)
-> ((c -> d) -> (b -> c) -> b -> d)
-> (c -> d)
-> (a -> b -> c)
-> a
-> b
-> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c -> d) -> (b -> c) -> b -> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)

-- | This is a very minor modification of 'renderSimplyDecorated', where the /text/ function is
-- additionally passed the current stack. Worth suggesting change upstream.
renderSimplyDecorated'
    :: Monoid out
    => ([ann] -> Text -> out) -- ^ Render plain 'Text'
    -> (ann -> out)  -- ^ How to render an annotation
    -> (ann -> out)  -- ^ How to render the removed annotation
    -> SimpleDocStream ann
    -> out
renderSimplyDecorated' :: ([ann] -> Text -> out)
-> (ann -> out) -> (ann -> out) -> SimpleDocStream ann -> out
renderSimplyDecorated' [ann] -> 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)      = [ann] -> Text -> out
text [ann]
stack (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)   = [ann] -> Text -> out
text [ann]
stack 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)      = [ann] -> Text -> out
text [ann]
stack (Char -> Text
T.singleton Char
'\n') out -> out -> out
forall a. Semigroup a => a -> a -> a
<> [ann] -> Text -> out
text [ann]
stack (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

-- | Helper for rendering an individual 'H.TextItem'.
renderText :: H.Attributes -> T.Text -> H.TextItem
renderText :: [Attribute] -> Text -> TextItem
renderText [Attribute]
cs Text
t
    | Text -> Bool
T.null Text
t   = TextItem
ti -- graphviz doesn't like an empty string between tags
    | Bool
otherwise  = [Attribute] -> Text -> TextItem
H.Font [Attribute]
cs [TextItem
ti]
    where ti :: TextItem
ti = Text -> TextItem
H.Str (Text -> TextItem) -> Text -> TextItem
forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.fromStrict Text
t