{-# LANGUAGE OverloadedStrings #-}
-- | Parses a CSS stylesheet
-- See `StyleSheet` & `parseForURL`.
module Stylist.Parse (
        parse, parse', parseForURL, TrivialStyleSheet(..),
        StyleSheet(..), skipAtRule, scanAtRule, scanBlock, skipSpace,
        StyleRule(..),
        -- For parsing at-rules, HTML "style" attribute, etc.
        parseProperties, parseProperties',
        -- for testing
        scanValue
    ) where

import Data.CSS.Syntax.Tokens
import Stylist.Parse.Selector
import Stylist.Parse.Util

import Data.Text.Internal (Text(..))
import Data.Text (pack, unpack)
import Network.URI (parseRelativeReference, relativeTo, uriToString, URI(..))

--------
---- Output type class
--------
-- | Describes how to store, and to some extent parse, CSS stylesheets.
-- These methods are used to construct the results from `parse`, etc.
class StyleSheet s where
    -- | Sets the stylesheet priority (useragent vs user vs author), optional.
    -- Favor `setPriorities` for richer API.
    setPriority :: Int -> s -> s
    setPriority v :: Int
v self :: s
self = [Int] -> s -> s
forall s. StyleSheet s => [Int] -> s -> s
setPriorities [Int
v] s
self
    -- | Sets the multi-layered stylesheet priority (for the sake of @layer rules), optional.
    setPriorities :: [Int] -> s -> s
    setPriorities _ = s -> s
forall a. a -> a
id
    -- | Stores a parsed selector+properties rule.
    addRule :: s -> StyleRule -> s
    -- | Stores and parses an identified at-rule.
    addAtRule :: s -> Text -> [Token] -> (s, [Token])
    addAtRule self :: s
self _ tokens :: [Token]
tokens = (s
self, [Token] -> [Token]
skipAtRule [Token]
tokens)

-- | Stores the parsed selector*s*+proeprties rule.
addRules :: StyleSheet ss => ss -> ([Selector], ([(Text, [Token])], Text)) -> ss
addRules :: ss -> ([Selector], ([(Text, [Token])], Text)) -> ss
addRules self :: ss
self (selector :: Selector
selector:selectors :: [Selector]
selectors, val :: ([(Text, [Token])], Text)
val@(props :: [(Text, [Token])]
props, psuedoel :: Text
psuedoel)) = ss -> ([Selector], ([(Text, [Token])], Text)) -> ss
forall ss.
StyleSheet ss =>
ss -> ([Selector], ([(Text, [Token])], Text)) -> ss
addRules ss
self' ([Selector]
selectors, ([(Text, [Token])], Text)
val)
    where self' :: ss
self' = ss -> StyleRule -> ss
forall s. StyleSheet s => s -> StyleRule -> s
addRule ss
self (StyleRule -> ss) -> StyleRule -> ss
forall a b. (a -> b) -> a -> b
$ Selector -> [(Text, [Token])] -> Text -> StyleRule
StyleRule Selector
selector [(Text, [Token])]
props Text
psuedoel
addRules self :: ss
self ([], _) = ss
self

-- | The properties to set for elements matching the given selector.
data StyleRule = StyleRule Selector [(Text, [Token])] Text deriving (Int -> StyleRule -> ShowS
[StyleRule] -> ShowS
StyleRule -> String
(Int -> StyleRule -> ShowS)
-> (StyleRule -> String)
-> ([StyleRule] -> ShowS)
-> Show StyleRule
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StyleRule] -> ShowS
$cshowList :: [StyleRule] -> ShowS
show :: StyleRule -> String
$cshow :: StyleRule -> String
showsPrec :: Int -> StyleRule -> ShowS
$cshowsPrec :: Int -> StyleRule -> ShowS
Show, StyleRule -> StyleRule -> Bool
(StyleRule -> StyleRule -> Bool)
-> (StyleRule -> StyleRule -> Bool) -> Eq StyleRule
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StyleRule -> StyleRule -> Bool
$c/= :: StyleRule -> StyleRule -> Bool
== :: StyleRule -> StyleRule -> Bool
$c== :: StyleRule -> StyleRule -> Bool
Eq)

