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 :: 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' :: 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
(.:) :: (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
(.)
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
renderText :: H.Attributes -> T.Text -> H.TextItem
renderText :: Attributes -> Text -> TextItem
renderText Attributes
cs Text
t
| Text -> Bool
T.null Text
t = TextItem
ti
| 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