module PrettyHTML
(
Html, runHtml,
tag, tag',
Attr, attr, attr',
text,
comment,
inline,
LazyText, TextBuilder
) where
import Foldable (fold)
import Natural (Natural)
import Semigroup (stimes)
import qualified TextBuilder
import qualified LazyText
type LazyText = LazyText.Text
type TextBuilder = TextBuilder.Builder
data Html = NoHtml | Html (Context -> TextBuilder)
runHtml :: Html -> TextBuilder
runHtml :: Html -> TextBuilder
runHtml = \case
Html
NoHtml -> forall a. Monoid a => a
mempty
Html Context -> TextBuilder
f -> Context -> TextBuilder
f (Natural -> Context
Block Natural
0)
instance Semigroup Html where
Html
NoHtml <> :: Html -> Html -> Html
<> Html
x = Html
x
Html
x <> Html
NoHtml = Html
x
Html Context -> TextBuilder
f <> Html Context -> TextBuilder
g = (Context -> TextBuilder) -> Html
Html \Context
c -> Context -> TextBuilder
f Context
c forall a. Semigroup a => a -> a -> a
<> Context -> TextBuilder
g Context
c
instance Monoid Html where
mempty :: Html
mempty = Html
NoHtml
data Context = Block Natural | Inline
type Attr = (LazyText, Maybe LazyText)
raw :: TextBuilder -> Html
raw :: TextBuilder -> Html
raw TextBuilder
x = (Context -> TextBuilder) -> Html
Html \Context
_ -> TextBuilder
x
indent :: Html
indent :: Html
indent = (Context -> TextBuilder) -> Html
Html \case
Block Natural
0 -> forall a. Monoid a => a
mempty
Block Natural
n -> forall a b. (Semigroup a, Integral b) => b -> a -> a
stimes Natural
n TextBuilder
"\t"
Context
Inline -> forall a. Monoid a => a
mempty
endOfLine :: Html
endOfLine :: Html
endOfLine = (Context -> TextBuilder) -> Html
Html \case
Block Natural
_ -> TextBuilder
"\n"
Context
Inline -> forall a. Monoid a => a
mempty
changeContext :: (Context -> Context) -> Html -> Html
changeContext :: (Context -> Context) -> Html -> Html
changeContext Context -> Context
f = \case
Html
NoHtml -> Html
NoHtml
Html Context -> TextBuilder
g -> (Context -> TextBuilder) -> Html
Html (Context -> TextBuilder
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Context
f)
changeIndent :: (Natural -> Natural) -> Context -> Context
changeIndent :: (Natural -> Natural) -> Context -> Context
changeIndent Natural -> Natural
f = \case
Block Natural
n -> Natural -> Context
Block (Natural -> Natural
f Natural
n)
Context
Inline -> Context
Inline
inline :: Html -> Html
inline :: Html -> Html
inline Html
x = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
[ Html
indent
, (Context -> Context) -> Html -> Html
changeContext (forall a b. a -> b -> a
const Context
Inline) Html
x
, Html
endOfLine
]
attr ::
LazyText
-> LazyText
-> Attr
attr :: LazyText -> LazyText -> Attr
attr LazyText
k LazyText
v = (LazyText
k, forall a. a -> Maybe a
Just LazyText
v)
attr' ::
LazyText
-> Attr
attr' :: LazyText -> Attr
attr' LazyText
x = (LazyText
x, forall a. Maybe a
Nothing)
tag :: Foldable t =>
LazyText
-> t Attr
-> Html
-> Html
tag :: forall (t :: * -> *).
Foldable t =>
LazyText -> t Attr -> Html -> Html
tag LazyText
x t Attr
a Html
mi = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
[ Html
indent
, (TextBuilder -> Html
raw forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold)
[ TextBuilder
"<"
, LazyText -> TextBuilder
TextBuilder.fromLazyText LazyText
x
, forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Attr -> TextBuilder
buildAttr t Attr
a
, TextBuilder
">"
]
, case Html
mi of
Html
NoHtml -> forall a. Monoid a => a
mempty
Html
i -> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
[ Html
endOfLine
, (Context -> Context) -> Html -> Html
changeContext ((Natural -> Natural) -> Context -> Context
changeIndent (forall a. Num a => a -> a -> a
+ Natural
1)) Html
i
, Html
indent
]
, (TextBuilder -> Html
raw forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold)
[ TextBuilder
"</"
, LazyText -> TextBuilder
TextBuilder.fromLazyText LazyText
x
, TextBuilder
">"
]
, Html
endOfLine
]
tag' :: Foldable t =>
LazyText
-> t Attr
-> Html
tag' :: forall (t :: * -> *). Foldable t => LazyText -> t Attr -> Html
tag' LazyText
x t Attr
a = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
[ Html
indent
, (TextBuilder -> Html
raw forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold)
[ TextBuilder
"<"
, LazyText -> TextBuilder
TextBuilder.fromLazyText LazyText
x
, forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Attr -> TextBuilder
buildAttr t Attr
a
, TextBuilder
">"
]
, Html
endOfLine
]
buildAttr :: Attr -> TextBuilder
buildAttr :: Attr -> TextBuilder
buildAttr (LazyText
k, Maybe LazyText
vMaybe) = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
[ TextBuilder
" "
, LazyText -> TextBuilder
TextBuilder.fromLazyText LazyText
k
, forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap LazyText -> TextBuilder
attrValue Maybe LazyText
vMaybe
]
attrValue :: LazyText -> TextBuilder
attrValue :: LazyText -> TextBuilder
attrValue LazyText
v = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
[ TextBuilder
"=\""
, forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Char -> TextBuilder
attrEscape (LazyText -> String
LazyText.unpack LazyText
v)
, TextBuilder
"\""
]
attrEscape :: Char -> TextBuilder
attrEscape :: Char -> TextBuilder
attrEscape = \case
Char
'<' -> TextBuilder
"<"
Char
'>' -> TextBuilder
">"
Char
'&' -> TextBuilder
"&"
Char
'"' -> TextBuilder
"""
Char
c -> Char -> TextBuilder
TextBuilder.singleton Char
c
text ::
LazyText
-> Html
text :: LazyText -> Html
text LazyText
x = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
[ Html
indent
, TextBuilder -> Html
raw (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Char -> TextBuilder
textEscape (LazyText -> String
LazyText.unpack LazyText
x))
, Html
endOfLine
]
textEscape :: Char -> TextBuilder
textEscape :: Char -> TextBuilder
textEscape = \case
Char
'<' -> TextBuilder
"<"
Char
'>' -> TextBuilder
"gt;"
Char
'&' -> TextBuilder
"&"
Char
c -> Char -> TextBuilder
TextBuilder.singleton Char
c
comment ::
LazyText
-> Html
LazyText
x = (Context -> TextBuilder) -> Html
Html \case
c :: Context
c@Block{} -> let Html Context -> TextBuilder
f = LazyText -> Html
blockComment LazyText
x in Context -> TextBuilder
f Context
c
c :: Context
c@Inline{} -> let Html Context -> TextBuilder
f = LazyText -> Html
oneLineComment LazyText
x in Context -> TextBuilder
f Context
c
oneLineComment :: LazyText -> Html
LazyText
x = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
[ Html
indent
, TextBuilder -> Html
raw TextBuilder
"<!-- "
, (Context -> Context) -> Html -> Html
changeContext (forall a b. a -> b -> a
const Context
Inline) (LazyText -> Html
commentBody LazyText
x)
, TextBuilder -> Html
raw TextBuilder
" -->"
, Html
endOfLine
]
blockComment :: LazyText -> Html
LazyText
i = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
[ Html
indent
, TextBuilder -> Html
raw TextBuilder
"<!--"
, Html
endOfLine
, (Context -> Context) -> Html -> Html
changeContext ((Natural -> Natural) -> Context -> Context
changeIndent (forall a. Num a => a -> a -> a
+ Natural
1)) (LazyText -> Html
commentBody LazyText
i)
, Html
indent
, TextBuilder -> Html
raw TextBuilder
"-->"
, Html
endOfLine
]
commentBody :: LazyText -> Html
commentBody :: LazyText -> Html
commentBody = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap LazyText -> Html
commentLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. LazyText -> [LazyText]
LazyText.lines
commentLine :: LazyText -> Html
LazyText
l = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
[ Html
indent
, TextBuilder -> Html
raw (LazyText -> TextBuilder
TextBuilder.fromLazyText LazyText
l)
, Html
endOfLine
]