-- | Gathers StyleRules into a list, mainly for testing.
data TrivialStyleSheet = TrivialStyleSheet [StyleRule] deriving (Int -> TrivialStyleSheet -> ShowS
[TrivialStyleSheet] -> ShowS
TrivialStyleSheet -> String
(Int -> TrivialStyleSheet -> ShowS)
-> (TrivialStyleSheet -> String)
-> ([TrivialStyleSheet] -> ShowS)
-> Show TrivialStyleSheet
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TrivialStyleSheet] -> ShowS
$cshowList :: [TrivialStyleSheet] -> ShowS
show :: TrivialStyleSheet -> String
$cshow :: TrivialStyleSheet -> String
showsPrec :: Int -> TrivialStyleSheet -> ShowS
$cshowsPrec :: Int -> TrivialStyleSheet -> ShowS
Show, TrivialStyleSheet -> TrivialStyleSheet -> Bool
(TrivialStyleSheet -> TrivialStyleSheet -> Bool)
-> (TrivialStyleSheet -> TrivialStyleSheet -> Bool)
-> Eq TrivialStyleSheet
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TrivialStyleSheet -> TrivialStyleSheet -> Bool
$c/= :: TrivialStyleSheet -> TrivialStyleSheet -> Bool
== :: TrivialStyleSheet -> TrivialStyleSheet -> Bool
$c== :: TrivialStyleSheet -> TrivialStyleSheet -> Bool
Eq)
instance StyleSheet TrivialStyleSheet where
    addRule :: TrivialStyleSheet -> StyleRule -> TrivialStyleSheet
addRule (TrivialStyleSheet self :: [StyleRule]
self) rule :: StyleRule
rule = [StyleRule] -> TrivialStyleSheet
TrivialStyleSheet ([StyleRule] -> TrivialStyleSheet)
-> [StyleRule] -> TrivialStyleSheet
forall a b. (a -> b) -> a -> b
$ StyleRule
ruleStyleRule -> [StyleRule] -> [StyleRule]
forall a. a -> [a] -> [a]
:[StyleRule]
self

-- | In case an indirect caller doesn't actually want to use Haskell Stylist.
instance StyleSheet () where
    addRule :: () -> StyleRule -> ()
addRule () _ = ()

--------
---- Basic parsing
--------
-- | Parse a CSS stylesheet
parse :: StyleSheet s => s -> Text -> s
parse :: s -> Text -> s
parse stylesheet :: s
stylesheet source :: Text
source = s -> [Token] -> s
forall t. StyleSheet t => t -> [Token] -> t
parse' s
stylesheet ([Token] -> s) -> [Token] -> s
forall a b. (a -> b) -> a -> b
$ Text -> [Token]
tokenize Text
source

-- | Parse a CSS stylesheet, resolving all URLs to absolute form.
parseForURL :: StyleSheet s => s -> URI -> Text -> s
parseForURL :: s -> URI -> Text -> s
parseForURL stylesheet :: s
stylesheet base :: URI
base source :: Text
source = s -> [Token] -> s
forall t. StyleSheet t => t -> [Token] -> t
parse' s
stylesheet ([Token] -> s) -> [Token] -> s
forall a b. (a -> b) -> a -> b
$ [Token] -> [Token]
rewriteURLs ([Token] -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$ Text -> [Token]
tokenize Text
source
    where
        rewriteURLs :: [Token] -> [Token]
rewriteURLs (Url text :: Text
text:toks :: [Token]
toks)
            | Just url :: URI
url <- String -> Maybe URI
parseRelativeReference (String -> Maybe URI) -> String -> Maybe URI
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
text =
                Text -> Token
Url (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ShowS -> URI -> ShowS
uriToString ShowS
forall a. a -> a
id (URI -> URI -> URI
relativeTo URI
url URI
base) "") Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token] -> [Token]
rewriteURLs [Token]
toks
            | Bool
