-- | Pretty-print GraphViz labels
module Prettyprinter.Render.GraphViz (
    render,
    render',
) where

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

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

-- | Render a document as a GraphViz label, using sensible defaults.
render :: Doc H.Attributes -> Label
render :: Doc Attributes -> Label
render = Label -> Label
HtmlLabel (Label -> Label)
-> (Doc Attributes -> Label) -> Doc Attributes -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Label
H.Text (Text -> Label)
-> (Doc Attributes -> Text) -> Doc Attributes -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDocStream Attributes -> Text
render' (SimpleDocStream Attributes -> Text)
-> (Doc Attributes -> SimpleDocStream Attributes)
-> Doc Attributes
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Attributes -> SimpleDocStream Attributes
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.Attributes -> H.Text
render' :: SimpleDocStream Attributes -> Text
render' = (Attributes -> Text)
-> (Attributes -> Text) -> SimpleDocStream Attributes -> Text
renderSimplyDecorated' Attributes -> Text
forall a. Monoid a => a
mempty Attributes -> 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 minor modification of 'renderSimplyDecorated', where the /text/ function is
additionally passed the current stack.
-}
renderSimplyDecorated' :: ([H.Attribute] -> [H.TextItem]) -> ([H.Attribute] -> [H.TextItem]) -> SimpleDocStream [H.Attribute] -> [H.TextItem]
renderSimplyDecorated' :: (Attributes -> Text)
-> (Attributes -> Text) -> SimpleDocStream Attributes -> Text
renderSimplyDecorated' Attributes -> Text
push Attributes -> Text
pop = [Attributes] -> SimpleDocStream Attributes -> Text
go []
  where
    text :: [Attributes] -> Text -> Text
text = TextItem -> Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TextItem -> Text)
-> ([Attributes] -> Text -> TextItem)
-> [Attributes]
-> Text
-> Text
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: (Attributes -> Text -> TextItem
renderText (Attributes -> Text -> TextItem)
-> ([Attributes] -> Attributes) -> [Attributes] -> Text -> TextItem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Attributes] -> Attributes
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat)
    go :: [Attributes] -> SimpleDocStream Attributes -> Text
go [Attributes]
_ SimpleDocStream Attributes
SFail = Text
forall void. void
panicUncaughtFail
    go [] SimpleDocStream Attributes
SEmpty = Text
forall a. Monoid a => a
mempty
    go (Attributes
_ : [Attributes]
_) SimpleDocStream Attributes
SEmpty = Text
forall void. void
panicInputNotFullyConsumed
    go [Attributes]
stack (SChar Char
c SimpleDocStream Attributes
rest) = [Attributes] -> Text -> Text
text [Attributes]
stack (Char -> Text
T.singleton Char
c) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Attributes] -> SimpleDocStream Attributes -> Text
go [Attributes]
stack SimpleDocStream Attributes
rest
    go [Attributes]
stack (SText Int
_l Text
t SimpleDocStream Attributes
rest) = [Attributes] -> Text -> Text
text [Attributes]
stack Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Attributes] -> SimpleDocStream Attributes -> Text
go [Attributes]
stack SimpleDocStream Attributes
rest
    go [Attributes]
stack (SLine Int
i SimpleDocStream Attributes
rest) = [Attributes -> TextItem
H.Newline [Align -> Attribute
H.Align Align
H.HLeft]] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Attributes] -> Text -> Text
text [Attributes]
stack (Int -> Text
textSpaces Int
i) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Attributes] -> SimpleDocStream Attributes -> Text
go [Attributes]
stack SimpleDocStream Attributes
rest
    go [Attributes]
stack (SAnnPush Attributes
ann SimpleDocStream Attributes
rest) = Attributes -> Text
push Attributes
ann Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Attributes] -> SimpleDocStream Attributes -> Text
go (Attributes
ann Attributes -> [Attributes] -> [Attributes]
forall a. a -> [a] -> [a]
: [Attributes]
stack) SimpleDocStream Attributes
rest
    go (Attributes
ann : [Attributes]
stack) (SAnnPop SimpleDocStream Attributes
rest) = Attributes -> Text
pop Attributes
ann Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Attributes] -> SimpleDocStream Attributes -> Text
go [Attributes]
stack SimpleDocStream Attributes
rest
    go [] SAnnPop{} = Text
forall void. void
panicUnpairedPop

-- | Helper for rendering an individual 'H.TextItem'.
renderText :: H.Attributes -> T.Text -> H.TextItem
renderText :: Attributes -> Text -> TextItem
renderText Attributes
cs Text
t
    | Text -> Bool
T.null Text
t = TextItem
ti -- graphviz doesn't like an empty string between tags
    | Bool
otherwise = Attributes -> Text -> TextItem
H.Font Attributes
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