{-|
Description: Render binary tree with layout to SVG
Copyright: Copyright (C) 2021 Yoo Chung
License: GPL-3.0-or-later
Maintainer: dev@chungyc.org

For a 'Tree' which has been laid out with position \((x,y)\) for every node,
such as with 'Problems.P64.layoutInorder', turns it into [SVG](https://www.w3.org/Graphics/SVG/)
so that the layout can be viewed graphically.  Only trees with 'Char' values are supported.

This is used to generate the graphical representation of binary trees
for inclusion in the Haddock documentation generated for the layout problems.
Doing it manually once was a painstaking and error-prone process;
the thought of doing it two more times was too much.
It could also be used to graphically explore alternative layout methods
that are not included in one of the problems.
-}
module Problems.BinaryTrees.SVG (toSVG, prettyXML, writeSVG, XML) where

import           Data.Text.Lazy            (Text)
import qualified Data.Text.Lazy            as Text
import           Prettyprinter
import           Prettyprinter.Render.Text
import           Problems.BinaryTrees
import           System.IO

-- | Represents XML content for the purposes of rendering 'Tree' to SVG.
data XML
  -- | Reprsents an XML element.
  = E String [Attribute] [XML]
  -- | Represents text content.
  | T Text deriving Int -> XML -> ShowS
[XML] -> ShowS
XML -> String
(Int -> XML -> ShowS)
-> (XML -> String) -> ([XML] -> ShowS) -> Show XML
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> XML -> ShowS
showsPrec :: Int -> XML -> ShowS
$cshow :: XML -> String
show :: XML -> String
$cshowList :: [XML] -> ShowS
showList :: [XML] -> ShowS
Show

-- | Represents an attribute for an XML element.
data Attribute = A String String deriving Int -> Attribute -> ShowS
[Attribute] -> ShowS
Attribute -> String
(Int -> Attribute -> ShowS)
-> (Attribute -> String)
-> ([Attribute] -> ShowS)
-> Show Attribute
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Attribute -> ShowS
showsPrec :: Int -> Attribute -> ShowS
$cshow :: Attribute -> String
show :: Attribute -> String
$cshowList :: [Attribute] -> ShowS
showList :: [Attribute] -> ShowS
Show

-- | Renders a binary tree with 'Char' values with annotated layout to SVG.
toSVG :: Tree (Char, (Int,Int)) -> XML
toSVG :: Tree (Char, (Int, Int)) -> XML
toSVG Tree (Char, (Int, Int))
t = String -> [Attribute] -> [XML] -> XML
E String
"svg"
  [ String -> String -> Attribute
A String
"version" String
"1.1"
  , String -> String -> Attribute
A String
"baseProfile" String
"full"
  , String -> String -> Attribute
A String
"width" String
"640"
  , String -> String -> Attribute
A String
"viewBox" String
viewbox
  , String -> String -> Attribute
A String
"preserveAspectRatio" String
"xMinYMin meet"
  , String -> String -> Attribute
A String
"xmlns" String
"http://www.w3.org/2000/svg"
  ]
  [ String -> [Attribute] -> [XML] -> XML
E String
"g"
    [ String -> String -> Attribute
A String
"font-family" String
"sans-serif"
    , String -> String -> Attribute
A String
"font-size" String
"40"
    , String -> String -> Attribute
A String
"dominant-baseline" String
"central"
    , String -> String -> Attribute
A String
"text-anchor" String
"middle"
    ]
    [ (Int, Int) -> XML
toGridLabelSVG (Int, Int)
size
    , (Int, Int) -> XML
toGridSVG (Int, Int)
size
    , [((Int, Int), (Int, Int))] -> XML
toEdgeSVG [((Int, Int), (Int, Int))]
es
    , [(Text, (Int, Int))] -> XML
toNodeSVG [(Text, (Int, Int))]
ns
    ]
  ]
  where ns :: [(Text, (Int, Int))]
ns = Tree (Char, (Int, Int)) -> [(Text, (Int, Int))]
nodes Tree (Char, (Int, Int))
t
        es :: [((Int, Int), (Int, Int))]
es = Tree (Char, (Int, Int)) -> [((Int, Int), (Int, Int))]
forall a. Tree (a, (Int, Int)) -> [((Int, Int), (Int, Int))]
edges Tree (Char, (Int, Int))
t
        size :: (Int, Int)
size@(Int
w,Int
h) = [(Text, (Int, Int))] -> (Int, Int)
forall a. [(a, (Int, Int))] -> (Int, Int)
gridSize [(Text, (Int, Int))]
ns
        viewbox :: String
viewbox = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"0 0 ", Float -> String
forall a. (Num a, Show a) => a -> String
c (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
0.5 :: Float)
                         , String
" ",   Float -> String
forall a. (Num a, Show a) => a -> String
c (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
0.5 :: Float)
                         ]

