hasmin-1.0.1: src/Hasmin/Parser/Value.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
-----------------------------------------------------------------------------
-- |
-- Module : Hasmin.Parser.Value
-- Copyright : (c) 2017 Cristian Adrián Ontivero
-- License : BSD3
-- Stability : experimental
-- Portability : unknown
--
-- Parsers for CSS values.
--
-----------------------------------------------------------------------------
module Hasmin.Parser.Value
( valuesFor
, valuesFallback
, value
, valuesInParens
, stringOrUrl
, percentage
, url
, stringtype
, textualvalue
, stringvalue -- used in StringSpec
, shadowList -- used in ShadowSpec
, timingFunction
, repeatStyle
, position
, color
, number
, fontStyle
) where
import Control.Applicative ((<|>), many, liftA3, optional)
import Control.Arrow (first, (&&&))
import Control.Monad (mzero)
import Data.Functor (($>))
import Data.Attoparsec.Text (asciiCI, char, count, option, Parser, satisfy,
skipSpace, string)
import Data.Map.Strict (Map)
import Data.Monoid ((<>))
import Data.Maybe (fromMaybe, isNothing)
import Data.Text (Text)
import Data.Word (Word8)
import Data.Char (isAscii)
import Text.Parser.Permutation ((<|?>), (<$$>), (<$?>), (<||>), permute)
import Numeric (readSigned, readFloat)
import qualified Data.Set as Set
import qualified Data.Attoparsec.Text as A
import qualified Data.Char as C
import qualified Data.Map.Strict as Map
import qualified Data.List as L
import qualified Data.Text as T
import Hasmin.Parser.Utils
import Hasmin.Types.BgSize
import Hasmin.Class
import Hasmin.Types.Color
import Hasmin.Types.Dimension
import Hasmin.Types.FilterFunction
import Hasmin.Types.Gradient
import Hasmin.Types.Numeric
import Hasmin.Types.PercentageLength
import Hasmin.Types.Position
import Hasmin.Types.RepeatStyle
import Hasmin.Types.Shadow
import Hasmin.Types.String
import Hasmin.Types.TimingFunction
import Hasmin.Types.TransformFunction
import Hasmin.Types.Value
-- | Given a propery name, it returns a specific parser of values for that
-- property. Fails if no specific parser is found.
valuesFor :: Text -> Parser Values
valuesFor propName =
case Map.lookup (T.toLower propName) propertyValueParsersMap of
Just x -> x <* skipComments
Nothing -> mzero
-- | Parser for <https://www.w3.org/TR/css-values-3/#numbers \<number\>>.
number :: Parser Number
number = Number <$> rational
-- ---------------------------------------------------------------------------
-- Color Parsers
-- ---------------------------------------------------------------------------
-- Assumes "rgb(" has already been read
rgb :: Parser Color
rgb = functionParser (rgbInt <|> rgbPer)
where rgbInt = mkRGBInt <$> word8 <* comma <*> word8 <* comma <*> word8
rgbPer = mkRGBPer <$> percentage <* comma
<*> percentage <* comma <*> percentage
-- Assumes "rgba(" has already been read
rgba :: Parser Color
rgba = functionParser (rgbaInt <|> rgbaPer)
where rgbaInt = mkRGBAInt <$> word8 <* comma <*> word8 <* comma
<*> word8 <* comma <*> alphavalue
rgbaPer = mkRGBAPer <$> percentage <* comma <*> percentage <* comma
<*> percentage <* comma <*> alphavalue
-- Assumes "hsl(" has already been read
hsl :: Parser Color
hsl = functionParser p
where p = mkHSL <$> int <* comma <*> percentage <* comma <*> percentage
-- Assumes "hsla(" has already been read
hsla :: Parser Color
hsla = functionParser p
where p = mkHSLA <$> int <* comma <*> percentage <* comma
<*> percentage <* comma <*> alphavalue
alphavalue :: Parser Alphavalue
alphavalue = mkAlphavalue <$> rational
hexvalue :: Parser Value
hexvalue = ColorV <$> hex
hex :: Parser Color
hex = do
_ <- char '#'
a <- hexadecimal
b <- hexadecimal
c <- hexadecimal
x <- optional hexadecimal
case x of
Nothing -> pure $ mkHex3 a b c
Just d -> do y <- optional hexadecimal
case y of
Nothing -> pure $ mkHex4 a b c d
Just e -> do f <- hexadecimal
z <- optional hexadecimal
case z of
Nothing -> pure $ mkHex6 [a,b] [c,d] [e,f]
Just g -> do h <- hexadecimal
pure $ mkHex8 [a,b] [c,d] [e,f] [g,h]
-- ---------------------------------------------------------------------------
-- Dimensions Parsers
-- ---------------------------------------------------------------------------
-- A map relating dimension units and the percentage symbol,
-- to functions that construct that value. Meant to unify all the numerical
-- parsing in a single parse for generality without losing much efficiency.
-- See numericalvalue.
numericalConstructorsMap :: Map Text (Number -> Value)
numericalConstructorsMap = Map.fromList $ fmap (first T.toCaseFold) l
where durationFunc u v = DurationV (Duration v u)
frequencyFunc u v = FrequencyV (Frequency v u)
resolutionFunc u v = ResolutionV (Resolution v u)
l = [("s", durationFunc S)
,("ms", durationFunc Ms)
,("hz", frequencyFunc Hz)
,("khz", frequencyFunc Khz)
,("dpi", resolutionFunc Dpi)
,("dpcm", resolutionFunc Dpcm)
,("dppx", resolutionFunc Dppx)
,("%", \x -> PercentageV (Percentage $ toRational x))
] ++ (fmap . fmap) (LengthV .) distanceConstructorsList
++ (fmap . fmap) (AngleV .) angleConstructorsList
-- Unified numerical parser.
-- Parses <number>, dimensions (i.e. <length>, <angle>, ...), and <percentage>
numericalvalue :: Parser Value
numericalvalue = do
n <- number
rest <- opt (string "%" <|> A.takeWhile1 C.isAlpha)
if T.null rest -- if true, then it was just a <number> value
then pure $ NumberV n
else case Map.lookup (T.toCaseFold rest) numericalConstructorsMap of
Just f -> pure $ f n
Nothing -> mzero -- TODO see if we should return an "Other" value
-- Create a numerical parser based on a Map.
-- See for instance, the "angle" parser
dimensionParser :: Map Text (Number -> a) -> a -> Parser a
dimensionParser m unitlessValue = do
n <- number
u <- opt (A.takeWhile1 C.isAlpha)
if T.null u
then if n == 0
then pure unitlessValue -- <angle> 0, without units
else mzero -- Non-zero <number>, fail
else case Map.lookup (T.toCaseFold u) m of
Just f -> pure $ f n
Nothing -> mzero -- parsed units aren't angle units, fail
distance :: Parser Length
distance = dimensionParser distanceConstructorsMap NullLength
where distanceConstructorsMap = Map.fromList distanceConstructorsList
angle :: Parser Angle
angle = dimensionParser angleConstructorsMap NullAngle
where angleConstructorsMap = Map.fromList angleConstructorsList
duration :: Parser Duration
duration = do
n <- number
u <- opt (A.takeWhile1 C.isAlpha)
if T.null u
then mzero
else case Map.lookup (T.toCaseFold u) durationConstructorsMap of
Just f -> pure $ f n
Nothing -> mzero -- parsed units aren't angle units, fail
where durationConstructorsMap = Map.fromList $
fmap (toText &&& flip Duration) [S, Ms]
angleConstructorsList :: [(Text, Number -> Angle)]
angleConstructorsList = fmap (toText &&& flip Angle)
[Deg, Grad, Rad, Turn]
distanceConstructorsList :: [(Text, Number -> Length)]
distanceConstructorsList = fmap (toText &&& flip Length)
[EM, EX, CH, VH, VW, VMIN, VMAX, REM, Q, CM, MM, IN, PC, PT, PX]
-- | Parser for <https://drafts.csswg.org/css-values-3/#percentages \<percentage\>>.
percentage :: Parser Percentage
percentage = Percentage <$> rational <* char '%'
-- ---------------------------------------------------------------------------
-- Primitives
-- ---------------------------------------------------------------------------
-- | \<integer\> data type parser, but into a String instead of an Int, for other
-- parsers to use (e.g.: see the parsers int, or rational)
int' :: Parser String
int' = do
sign <- char '-' <|> pure '+'
d <- digits
case sign of
'+' -> pure d
'-' -> pure (sign:d)
_ -> error "int': parsed a number starting with other than [+|-]"
-- | Parser for \<integer\>: [+|-][0-9]+
int :: Parser Int
int = read <$> int'
word8 :: Parser Word8
word8 = read <$> digits
-- Note that many properties that allow an integer or real number as a value
-- actually restrict the value to some range, often to a non-negative value.
--
-- | Real number parser. \<number\>: <'int' integer> | [0-9]*.[0-9]+
rational :: Parser Rational
rational = do
sign <- option [] (wrapMinus <$> (char '-' <|> char '+'))
dgts <- ((++) <$> digits <*> option "" fractionalPart)
<|> ("0"++) <$> fractionalPart -- append a zero for read not to fail
e <- option [] expo
pure . fst . head $ readSigned readFloat (sign ++ dgts ++ e)
where fractionalPart = (:) <$> char '.' <*> digits
expo = (:) <$> satisfy (\c -> c == 'e' || c == 'E') <*> int'
wrapMinus x = [x | x == '-'] -- we use this since read fails with leading '+'
-- | Parser for <https://drafts.csswg.org/css-fonts-3/#propdef-font-style \<font-style\>>,
-- used in the @font-style@ and @font@ properties.
fontStyle :: Parser Value
fontStyle = Other <$> matchKeywords ["normal", "italic", "oblique"]
{-
fontWeight :: Parser Value
fontWeight = do
k <- ident
if Set.member k keywords
then pure $ mkOther k
else mzero
where keywords = Set.fromList ["normal", "bold", "lighter", "bolder"]
validNumbers = Set.fromList [100, 200, 300, 400, 500, 600, 700, 800, 900]
-}
fontSize :: Parser Value
fontSize = fontSizeKeyword
<|> (LengthV <$> distance)
<|> (PercentageV <$> percentage)
where fontSizeKeyword = Other <$> matchKeywords
["large", "xx-small", "x-small", "small", "medium",
"x-large", "xx-large", "smaller" , "larger"]
{- [ [ <‘font-style’> || <font-variant-css21> || <‘font-weight’> ||
- <‘font-stretch’> ]? <‘font-size’> [ / <‘line-height’> ]? <‘font-family’> ] |
- caption | icon | menu | message-box | small-caption | status-bar
where <font-variant-css21> = [normal | small-caps]
-}
positionvalue :: Parser Value
positionvalue = PositionV <$> position
-- | Parser for <https://drafts.csswg.org/css-values-3/#position \<position\>>.
position :: Parser Position
position = perLen <|> kword
where
perLen = percentageLength >>= startsWithPL
kword = do
i <- ident
case Map.lookup (T.toCaseFold i) keywords of
Just x -> skipComments *> x
Nothing -> mzero
keywords = Map.fromList
[("left", startsWith (Just PosLeft) tb)
,("right", startsWith (Just PosRight) tb)
,("top", startsWith (Just PosTop) lr)
,("bottom", startsWith (Just PosBottom) lr)
,("center", startsWithCenter)]
tb = (asciiCI "top" $> Just PosTop, asciiCI "bottom" $> Just PosBottom)
lr = (asciiCI "left" $> Just PosLeft, asciiCI "right" $> Just PosRight)
startsWithPL :: PercentageLength -> Parser Position
startsWithPL x = skipComments *>
(followsWithPL <|> someKeyword <|> wasASinglePL)
where
pl = Just x
followsWithPL = Position Nothing pl Nothing <$> (Just <$> percentageLength)
wasASinglePL = pure $ Position Nothing pl Nothing Nothing
someKeyword = do
i <- ident
case T.toCaseFold i of
"center" -> pure $ Position Nothing pl (Just PosCenter) Nothing
"top" -> pure $ Position Nothing pl (Just PosTop) Nothing
"bottom" -> pure $ Position Nothing pl (Just PosBottom) Nothing
_ -> mzero
maybePL :: Parser (Maybe PercentageLength)
maybePL = optional percentageLength
startsWithCenter :: Parser Position
startsWithCenter = followsWithPL
<|> followsWithAKeyword
<|> pure (posTillNow Nothing Nothing)
where
followsWithPL = (posTillNow Nothing . Just) <$> percentageLength
followsWithAKeyword = do
i <- ident <* skipComments
let f x = posTillNow (Just x) <$> maybePL
case T.toCaseFold i of
"left" -> f PosLeft
"right" -> f PosRight
"top" -> f PosTop
"bottom" -> f PosBottom
"center" -> pure $ posTillNow (Just PosCenter) Nothing
_ -> mzero
posTillNow = Position (Just PosCenter) Nothing
-- Used for the cases when a position starts with the X axis (left and right
-- keywords) or Y axis (top and bottom)
startsWith :: Maybe PosKeyword
-> (Parser (Maybe PosKeyword), Parser (Maybe PosKeyword))
-> Parser Position
startsWith x (p1, p2) = do
pl <- optional (percentageLength <* skipComments)
let endsWithCenter = Position x pl <$> center <*> pure Nothing
endsWithKeywordAndMaybePL = Position x pl <$> posKeyword <*> maybePL
endsWithPL = pure $ Position x Nothing Nothing pl
endsWithCenter <|> endsWithKeywordAndMaybePL <|> endsWithPL
where
posKeyword = (p1 <|> p2) <* skipComments
center = asciiCI "center" $> Just PosCenter
{-
transformOrigin :: Parser Values
transformOrigin = twoVal <|> oneVal
where oneVal = (singleValue numericalvalue) <|> offsetKeyword
offsetKeyword = do
v1 <- ident
if v1 == "top" || v1 == "right" || v1 == "bottom" || v1 == "left" || v1 == "center"
then pure $ mkValues [mkOther v1]
else mzero
twoVal = do
(v1, v2) <- ((,) <$> yAxis <*> (skipComments *> (xAxis <|> numericalvalue)))
<|> ((,) <$> xAxis <*> (skipComments *> (yAxis <|> numericalvalue)))
<|> ((,) <$> numericalvalue <*> (skipComments *> (yAxis <|> xAxis)))
option (mkValues [v1,v2]) ((\x -> mkValues [v1,v2, LengthV x]) <$> distance)
yAxis = do
v1 <- ident
if v1 == "top" || v1 == "bottom" || v1 == "center"
then pure $ mkOther v1
else mzero
xAxis = do
v1 <- ident
if v1 == "right" || v1 == "left" || v1 == "center"
then pure $ mkOther v1
else mzero
-}
bgSize :: Parser BgSize
bgSize = twovaluesyntax <|> contain <|> cover
where cover = asciiCI "cover" $> Cover
contain = asciiCI "contain" $> Contain
twovaluesyntax = do
x <- bgsizeValue <* skipComments
(BgSize2 x <$> bgsizeValue) <|> pure (BgSize1 x)
bgsizeValue = (Left <$> percentageLength) <|> (Right <$> auto)
bgAttachment :: Parser TextV
bgAttachment = matchKeywords ["scroll", "fixed", "local"]
box :: Parser TextV
box = matchKeywords ["border-box", "padding-box", "content-box"]
-- [ <bg-layer> , ]* <final-bg-layer>
background :: Parser Values
background = do
xs <- many (bgLayer <* char ',' <* skipComments)
x <- finalBgLayer
pure $ if null xs
then Values x []
else Values (head xs) (fmap (Comma,) $ tail xs ++ [x])
-- <final-bg-layer> = <bg-image> || <position> [ / <bg-size> ]? || <repeat-style> || <attachment> || <box> || <box> || <'background-color'>
finalBgLayer :: Parser Value
finalBgLayer = do
layer <- permute (mkFinalBgLayer <$?> (Nothing, Just <$> image <* skipComments)
<|?> (Nothing, Just <$> positionAndBgSize <* skipComments)
<|?> (Nothing, Just <$> repeatStyle <* skipComments)
<|?> (Nothing, Just <$> bgAttachment <* skipComments)
<|?> (Nothing, Just <$> box <* skipComments)
<|?> (Nothing, Just <$> box <* skipComments)
<|?> (Nothing, Just <$> color <* skipComments))
if finalBgLayerIsEmpty layer
then mzero
else pure layer
where finalBgLayerIsEmpty (FinalBgLayer Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing) = True
finalBgLayerIsEmpty _ = False
-- parameters e and f are being swapped to deal with the permutation
-- changing the original order of the parsed values.
mkFinalBgLayer a Nothing c d e f g = FinalBgLayer a Nothing Nothing c d f e g
mkFinalBgLayer a (Just (p,s)) c d e f g = FinalBgLayer a (Just p) s c d f e g
-- <bg-layer> = <bg-image> || <position> [ / <bg-size> ]? || <repeat-style> || <attachment> || <box>{1,2}
bgLayer :: Parser Value
bgLayer = do
layer <- permute (mkBgLayer <$?> (Nothing, Just <$> image <* skipComments)
<|?> (Nothing, Just <$> positionAndBgSize <* skipComments)
<|?> (Nothing, Just <$> repeatStyle <* skipComments)
<|?> (Nothing, Just <$> bgAttachment <* skipComments)
<|?> (Nothing, Just <$> box2 <* skipComments))
if bgLayerIsEmpty layer
then mzero
else pure layer
where bgLayerIsEmpty (BgLayer Nothing Nothing Nothing Nothing Nothing Nothing Nothing) = True
bgLayerIsEmpty _ = False
mkBgLayer a Nothing c d Nothing = BgLayer a Nothing Nothing c d Nothing Nothing
mkBgLayer a (Just (p,s)) c d Nothing = BgLayer a (Just p) s c d Nothing Nothing
mkBgLayer a Nothing c d (Just (i,j)) = BgLayer a Nothing Nothing c d (Just i) j
mkBgLayer a (Just (p,s)) c d (Just (i,j)) = BgLayer a (Just p) s c d (Just i) j
box2 :: Parser (TextV, Maybe TextV)
box2 = do
x <- box <* skipComments
y <- optional box
pure (x,y)
-- used for the background property, which takes among other things:
-- <position> [ / <bg-size> ]?
positionAndBgSize :: Parser (Position, Maybe BgSize)
positionAndBgSize = (,) <$> position <*> optional (slash *> bgSize)
matchKeywords :: [Text] -> Parser TextV
matchKeywords listOfKeywords = do
i <- ident
if T.toCaseFold i `elem` Set.fromList listOfKeywords
then pure $ TextV i
else mzero
-- <image> = <url> | <image()> | <image-set()> | <element()> | <cross-fade()> | <gradient>
image :: Parser Value
image = do
i <- ident
let lowercased = T.toLower i
if lowercased == "none"
then pure $ mkOther "none"
else do _ <- char '('
if Set.member lowercased possibilities
then fromMaybe mzero (Map.lookup lowercased functionsMap)
else mzero
where possibilities = Set.fromList $ map T.toCaseFold
["url", "element", "linear-gradient", "radial-gradient"]
transition :: Parser Values
transition = parseCommaSeparated singleTransition
-- [ none | <single-transition-property> ] || <time> || <single-transition-timing-function> || <time>
singleTransition :: Parser Value
singleTransition = do
st <- permute (mkSingleTransition <$?> (Nothing, Just <$> singleTransitionProperty <* skipComments)
<|?> (Nothing, Just <$> duration <* skipComments)
<|?> (Nothing, Just <$> timingFunction <* skipComments)
<|?> (Nothing, Just <$> duration <* skipComments))
if singleTransitionIsEmpty st
then mzero
else pure st
where singleTransitionIsEmpty (SingleTransition Nothing Nothing Nothing Nothing) = True
singleTransitionIsEmpty _ = False
-- Needed because permute is swapping the order of the time parameters.
mkSingleTransition a b c d = SingleTransition a d c b
singleTransitionProperty = do
i <- ident
let lowercased = T.toLower i
if lowercased `Set.member` excludedKeywords
then mzero
else pure $ TextV i
excludedKeywords = Set.fromList ["initial", "inherit", "unset", "default", "none"]
-- | Parser for <https://drafts.csswg.org/css-timing-1/#single-timing-function-production \<single-timing-function\>>.
timingFunction :: Parser TimingFunction
timingFunction = do
i <- ident
fromMaybe mzero $ Map.lookup (T.toLower i) timingFunctionKeywords
where timingFunctionKeywords = Map.fromList
[("ease", pure Ease)
,("ease-in", pure EaseIn)
,("ease-in-out", pure EaseInOut)
,("ease-out", pure EaseOut)
,("linear", pure Linear)
,("step-end", pure StepEnd)
,("step-start", pure StepStart)
,("steps", char '(' *> steps)
,("cubic-bezier", char '(' *> cubicbezier)]
backgroundSize :: Parser Values
backgroundSize = parseCommaSeparated (BgSizeV <$> bgSize)
auto :: Parser Auto
auto = asciiCI "auto" $> Auto
propertyValueParsersMap :: Map Text (Parser Values)
propertyValueParsersMap = Map.fromList
[--("color", (:[]) <$> colorvalue)
("display", singleValue textualvalue)
,("font", singleValue font)
,("font-size", singleValue fontSize)
,("font-style", singleValue fontStyle)
,("font-weight", singleValue numberOrText)
,("font-family", fontFamilyValues)
,("background", background)
,("background-repeat", parseCommaSeparated (RepeatStyleV <$> repeatStyle))
,("background-size", backgroundSize)
,("box-shadow", shadowList)
,("-o-box-shadow", shadowList)
,("-moz-box-shadow", shadowList)
,("-webkit-box-shadow", shadowList)
,("text-shadow", textShadow)
,("animation", animation)
,("-o-animation", animation)
,("-ms-animation", animation)
,("-moz-animation", animation)
,("-webkit-animation", animation)
,("transition", transition)
,("-o-transition", transition)
,("-ms-transition", transition)
,("-moz-transition", transition)
,("-webkit-transition", transition)
,("height", singleValue numberOrText) -- <length>|<percentage>|auto
,("margin-bottom", singleValue numberOrText)
,("margin-left", singleValue numberOrText)
,("background-position", singleValue positionvalue)
,("perspective-origin", singleValue positionvalue)
,("-o-perspective-origin", singleValue positionvalue)
,("-moz-perspective-origin", singleValue positionvalue)
,("-webkit-perspective-origin", singleValue positionvalue)
,("mask-position", positionList)
,("-webkit-mask-position", positionList)
-- ,("transform-origin", transformOrigin)
-- ,("-ms-transform-origin", transformOrigin)
-- ,("-webkit-transform-origin", transformOrigin)
-- ,("font",
-- ,("margin-right", numberOrText)
-- ,("margin-top", numberOrText)
-- ,("opacity", someNumericalValue)
-- ,("overflow", someText)
-- ,("padding-bottom", someNumericalValue)
-- ,("padding-left", someNumericalValue)
-- ,("padding-right", someNumericalValue)
-- ,("padding-top", someNumericalValue)
-- ,("position", someText)
-- ,("text-align", someText)
-- ,("width", numberOrText)
]
where numberOrText = numericalvalue <|> textualvalue
-- helper wrapper
singleValue :: Parser Value -> Parser Values
singleValue = (flip Values [] <$>)
-- | Parses until the end of the declaration, i.e. ';' or '}'.
-- Used to deal with invalid input, or an IE specific hack.
invalidvalue :: Parser Value
invalidvalue = mkOther <$> A.takeWhile1 cond
where cond c = c /= '\\' && c /= ';' && c /= '}' && c /= '!'
-- [ [ <'font-style'> || <font-variant-css21> || <'font-weight'> ||
-- <'font-stretch'> ]? <'font-size'> [ / <'line-height'> ]? <'font-family'> ] |
font :: Parser Value
font = systemFonts <|> do
(fsty, fvar, fwgt, fstr) <- parse4
(fsz, lh) <- fontSizeAndLineHeight
ff <- ((:) <$> fontfamily <* skipComments) <*> many (char ',' *> lexeme fontfamily)
pure $ FontV fsty fvar fwgt fstr fsz lh ff
where systemFonts = Other <$> parseIdents ["caption", "icon", "menu", "message-box", "small-caption", "status-bar"]
fontSizeAndLineHeight = do
fsz <- fontSize <* skipComments
lh <- optional (char '/' *> lexeme lineHeight)
pure (fsz, lh)
lineHeight = let validNum = do n <- numericalvalue
case n of
NumberV _ -> pure n
PercentageV _ -> pure n
LengthV _ -> pure n
_ -> mzero
in (Other <$> parseIdents ["normal"]) <|> validNum
fontWeightNumber :: Parser Value
fontWeightNumber = do
n <- number
if Set.notMember n (Set.fromList [100, 200, 300, 400, 500, 600, 700, 800, 900])
then mzero
else do c <- A.peekChar
case c of
Nothing -> mzero
Just x -> if isAscii x || x == '%'
then mzero
else pure $ NumberV n
parseFirstFour j = (storeProperty' j <$> fontWeightNumber <* skipComments) <|> do
i <- ident
case Map.lookup (T.toLower i) m of
Just x -> case x of
FontWeight -> pure $ storeProperty' j (mkOther i)
_ -> pure $ storeProperty j x (TextV i)
Nothing -> mzero
where m = Map.fromList $ zip ["ultra-condensed", "extra-condensed", "condensed", "semi-condensed", "semi-expanded", "expanded", "extra-expanded", "ultra-expanded"] (repeat FontStretch)
++ zip ["small-caps"] (repeat FontVariant)
++ zip ["italic", "oblique"] (repeat FontStyle)
++ zip ["bold", "bolder", "lighter"] (repeat FontWeight)
++ [("normal", Ambiguous)]
parse4 :: Parser (Maybe TextV, Maybe TextV, Maybe Value, Maybe TextV)
parse4 = do
let initialized = (Nothing, Nothing, Nothing, Nothing, 0)
w <- option initialized (parseFirstFour initialized <* skipComments)
x <- option w (parseFirstFour w <* skipComments)
y <- option x (parseFirstFour x <* skipComments)
(a,b,c,d,e) <- option y (parseFirstFour y <* skipComments)
pure $ fillTuple (a,b,c,d) e
fillTuple (a,b,c,d) 0 = (a,b,c,d)
fillTuple (a,b,c,d) x
| isNothing a = fillTuple (Just nrml,b,c,d) (x-1)
| isNothing b = fillTuple (a, Just nrml,c,d) (x-1)
| isNothing c = fillTuple (a,b, Just $ Other nrml,d) (x-1)
| isNothing d = fillTuple (a,b,c, Just nrml) (x-1)
| otherwise = (a,b,c,d)
where nrml = TextV "normal"
data FontProperty = FontStyle | FontVariant | FontWeight | FontStretch | Ambiguous
deriving (Eq, Show)
storeProperty :: (Maybe TextV, Maybe TextV, Maybe Value, Maybe TextV, Int) -> FontProperty -> TextV
-> (Maybe TextV, Maybe TextV, Maybe Value, Maybe TextV, Int)
storeProperty (a,b,c,d,i) y x = replace y
where replace FontStyle = (Just x,b,c,d,i)
replace FontVariant = (a, Just x,c,d,i)
replace FontStretch = (a,b,c, Just x,i)
replace Ambiguous = (a,b,c,d,i + 1)
replace _ = (a,b,c,d,i)
storeProperty' :: (Maybe TextV, Maybe TextV, Maybe Value, Maybe TextV, Int) -> Value
-> (Maybe TextV, Maybe TextV, Maybe Value, Maybe TextV, Int)
storeProperty' (a,b,_,d,i) x = (a,b, Just x,d,i)
-- font-style: normal
-- font-variant: normal
-- font-weight: normal
-- font-stretch: normal
-- font-size: medium
-- line-height: normal
-- font-family: depends on user agent
fontFamilyValues :: Parser Values
fontFamilyValues = singleValue csswideKeyword <|> do
v <- fontfamily
vs <- many ((,) <$> separator <*> fontfamily)
pure $ Values v vs
fontfamily :: Parser Value
fontfamily = (StringV <$> stringtype) <|> (mkOther <$> unquotedFontFamily)
local :: Parser Value
local = functionParser $
Local <$> ((Left <$> unquotedFontFamily) <|> (Right <$> stringtype))
unquotedFontFamily :: Parser Text
unquotedFontFamily = do
v <- ident
vs <- many (skipComments *> ident)
pure $ v <> foldMap (T.singleton ' ' <>) vs
textualvalue :: Parser Value
textualvalue = do
i <- ident
if i == "\\9" -- iehack
then mzero
else do c <- A.peekChar
case c of
Just '(' -> functionParsers i
Just ':' -> mzero -- invalid
_ -> textualParsers i
textualParsers :: Text -> Parser Value
textualParsers i = let t = T.toCaseFold i
in fromMaybe (pure $ mkOther i) (Map.lookup t textualParsersMap)
where textualParsersMap = Map.union csswideKeywordsMap namedColorsParsersMap
csswideKeyword :: Parser Value
csswideKeyword = do
i <- ident <* skipComments
let lowercased = T.toLower i
case Map.lookup lowercased csswideKeywordsMap of
Nothing -> mzero
Just x -> do c <- A.peekChar
case c of
Nothing -> x
Just y -> if y `elem` ['!', ';', '}']
then x
else mzero
csswideKeywordsMap :: Map Text (Parser Value)
csswideKeywordsMap = Map.fromList $ map (first T.toCaseFold)
[("initial", pure Initial)
,("inherit", pure Inherit)
,("unset", pure Unset)]
stringvalue :: Parser Value
stringvalue = StringV <$> stringtype
functionParsers :: Text -> Parser Value
functionParsers i = char '(' *>
case Map.lookup (T.toCaseFold i) functionsMap of
Just x -> x <|> genericFunc i
Nothing -> genericFunc i
<|> (mkOther <$> (f i "(" <$> someText <*> string ")"))
where f x y z w = x <> y <> z <> w
someText = A.takeWhile (/= ')')
genericFunc :: Text -> Parser Value
genericFunc i = (GenericFunc i <$> valuesInParens) <* char ')'
valuesInParens :: Parser Values
valuesInParens = Values <$> v <*> many ((,) <$> separator <*> v) <* skipComments
where v = textualvalue
<|> numericalvalue
<|> hexvalue
<|> (StringV <$> stringtype)
stringOrUrl :: Parser (Either StringType Url)
stringOrUrl = (Left <$> stringtype) <|> (Right <$> someUrl)
where someUrl :: Parser Url
someUrl = asciiCI "url" *> char '(' *> url
-- | Parser for <https://www.w3.org/TR/css-backgrounds-3/#typedef-repeat-style \<repeat-style\>>,
-- used in @background-repeat@ and @background@.
repeatStyle :: Parser RepeatStyle
repeatStyle = do
i <- ident
let lowercased = T.toLower i
case L.lookup lowercased singleKeywords of
Nothing -> case Map.lookup lowercased keywordPairs of
Nothing -> mzero
Just y -> (RepeatStyle2 y <$> secondKeyword)
<|> pure (RepeatStyle1 y)
Just x -> pure x
where secondKeyword = do
z <- skipComments *> ident
maybe mzero pure $ Map.lookup (T.toLower z) keywordPairs
singleKeywords = [("repeat-x", RepeatX), ("repeat-y", RepeatY)]
keywordPairs = Map.fromList [("repeat", RsRepeat)
,("no-repeat", RsNoRepeat)
,("space", RsSpace)
,("round", RsRound)]
functionsMap :: Map Text (Parser Value)
functionsMap = Map.fromList $ fmap (first T.toCaseFold)
[("rgb", ColorV <$> rgb)
,("rgba", ColorV <$> rgba)
,("hsl", ColorV <$> hsl)
,("hsla", ColorV <$> hsla)
,("url", UrlV <$> url)
,("format", format)
,("local", local)
-- <gradient> parsers
,("linear-gradient", GradientV "linear-gradient" <$> lineargradient)
,("-o-linear-gradient", GradientV "-o-linear-gradient" <$> lineargradient)
,("-ms-linear-gradient", GradientV "-ms-linear-gradient" <$> lineargradient)
,("-moz-linear-gradient", GradientV "-moz-linear-gradient" <$> lineargradient)
,("-webkit-linear-gradient", GradientV "-webkit-linear-gradient" <$> lineargradient)
,("radial-gradient", GradientV "radial-gradient" <$> radialgradient)
,("-o-radial-gradient", GradientV "-o-radial-gradient" <$> radialgradient)
,("-moz-radial-gradient", GradientV "-moz-radial-gradient" <$> radialgradient)
,("-webkit-radial-gradient", GradientV "-webkit-radial-gradient" <$> radialgradient)
--,("repeating-linear-gradient", ? ) -- TODO
--,("repeating-radial-gradient", ? ) -- TODO
-- <shape>
,("rect", rect)
-- <transform-function>
,("matrix", TransformV <$> matrix)
,("matrix3d", TransformV <$> matrix3d)
,("rotate", (TransformV . Rotate) <$> functionParser angle)
,("rotate3d", TransformV <$> rotate3d)
,("rotateX", (TransformV . Rotate) <$> functionParser angle)
,("rotateY", (TransformV . Rotate) <$> functionParser angle)
,("rotateZ", (TransformV . Rotate) <$> functionParser angle)
,("scale", TransformV <$> scale)
,("scale3d", TransformV <$> scale3d)
,("scaleX", (TransformV . ScaleY) <$> functionParser number)
,("scaleY", (TransformV . ScaleY) <$> functionParser number)
,("scaleZ", (TransformV . ScaleZ) <$> functionParser number)
,("skew", TransformV <$> skew)
,("skewX", (TransformV . SkewX) <$> functionParser angle)
,("skewY", (TransformV . SkewY) <$> functionParser angle)
,("translate", TransformV <$> translate)
,("translate3d", TransformV <$> translate3d)
,("translateX", (TransformV . TranslateX) <$> functionParser percentageLength)
,("translateY", (TransformV . TranslateY) <$> functionParser percentageLength)
,("translateZ", (TransformV . TranslateZ) <$> functionParser distance)
,("perspective", (TransformV . Perspective) <$> functionParser distance)
-- <timing-function>
,("cubic-bezier", TimingFuncV <$> cubicbezier)
,("steps", TimingFuncV <$> steps)
-- <filter-function>
,("blur", (FilterV . Blur) <$> functionParser distance)
,("contrast", (FilterV . Contrast) <$> functionParser numberPercentage)
,("grayscale", (FilterV . Grayscale) <$> functionParser numberPercentage)
,("invert", (FilterV . Invert) <$> functionParser numberPercentage)
,("opacity", (FilterV . Opacity) <$> functionParser numberPercentage)
,("saturate", (FilterV . Saturate) <$> functionParser numberPercentage)
,("sepia", (FilterV . Sepia) <$> functionParser numberPercentage)
,("brightness", (FilterV . Brightness) <$> functionParser numberPercentage)
,("drop-shadow", FilterV <$> dropShadow)
,("hue-rotate", (FilterV . HueRotate) <$> functionParser angle)
,("element", genericFunc "element")
--
-- <basic-shape>
-- circle() = circle( [<shape-radius>]? [at <position>]? )
-- polygon( [<fill-rule>,]? [<shape-arg> <shape-arg>]# )
-- inset()
-- ellipse( [<shape-radius>{2}]? [at <position>]? )
--
-- <image> https://drafts.csswg.org/css-images
-- Note: <gradient> is a type of <image> !
-- cross-fade()
-- image()
-- image-set()
-- image-set()
-- element()
--
--
--,("stylistic", functionParser ident) -- IDENT
--,("styleset", ? ) -- ident#
--,("swash", ? ) -- ident
--,("annotation", ? ) -- ident
--,("attr", ? ) -- <attr-name> <type-or-unit>? [, <attr-fallback> ]?
--,("calc", ? ) -- <calc-sum> , experimental
--,("character-variant", ? ) -- ident#
--,("element", ? ) -- id selector, experimental
--,("local", ? )
--,("ornaments", ? ) -- ident
--,("symbols", ? ) -- <symbols-type>? [ <string> | <image> ]+
--,("var", ? ) -- experimental: <custom-property-name> [, <declaration-value> ]?
-- minmax()
]
dropShadow :: Parser FilterFunction
dropShadow = functionParser $ do
l1 <- distance
l2 <- lexeme distance
l3 <- optional (distance <* skipComments)
c <- optional color
pure $ DropShadow l1 l2 l3 c
textShadow :: Parser Values
textShadow = parseCommaSeparated shadowText
shadowText :: Parser Value
shadowText = permute (mkShadowText <$$> (lns <* skipComments)
<|?> (Nothing , Just <$> color <* skipComments))
where mkShadowText (x,y,b) = ShadowText x y b
lns = do
l1 <- distance
l2 <- lexeme distance
l3 <- optional (distance <* skipComments)
pure (l1,l2,l3)
-- | Parser for <https://drafts.csswg.org/css-backgrounds-3/#typedef-shadow \<shadow>>
-- values, used in the @box-shadow@ property.
shadowList :: Parser Values
shadowList = parseCommaSeparated (ShadowV <$> shadow)
positionList :: Parser Values
positionList = parseCommaSeparated positionvalue
parseCommaSeparated :: Parser Value -> Parser Values
parseCommaSeparated p = do
v <- p
vs <- lexeme $ many ((,) <$> commaSeparator <*> p)
c <- A.peekChar
case c of
Just x -> if x `elem` ['!', ';', '}']
then pure $ Values v vs
else mzero
Nothing -> pure $ Values v vs
shadow :: Parser Shadow
shadow = permute (mkShadow <$?> (False, asciiCI "inset" $> True <* skipComments)
<||> fourLengths
<|?> (Nothing , Just <$> color <* skipComments))
where mkShadow i (l1,l2,l3,l4) = Shadow i l1 l2 l3 l4
fourLengths = do
l1 <- distance
l2 <- lexeme distance
l3 <- optional (distance <* skipComments)
l4 <- optional (distance <* skipComments)
pure (l1,l2,l3,l4)
radialgradient :: Parser Gradient
radialgradient = functionParser $ do
(def, c) <- option (True, RadialGradient Nothing Nothing) ((False,) <$> endingShapeAndSize <* skipComments)
p <- optional (asciiCI "at" *> skipComments *> position)
_ <- if def && isNothing p
then pure '*' -- do nothing
else comma
cs <- colorStopList
pure $ c p cs
where circle = asciiCI "circle" $> Just Circle <* skipComments
ellipse = asciiCI "ellipse" $> Just Ellipse <* skipComments
endingShapeAndSize = r1 <|> r2 <|> r3
where r1 = permute (RadialGradient <$?> (Nothing, ellipse) <||> (Just <$> (PL <$> percentageLength <*> lexeme percentageLength)))
r2 = permute (RadialGradient <$?> (Nothing, circle) <||> ((Just . SL) <$> distance <* skipComments))
r3 = permute (RadialGradient <$?> (Nothing, circle <|> ellipse) <||> extentKeyword)
<|> permute (RadialGradient <$$> (circle <|> ellipse) <|?> (Nothing, extentKeyword))
extentKeyword = do
i <- ident
_ <- skipComments
case Map.lookup i extentKeywords of
Just x -> pure (Just x)
Nothing -> mzero
extentKeywords :: Map Text Size
extentKeywords = Map.fromList [("closest-corner", ClosestCorner)
,("closest-side", ClosestSide)
,("farthest-corner", FarthestCorner)
,("farthest-side", FarthestSide)]
-- | Assumes "linear-gradient(", or one of its prefixed equivalents, has been parsed.
-- : [<angle>|to <side-or-corner> ,]? <color-stop> [, <color-stop>]+
lineargradient :: Parser Gradient
lineargradient = functionParser (lg <|> oldLg)
where lg = LinearGradient <$> optional angleOrSide <*> colorStopList
oldLg = OldLinearGradient <$> optional ((ga <|> sc) <* comma)
<*> colorStopList
angleOrSide = (ga <|> gs) <* comma
ga = Left <$> angle
gs = asciiCI "to" *> skipComments *> sc
sc = Right <$> sideOrCorner
-- <side-or-corner> = [left | right] || [top | bottom]
sideOrCorner :: Parser (Side, Maybe Side)
sideOrCorner = orderOne <|> orderTwo
where orderOne = (,) <$> leftright <* skipComments
<*> optional topbottom
orderTwo = (,) <$> topbottom <* skipComments
<*> optional leftright
leftright :: Parser Side
leftright = (asciiCI "left" $> LeftSide)
<|> (asciiCI "right" $> RightSide)
topbottom :: Parser Side
topbottom = (asciiCI "top" $> TopSide)
<|> (asciiCI "bottom" $> BottomSide)
colorStopList :: Parser [ColorStop]
colorStopList = do
c1 <- colorStop
_ <- char ',' <* skipComments
c2 <- colorStop
cs <- many (char ',' *> skipComments *> colorStop)
pure $ c1:c2:cs
colorStop :: Parser ColorStop
colorStop = ColorStop <$> color <* skipComments
<*> optional (percentageLength <* skipComments)
-- | Parser for <https://drafts.csswg.org/css-color-3/#colorunits \<color\>>.
color :: Parser Color
color = hex <|> othercolor
where othercolor = do
t <- textualvalue
case t of
ColorV c -> pure c
_ -> mzero
-- TODO make parser specifically for it instead of reusing numericalvalue
percentageLength :: Parser PercentageLength
percentageLength = do
n <- numericalvalue
case n of
PercentageV p -> pure $ Left p
NumberV 0 -> pure $ Right NullLength
LengthV d -> pure $ Right d
_ -> mzero
numberPercentage :: Parser (Either Number Percentage)
numberPercentage = do
n <- numericalvalue
case n of
NumberV x -> pure $ Left x
PercentageV p -> pure $ Right p
_ -> mzero
-- | Assumes "rect(" has been already parsed
rect :: Parser Value
rect = functionParser $ do
length1 <- distance <* comma
length2 <- distance <* comma
length3 <- distance <* comma
length4 <- distance
pure $ Rect length1 length2 length3 length4
-- | Assumes "translate(" has been already parsed
translate :: Parser TransformFunction
translate = functionParser $ do
pl <- percentageLength
mpl <- optional (comma *> percentageLength)
pure $ Translate pl mpl
-- | Parser of scale() function. Assumes "scale(" has been already parsed
scale :: Parser TransformFunction
scale = functionParser $ do
n <- number
mn <- optional (comma *> number)
pure $ Scale n mn
scale3d :: Parser TransformFunction
scale3d = functionParser $ liftA3 Scale3d n n number
where n = number <* comma
skew :: Parser TransformFunction
skew = functionParser $ do
a <- angle
ma <- optional (comma *> angle)
pure $ Skew a ma
translate3d :: Parser TransformFunction
translate3d = functionParser $
Translate3d <$> percentageLength <* comma
<*> percentageLength <* comma
<*> distance
matrix :: Parser TransformFunction
matrix = functionParser $ do
n <- number
ns <- count 5 (comma *> number)
pure $ mkMat (n:ns)
matrix3d :: Parser TransformFunction
matrix3d = functionParser $ do
n <- number
ns <- count 15 (comma *> number)
pure $ mkMat3d (n:ns)
rotate3d :: Parser TransformFunction
rotate3d = functionParser $ do
x <- number <* comma
y <- number <* comma
z <- number <* comma
a <- angle
pure $ Rotate3d x y z a
cubicbezier :: Parser TimingFunction
cubicbezier = functionParser $ do
p0 <- number <* comma
p1 <- number <* comma
p2 <- number <* comma
p3 <- number
pure $ CubicBezier p0 p1 p2 p3
steps :: Parser TimingFunction
steps = functionParser $ do
i <- int
s <- optional (comma *> startOrEnd)
pure $ Steps i s
where startOrEnd = (asciiCI "end" $> End)
<|> (asciiCI "start" $> Start)
-- It uses skipSpace instead of skipComments, since comments aren't valid inside
-- the url-token. From the spec:
-- COMMENT tokens cannot occur within other tokens: thus, "url(/*x*/pic.png)"
-- denotes the URI "/*x*/pic.png", not "pic.png".
--
-- | Parser for <https://drafts.csswg.org/css-values-3/#urls \<url\>>. Assumes
-- @\"url(\"@ has already been parsed.
url :: Parser Url
url = Url <$> (skipSpace *> someUri <* skipSpace <* char ')')
where someUri = (Right <$> stringtype) <|> (Left <$> nonQuotedUri)
nonQuotedUri = A.takeWhile1 (/= ')') -- TODO maybe parse ident?
-- format(<string>#)
-- Assumes "format(" has been already parsed
format :: Parser Value
format = Format <$> functionParser p
where p = (:) <$> stringtype <*> many (comma *> stringtype)
namedColorsParsersMap :: Map Text (Parser Value)
namedColorsParsersMap = Map.fromList $ foldr f [] keywordColors
where f x xs = let a = fst x
in (a, pure $ ColorV (Named a)) : xs
-- | For cases when CSS hacks are used, e.g.: @margin-top: 1px \\9;@.
valuesFallback :: Parser Values
valuesFallback = Values <$> value <*> many ((,) <$> separator <*> value) <* skipComments
value :: Parser Value
value = textualvalue
<|> numericalvalue
<|> hexvalue
<|> (StringV <$> stringtype)
<|> invalidvalue
separator :: Parser Separator
separator = lexeme $ (char ',' $> Comma)
<|> (char '/' $> Slash)
<|> pure Space
commaSeparator :: Parser Separator
commaSeparator = lexeme (char ',' $> Comma)
-- <string> data type parser
stringtype :: Parser StringType
stringtype = doubleQuotesString <|> singleQuotesString
doubleQuotesString :: Parser StringType
doubleQuotesString = char '\"' *> (DoubleQuotes <$> untilDoubleQuotes)
where untilDoubleQuotes = mappend <$> A.takeWhile (\c -> c /= '\\' && c /= '\"') <*> checkCharacter
checkCharacter = (string "\"" $> mempty)
<|> (T.cons <$> char '\\' <*> untilDoubleQuotes)
singleQuotesString :: Parser StringType
singleQuotesString = char '\'' *> (SingleQuotes <$> untilSingleQuotes)
where untilSingleQuotes = mappend <$> A.takeWhile (\c -> c /= '\\' && c /= '\'') <*> checkCharacter
checkCharacter = (string "\'" $> mempty)
<|> (T.cons <$> char '\\' <*> untilSingleQuotes)
-- <single-animation>#
animation :: Parser Values
animation = parseCommaSeparated singleAnimation
-- <single-animation> = <time> || <timing-function> || <time> || <animation-iteration-count> || <animation-direction> || <animation-fill-mode> || <animation-play-state> || [ none | <keyframes-name> ]
singleAnimation :: Parser Value
singleAnimation = do
sa <- permute (mkSingleAnimation <$?> (Nothing, Just <$> keyframesName <* skipComments)
<|?> (Nothing, Just <$> iterationCount <* skipComments)
<|?> (Nothing, Just <$> duration <* skipComments)
<|?> (Nothing, Just <$> duration <* skipComments)
<|?> (Nothing, Just <$> timingFunction <* skipComments)
<|?> (Nothing, Just <$> animationDirection <* skipComments)
<|?> (Nothing, Just <$> animationFillMode <* skipComments)
<|?> (Nothing, Just <$> animationPlayState <* skipComments))
if saIsEmpty sa
then mzero
else pure sa
where -- mkSingleAnimation is used to order properly the overlapping values parsed by permute.
mkSingleAnimation kf ic t1 t2 tf c d e = SingleAnimation t2 tf t1 ic c d e kf
saIsEmpty (SingleAnimation Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing) = True
saIsEmpty _ = False
iterationCount = (mkOther <$> asciiCI "infinite") <|> (NumberV <$> number)
animationDirection = parseIdents ["normal", "reverse", "alternate", "alternate-reverse"]
animationFillMode = parseIdents ["none", "forwards", "backwards", "both"]
animationPlayState = parseIdents ["running", "paused"]
keyframesName = stringvalue <|> (mkOther <$> ident)
parseIdents :: [Text] -> Parser TextV
parseIdents ls = do
i <- ident
if Set.member (T.toLower i) s
then pure $ TextV i
else mzero
where s = Set.fromList ls
-- <single-animation-fill-mode> = none | forwards | backwards | both