otherwise = Text -> Token
Function "url" Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Token
RightParen Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token] -> [Token]
rewriteURLs [Token]
toks
        rewriteURLs (tok :: Token
tok:toks :: [Token]
toks) = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token] -> [Token]
rewriteURLs [Token]
toks
        rewriteURLs [] = []

-- | Parse a tokenized (via `css-syntax`) CSS stylesheet
parse' :: StyleSheet t => t -> [Token] -> t
-- Things to skip.
parse' :: t -> [Token] -> t
parse' stylesheet :: t
stylesheet (Whitespace:tokens :: [Token]
tokens) = t -> [Token] -> t
forall t. StyleSheet t => t -> [Token] -> t
parse' t
stylesheet [Token]
tokens
parse' stylesheet :: t
stylesheet (CDO:tokens :: [Token]
tokens) = t -> [Token] -> t
forall t. StyleSheet t => t -> [Token] -> t
parse' t
stylesheet [Token]
tokens
parse' stylesheet :: t
stylesheet (CDC:tokens :: [Token]
tokens) = t -> [Token] -> t
forall t. StyleSheet t => t -> [Token] -> t
parse' t
stylesheet [Token]
tokens
parse' stylesheet :: t
stylesheet (Comma:tokens :: [Token]
tokens) = t -> [Token] -> t
forall t. StyleSheet t => t -> [Token] -> t
parse' t
stylesheet [Token]
tokens -- TODO issue warnings.

parse' stylesheet :: t
stylesheet [] = t
stylesheet

parse' stylesheet :: t
stylesheet (AtKeyword kind :: Text
kind:tokens :: [Token]
tokens) = t -> [Token] -> t
forall t. StyleSheet t => t -> [Token] -> t
parse' t
stylesheet' [Token]
tokens'
    where (stylesheet' :: t
stylesheet', tokens' :: [Token]
tokens') = t -> Text -> [Token] -> (t, [Token])
forall s. StyleSheet s => s -> Text -> [Token] -> (s, [Token])
addAtRule t
stylesheet Text
kind ([Token] -> (t, [Token])) -> [Token] -> (t, [Token])
forall a b. (a -> b) -> a -> b
$ [Token] -> [Token]
skipSpace [Token]
tokens
parse' stylesheet :: t
stylesheet tokens :: [Token]
tokens = t -> [Token] -> t
forall t. StyleSheet t => t -> [Token] -> t
parse' (t -> ([Selector], ([(Text, [Token])], Text)) -> t
forall ss.
StyleSheet ss =>
ss -> ([Selector], ([(Text, [Token])], Text)) -> ss
addRules t
stylesheet ([Selector], ([(Text, [Token])], Text))
rule) [Token]
tokens'
    where (rule :: ([Selector], ([(Text, [Token])], Text))
rule, tokens' :: [Token]
tokens') = ([Selector]
 -> ([(Text, [Token])], Text)
 -> ([Selector], ([(Text, [Token])], Text)))
-> Parser [Selector]
-> Parser ([(Text, [Token])], Text)
-> Parser ([Selector], ([(Text, [Token])], Text))
forall a b c. (a -> b -> c) -> Parser a -> Parser b -> Parser c
concatP (,) Parser [Selector]
parseSelectors Parser ([(Text, [Token])], Text)
parseProperties [Token]
tokens

--------
---- Property parsing
--------
-- | Parse "{key: value; ...}" property values, with a psuedoelement.
parseProperties :: Parser ([(Text, [Token])], Text)
parseProperties :: Parser ([(Text, [Token])], Text)
parseProperties (LeftCurlyBracket:tokens :: [Token]
tokens) = ([(Text, [Token])], [Token])
-> (([(Text, [Token])], Text), [Token])
forall x y. (x, y) -> ((x, Text), y)
noPsuedoel (([(Text, [Token])], [Token])
 -> (([(Text, [Token])], Text), [Token]))