-- | Writes the SVG for the binary tree to the given file.
writeSVG :: FilePath -> Tree (Char, (Int,Int)) -> IO ()
writeSVG :: String -> Tree (Char, (Int, Int)) -> IO ()
writeSVG String
path Tree (Char, (Int, Int))
tree = String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
path IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
  \Handle
h -> Handle -> SimpleDocStream Any -> IO ()
forall ann. Handle -> SimpleDocStream ann -> IO ()
renderIO Handle
h (SimpleDocStream Any -> IO ()) -> SimpleDocStream Any -> IO ()
forall a b. (a -> b) -> a -> b
$ LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions (Doc Any -> SimpleDocStream Any) -> Doc Any -> SimpleDocStream Any
forall a b. (a -> b) -> a -> b
$
        XML -> Doc Any
forall ann. XML -> Doc ann
prettyXML (XML -> Doc Any) -> XML -> Doc Any
forall a b. (a -> b) -> a -> b
$ Tree (Char, (Int, Int)) -> XML
toSVG Tree (Char, (Int, Int))
tree

-- | Labels for the grid axes.
toGridLabelSVG :: (Int,Int) -> XML
toGridLabelSVG :: (Int, Int) -> XML
toGridLabelSVG (Int
w, Int
h) = String -> [Attribute] -> [XML] -> XML
E String
"g" [] ([XML] -> XML) -> [XML] -> XML
forall a b. (a -> b) -> a -> b
$ [XML]
xlabels [XML] -> [XML] -> [XML]
forall a. [a] -> [a] -> [a]
++ [XML]
ylabels
  where xlabels :: [XML]
xlabels = (Int -> XML) -> [Int] -> [XML]
forall a b. (a -> b) -> [a] -> [b]
map Int -> XML
forall {a}. (Num a, Show a) => a -> XML
xlabel [Int
1..Int
w]
        ylabels :: [XML]
ylabels = (Int -> XML) -> [Int] -> [XML]
forall a b. (a -> b) -> [a] -> [b]
map Int -> XML
forall {a}. (Num a, Show a) => a -> XML
ylabel [Int
1..Int
h]
        xlabel :: a -> XML
