{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Text.Blaze.Colonnade
(
encodeCappedCellTable
, encodeHtmlTable
, encodeCellTable
, encodeTable
, encodeCappedTable
, Cell (..)
, charCell
, htmlCell
, stringCell
, textCell
, lazyTextCell
, builderCell
, htmlFromCell
, printCompactHtml
, printVeryCompactHtml
) where
import Colonnade (Colonnade, Cornice, Fascia, Headed)
import qualified Colonnade.Encode as E
import Control.Monad
import Data.Char (isSpace)
import Data.Foldable
import qualified Data.List as List
import Data.Maybe (listToMaybe)
import Data.String (IsString (..))
import Data.Text (Text)
import qualified Data.Text.Lazy as LText
import qualified Data.Text.Lazy.Builder as TBuilder
import Text.Blaze (Attribute, (!))
import Text.Blaze.Html (Html, toHtml)
import qualified Text.Blaze.Html.Renderer.Pretty as Pretty
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA
data Cell = Cell
{ Cell -> Attribute
cellAttribute :: !Attribute
, Cell -> Html
cellHtml :: !Html
}
instance IsString Cell where
fromString :: String -> Cell
fromString = String -> Cell
stringCell
instance Semigroup Cell where
(Cell Attribute
a1 Html
c1) <> :: Cell -> Cell -> Cell
<> (Cell Attribute
a2 Html
c2) = Attribute -> Html -> Cell
Cell (Attribute
a1 Attribute -> Attribute -> Attribute
forall a. Semigroup a => a -> a -> a
<> Attribute
a2) (Html
c1 Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
c2)
instance Monoid Cell where
mempty :: Cell
mempty = Attribute -> Html -> Cell
Cell Attribute
forall a. Monoid a => a
mempty Html
forall a. Monoid a => a
mempty
mappend :: Cell -> Cell -> Cell
mappend = Cell -> Cell -> Cell
forall a. Semigroup a => a -> a -> a
(<>)
htmlCell :: Html -> Cell
htmlCell :: Html -> Cell
htmlCell = Attribute -> Html -> Cell
Cell Attribute
forall a. Monoid a => a
mempty
stringCell :: String -> Cell
stringCell :: String -> Cell
stringCell = Html -> Cell
htmlCell (Html -> Cell) -> (String -> Html) -> String -> Cell
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Html
forall a. IsString a => String -> a
fromString
charCell :: Char -> Cell
charCell :: Char -> Cell
charCell = String -> Cell
stringCell (String -> Cell) -> (Char -> String) -> Char -> Cell
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
textCell :: Text -> Cell
textCell :: Text -> Cell
textCell = Html -> Cell
htmlCell (Html -> Cell) -> (Text -> Html) -> Text -> Cell
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Html
forall a. ToMarkup a => a -> Html
toHtml
lazyTextCell :: LText.Text -> Cell
lazyTextCell :: Text -> Cell
lazyTextCell = Text -> Cell
textCell (Text -> Cell) -> (Text -> Text) -> Text -> Cell
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
LText.toStrict
builderCell :: TBuilder.Builder -> Cell
builderCell :: Builder -> Cell
builderCell = Text -> Cell
lazyTextCell (Text -> Cell) -> (Builder -> Text) -> Builder -> Cell
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
TBuilder.toLazyText
encodeTable ::
forall h f a c.
(Foldable f, E.Headedness h) =>
h (Attribute, Attribute) ->
Attribute ->
(a -> Attribute) ->
((Html -> Html) -> c -> Html) ->
Attribute ->
Colonnade h a c ->
f a ->
Html
encodeTable :: forall (h :: * -> *) (f :: * -> *) a c.
(Foldable f, Headedness h) =>
h (Attribute, Attribute)
-> Attribute
-> (a -> Attribute)
-> ((Html -> Html) -> c -> Html)
-> Attribute
-> Colonnade h a c
-> f a
-> Html
encodeTable h (Attribute, Attribute)
mtheadAttrs Attribute
tbodyAttrs a -> Attribute
trAttrs (Html -> Html) -> c -> Html
wrapContent Attribute
tableAttrs Colonnade h a c
colonnade f a
xs =
Html -> Html
H.table (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! Attribute
tableAttrs (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
case Maybe (ExtractForall h)
forall (h :: * -> *). Headedness h => Maybe (ExtractForall h)
E.headednessExtractForall of
Maybe (ExtractForall h)
Nothing -> () -> Html
forall a. a -> MarkupM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall a. Monoid a => a
mempty
Just ExtractForall h
extractForall -> do
let (Attribute
theadAttrs, Attribute
theadTrAttrs) = h (Attribute, Attribute) -> (Attribute, Attribute)
forall y. h y -> y
extract h (Attribute, Attribute)
mtheadAttrs
Html -> Html
H.thead (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! Attribute
theadAttrs (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.tr (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! Attribute
theadTrAttrs (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
(OneColonnade h a c -> Html) -> Vector (OneColonnade h a c) -> Html
forall (g :: * -> *) b a (m :: * -> *).
(Foldable g, Monoid b, Monad m) =>
(a -> m b) -> g a -> m b
foldlMapM' ((Html -> Html) -> c -> Html
wrapContent Html -> Html
H.th (c -> Html)
-> (OneColonnade h a c -> c) -> OneColonnade h a c -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. h c -> c
forall y. h y -> y
extract (h c -> c)
-> (OneColonnade h a c -> h c) -> OneColonnade h a c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneColonnade h a c -> h c
forall (h :: * -> *) a c. OneColonnade h a c -> h c
E.oneColonnadeHead) (Colonnade h a c -> Vector (OneColonnade h a c)
forall (h :: * -> *) a c.
Colonnade h a c -> Vector (OneColonnade h a c)
E.getColonnade Colonnade h a c
colonnade)
where
extract :: forall y. h y -> y
extract :: forall y. h y -> y
extract = ExtractForall h -> forall y. h y -> y
forall (h :: * -> *). ExtractForall h -> forall a. h a -> a
E.runExtractForall ExtractForall h
extractForall
(a -> Attribute)
-> ((Html -> Html) -> c -> Html)
-> Attribute
-> Colonnade h a c
-> f a
-> Html
forall (f :: * -> *) a c (h :: * -> *).
Foldable f =>
(a -> Attribute)
-> ((Html -> Html) -> c -> Html)
-> Attribute
-> Colonnade h a c
-> f a
-> Html
encodeBody a -> Attribute
trAttrs (Html -> Html) -> c -> Html
wrapContent Attribute
tbodyAttrs Colonnade h a c
colonnade f a
xs
foldlMapM' :: forall g b a m. (Foldable g, Monoid b, Monad m) => (a -> m b) -> g a -> m b
foldlMapM' :: forall (g :: * -> *) b a (m :: * -> *).
(Foldable g, Monoid b, Monad m) =>
(a -> m b) -> g a -> m b
foldlMapM' a -> m b
f g a
xs = (a -> (b -> m b) -> b -> m b) -> (b -> m b) -> g a -> b -> m b
forall a b. (a -> b -> b) -> b -> g a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> (b -> m b) -> b -> m b
f' b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure g a
xs b
forall a. Monoid a => a
mempty
where
f' :: a -> (b -> m b) -> b -> m b
f' :: a -> (b -> m b) -> b -> m b
f' a
x b -> m b
k b
bl = do
b
br <- a -> m b
f a
x
let !b :: b
b = b -> b -> b
forall a. Monoid a => a -> a -> a
mappend b
bl b
br
b -> m b
k b
b
encodeCappedCellTable ::
(Foldable f) =>
Attribute ->
Fascia p Attribute ->
Cornice Headed p a Cell ->
f a ->
Html
encodeCappedCellTable :: forall (f :: * -> *) (p :: Pillar) a.
Foldable f =>
Attribute
-> Fascia p Attribute -> Cornice Headed p a Cell -> f a -> Html
encodeCappedCellTable = Attribute
-> Attribute
-> (a -> Attribute)
-> ((Html -> Html) -> Cell -> Html)
-> Attribute
-> Fascia p Attribute
-> Cornice Headed p a Cell
-> f a
-> Html
forall (f :: * -> *) a c (p :: Pillar).
Foldable f =>
Attribute
-> Attribute
-> (a -> Attribute)
-> ((Html -> Html) -> c -> Html)
-> Attribute
-> Fascia p Attribute
-> Cornice Headed p a c
-> f a
-> Html
encodeCappedTable Attribute
forall a. Monoid a => a
mempty Attribute
forall a. Monoid a => a
mempty (Attribute -> a -> Attribute
forall a b. a -> b -> a
const Attribute
forall a. Monoid a => a
mempty) (Html -> Html) -> Cell -> Html
htmlFromCell
encodeCappedTable ::
(Foldable f) =>
Attribute ->
Attribute ->
(a -> Attribute) ->
((Html -> Html) -> c -> Html) ->
Attribute ->
Fascia p Attribute ->
Cornice Headed p a c ->
f a ->
Html
encodeCappedTable :: forall (f :: * -> *) a c (p :: Pillar).
Foldable f =>
Attribute
-> Attribute
-> (a -> Attribute)
-> ((Html -> Html) -> c -> Html)
-> Attribute
-> Fascia p Attribute
-> Cornice Headed p a c
-> f a
-> Html
encodeCappedTable Attribute
theadAttrs Attribute
tbodyAttrs a -> Attribute
trAttrs (Html -> Html) -> c -> Html
wrapContent Attribute
tableAttrs Fascia p Attribute
fascia Cornice Headed p a c
cornice f a
xs = do
let colonnade :: Colonnade Headed a c
colonnade = Cornice Headed p a c -> Colonnade Headed a c
forall (h :: * -> *) (p :: Pillar) a c.
Cornice h p a c -> Colonnade h a c
E.discard Cornice Headed p a c
cornice
annCornice :: AnnotatedCornice (Maybe Int) Headed p a c
annCornice = Cornice Headed p a c -> AnnotatedCornice (Maybe Int) Headed p a c
forall (p :: Pillar) a c.
Cornice Headed p a c -> AnnotatedCornice (Maybe Int) Headed p a c
E.annotate Cornice Headed p a c
cornice
Html -> Html
H.table (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! Attribute
tableAttrs (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
Html -> Html
H.thead (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! Attribute
theadAttrs (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
Maybe (Fascia p Attribute, Attribute -> Html -> Html)
-> [(Maybe Int -> c -> Html, Html -> Html)]
-> AnnotatedCornice (Maybe Int) Headed p a c
-> Html
forall sz r m c (p :: Pillar) a (h :: * -> *).
(Monoid m, Headedness h) =>
Maybe (Fascia p r, r -> m -> m)
-> [(sz -> c -> m, m -> m)] -> AnnotatedCornice sz h p a c -> m
E.headersMonoidal
((Fascia p Attribute, Attribute -> Html -> Html)
-> Maybe (Fascia p Attribute, Attribute -> Html -> Html)
forall a. a -> Maybe a
Just (Fascia p Attribute
fascia, \Attribute
attrs Html
theHtml -> Html -> Html
H.tr (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! Attribute
attrs (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
theHtml))
[
( \Maybe Int
msz c
c -> case Maybe Int
msz of
Just Int
sz -> (Html -> Html) -> c -> Html
wrapContent Html -> Html
H.th c
c Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.colspan (String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue (Int -> String
forall a. Show a => a -> String
show Int
sz))
Maybe Int
Nothing -> Html
forall a. Monoid a => a
mempty
, Html -> Html
forall a. a -> a
id
)
]
AnnotatedCornice (Maybe Int) Headed p a c
annCornice
(a -> Attribute)
-> ((Html -> Html) -> c -> Html)
-> Attribute
-> Colonnade Headed a c
-> f a
-> Html
forall (f :: * -> *) a c (h :: * -> *).
Foldable f =>
(a -> Attribute)
-> ((Html -> Html) -> c -> Html)
-> Attribute
-> Colonnade h a c
-> f a
-> Html
encodeBody a -> Attribute
trAttrs (Html -> Html) -> c -> Html
wrapContent Attribute
tbodyAttrs Colonnade Headed a c
colonnade f a
xs
encodeBody ::
(Foldable f) =>
(a -> Attribute) ->
((Html -> Html) -> c -> Html) ->
Attribute ->
Colonnade h a c ->
f a ->
Html
encodeBody :: forall (f :: * -> *) a c (h :: * -> *).
Foldable f =>
(a -> Attribute)
-> ((Html -> Html) -> c -> Html)
-> Attribute
-> Colonnade h a c
-> f a
-> Html
encodeBody a -> Attribute
trAttrs (Html -> Html) -> c -> Html
wrapContent Attribute
tbodyAttrs Colonnade h a c
colonnade f a
xs = do
Html -> Html
H.tbody (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! Attribute
tbodyAttrs (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
f a -> (a -> Html) -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ f a
xs ((a -> Html) -> Html) -> (a -> Html) -> Html
forall a b. (a -> b) -> a -> b
$ \a
x -> do
Html -> Html
H.tr (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! a -> Attribute
trAttrs a
x (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Colonnade h a c -> (c -> Html) -> a -> Html
forall m (h :: * -> *) a c.
Monoid m =>
Colonnade h a c -> (c -> m) -> a -> m
E.rowMonoidal Colonnade h a c
colonnade ((Html -> Html) -> c -> Html
wrapContent Html -> Html
H.td) a
x
encodeCellTable ::
(Foldable f) =>
Attribute ->
Colonnade Headed a Cell ->
f a ->
Html
encodeCellTable :: forall (f :: * -> *) a.
Foldable f =>
Attribute -> Colonnade Headed a Cell -> f a -> Html
encodeCellTable =
Headed (Attribute, Attribute)
-> Attribute
-> (a -> Attribute)
-> ((Html -> Html) -> Cell -> Html)
-> Attribute
-> Colonnade Headed a Cell
-> f a
-> Html
forall (h :: * -> *) (f :: * -> *) a c.
(Foldable f, Headedness h) =>
h (Attribute, Attribute)
-> Attribute
-> (a -> Attribute)
-> ((Html -> Html) -> c -> Html)
-> Attribute
-> Colonnade h a c
-> f a
-> Html
encodeTable
((Attribute, Attribute) -> Headed (Attribute, Attribute)
forall a. a -> Headed a
forall (h :: * -> *) a. Headedness h => a -> h a
E.headednessPure (Attribute
forall a. Monoid a => a
mempty, Attribute
forall a. Monoid a => a
mempty))
Attribute
forall a. Monoid a => a
mempty
(Attribute -> a -> Attribute
forall a b. a -> b -> a
const Attribute
forall a. Monoid a => a
mempty)
(Html -> Html) -> Cell -> Html
htmlFromCell
encodeHtmlTable ::
(Foldable f, E.Headedness h) =>
Attribute ->
Colonnade h a Html ->
f a ->
Html
encodeHtmlTable :: forall (f :: * -> *) (h :: * -> *) a.
(Foldable f, Headedness h) =>
Attribute -> Colonnade h a Html -> f a -> Html
encodeHtmlTable =
h (Attribute, Attribute)
-> Attribute
-> (a -> Attribute)
-> ((Html -> Html) -> Html -> Html)
-> Attribute
-> Colonnade h a Html
-> f a
-> Html
forall (h :: * -> *) (f :: * -> *) a c.
(Foldable f, Headedness h) =>
h (Attribute, Attribute)
-> Attribute
-> (a -> Attribute)
-> ((Html -> Html) -> c -> Html)
-> Attribute
-> Colonnade h a c
-> f a
-> Html
encodeTable
((Attribute, Attribute) -> h (Attribute, Attribute)
forall a. a -> h a
forall (h :: * -> *) a. Headedness h => a -> h a
E.headednessPure (Attribute
forall a. Monoid a => a
mempty, Attribute
forall a. Monoid a => a
mempty))
Attribute
forall a. Monoid a => a
mempty
(Attribute -> a -> Attribute
forall a b. a -> b -> a
const Attribute
forall a. Monoid a => a
mempty)
(Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
($)
htmlFromCell :: (Html -> Html) -> Cell -> Html
htmlFromCell :: (Html -> Html) -> Cell -> Html
htmlFromCell Html -> Html
f (Cell Attribute
attr Html
content) = Html -> Html
f (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! Attribute
attr (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
content
data St = St
{ St -> [String]
_stContext :: [String]
, St -> TagStatus
_stTagStatus :: TagStatus
, St -> String -> String
stResult :: String -> String
}
data TagStatus
= TagStatusSomeTag
| TagStatusOpening (String -> String)
| TagStatusOpeningAttrs
| TagStatusNormal
| TagStatusClosing (String -> String)
| TagStatusAfterTag
removeWhitespaceAfterTag :: String -> String -> String
removeWhitespaceAfterTag :: String -> String -> String
removeWhitespaceAfterTag String
chosenTag =
(String -> String) -> (St -> String) -> Either String St -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> String
forall a. a -> a
id (\St
st -> St -> String -> String
stResult St
st String
"") (Either String St -> String)
-> (String -> Either String St) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (St -> Char -> Either String St)
-> St -> String -> Either String St
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM ((Char -> St -> Either String St) -> St -> Char -> Either String St
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> St -> Either String St
f) ([String] -> TagStatus -> (String -> String) -> St
St [] TagStatus
TagStatusNormal String -> String
forall a. a -> a
id)
where
f :: Char -> St -> Either String St
f :: Char -> St -> Either String St
f Char
c (St [String]
ctx TagStatus
status String -> String
res) = case TagStatus
status of
TagStatus
TagStatusNormal
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'<' -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx TagStatus
TagStatusSomeTag String -> String
likelyRes)
| Char -> Bool
isSpace Char
c ->
if String -> Maybe String
forall a. a -> Maybe a
Just String
chosenTag Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe [String]
ctx
then St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx TagStatus
TagStatusNormal String -> String
res)
else St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx TagStatus
TagStatusNormal String -> String
likelyRes)
| Bool
otherwise -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx TagStatus
TagStatusNormal String -> String
likelyRes)
TagStatus
TagStatusSomeTag
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx ((String -> String) -> TagStatus
TagStatusClosing String -> String
forall a. a -> a
id) String -> String
likelyRes)
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'>' -> String -> Either String St
forall a b. a -> Either a b
Left String
"unexpected >"
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'<' -> String -> Either String St
forall a b. a -> Either a b
Left String
"unexpected <"
| Bool
otherwise -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx ((String -> String) -> TagStatus
TagStatusOpening (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
:)) String -> String
likelyRes)
TagStatusOpening String -> String
tag
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'>' -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St (String -> String
tag String
"" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
ctx) TagStatus
TagStatusAfterTag String -> String
likelyRes)
| Char -> Bool
isSpace Char
c -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St (String -> String
tag String
"" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
ctx) TagStatus
TagStatusOpeningAttrs String -> String
likelyRes)
| Bool
otherwise -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx ((String -> String) -> TagStatus
TagStatusOpening (String -> String
tag (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
:))) String -> String
likelyRes)
TagStatus
TagStatusOpeningAttrs
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'>' -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx TagStatus
TagStatusAfterTag String -> String
likelyRes)
| Bool
otherwise -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx TagStatus
TagStatusOpeningAttrs String -> String
likelyRes)
TagStatusClosing String -> String
tag
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'>' -> do
[String]
otherTags <- case [String]
ctx of
[] -> String -> Either String [String]
forall a b. a -> Either a b
Left String
"closing tag without any opening tag"
String
closestTag : [String]
otherTags ->
if String
closestTag String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> String
tag String
""
then [String] -> Either String [String]
forall a b. b -> Either a b
Right [String]
otherTags
else String -> Either String [String]
forall a b. a -> Either a b
Left (String -> Either String [String])
-> String -> Either String [String]
forall a b. (a -> b) -> a -> b
$ String
"closing tag <" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
tag String
"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"> did not match opening tag <" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
closestTag String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"
St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
otherTags TagStatus
TagStatusAfterTag String -> String
likelyRes)
| Bool
otherwise -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx ((String -> String) -> TagStatus
TagStatusClosing (String -> String
tag (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
:))) String -> String
likelyRes)
TagStatus
TagStatusAfterTag
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'<' -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx TagStatus
TagStatusSomeTag String -> String
likelyRes)
| Char -> Bool
isSpace Char
c ->
if String -> Maybe String
forall a. a -> Maybe a
Just String
chosenTag Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe [String]
ctx
then St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx TagStatus
TagStatusAfterTag String -> String
res)
else St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx TagStatus
TagStatusNormal String -> String
likelyRes)
| Bool
otherwise -> St -> Either String St
forall a b. b -> Either a b
Right ([String] -> TagStatus -> (String -> String) -> St
St [String]
ctx TagStatus
TagStatusNormal String -> String
likelyRes)
where
likelyRes :: String -> String
likelyRes :: String -> String
likelyRes = String -> String
res (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
:)
printCompactHtml :: Html -> IO ()
printCompactHtml :: Html -> IO ()
printCompactHtml =
String -> IO ()
putStrLn
(String -> IO ()) -> (Html -> String) -> Html -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
List.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n')
(String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
removeWhitespaceAfterTag String
"td"
(String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
removeWhitespaceAfterTag String
"th"
(String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
removeWhitespaceAfterTag String
"strong"
(String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
removeWhitespaceAfterTag String
"span"
(String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
removeWhitespaceAfterTag String
"em"
(String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> String
Pretty.renderHtml
printVeryCompactHtml :: Html -> IO ()
printVeryCompactHtml :: Html -> IO ()
printVeryCompactHtml =
String -> IO ()
putStrLn
(String -> IO ()) -> (Html -> String) -> Html -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
List.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n')
(String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
removeWhitespaceAfterTag String
"td"
(String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
removeWhitespaceAfterTag String
"th"
(String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
removeWhitespaceAfterTag String
"strong"
(String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
removeWhitespaceAfterTag String
"span"
(String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
removeWhitespaceAfterTag String
"em"
(String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
removeWhitespaceAfterTag String
"tr"
(String -> String) -> (Html -> String) -> Html -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> String
Pretty.renderHtml