-> ([(Text, [Token])], [Token])
-> (([(Text, [Token])], Text), [Token])
forall a b. (a -> b) -> a -> b
$ Parser [(Text, [Token])]
parseProperties' [Token]
tokens
parseProperties (Whitespace:tokens :: [Token]
tokens) = Parser ([(Text, [Token])], Text)
parseProperties [Token]
tokens
parseProperties (Colon:Colon:Ident n :: Text
n:tokens :: [Token]
tokens) = (([(Text, [Token])]
val, Text
n), [Token]
tokens')
    where ((val :: [(Text, [Token])]
val, _), tokens' :: [Token]
tokens') = Parser ([(Text, [Token])], Text)
parseProperties [Token]
tokens
-- This error recovery is a bit overly conservative, but it's simple.
parseProperties (_:tokens :: [Token]
tokens) = ([(Text, [Token])], [Token])
-> (([(Text, [Token])], Text), [Token])
forall x y. (x, y) -> ((x, Text), y)
noPsuedoel ([], [Token] -> [Token]
skipAtRule [Token]
tokens)
parseProperties [] = ([(Text, [Token])], [Token])
-> (([(Text, [Token])], Text), [Token])
forall x y. (x, y) -> ((x, Text), y)
noPsuedoel ([], [])

noPsuedoel :: (x, y) -> ((x, Text), y)
noPsuedoel :: (x, y) -> ((x, Text), y)
noPsuedoel (val :: x
val, tokens :: y
tokens) = ((x
val, ""), y
tokens)

-- | Parse "key: value;"... property values, as per the HTML "style" property.
parseProperties' :: Parser [(Text, [Token])]
parseProperties' :: Parser [(Text, [Token])]
parseProperties' (Whitespace:tokens :: [Token]
tokens) = Parser [(Text, [Token])]
parseProperties' [Token]
tokens
parseProperties' (Ident name :: Text
name:tokens :: [Token]
tokens)
    | Colon:tokens' :: [Token]
tokens' <- [Token] -> [Token]
skipSpace [Token]
tokens =
        ([Token] -> [(Text, [Token])] -> [(Text, [Token])])
-> Parser [Token]
-> Parser [(Text, [Token])]
-> Parser [(Text, [Token])]
forall a b c. (a -> b -> c) -> Parser a -> Parser b -> Parser c
concatP [Token] -> [(Text, [Token])] -> [(Text, [Token])]
forall b. b -> [(Text, b)] -> [(Text, b)]
appendProp Parser [Token]
scanValue Parser [(Text, [Token])]
parseProperties' [Token]
tokens'
    where appendProp :: b -> [(Text, b)] -> [(Text, b)]
appendProp value :: b
value props :: [(Text, b)]
props = (Text
name, b
value)(Text, b) -> [(Text, b)] -> [(Text, b)]
forall a. a -> [a] -> [a]
:[(Text, b)]
props
parseProperties' (RightCurlyBracket:tokens :: [Token]
tokens) = ([], [Token]
tokens)
parseProperties' [] = ([], [])
parseProperties' tokens :: [Token]
tokens = Parser [(Text, [Token])]
parseProperties' ([Token] -> [Token]
skipValue [Token]
tokens)

--------
---- Skipping/Scanning utilities
--------
-- | Returns tokens before & after an at-rule value, terminated after a curly-bracketed block or a semicolon.
scanAtRule :: Parser [Token]
scanAtRule :: Parser [Token]
scanAtRule (Semicolon:tokens :: [Token]
tokens) = ([Token
Semicolon], [Token]
tokens)
scanAtRule tokens :: [Token]
tokens@(LeftCurlyBracket:_) = [Token] -> Parser [Token] -> ([Token], [Token])
scanInner [Token]
tokens (Parser [Token] -> ([Token], [Token]))
-> Parser [Token] -> ([Token], [Token])
forall a b. (a -> b) -> a -> b
$ \rest :: [Token]
rest -> ([], [Token]
rest)