xlabel a
x = String -> [Attribute] -> [XML] -> XML
E String
"text" [String -> String -> Attribute
A String
"x" (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. (Num a, Show a) => a -> String
c a
x, String -> String -> Attribute
A String
"y" (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ Float -> String
forall a. (Num a, Show a) => a -> String
c Float
offset] [Text -> XML
T (Text -> XML) -> Text -> XML
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
x]
        ylabel :: a -> XML
ylabel a
y = String -> [Attribute] -> [XML] -> XML
E String
"text" [String -> String -> Attribute
A String
"x" (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ Float -> String
forall a. (Num a, Show a) => a -> String
c Float
offset, String -> String -> Attribute
A String
"y" (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. (Num a, Show a) => a -> String
c a
y] [Text -> XML
T (Text -> XML) -> Text -> XML
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
y]
        offset :: Float
offset = Float
0.3 :: Float

-- | Grid lines.
toGridSVG :: (Int,Int) -> XML
toGridSVG :: (Int, Int) -> XML
toGridSVG (Int
w, Int
h) = String -> [Attribute] -> [XML] -> XML
E String
"g" [String -> String -> Attribute
A String
"stroke" String
"black"] ([XML] -> XML) -> [XML] -> XML
forall a b. (a -> b) -> a -> b
$ [XML]
xlines [XML] -> [XML] -> [XML]
forall a. [a] -> [a] -> [a]
++ [XML]
ylines
  where xlines :: [XML]
xlines = (Int -> XML) -> [Int] -> [XML]
forall a b. (a -> b) -> [a] -> [b]
map Int -> XML
forall {a}. (Num a, Show a) => a -> XML
xline [Int
1..Int
w]
        ylines :: [XML]
ylines = (Int -> XML) -> [Int] -> [XML]
forall a b. (a -> b) -> [a] -> [b]
map Int -> XML
forall {a}. (Num a, Show a) => a -> XML
yline [Int
1..Int
h]
        xline :: a -> XML
xline a
x = String -> [Attribute] -> [XML] -> XML
E String
"line" [ String -> String -> Attribute
A String
"x1" (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. (Num a, Show a) => a -> String
c a
x
                           , String -> String -> Attribute
A String
"x2" (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. (Num a, Show a) => a -> String
c a
x
                           , String -> String -> Attribute
A String
"y1" (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. (Num a, Show a) => a -> String
c (Int
1 :: Int)
                           , String -> String -> Attribute
A String
"y2" (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. (Num a, Show a) => a -> String
c Int
h
                           ] []
        yline :: a -> XML
yline a
y = String -> [Attribute] -> [XML] -> XML
E String
"line" [ String -> String -> Attribute
A String
"x1" (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. (Num a, Show a) => a -> String
c (Int
1 :: Int)
                           , String -> String -> Attribute
A String
"x2" (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. (Num a, Show a) => a -> String
c Int
w
                           , String -> String -> Attribute
A String
"y1" (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. (Num a, Show a) => a -> String
c a
y
                           , String -> String -> Attribute
A String
"y2" (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. (Num a, Show a) => a -> String
c a
y
                           ] []

-- | The circle and label for the nodes.
toNodeSVG :: [(Text, (Int,Int))] -> XML
toNodeSVG :: [(Text, (Int, Int))] -> XML
toNodeSVG [(Text, (Int, Int))]
ns = String -> [Attribute] -> [XML] -> XML
E String
"g" [] [XML
circles, XML
labels]
  where circles :: XML
circles = String -> [Attribute] -> [XML] -> XML
E String
"g" [String -> String -> Attribute
A String
"fill" String
"white",
                         String -> String -> Attribute
A String
"stroke" String
"black",
                         String -> String -> Attribute
A String
"stroke-width" String
"3"] ([XML] -> XML) -> [XML] -> XML
forall a b. (a -> b) -> a -> b
$ ((Text, (Int, Int)) -> XML) -> [(Text, (Int, Int))] -> [XML]
forall a b. (a -> b) -> [a] -> [b]
map (Text, (Int, Int)) -> XML
forall {a} {a} {a}.
(Num a, Num a, Show a, Show a) =>
(a, (a, a)) -> XML
circle [(Text, (Int, Int))]
ns
        labels :: XML
labels = String -> [Attribute] -> [XML] -> XML
E String
"g" [] ([XML] -> XML) -> [XML] -> XML
forall a b. (a -> b) -> a -> b
$ ((Text, (Int, Int)) -> XML) -> [(Text, (Int, Int))] -> [XML]
forall a b. (a -> b) -> [a] -> [b]
map (Text, (Int, Int)) -> XML
forall {a} {a}.
(Num a, Num a, Show a, Show a) =>
(Text, (a, a)) -> XML
label [(Text, (Int, Int))]
ns
        circle :: (a, (a, a)) -> XML
circle (a
_, (a
x,a
y)) = String -> [Attribute] -> [XML] -> XML
E String
"circle" [ String -> String -> Attribute
A String
"r" (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ Float -> String
forall a. (Num a, Show a) => a -> String
c (Float
0.4 :: Float)
                                       , String -> String -> Attribute
A String
"cx" (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. (Num a, Show a) => a -> String
c a
x
                                       , String -> String -> Attribute
A String
"cy" (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. (Num a, Show a) => a -> String
c a
y
                                       ] []
        label :: (Text, (a, a)) -> XML
label (Text
l, (a
x,a
y)) = String -> [Attribute] -> [XML] -> XML
E String
"text" [ String -> String -> Attribute
A String
"x" (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. (Num a, Show a) => a -> String
c a
x
                                    , String -> String -> Attribute
A String
"y" (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. (Num a, Show a) => a -> String
c a
y
                                    ] [ Text -> XML
T Text
l ]

-- | The lines for the edges.
toEdgeSVG :: [((Int,Int), (Int,Int))] -> XML
toEdgeSVG :: [((Int, Int), (Int, Int))] -> XML
toEdgeSVG [((Int, Int), (Int, Int))]
es = String -> [Attribute] -> [XML] -> XML
E String
"g" [String -> String -> Attribute
A String
"stroke" String
"black", String -> String -> Attribute
A String
"stroke-width" String
"3"] [XML]
edgeLines
  where edgeLines :: [XML]
edgeLines = (((Int, Int), (Int, Int)) -> XML)
-> [((Int, Int), (Int, Int))] -> [XML]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, Int), (Int, Int)) -> XML
forall {a} {a} {a} {a}.
(Num a, Num a, Num a, Num a, Show a, Show a, Show a, Show a) =>
((a, a), (a, a)) -> XML
edgeLine [((Int, Int), (Int, Int))]
es
        edgeLine :: ((a, a), (a, a)) -> XML
edgeLine ((a
x1,a
y1), (a
x2,a
y2)) = String -> [Attribute] -> [XML] -> XML
E String
"line" [ String -> String -> Attribute
A String
"x1" (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. (Num a, Show a) => a -> String
c a
x1
                                               , String -> String -> Attribute
A String
"y1" (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. (Num a, Show a) => a -> String
c a
y1
                                               , String -> String -> Attribute
A String
"x2" (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. (Num a, Show a) => a -> String
c a
x2
                                               , String -> String -> Attribute
A String
"y2" (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. (Num a, Show a) => a -> String
c a
y2] []

-- | Gather labels and layout positions for each node in the binary tree.
nodes :: Tree (Char, (Int,Int)) -> [(Text, (Int,Int))]
nodes :: Tree (Char, (Int, Int)) -> [(Text, (Int, Int))]
nodes Tree (Char, (Int, Int))
Empty                 = []
nodes (Branch (Char
x, (Int, Int)
pos) Tree (Char, (Int, Int))
l Tree (Char, (Int, Int))
r) = (String -> Text
Text.pack [Char
x], (Int, Int)
pos) (Text, (Int, Int)) -> [(Text, (Int, Int))] -> [(Text, (Int, Int))]
forall a. a -> [a] -> [a]
: Tree (Char, (Int, Int)) -> [(Text, (Int, Int))]
nodes Tree (Char, (Int, Int))
l [(Text, (Int, Int))]
-> [(Text, (Int, Int))] -> [(Text, (Int, Int))]
forall a. [a] -> [a] -> [a]
++ Tree (Char, (Int, Int)) -> [(Text, (Int, Int))]
nodes Tree (Char, (Int, Int))
r

-- | Gather the layout positions for the end points of each edge in the binary tree.
edges :: Tree (a, (Int,Int)) -> [((Int,Int),(Int,Int))]
edges :: forall a. Tree (a, (Int, Int)) -> [((Int, Int), (Int, Int))]
edges Tree (a, (Int, Int))
Empty                 = []
edges (Branch (a
_, (Int, Int)
pos) Tree (a, (Int, Int))
l Tree (a, (Int, Int))
r) = Tree (a, (Int, Int)) -> [((Int, Int), (Int, Int))]
forall {a} {b}. Tree (a, b) -> [((Int, Int), b)]
edge Tree (a, (Int, Int))
l [((Int, Int), (Int, Int))]
-> [((Int, Int), (Int, Int))] -> [((Int, Int), (Int, Int))]
forall a. [a] -> [a] -> [a]
++ Tree (a, (Int, Int)) -> [((Int, Int), (Int, Int))]
forall {a} {b}. Tree (a, b) -> [((Int, Int), b)]
edge Tree (a, (Int, Int))
r [((Int, Int), (Int, Int))]
-> [((Int, Int), (Int, Int))] -> [((Int, Int), (Int, Int))]
forall a. [a] -> [a] -> [a]
++ Tree (a, (Int, Int)) -> [((Int, Int), (Int, Int))]
forall a. Tree (a, (Int, Int)) -> [((Int, Int), (Int, Int))]
edges Tree (a, (Int, Int))
l [((Int, Int), (Int, Int))]
-> [((Int, Int), (Int, Int))] -> [((Int, Int), (Int, Int))]
forall a. [a] -> [a] -> [a]
++ Tree (a, (Int, Int)) -> [((Int, Int), (Int, Int))]
forall a. Tree (a, (Int, Int)) -> [((Int, Int), (Int, Int))]
edges Tree (a, (Int, Int))
r
  where edge :: Tree (a, b) -> [((Int, Int), b)]
edge Tree (a, b)
Empty                  = []
        edge (Branch (a
_, b
pos') Tree (a, b)
_ Tree (a, b)
_) = [((Int, Int)
pos,b
pos')]

-- | Returns the size of the grid necessary to represent all nodes.
-- Assumes that the smallest layout position is (1,1).
gridSize :: [(a, (Int,Int))] -> (Int,Int)
gridSize :: forall a. [(a, (Int, Int))] -> (Int, Int)
gridSize [(a, (Int, Int))]
ns = (Int
w, Int
h)
  where w :: Int
w = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ ((a, (Int, Int)) -> Int) -> [(a, (Int, Int))] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int)
-> ((a, (Int, Int)) -> (Int, Int)) -> (a, (Int, Int)) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, (Int, Int)) -> (Int, Int)
forall a b. (a, b) -> b
snd) [(a, (Int, Int))]
ns
        h :: Int
h = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ ((a, (Int, Int)) -> Int) -> [(a, (Int, Int))] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int)
-> ((a, (Int, Int)) -> (Int, Int)) -> (a, (Int, Int)) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, (Int, Int)) -> (Int, Int)
forall a b. (a, b) -> b
snd) [(a, (Int, Int))]
ns

-- | Converts the coordinate used for binary tree layout
-- to a coordinate in the view box for the SVG image.
c :: (Num a, Show a) => a -> String
c :: forall a. (Num a, Show a) => a -> String
c a
x = a -> String
forall a. Show a => a -> String
show (a -> String) -> a -> String
forall a b. (a -> b) -> a -> b
$ a
100 a -> a -> a
forall a. Num a => a -> a -> a
* a
x

-- | Pretty print XML, so we have prettier output instead of one very long line.
--
-- Supports a limited subset of XML sufficient to output SVG generated by 'toSVG'.
prettyXML :: XML -> Doc ann
prettyXML :: forall ann. XML -> Doc ann
prettyXML (T Text
t) = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Text -> Doc ann
pretty Text
t
prettyXML (E String
name [Attribute]
attributes []) =
  [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
sep [String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ String
"<" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name, [Attribute] -> Doc ann
forall ann. [Attribute] -> Doc ann
prettyAttributes [Attribute]
attributes, String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"/>"]
prettyXML (E String
name [Attribute]
attributes [XML]
xs) =
  [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
cat [ Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
cat [[Attribute] -> Doc ann
forall ann. [Attribute] -> Doc ann
startTag [Attribute]
attributes, [XML] -> Doc ann
forall ann. [XML] -> Doc ann
prettyContent [XML]
xs], Doc ann
forall {ann}. Doc ann
endTag ]
  where startTag :: [Attribute] -> Doc ann
startTag []    = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
angles (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
name
        startTag [Attribute]
attrs = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
angles (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
name Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Attribute] -> Doc ann
forall ann. [Attribute] -> Doc ann
prettyAttributes [Attribute]
attrs
        endTag :: Doc ann
endTag = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ String
"</" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"

prettyContent :: [XML] -> Doc ann
prettyContent :: forall ann. [XML] -> Doc ann
prettyContent [XML]
xs = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
sep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (XML -> Doc ann) -> [XML] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map XML -> Doc ann
forall ann. XML -> Doc ann
prettyXML [XML]
xs

prettyAttributes :: [Attribute] -> Doc ann
prettyAttributes :: forall ann. [Attribute] -> Doc ann
prettyAttributes [Attribute]
as = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
sep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (Attribute -> Doc ann) -> [Attribute] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Attribute -> Doc ann
forall ann. Attribute -> Doc ann
prettyAttribute [Attribute]
as

prettyAttribute :: Attribute -> Doc ann
prettyAttribute :: forall ann. Attribute -> Doc ann
prettyAttribute (A String
name String
value) = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
name Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall {ann}. Doc ann
equals Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
dquotes (String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
value)