{-# LANGUAGE OverloadedStrings #-}
-- | Bindings from `xml-conduit` to `haskell-stylist`.
module Data.HTML2CSS(
        html2css, -- parsing
        el2styletree, els2stylist, el2stylist -- application
    ) 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

---- Parsing
-- | Converts a parsed XML or HTML file to a `ConditionalStyles` `StyleSheet`.
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 -- Unsupported stylesheet.
    | 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
-- We do want to read in comments for CSS, just not for display.
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
""

---- Styling

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