scanAtRule tokens :: [Token]
tokens@(LeftParen:_) = [Token] -> Parser [Token] -> ([Token], [Token])
scanInner [Token]
tokens Parser [Token]
scanValue
scanAtRule tokens :: [Token]
tokens@(Function _:_) = [Token] -> Parser [Token] -> ([Token], [Token])
scanInner [Token]
tokens Parser [Token]
scanValue
scanAtRule tokens :: [Token]
tokens@(LeftSquareBracket:_) = [Token] -> Parser [Token] -> ([Token], [Token])
scanInner [Token]
tokens Parser [Token]
scanValue
-- To ensure parens are balanced, should already be handled.
scanAtRule (RightCurlyBracket:tokens :: [Token]
tokens) = ([], Token
RightCurlyBracketToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:[Token]
tokens)
scanAtRule (RightParen:tokens :: [Token]
tokens) = ([], Token
RightParenToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:[Token]
tokens)
scanAtRule (RightSquareBracket:tokens :: [Token]
tokens) = ([], Token
RightSquareBracketToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:[Token]
tokens)

scanAtRule tokens :: [Token]
tokens = Parser [Token] -> Parser [Token]
capture Parser [Token]
scanAtRule [Token]
tokens

-- | Returns tokens after an at-rule, as per `scanAtRule`.
skipAtRule :: [Token] -> [Token]
skipAtRule :: [Token] -> [Token]
skipAtRule tokens :: [Token]
tokens = ([Token], [Token]) -> [Token]
forall a b. (a, b) -> b
snd (([Token], [Token]) -> [Token]) -> ([Token], [Token]) -> [Token]
forall a b. (a -> b) -> a -> b
$ Parser [Token]
scanAtRule [Token]
tokens

-- | Returns tokens before & after a semicolon.
scanValue :: Parser [Token]
scanValue :: Parser [Token]
scanValue (Semicolon:tokens :: [Token]
tokens) = ([], [Token]
tokens)
scanValue (Whitespace:tokens :: [Token]
tokens) = Parser [Token]
scanValue [Token]
tokens

scanValue tokens :: [Token]
tokens@(LeftCurlyBracket:_) = [Token] -> Parser [Token] -> ([Token], [Token])
scanInner [Token]
tokens Parser [Token]
scanValue
scanValue tokens :: [Token]
tokens@(LeftParen:_) = [Token] -> Parser [Token] -> ([Token], [Token])
scanInner [Token]
tokens Parser [Token]
scanValue
scanValue tokens :: [Token]
tokens@(Function _:_) = [Token] -> Parser [Token] -> ([Token], [Token])
scanInner [Token]
tokens Parser [Token]
scanValue
scanValue tokens :: [Token]
tokens@(LeftSquareBracket:_) = [Token] -> Parser [Token] -> ([Token], [Token])
scanInner [Token]
tokens Parser [Token]
scanValue
-- To ensure parens are balanced, should already be handled.
scanValue (RightCurlyBracket:tokens :: [Token]
tokens) = ([], Token
RightCurlyBracketToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:[Token]
tokens)
scanValue (RightParen:tokens :: [Token]
tokens) = ([], Token
RightParenToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:[Token]
tokens)
scanValue (RightSquareBracket:tokens :: [Token]
tokens) = ([], Token
RightSquareBracketToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:[Token]
tokens)

scanValue tokens :: [Token]
tokens = Parser [Token] -> Parser [Token]
capture Parser [Token]
scanValue [Token]
tokens

-- | Returns tokens after a semicolon.
skipValue :: [Token] -> [Token]
skipValue :: [Token] -> [Token]
skipValue tokens :: [Token]
tokens = ([Token], [Token]) -> [Token]
forall a b. (a, b) -> b
snd (([Token], [Token]) -> [Token]) -> ([Token], [Token]) -> [Token]
forall a b. (a -> b) -> a -> b
$ Parser [Token]
scanValue [Token]
tokens