{-# LANGUAGE OverloadedStrings #-}
module Data.HTML2CSS(
html2css,
el2styletree, els2stylist, el2stylist
) where
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Text as Txt
import Data.Maybe
import qualified Text.XML as XML
import Stylist.Parse
import Stylist
import Stylist.Tree
import Data.CSS.Syntax.Tokens
import Network.URI
html2css :: StyleSheet s => XML.Document -> URI -> s -> s
html2css :: forall s. StyleSheet s => Document -> URI -> s -> s
html2css Document
xml URI
url s
self = Element -> URI -> s -> s
forall s. StyleSheet s => Element -> URI -> s -> s
html2css' (Document -> Element
XML.documentRoot Document
xml) URI
url s
self
html2css' :: StyleSheet s => XML.Element -> URI -> s -> s
html2css' :: forall s. StyleSheet s => Element -> URI -> s -> s
html2css' (XML.Element (XML.Name Text
"style" Maybe Text
_ Maybe Text
_) Map Name Text
attrs [Node]
children) URI
url s
self
| Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
"type" Map Name Text
attrs Maybe Text -> [Maybe Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Maybe Text
forall a. Maybe a
Nothing, Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"text/css"] = s
self
| Just Text
media <- Name
"media" Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map Name Text
attrs =
(s, [Token]) -> s
forall a b. (a, b) -> a
fst ((s, [Token]) -> s) -> (s, [Token]) -> s
forall a b. (a -> b) -> a -> b
$ s -> Text -> [Token] -> (s, [Token])
forall s. StyleSheet s => s -> Text -> [Token] -> (s, [Token])
addAtRule s
self Text
"media" (Text -> [Token]
tokenize Text
media [Token] -> [Token] -> [Token]
forall a. [a] -> [a] -> [a]
++
Token
LeftCurlyBracket Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: URI -> [Node] -> [Token]
tokContent URI
url [Node]
children [Token] -> [Token] -> [Token]
forall a. [a] -> [a] -> [a]
++ [Token
RightCurlyBracket])
| Bool
otherwise = s -> URI -> Text -> s
forall s. StyleSheet s => s -> URI -> Text -> s
parseForURL s
self URI
url (Text -> s) -> Text -> s
forall a b. (a -> b) -> a -> b
$ [Node] -> Text
strContent [Node]
children
html2css' (XML.Element (XML.Name Text
"link" Maybe Text
_ Maybe Text
_) Map Name Text
attrs [Node]
_) URI
baseURL s
self
| Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
"type" Map Name Text
attrs Maybe Text -> [Maybe Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Maybe Text
forall a. Maybe a
Nothing, Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"text/css"],
Just Text
"stylesheet" <- Name
"rel" Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map Name Text
attrs,
Just Text
link <- Name
"href" Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map Name Text
attrs,
Just URI
url <- String -> Maybe URI
parseURIReference (String -> Maybe URI) -> String -> Maybe URI
forall a b. (a -> b) -> a -> b
$ Text -> String
Txt.unpack Text
link =
(s, [Token]) -> s
forall a b. (a, b) -> a
fst ((s, [Token]) -> s) -> (s, [Token]) -> s
forall a b. (a -> b) -> a -> b
$ s -> Text -> [Token] -> (s, [Token])
forall s. StyleSheet s => s -> Text -> [Token] -> (s, [Token])
addAtRule s
self Text
"import" (
Text -> Token
Url (String -> Text
Txt.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ URI -> String
uriToString' (URI -> String) -> URI -> String
forall a b. (a -> b) -> a -> b
$ URI -> URI -> URI
relativeTo URI
url URI
baseURL) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:
[Token] -> Maybe [Token] -> [Token]
forall a. a -> Maybe a -> a
fromMaybe [] (Text -> [Token]
tokenize (Text -> [Token]) -> Maybe Text -> Maybe [Token]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
"media" Map Name Text
attrs) [Token] -> [Token] -> [Token]
forall a. [a] -> [a] -> [a]
++
[Token
Semicolon])
html2css' (XML.Element Name
_ Map Name Text
_ [Node]
children) URI
url s
self =
(s -> Element -> s) -> s -> [Element] -> s
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' (\s
s Element
el -> Element -> URI -> s -> s
forall s. StyleSheet s => Element -> URI -> s -> s
html2css' Element
el URI
url s
s) s
self [Element
el | XML.NodeElement Element
el <- [Node]
children]
strContent :: [XML.Node] -> Txt.Text
strContent :: [Node] -> Text
strContent (XML.NodeContent Text
text : [Node]
rest) = Text
text Text -> Text -> Text
`Txt.append` [Node] -> Text
strContent [Node]
rest
strContent (XML.NodeComment Text
text : [Node]
rest) = Text
text Text -> Text -> Text
`Txt.append` [Node] -> Text
strContent [Node]
rest
strContent (XML.NodeElement (XML.Element Name
_ Map Name Text
_ [Node]
children):[Node]
rest) =
[Node] -> Text
strContent [Node]
children Text -> Text -> Text
`Txt.append` [Node] -> Text
strContent [Node]
rest
strContent (Node
_:[Node]
rest) = [Node] -> Text
strContent [Node]
rest
strContent [] = Text
""
tokContent :: URI -> [XML.Node] -> [Token]
tokContent :: URI -> [Node] -> [Token]
tokContent URI
baseURL = (Token -> Token) -> [Token] -> [Token]
forall a b. (a -> b) -> [a] -> [b]
map Token -> Token
absolutizeUrl ([Token] -> [Token]) -> ([Node] -> [Token]) -> [Node] -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Token]
tokenize (Text -> [Token]) -> ([Node] -> Text) -> [Node] -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> Text
strContent
where
absolutizeUrl :: Token -> Token
absolutizeUrl (Url Text
link) | Just URI
url <- String -> Maybe URI
parseURIReference (String -> Maybe URI) -> String -> Maybe URI
forall a b. (a -> b) -> a -> b
$ Text -> String
Txt.unpack Text
link =
Text -> Token
Url (Text -> Token) -> Text -> Token
forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ URI -> String
uriToString' (URI -> String) -> URI -> String
forall a b. (a -> b) -> a -> b
$ URI -> URI -> URI
relativeTo URI
url URI
baseURL
uriToString' :: URI -> String
uriToString' URI
uri = (String -> String) -> URI -> String -> String
uriToString String -> String
forall a. a -> a
id URI
uri String
""
el2styletree :: Element -> StyleTree (Either Element [(a, [Token])])
el2styletree Element
el = Either Element [(a, [Token])]
-> [StyleTree (Either Element [(a, [Token])])]
-> StyleTree (Either Element [(a, [Token])])
forall p. p -> [StyleTree p] -> StyleTree p
StyleTree (Element -> Either Element [(a, [Token])]
forall a b. a -> Either a b
Left Element
el) ([StyleTree (Either Element [(a, [Token])])]
-> StyleTree (Either Element [(a, [Token])]))
-> [StyleTree (Either Element [(a, [Token])])]
-> StyleTree (Either Element [(a, [Token])])
forall a b. (a -> b) -> a -> b
$ (Node -> Maybe (StyleTree (Either Element [(a, [Token])])))
-> [Node] -> [StyleTree (Either Element [(a, [Token])])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Node -> Maybe (StyleTree (Either Element [(a, [Token])]))
node2styletree ([Node] -> [StyleTree (Either Element [(a, [Token])])])
-> [Node] -> [StyleTree (Either Element [(a, [Token])])]
forall a b. (a -> b) -> a -> b
$ Element -> [Node]
XML.elementNodes Element
el
node2styletree :: Node -> Maybe (StyleTree (Either Element [(a, [Token])]))
node2styletree (XML.NodeElement Element
el) = StyleTree (Either Element [(a, [Token])])
-> Maybe (StyleTree (Either Element [(a, [Token])]))
forall a. a -> Maybe a
Just (StyleTree (Either Element [(a, [Token])])
-> Maybe (StyleTree (Either Element [(a, [Token])])))
-> StyleTree (Either Element [(a, [Token])])
-> Maybe (StyleTree (Either Element [(a, [Token])]))
forall a b. (a -> b) -> a -> b
$ Element -> StyleTree (Either Element [(a, [Token])])
el2styletree Element
el
node2styletree (XML.NodeContent Text
txt) = StyleTree (Either Element [(a, [Token])])
-> Maybe (StyleTree (Either Element [(a, [Token])]))
forall a. a -> Maybe a
Just (StyleTree (Either Element [(a, [Token])])
-> Maybe (StyleTree (Either Element [(a, [Token])])))
-> StyleTree (Either Element [(a, [Token])])
-> Maybe (StyleTree (Either Element [(a, [Token])]))
forall a b. (a -> b) -> a -> b
$ Either Element [(a, [Token])]
-> [StyleTree (Either Element [(a, [Token])])]
-> StyleTree (Either Element [(a, [Token])])
forall p. p -> [StyleTree p] -> StyleTree p
StyleTree ([(a, [Token])] -> Either Element [(a, [Token])]
forall a b. b -> Either a b
Right [
(a
"content", [Text -> Token
String Text
txt]), (a
"display", [Text -> Token
Ident Text
"inline"])]) []
node2styletree Node
_ = Maybe (StyleTree (Either Element [(a, [Token])]))
forall a. Maybe a
Nothing
previous' :: Maybe Element -> Maybe Element
previous' (Just ElementNode {name :: Element -> Text
name = Text
"", previous :: Element -> Maybe Element
previous = Maybe Element
prev'}) = Maybe Element -> Maybe Element
previous' Maybe Element
prev'
previous' Maybe Element
prev' = Maybe Element
prev'
els2stylist :: StyleTree (Either Element [(Text, [Token])]) -> StyleTree Element
els2stylist = (Maybe Element
-> Maybe Element -> Either Element [(Text, [Token])] -> Element)
-> StyleTree (Either Element [(Text, [Token])])
-> StyleTree Element
forall b a.
(Maybe b -> Maybe b -> a -> b) -> StyleTree a -> StyleTree b
preorder Maybe Element
-> Maybe Element -> Either Element [(Text, [Token])] -> Element
els2stylist'
els2stylist' :: Maybe Element
-> Maybe Element -> Either Element [(Text, [Token])] -> Element
els2stylist' Maybe Element
parent Maybe Element
previous (Left (XML.Element (XML.Name Text
name Maybe Text
ns Maybe Text
_) Map Name Text
attrs [Node]
_)) =
ElementNode :: Maybe Element
-> Maybe Element -> Text -> Text -> [Attribute] -> Element
ElementNode {
name :: Text
name = Text
name, namespace :: Text
namespace = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
ns,
attributes :: [Attribute]
attributes = [Attribute] -> [Attribute]
forall a. Ord a => [a] -> [a]
L.sort [
Text -> Text -> String -> Attribute
Attribute Text
n (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
ns) (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ Text -> String
Txt.unpack Text
v | (XML.Name Text
n Maybe Text
ns Maybe Text
_, Text
v) <- Map Name Text -> [(Name, Text)]
forall k a. Map k a -> [(k, a)]
M.toList Map Name Text
attrs
],
parent :: Maybe Element
parent = Maybe Element
parent, previous :: Maybe Element
previous = Maybe Element -> Maybe Element
previous' Maybe Element
previous
}
els2stylist' Maybe Element
parent Maybe Element
previous (Right [(Text, [Token])]
attrs) = ElementNode :: Maybe Element
-> Maybe Element -> Text -> Text -> [Attribute] -> Element
ElementNode {
name :: Text
name = Text
"", namespace :: Text
namespace = Text
"",
attributes :: [Attribute]
attributes = [Text -> Text -> String -> Attribute
Attribute Text
"style" Text
"" (String -> Attribute) -> String -> Attribute
forall a b. (a -> b) -> a -> b
$ Text -> String
Txt.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Txt.concat [Text]
style],
parent :: Maybe Element
parent = Maybe Element
parent, previous :: Maybe Element
previous = Maybe Element -> Maybe Element
previous' Maybe Element
previous
} where style :: [Text]
style = [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Text
prop, Text
": ", [Token] -> Text
serialize [Token]
v, Text
"; "] | (Text
prop, [Token]
v) <- [(Text, [Token])]
attrs]
el2stylist :: Element -> StyleTree Element
el2stylist = StyleTree (Either Element [(Text, [Token])]) -> StyleTree Element
els2stylist (StyleTree (Either Element [(Text, [Token])]) -> StyleTree Element)
-> (Element -> StyleTree (Either Element [(Text, [Token])]))
-> Element
-> StyleTree Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> StyleTree (Either Element [(Text, [Token])])
forall {a}.
IsString a =>
Element -> StyleTree (Either Element [(a, [Token])])
el2styletree