diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,53 @@ # Changelog This project adheres to [PVP](https://pvp.haskell.org). +## 1.0.1 + +### Added + +* Removing `all` and `all and` in media query lists, since `all` + is assumed when not present. In other words, the following + rules are equivalent: + ```css + @media all {/*..*/} + @media {/*..*/} + ``` + and so are these: + ```css + @media all and (min-width: 500px) {/*..*/} + @media (min-width: 500px) {/*..*/} + ``` + Note that this applies to media query lists in at-import rules too. + +* Replacing the `url()` notation for a \ when used in the `@import` + rule. + +* Four pseudoelement minifications: + + 1. `:nth-of-type(1)` --> `:first-of-type`. + 2. `:nth-last-of-type(1)` --> `:last-of-type`. + 3. `:nth-child(1)` --> `:first-child`. + 4. `:nth-last-child(1)` --> `:last-child`. + +* `[class~=x]` to `.x` minification. + +### Improved +* \ parser, making hasmin around four times faster on stylesheets with + many \ values. + +### Fixed +* Length's Eq instance, which would equate lengths with the same numerical + value when one had an absolute unit, and the other relative, e.g. 1in and 1em. +* Escaped character conversion: converting characters would crash the program + when: + + 1. The escaped character had more than 6 hexadecimal digits (6 is the specs + maximum); E.g. `\aaaaaaa`. + 2. The escaped character's numerical representation was out of the unicode + range. + + This is no longer the case. + ## 1.0 ### Added diff --git a/hasmin.cabal b/hasmin.cabal --- a/hasmin.cabal +++ b/hasmin.cabal @@ -1,5 +1,5 @@ name: hasmin -version: 1.0 +version: 1.0.1 license: BSD3 license-file: LICENSE author: (c) 2017 Cristian Adrián Ontivero @@ -34,17 +34,11 @@ main-is: Main.hs other-modules: Paths_hasmin build-depends: base >=4.9 && <5.1 - , attoparsec >=0.12 && <0.14 - , containers >=0.5 && <0.6 , optparse-applicative >=0.11 && <0.15 - , parsers >=0.12.3 && <0.13 , text >=1.2 && <1.3 , hopfli >=0.2 && <0.4 , bytestring >=0.10.2.0 && <0.11 , gitrev >=1.0.0 && <1.4 - , matrix >=0.3.4 && <0.4 - , mtl >=2.2.1 && <2.3 - , numbers >=3000.2.0.0 && <3000.3 , hasmin library @@ -68,6 +62,7 @@ , Hasmin.Types.FilterFunction , Hasmin.Types.Position , Hasmin.Types.BgSize + , Hasmin.Types.String , Hasmin.Utils , Hasmin.Types.TimingFunction other-modules: Hasmin.Parser.Utils @@ -76,10 +71,9 @@ , Hasmin.Types.Gradient , Hasmin.Types.PercentageLength , Hasmin.Types.Shadow - , Hasmin.Types.String build-depends: base >=4.9 && <5.1 + , bifunctors >=5.4 && <5.5 , attoparsec >=0.12 && <0.14 - , bytestring >=0.10.2.0 && <0.11 , containers >=0.5 && <0.6 , matrix >=0.3.4 && <0.4 , mtl >=2.2.1 && <2.3 diff --git a/src/Hasmin.hs b/src/Hasmin.hs --- a/src/Hasmin.hs +++ b/src/Hasmin.hs @@ -34,7 +34,7 @@ minifyCSSWith cfg t = do sheet <- parseOnly stylesheet t let rs = runReader (minifyRules sheet) cfg - pure . TL.toStrict . toLazyText . mconcat $ map toBuilder rs + pure . TL.toStrict . toLazyText $ foldMap toBuilder rs -- | Minify 'Text' CSS, using a default set of configurations (with most -- minification techniques enabled). 'minifyCSS' is equivalent to diff --git a/src/Hasmin/Parser/Internal.hs b/src/Hasmin/Parser/Internal.hs --- a/src/Hasmin/Parser/Internal.hs +++ b/src/Hasmin/Parser/Internal.hs @@ -11,6 +11,7 @@ module Hasmin.Parser.Internal ( stylesheet , atRule + , atMedia , styleRule , rule , rules @@ -20,9 +21,7 @@ , supportsCondition ) where -import Control.Arrow (first) -import Control.Applicative ((<|>), many, some, empty) -import qualified Data.List.NonEmpty as NE +import Control.Applicative ((<|>), many, some, empty, optional) import Data.Functor (($>)) import Data.Attoparsec.Combinator (lookAhead, sepBy, endOfInput) import Data.Attoparsec.Text (asciiCI, char, many1, manyTill, @@ -33,6 +32,7 @@ import Data.Text (Text) import Data.Text.Lazy.Builder as LB import Data.Map.Strict (Map) +import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Attoparsec.Text as A @@ -59,11 +59,11 @@ -- | Parser for selector combinators, i.e. ">>" (descendant), '>' (child), '+' -- (adjacent sibling), '~' (general sibling), and ' ' (descendant) combinators. combinator :: Parser Combinator -combinator = (skipComments *> ((string ">>" $> Descendant) +combinator = (skipComments *> ((string ">>" $> DescendantBrackets) <|> (char '>' $> Child) <|> (char '+' $> AdjacentSibling) <|> (char '~' $> GeneralSibling))) - <|> (satisfy ws $> Descendant) + <|> (satisfy ws $> DescendantSpace) where ws c = c == ' ' || c == '\t' || c == '\n' || c == '\r' || c == '\f' compoundSelector :: Parser CompoundSelector @@ -150,30 +150,27 @@ Just p -> functionParser p Nothing -> functionParser (FunctionalPseudoClass i <$> A.takeWhile (/= ')')) _ -> pure $ PseudoClass i - pseudoElementSelector = do - parsedColon <- option False (char ':' $> True) - if parsedColon - then PseudoElem <$> ident - else ident >>= handleSpecialCase - where handleSpecialCase :: Text -> Parser SimpleSelector - handleSpecialCase t = if T.toCaseFold t `elem` specialPseudoElements - then pure $ PseudoElem t - else empty + pseudoElementSelector = + (char ':' *> (PseudoElem <$> ident)) <|> (ident >>= handleSpecialCase) + where + handleSpecialCase :: Text -> Parser SimpleSelector + handleSpecialCase t + | isSpecialPseudoElement = pure $ PseudoElem t + | otherwise = empty + where isSpecialPseudoElement = T.toCaseFold t `elem` specialPseudoElements -- \ microsyntax parser. anplusb :: Parser AnPlusB anplusb = (asciiCI "even" $> Even) <|> (asciiCI "odd" $> Odd) <|> do - s <- option Nothing (Just <$> parseSign) - x <- option mempty digits - case x of - [] -> ciN *> skipComments *> option (A s Nothing) (AB s Nothing <$> bValue) - _ -> do n <- option False (ciN $> True) - let a = read x :: Int - if n - then skipComments *> option (A s (Just a)) (AB s (Just a) <$> bValue) - else pure $ B (getSign s * a) + s <- optional parseSign + dgts <- option mempty digits + case dgts of + [] -> ciN *> skipComments *> option (A s Nothing) (AB s Nothing <$> bValue) + _ -> let n = read dgts :: Int + in (ciN *> skipComments *> option (A s $ Just n) (AB s (Just n) <$> bValue)) + <|> (pure . B $ getSign s * n) where ciN = satisfy (\c -> c == 'N' || c == 'n') parseSign = (char '-' $> Minus) <|> (char '+' $> Plus) getSign (Just Minus) = -1 @@ -187,7 +184,7 @@ -- Functional pseudo classes parsers map fpcMap :: Map Text (Parser SimpleSelector) -fpcMap = Map.fromList $ fmap (first T.toCaseFold) +fpcMap = Map.fromList [buildTuple "nth-of-type" (\x -> FunctionalPseudoClass2 x <$> anplusb) ,buildTuple "nth-last-of-type" (\x -> FunctionalPseudoClass2 x <$> anplusb) ,buildTuple "nth-column" (\x -> FunctionalPseudoClass2 x <$> anplusb) @@ -286,9 +283,7 @@ pure $ AtImport esu mql atCharset :: Parser Rule -atCharset = do - st <- lexeme stringtype <* char ';' - pure $ AtCharset st +atCharset = AtCharset <$> (lexeme stringtype <* char ';') -- @namespace ? [ | ]; -- where @@ -301,14 +296,13 @@ else decideBasedOn i _ <- skipComments <* char ';' pure ret - where decideBasedOn x = - let urltext = T.toCaseFold "url" - in if T.toCaseFold x == urltext - then do c <- A.peekChar - case c of - Just '(' -> AtNamespace mempty <$> (char '(' *> (Right <$> url)) - _ -> AtNamespace x <$> (skipComments *> stringOrUrl) - else AtNamespace x <$> (skipComments *> stringOrUrl) + where decideBasedOn x + | T.toCaseFold x == "url" = + do c <- A.peekChar + case c of + Just '(' -> AtNamespace mempty <$> (char '(' *> (Right <$> url)) + _ -> AtNamespace x <$> (skipComments *> stringOrUrl) + | otherwise = AtNamespace x <$> (skipComments *> stringOrUrl) atKeyframe :: Text -> Parser Rule atKeyframe t = do @@ -360,7 +354,7 @@ supportsCondInParens :: Parser SupportsCondInParens supportsCondInParens = do _ <- char '(' - x <- lexeme ((ParensCond <$> supportsCondition) <|> (ParensDec <$> atSupportsDeclaration)) + x <- lexeme $ (ParensCond <$> supportsCondition) <|> (ParensDec <$> atSupportsDeclaration) _ <- char ')' pure x @@ -456,8 +450,8 @@ expression = char '(' *> skipComments *> (expr <|> expFallback) where expr = do e <- ident <* skipComments - v <- option Nothing (char ':' *> lexeme (Just <$> value)) - _ <- char ')' + v <- optional (char ':' *> lexeme value) + _ <- char ')' -- Needed here for expFallback to trigger pure $ Expression e v expFallback = InvalidExpression <$> A.takeWhile (/= ')') <* char ')' diff --git a/src/Hasmin/Parser/Utils.hs b/src/Hasmin/Parser/Utils.hs --- a/src/Hasmin/Parser/Utils.hs +++ b/src/Hasmin/Parser/Utils.hs @@ -18,8 +18,10 @@ , digits , comma , colon + , slash , opt , nmchar + , hexadecimal ) where import Control.Applicative ((<|>), many) @@ -50,6 +52,9 @@ colon :: Parser Char colon = lexeme $ char ':' +slash :: Parser Char +slash = lexeme $ char '/' + lexeme :: Parser a -> Parser a lexeme p = skipComments *> p <* skipComments @@ -78,7 +83,7 @@ is <- many (skipComments *> ident) if T.toLower i `elem` invalidNames then mzero - else pure $ i <> mconcat (map (" "<>) is) + else pure $ i <> foldMap (" "<>) is where invalidNames = ["serif", "sans-serif", "monospace", "cursive", "fantasy", "inherit", "initial", "unset", "default"] @@ -133,3 +138,6 @@ -- | Parser one or more digits. digits :: Parser String digits = many1 digit + +hexadecimal :: Parser Char +hexadecimal = satisfy C.isHexDigit diff --git a/src/Hasmin/Parser/Value.hs b/src/Hasmin/Parser/Value.hs --- a/src/Hasmin/Parser/Value.hs +++ b/src/Hasmin/Parser/Value.hs @@ -11,8 +11,8 @@ -- Parsers for CSS values. -- ----------------------------------------------------------------------------- -module Hasmin.Parser.Value ( - valuesFor +module Hasmin.Parser.Value + ( valuesFor , valuesFallback , value , valuesInParens @@ -31,7 +31,7 @@ , fontStyle ) where -import Control.Applicative ((<|>), many, liftA3) +import Control.Applicative ((<|>), many, liftA3, optional) import Control.Arrow (first, (&&&)) import Control.Monad (mzero) import Data.Functor (($>)) @@ -135,8 +135,6 @@ Nothing -> pure $ mkHex6 [a,b] [c,d] [e,f] Just g -> do h <- hexadecimal pure $ mkHex8 [a,b] [c,d] [e,f] [g,h] - where optional w = option Nothing (Just <$> w) - hexadecimal = satisfy C.isHexDigit -- --------------------------------------------------------------------------- -- Dimensions Parsers @@ -228,7 +226,7 @@ -- parsers to use (e.g.: see the parsers int, or rational) int' :: Parser String int' = do - sign <- option '+' (char '-' <|> char '+') + sign <- char '-' <|> pure '+' d <- digits case sign of '+' -> pure d @@ -260,12 +258,7 @@ -- | Parser for >, -- used in the @font-style@ and @font@ properties. fontStyle :: Parser Value -fontStyle = do - k <- ident - if Set.member k keywords - then pure $ mkOther k - else mzero - where keywords = Set.fromList ["normal", "italic", "oblique"] +fontStyle = Other <$> matchKeywords ["normal", "italic", "oblique"] {- fontWeight :: Parser Value @@ -282,14 +275,9 @@ fontSize = fontSizeKeyword <|> (LengthV <$> distance) <|> (PercentageV <$> percentage) - where fontSizeKeyword = do - v1 <- ident - if Set.member v1 keywords - then pure $ mkOther v1 - else mzero - keywords = Set.fromList ["medium", "xx-small", "x-small", "small" - ,"large", "x-large", "xx-large", "smaller" - ,"larger"] + where fontSizeKeyword = Other <$> matchKeywords + ["large", "xx-small", "x-small", "small", "medium", + "x-large", "xx-large", "smaller" , "larger"] {- [ [ <‘font-style’> || || <‘font-weight’> || - <‘font-stretch’> ]? <‘font-size’> [ / <‘line-height’> ]? <‘font-family’> ] | @@ -298,65 +286,79 @@ -} --- TODO clean parsers pos1, pos2, and pos4 positionvalue :: Parser Value positionvalue = PositionV <$> position -- | Parser for >. position :: Parser Position -position = pos4 <|> pos2 <|> pos1 +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) -pos1 :: Parser Position -pos1 = (asciiCI "left" $> f (Just PosLeft)) - <|> (asciiCI "center" $> f (Just PosCenter)) - <|> (asciiCI "right" $> f (Just PosRight)) - <|> (asciiCI "top" $> f (Just PosTop)) - <|> (asciiCI "bottom" $> f (Just PosBottom)) - <|> ((\a -> Position Nothing a Nothing Nothing) <$> (Just <$> percentageLength)) - where f x = Position x Nothing Nothing Nothing + 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 -pos2 :: Parser Position -pos2 = firstx <|> firsty - where firstx = do - a <- (asciiCI "left" $> Position (Just PosLeft) Nothing) - <|> (asciiCI "center" $> Position (Just PosCenter) Nothing) - <|> (asciiCI "right" $> Position (Just PosRight) Nothing) - <|> ((Position Nothing . Just) <$> percentageLength) - skipComments *> ((asciiCI "top" $> a (Just PosTop) Nothing) - <|> (asciiCI "center" $> a (Just PosCenter) Nothing) - <|> (asciiCI "bottom" $> a (Just PosBottom) Nothing) - <|> ((a Nothing . Just) <$> percentageLength)) - firsty = do - a <- (asciiCI "top" $> Position (Just PosTop) Nothing) - <|> (asciiCI "center" $> Position (Just PosCenter) Nothing) - <|> (asciiCI "bottom" $> Position (Just PosBottom) Nothing) - <|> ((Position Nothing . Just) <$> percentageLength) - skipComments *> ((asciiCI "left" $> a (Just PosLeft) Nothing) - <|> (asciiCI "center" $> a (Just PosCenter) Nothing) - <|> (asciiCI "right" $> a (Just PosRight) Nothing) - <|> ((a Nothing . Just) <$> percentageLength)) + maybePL :: Parser (Maybe PercentageLength) + maybePL = optional percentageLength -pos4 :: Parser Position -pos4 = firstx <|> firsty - where posTop = asciiCI "top" $> Position (Just PosTop) - posRight = asciiCI "right" $> Position (Just PosRight) - posBottom = asciiCI "bottom" $> Position (Just PosBottom) - posLeft = asciiCI "left" $> Position (Just PosLeft) - firstx = do - x <- (asciiCI "center" $> Position (Just PosCenter) Nothing) - <|> ((posLeft <|> posRight) <*> (skipComments *> option Nothing (Just <$> percentageLength))) - _ <- skipComments - (asciiCI "center" $> x (Just PosCenter) Nothing) - <|> (((asciiCI "top" $> x (Just PosTop)) <|> (asciiCI "bottom" $> x (Just PosBottom))) - <*> (skipComments *> option Nothing (Just <$> percentageLength))) - firsty = do - x <- (asciiCI "center" $> Position (Just PosCenter) Nothing) - <|> ((posTop <|> posBottom) <*> (skipComments *> option Nothing (Just <$> percentageLength))) - _ <- skipComments - (asciiCI "center" $> x (Just PosCenter) Nothing) - <|> (((asciiCI "left" $> x (Just PosLeft)) <|> (asciiCI "right" $> x (Just PosRight))) - <*> (skipComments *> option Nothing (Just <$> 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 @@ -447,16 +449,13 @@ box2 :: Parser (TextV, Maybe TextV) box2 = do x <- box <* skipComments - y <- option Nothing (Just <$> box) + y <- optional box pure (x,y) -- used for the background property, which takes among other things: -- [ / ]? positionAndBgSize :: Parser (Position, Maybe BgSize) -positionAndBgSize = do - x <- position <* skipComments - y <- option Nothing (Just <$> (char '/' *> skipComments *> bgSize)) - pure (x,y) +positionAndBgSize = (,) <$> position <*> optional (slash *> bgSize) matchKeywords :: [Text] -> Parser TextV matchKeywords listOfKeywords = do @@ -499,7 +498,7 @@ singleTransitionProperty = do i <- ident let lowercased = T.toLower i - if Set.member lowercased excludedKeywords + if lowercased `Set.member` excludedKeywords then mzero else pure $ TextV i excludedKeywords = Set.fromList ["initial", "inherit", "unset", "default", "none"] @@ -508,21 +507,17 @@ timingFunction :: Parser TimingFunction timingFunction = do i <- ident - let lowercased = T.toLower i - case Map.lookup lowercased timingFunctionKeywords of - Just x -> x - Nothing -> char '(' *> (if lowercased == "steps" - then steps - else if lowercased == "cubic-bezier" - then cubicbezier - else mzero) - 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)] + 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) @@ -609,7 +604,7 @@ where systemFonts = Other <$> parseIdents ["caption", "icon", "menu", "message-box", "small-caption", "status-bar"] fontSizeAndLineHeight = do fsz <- fontSize <* skipComments - lh <- option Nothing (Just <$> (char '/' *> lexeme lineHeight)) + lh <- optional (char '/' *> lexeme lineHeight) pure (fsz, lh) lineHeight = let validNum = do n <- numericalvalue case n of @@ -700,7 +695,7 @@ unquotedFontFamily = do v <- ident vs <- many (skipComments *> ident) - pure $ v <> mconcat (map (T.singleton ' ' <>) vs) + pure $ v <> foldMap (T.singleton ' ' <>) vs textualvalue :: Parser Value @@ -881,8 +876,8 @@ dropShadow = functionParser $ do l1 <- distance l2 <- lexeme distance - l3 <- option Nothing ((Just <$> distance) <* skipComments) - c <- option Nothing (Just <$> color) + l3 <- optional (distance <* skipComments) + c <- optional color pure $ DropShadow l1 l2 l3 c textShadow :: Parser Values @@ -895,7 +890,7 @@ lns = do l1 <- distance l2 <- lexeme distance - l3 <- option Nothing ((Just <$> distance) <* skipComments) + l3 <- optional (distance <* skipComments) pure (l1,l2,l3) -- | Parser for > @@ -926,14 +921,14 @@ fourLengths = do l1 <- distance l2 <- lexeme distance - l3 <- option Nothing ((Just <$> distance) <* skipComments) - l4 <- option Nothing ((Just <$> distance) <* skipComments) + 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 <- option Nothing (asciiCI "at" *> skipComments *> (Just <$> position)) + p <- optional (asciiCI "at" *> skipComments *> position) _ <- if def && isNothing p then pure '*' -- do nothing else comma @@ -962,25 +957,21 @@ -- : [|to ,]? [, ]+ lineargradient :: Parser Gradient lineargradient = functionParser (lg <|> oldLg) - where lg = do - x <- option Nothing angleOrSide - c <- colorStopList - pure $ LinearGradient x c - oldLg = do - x <- option Nothing ((ga <|> ((Just . Right) <$> sideOrCorner)) <* comma) - c <- colorStopList - pure $ OldLinearGradient x c + where lg = LinearGradient <$> optional angleOrSide <*> colorStopList + oldLg = OldLinearGradient <$> optional ((ga <|> sc) <* comma) + <*> colorStopList angleOrSide = (ga <|> gs) <* comma - ga = (Just . Left) <$> angle - gs = asciiCI "to" *> skipComments *> ((Just . Right) <$> sideOrCorner) + ga = Left <$> angle + gs = asciiCI "to" *> skipComments *> sc + sc = Right <$> sideOrCorner -- = [left | right] || [top | bottom] sideOrCorner :: Parser (Side, Maybe Side) sideOrCorner = orderOne <|> orderTwo where orderOne = (,) <$> leftright <* skipComments - <*> option Nothing (Just <$> topbottom) + <*> optional topbottom orderTwo = (,) <$> topbottom <* skipComments - <*> option Nothing (Just <$> leftright) + <*> optional leftright leftright :: Parser Side leftright = (asciiCI "left" $> LeftSide) @@ -1000,7 +991,7 @@ colorStop :: Parser ColorStop colorStop = ColorStop <$> color <* skipComments - <*> option Nothing (Just <$> percentageLength <* skipComments) + <*> optional (percentageLength <* skipComments) -- | Parser for >. color :: Parser Color @@ -1041,15 +1032,15 @@ -- | Assumes "translate(" has been already parsed translate :: Parser TransformFunction translate = functionParser $ do - pl <- percentageLength <* skipComments - mpl <- option Nothing (char ',' *> skipComments *> (Just <$> percentageLength)) + 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 <* skipComments - mn <- option Nothing (char ',' *> skipComments *> (Just <$> number)) + n <- number + mn <- optional (comma *> number) pure $ Scale n mn scale3d :: Parser TransformFunction @@ -1058,16 +1049,15 @@ skew :: Parser TransformFunction skew = functionParser $ do - a <- angle <* skipComments - ma <- option Nothing (char ',' *> skipComments *> (Just <$> angle)) + a <- angle + ma <- optional (comma *> angle) pure $ Skew a ma translate3d :: Parser TransformFunction -translate3d = functionParser $ do - x <- percentageLength <* comma - y <- percentageLength <* comma - z <- distance - pure $ Translate3d x y z +translate3d = functionParser $ + Translate3d <$> percentageLength <* comma + <*> percentageLength <* comma + <*> distance matrix :: Parser TransformFunction matrix = functionParser $ do @@ -1100,7 +1090,7 @@ steps :: Parser TimingFunction steps = functionParser $ do i <- int - s <- option Nothing (comma *> (Just <$> startOrEnd)) + s <- optional (comma *> startOrEnd) pure $ Steps i s where startOrEnd = (asciiCI "end" $> End) <|> (asciiCI "start" $> Start) diff --git a/src/Hasmin/Types/BgSize.hs b/src/Hasmin/Types/BgSize.hs --- a/src/Hasmin/Types/BgSize.hs +++ b/src/Hasmin/Types/BgSize.hs @@ -73,5 +73,5 @@ minifyBgSizeArg :: Either PercentageLength Auto -> Reader Config (Either PercentageLength Auto) -minifyBgSizeArg (Left a) = Left <$> minify a +minifyBgSizeArg (Left a) = Left <$> minifyPL a minifyBgSizeArg (Right Auto) = pure $ Right Auto diff --git a/src/Hasmin/Types/Declaration.hs b/src/Hasmin/Types/Declaration.hs --- a/src/Hasmin/Types/Declaration.hs +++ b/src/Hasmin/Types/Declaration.hs @@ -40,16 +40,17 @@ import Hasmin.Utils -- | A CSS >. -data Declaration = Declaration { propertyName :: Text -- ^ Property name of the declaration. - , valueList :: Values -- ^ Values used in the declaration. - , isImportant :: Bool -- ^ Whether the declaration is \"!important\" (i.e. ends with it). - , hasIEhack :: Bool -- ^ Whether the declaration ends with the \"\\9\" IE hack. - } deriving (Eq, Show) +data Declaration = Declaration + { propertyName :: Text -- ^ Property name of the declaration. + , valueList :: Values -- ^ Values used in the declaration. + , isImportant :: Bool -- ^ Whether the declaration is \"!important\" (i.e. ends with it). + , hasIEhack :: Bool -- ^ Whether the declaration ends with the \"\\9\" IE hack. + } deriving (Eq, Show) instance ToText Declaration where toBuilder (Declaration p vs i h) = fromText p <> singleton ':' - <> toBuilder vs <> imp <> (if h then " \\9" else mempty) - where imp | i = "!important" - | otherwise = mempty + <> toBuilder vs <> imp <> iehack + where imp = if i then "!important" else mempty + iehack = if h then "\\9" else mempty instance Ord Declaration where -- Just use a lexicographical ordering, since the instance is required by Set @@ -159,7 +160,7 @@ zeroPercentageToLength x = PercentageV x f (BgSizeV bgsz) = pure . BgSizeV $ case bgsz of - BgSize1 x -> BgSize1 (zeroPerToLength x) + BgSize1 x -> BgSize1 (zeroPerToLength x) BgSize2 x y -> BgSize2 (zeroPerToLength x) (zeroPerToLength y) x -> x where zeroPerToLength (Left (Left 0)) = Left $ Right NullLength @@ -174,13 +175,13 @@ replaceWithZero :: Text -> Declaration -> Reader Config Declaration replaceWithZero s d@(Declaration p (Values v vs) _ _) | not (null vs) = pure d -- Some error occured, since there should be only one value - | otherwise = + | otherwise = pure $ case Map.lookup (T.toCaseFold p) propertiesTraits of Just (PropertyInfo iv inhs _ _) -> if f iv inhs == mkOther s - then pure $ d { valueList = Values (LengthV NullLength) [] } - else pure d - Nothing -> pure d + then d { valueList = Values (LengthV NullLength) [] } + else d + Nothing -> d where f (Just (Values x _)) inh | v == Initial || v == Unset && inh == NonInherited = x | otherwise = v @@ -199,9 +200,9 @@ replaceForSynonym :: TextV -> Value replaceForSynonym t - | t == TextV "normal" = NumberV 400 - | t == TextV "bold" = NumberV 700 - | otherwise = Other t + | t == "normal" = NumberV 400 + | t == "bold" = NumberV 700 + | otherwise = Other t optimizeTransformOrigin :: Declaration -> Reader Config Declaration optimizeTransformOrigin d@(Declaration _ vals _ _) = do @@ -535,10 +536,7 @@ _ -> Nothing -- E.g.: an iehack read as a value. where originalLength = textualLength d1 + textualLength d2 + 1 -- The (+1) is because of the ; trblValues = v1 : map snd vs - indexTable = fmap (first T.toCaseFold) [("top", 0) - ,("right", 1) - ,("bottom", 2) - ,("left", 3)] + indexTable = zip ["top", "right", "bottom", "left"] [0..] -- E.g.: margin: 6px 6px 6px 6px; --> margin: 6px; -- margin: 1px 0 2px 0; --> margin: 1px 0 2px; diff --git a/src/Hasmin/Types/Dimension.hs b/src/Hasmin/Types/Dimension.hs --- a/src/Hasmin/Types/Dimension.hs +++ b/src/Hasmin/Types/Dimension.hs @@ -46,8 +46,9 @@ deriving (Show) instance Eq Length where (Length r1 u1) == (Length r2 u2) - | u1 == u2 = r1 == r2 - | otherwise = toInches r1 u1 == toInches r2 u2 + | u1 == u2 = r1 == r2 + | isAbsolute u1 && isAbsolute u2 = toInches r1 u1 == toInches r2 u2 + | otherwise = r1 == 0 && r2 == 0 x == y = isZeroLen x && isZeroLen y instance Minifiable Length where minify NullLength = pure NullLength @@ -62,6 +63,10 @@ isRelative :: LengthUnit -> Bool isRelative x = x == EM || x == EX || x == CH || x == VH || x == VW || x == VMIN || x == VMAX || x == REM + +isAbsolute :: LengthUnit -> Bool +isAbsolute x = x == PX || x == PT || x == PC || x == IN + || x == MM || x == CM || x == Q isRelativeLength :: Length -> Bool isRelativeLength (Length _ u) = isRelative u diff --git a/src/Hasmin/Types/FilterFunction.hs b/src/Hasmin/Types/FilterFunction.hs --- a/src/Hasmin/Types/FilterFunction.hs +++ b/src/Hasmin/Types/FilterFunction.hs @@ -8,14 +8,15 @@ -- Portability : unknown -- ----------------------------------------------------------------------------- -module Hasmin.Types.FilterFunction ( - FilterFunction(..) +module Hasmin.Types.FilterFunction + ( FilterFunction(..) , minifyPseudoShadow ) where import Control.Monad.Reader (Reader, ask) import Data.Monoid ((<>)) import Data.Text.Lazy.Builder (singleton, Builder) + import Hasmin.Config import Hasmin.Class import Hasmin.Types.Dimension @@ -91,9 +92,9 @@ z <- case c of Just r -> if isZeroLen r then pure Nothing - else mapM minify c + else traverse minify c Nothing -> pure Nothing - c2 <- mapM minify d + c2 <- traverse minify d pure $ constr x y z c2 minifyNumberPercentage :: Either Number Percentage @@ -117,4 +118,3 @@ filterFunctionEquality (Right a) (Right b) = toRational a == toRational b filterFunctionEquality (Left a) (Right b) = toRational a == toRational b/100 filterFunctionEquality (Right a) (Left b) = toRational a/100 == toRational b - diff --git a/src/Hasmin/Types/Gradient.hs b/src/Hasmin/Types/Gradient.hs --- a/src/Hasmin/Types/Gradient.hs +++ b/src/Hasmin/Types/Gradient.hs @@ -66,9 +66,8 @@ | otherwise = c1 newC2 | ch2 == Just (Left (Percentage 100)) = c2 {colorHint = Nothing} - | otherwise = if ch2 `notGreaterThan` ch1 - then c2 {colorHint = Just $ Right NullLength} - else c2 + | ch2 `notGreaterThan` ch1 = c2 {colorHint = Just $ Right NullLength} + | otherwise = c2 minifyColorHints (c@(ColorStop a x):xs) = case x of Nothing -> c : analyzeList (Left $ Percentage 0) 1 (c:xs) xs Just y -> if isZero y @@ -85,7 +84,7 @@ Left p -> maybe False (either (<= p) (const False)) y Right d -> maybe False (either (const False) (notGreaterThanLength d)) y where notPositive = maybe False (either (<= 0) notPositiveLength) - + notPositiveLength (Length d _) = d <= 0 notPositiveLength NullLength = True @@ -179,7 +178,10 @@ -- | CSS > data -- type, used by @radial-gradient()@. -data Size = ClosestCorner | ClosestSide | FarthestCorner | FarthestSide +data Size = ClosestCorner + | ClosestSide + | FarthestCorner + | FarthestSide | SL Length | PL PercentageLength PercentageLength deriving (Eq, Show) @@ -254,25 +256,21 @@ minifyAngleOrSide :: Maybe (Either Angle SideOrCorner) -> Reader Config (Maybe (Either Angle SideOrCorner)) -minifyAngleOrSide mas = - case mas of - Nothing -> pure Nothing - Just y -> case y of - Left a -> if a == defaultGradientAngle - then pure Nothing - else minify a >>= pure . Just . Left - Right b -> if b == defaultGradientSideOrCorner - then pure Nothing - else pure $ Just (minifySide b) - where minifySide (TopSide, Nothing) = Left NullAngle +minifyAngleOrSide Nothing = pure Nothing +minifyAngleOrSide (Just (Left a)) + | a == defaultGradientAngle = pure Nothing + | otherwise = (Just . Left) <$> minify a + where defaultGradientAngle = Angle 180 Deg +minifyAngleOrSide (Just (Right b)) + | b == defaultGradientSideOrCorner = pure Nothing + | otherwise = pure $ Just (minifySide b) + where defaultGradientSideOrCorner = (BottomSide, Nothing) + minifySide (TopSide, Nothing) = Left NullAngle minifySide (RightSide, Nothing) = Left (Angle 90 Deg) minifySide (BottomSide, Nothing) = Left (Angle 180 Deg) minifySide (LeftSide, Nothing) = Left (Angle 270 Deg) minifySide z = Right z - defaultGradientAngle = Angle 180 Deg - defaultGradientSideOrCorner = (BottomSide, Nothing) - instance ToText Gradient where toBuilder (OldLinearGradient mas csl) = maybe mempty f mas <> mconcatIntersperse id (singleton ',') (fmap toBuilder csl) @@ -289,9 +287,9 @@ toBuilder (RadialGradient sh sz p cs) = firstPart <> mconcatIntersperse id (singleton ',') (fmap toBuilder cs) where l = catMaybes [fmap toBuilder sh, fmap toBuilder sz, fmap (\x -> "at " <> toBuilder x) p] - firstPart = if null l - then mempty - else mconcatIntersperse id (singleton ' ') l <> singleton ',' + firstPart + | null l = mempty + | otherwise = mconcatIntersperse id (singleton ' ') l <> singleton ',' instance Eq Gradient where LinearGradient x1 csl1 == LinearGradient x2 csl2 = diff --git a/src/Hasmin/Types/PercentageLength.hs b/src/Hasmin/Types/PercentageLength.hs --- a/src/Hasmin/Types/PercentageLength.hs +++ b/src/Hasmin/Types/PercentageLength.hs @@ -12,11 +12,14 @@ ( PercentageLength , isZero , isNonZeroPercentage + , minifyPL ) where +import Control.Monad.Reader (Reader) import Hasmin.Types.Dimension import Hasmin.Types.Numeric import Hasmin.Class +import Hasmin.Config -- | CSS data type, i.e.: [length | percentage] -- Though because of the name it would be more intuitive to define: @@ -25,18 +28,17 @@ -- makes no sense to minify a Percentage. type PercentageLength = Either Percentage Length --- TODO see if this instance can be deleted altogether. -instance Minifiable PercentageLength where - minify x@(Right _) = mapM minify x - minify x@(Left p) - | p == 0 = pure $ Right NullLength -- minifies 0% to 0 - | otherwise = pure x +minifyPL :: PercentageLength + -> Reader Config PercentageLength +minifyPL x@(Right _) = mapM minify x +minifyPL x@(Left p) + | p == 0 = pure $ Right NullLength -- minifies 0% to 0 + | otherwise = pure x + isNonZeroPercentage :: PercentageLength -> Bool isNonZeroPercentage (Left p) = p /= 0 isNonZeroPercentage _ = False isZero :: (Num a, Eq a) => Either a Length -> Bool isZero = either (== 0) isZeroLen - - diff --git a/src/Hasmin/Types/Selector.hs b/src/Hasmin/Types/Selector.hs --- a/src/Hasmin/Types/Selector.hs +++ b/src/Hasmin/Types/Selector.hs @@ -24,6 +24,7 @@ import Control.Applicative (liftA2) import Control.Monad.Reader (ask) import Data.Text (Text) +import Data.Bitraversable (bitraverse) import qualified Data.Text as T import Data.Text.Lazy.Builder (fromText, singleton, Builder) import Data.Monoid ((<>)) @@ -44,18 +45,34 @@ -- | A , -- which can either: whitespace, "greater-than sign" (U+003E, >), "plus sign" -- (U+002B, +) or "tilde" (U+007E, ~). -data Combinator = Descendant -- ^ ' ' - | Child -- ^ '>' - | AdjacentSibling -- ^ '+' - | GeneralSibling -- ^ '~' - deriving (Eq, Show) +data Combinator = DescendantSpace -- ^ ' ' + | DescendantBrackets -- ^ '>>' + | Child -- ^ '>' + | AdjacentSibling -- ^ '+' + | GeneralSibling -- ^ '~' + deriving (Show) +instance Eq Combinator where + DescendantSpace == DescendantSpace = True + DescendantSpace == DescendantBrackets = True + DescendantBrackets == DescendantSpace = True + DescendantBrackets == DescendantBrackets = True + Child == Child = True + AdjacentSibling == AdjacentSibling = True + GeneralSibling == GeneralSibling = True + _ == _ = False + instance ToText Combinator where - toBuilder Descendant = " " - toBuilder Child = ">" - toBuilder AdjacentSibling = "+" - toBuilder GeneralSibling = "~" + toBuilder DescendantSpace = " " + toBuilder DescendantBrackets = " " + toBuilder Child = ">" + toBuilder AdjacentSibling = "+" + toBuilder GeneralSibling = "~" +instance Minifiable Combinator where + minify DescendantBrackets = pure DescendantSpace + minify x = pure x + -- Note: an empty selector, containing no sequence of simple selectors and no -- pseudo-element, is an invalid selector. -- @@ -71,13 +88,12 @@ s1 <= s2 = toText s1 <= toText s2 instance ToText Selector where - toBuilder (Selector cs ccss) = toBuilder cs - <> mconcat (fmap build ccss) + toBuilder (Selector cs ccss) = toBuilder cs <> foldMap build ccss where build (comb, compSel) = toBuilder comb <> toBuilder compSel instance Minifiable Selector where minify (Selector c xs) = do newC <- minify c - newCs <- (mapM . mapM) minify xs + newCs <- mapM (bitraverse minify minify) xs pure $ Selector newC newCs type Specificity = (Int, Int, Int) @@ -113,8 +129,8 @@ instance ToText CompoundSelector where toBuilder ns@(Universal{} :| xs) - | length ns > 1 = mconcat $ fmap toBuilder xs - toBuilder ns = mconcat $ N.toList (fmap toBuilder ns) + | length ns > 1 = foldMap toBuilder xs + toBuilder ns = foldMap toBuilder (N.toList ns) instance Minifiable CompoundSelector where minify (a :| xs) = liftA2 (:|) (minify a) (mapM minify xs) @@ -184,7 +200,7 @@ <> singleton '(' <> toBuilder a <> f xs <> singleton ')' where f [] = mempty f (y:ys) = " of " <> toBuilder y - <> mconcat (fmap (\z -> singleton ',' <> toBuilder z) ys) + <> foldMap (\z -> singleton ',' <> toBuilder z) ys -- | List of pseudo-elements that support the old syntax of a single semicolon, -- as well as the new one of two semicolons. @@ -192,7 +208,18 @@ specialPseudoElements = fmap T.toCaseFold ["after", "before", "first-line", "first-letter"] +-- Pseudo element names are ASCII case-insensitive +-- https://drafts.csswg.org/selectors-4/#pseudo-element%20syntax instance Minifiable SimpleSelector where + -- [class~="a"] == .a + minify a@(AttributeSel (attid :~=: attval)) + -- In HTML attribute names are matched case-insensitively + | T.toLower attid == "class" = + pure $ case attval of + Left z -> ClassSel z + Right x -> case removeQuotes x of + Left y -> ClassSel y + Right _ -> a minify a@(AttributeSel att) = do conf <- ask pure $ if shouldRemoveQuotes conf @@ -213,8 +240,18 @@ Left _ -> a Right s -> Lang (removeQuotes s) else a - minify (FunctionalPseudoClass1 i cs) = FunctionalPseudoClass1 i <$> mapM minify cs - minify (FunctionalPseudoClass2 i n) = FunctionalPseudoClass2 i <$> minify n + -- Pseudoclasses are ASCII case-insensitive + -- https://drafts.csswg.org/selectors-4/#pseudo-classes + minify (FunctionalPseudoClass1 i cs) = FunctionalPseudoClass1 i <$> mapM minify cs + minify (FunctionalPseudoClass2 i (B 1)) + | iden == "nth-of-type" = pure $ PseudoClass "first-of-type" + | iden == "nth-last-of-type" = pure $ PseudoClass "last-of-type" + where iden = T.toLower i + minify (FunctionalPseudoClass2 i n) = FunctionalPseudoClass2 i <$> minify n + minify (FunctionalPseudoClass3 i (B 1) []) + | iden == "nth-last-child" = pure $ PseudoClass "last-child" + | iden == "nth-child" = pure $ PseudoClass "first-child" + where iden = T.toLower i minify (FunctionalPseudoClass3 i n cs) = FunctionalPseudoClass3 i <$> minify n <*> pure cs minify x = pure x @@ -229,6 +266,7 @@ -- | The > microsyntax type. data AnPlusB = Even | Odd + -- A Nothing Nothing is "n" alone. | A (Maybe Sign) (Maybe Int) -- "sign n number", e.g. +3n, -2n, 1n. | B Int -- "sign number", e.g. +1, +2, 3. | AB (Maybe Sign) (Maybe Int) Int -- "sign n number sign number", e.g. 2n+1 diff --git a/src/Hasmin/Types/String.hs b/src/Hasmin/Types/String.hs --- a/src/Hasmin/Types/String.hs +++ b/src/Hasmin/Types/String.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | @@ -12,16 +13,20 @@ ( removeQuotes , unquoteUrl , unquoteFontFamily + , convertEscaped , mapString , StringType(..) ) where -import Control.Applicative (liftA2) +import Control.Applicative (liftA2, (<|>)) import Control.Monad.Reader (ask, Reader) import Data.Attoparsec.Text (Parser, parse, IResult(Done, Partial, Fail), maybeResult, feed) import Data.Monoid ((<>)) import Data.Text (Text) -import Data.Text.Lazy.Builder (singleton, fromText, toLazyText) +import Data.Foldable (foldl') +import Data.Bits ((.|.), shiftL) +import Data.Text.Lazy.Builder (Builder) +import qualified Data.Text.Lazy.Builder as B import qualified Data.Attoparsec.Text as A import qualified Data.Char as C import qualified Data.Text as T @@ -33,13 +38,13 @@ -- | The > data type. -- It represents a string, formed by Unicode characters, delimited by either --- double (") or single (') quotes. +-- double (\") or single (\') quotes. data StringType = DoubleQuotes Text | SingleQuotes Text deriving (Show, Eq) instance ToText StringType where - toBuilder (DoubleQuotes t) = singleton '\"' <> fromText t <> singleton '\"' - toBuilder (SingleQuotes t) = singleton '\'' <> fromText t <> singleton '\'' + toBuilder (DoubleQuotes t) = B.singleton '\"' <> B.fromText t <> B.singleton '\"' + toBuilder (SingleQuotes t) = B.singleton '\'' <> B.fromText t <> B.singleton '\'' instance Minifiable StringType where minify (DoubleQuotes t) = do conf <- ask @@ -67,8 +72,8 @@ else t mapString :: (Text -> Reader Config Text) -> StringType -> Reader Config StringType -mapString f (DoubleQuotes t) = f t >>= pure . DoubleQuotes -mapString f (SingleQuotes t) = f t >>= pure . SingleQuotes +mapString f (DoubleQuotes t) = DoubleQuotes <$> f t +mapString f (SingleQuotes t) = SingleQuotes <$> f t unquoteStringType :: (Text -> Maybe Text) -> StringType -> Either Text StringType unquoteStringType g x@(DoubleQuotes s) = maybe (Right x) Left (g s) @@ -100,12 +105,46 @@ toUnquotedFontFamily :: Text -> Maybe Text toUnquotedFontFamily = unquote fontfamilyname +-- TODO can the Parser be avoided by a fold, or one of the provided library +-- functions? Apart from being cleaner, doing so would simplify other functions. +-- | Parse and convert any escaped unicode to its underlying Char. convertEscaped :: Parser Text -convertEscaped = (TL.toStrict . toLazyText) <$> go - where go = do - t <- fromText <$> A.takeWhile (/= '\\') - c <- A.peekChar - case c of - Just '\\' -> A.char '\\' *> liftA2 (mappend . mappend t . singleton) utf8 go - _ -> pure t - utf8 = C.chr <$> A.hexadecimal +convertEscaped = (TL.toStrict . B.toLazyText) <$> go + where + go = do + nonescapedText <- B.fromText <$> A.takeWhile (/= '\\') + cont nonescapedText <|> pure nonescapedText + cont b = do + _ <- A.char '\\' + c <- A.peekChar + case c of + Just _ -> parseEscapedAndContinue b + Nothing -> pure (b <> B.singleton '\\') + + parseEscapedAndContinue :: Builder -> Parser Builder + parseEscapedAndContinue b = do + u8 <- utf8 + (b `mappend` u8 `mappend`) <$> go + + utf8 :: Parser Builder + utf8 = do + mch <- atMost 6 hexadecimal + pure $ maybe ("\\" <> B.fromString mch) B.singleton (hexToChar mch) + + -- Interpret a hexadecimal string as a decimal Int, and convert it into the + -- corresponding Char. + hexToChar :: [Char] -> Maybe Char + hexToChar xs + | i > maxChar = Nothing + | otherwise = Just (C.chr i) + where i = foldl' step 0 xs + maxChar = fromEnum (maxBound :: Char) + step a c + | w - 48 < 10 = (a `shiftL` 4) .|. fromIntegral (w - 48) + | w >= 97 = (a `shiftL` 4) .|. fromIntegral (w - 87) + | otherwise = (a `shiftL` 4) .|. fromIntegral (w - 55) + where w = C.ord c + + atMost :: Int -> Parser a -> Parser [a] + atMost 0 _ = pure [] + atMost n p = A.option [] $ liftA2 (:) p (atMost (n-1) p) diff --git a/src/Hasmin/Types/Stylesheet.hs b/src/Hasmin/Types/Stylesheet.hs --- a/src/Hasmin/Types/Stylesheet.hs +++ b/src/Hasmin/Types/Stylesheet.hs @@ -9,8 +9,8 @@ -- Portability : unknown -- ----------------------------------------------------------------------------- -module Hasmin.Types.Stylesheet ( - Expression(..) +module Hasmin.Types.Stylesheet + ( Expression(..) , MediaQuery(..) , Rule(..) , KeyframeSelector(..) @@ -53,8 +53,8 @@ | MediaQuery2 [Expression] -- ^ Second possibility in the grammar deriving (Show, Eq) instance Minifiable MediaQuery where - minify (MediaQuery1 t1 t2 es) = MediaQuery1 t1 t2 <$> mapM minify es - minify (MediaQuery2 es) = MediaQuery2 <$> mapM minify es + minify (MediaQuery1 t1 t2 es) = MediaQuery1 t1 t2 <$> traverse minify es + minify (MediaQuery2 es) = MediaQuery2 <$> traverse minify es instance ToText MediaQuery where toBuilder (MediaQuery1 t1 t2 es) = notOrOnly <> fromText t2 <> expressions @@ -67,7 +67,7 @@ | InvalidExpression Text deriving (Show, Eq) instance Minifiable Expression where - minify (Expression t mv) = Expression t <$> mapM minify mv + minify (Expression t mv) = Expression t <$> traverse minify mv minify x = pure x instance ToText Expression where toBuilder (Expression t mv) = @@ -102,10 +102,8 @@ <> mconcatIntersperse toBuilder (singleton ';') ds <> singleton '}' instance Minifiable KeyframeBlock where - minify (KeyframeBlock ss ds) = do - decs <- mapM minify ds - sels <- mapM minify ss - pure $ KeyframeBlock sels decs + minify (KeyframeBlock ss ds) = + KeyframeBlock <$> traverse minify ss <*> traverse minify ds type VendorPrefix = Text @@ -123,9 +121,9 @@ deriving (Eq, Show) instance ToText Rule where toBuilder (AtMedia mqs rs) = "@media " <> mconcatIntersperse toBuilder (singleton ',') mqs - <> singleton '{' <> mconcat (fmap toBuilder rs) <> singleton '}' + <> singleton '{' <> foldMap toBuilder rs <> singleton '}' toBuilder (AtSupports sc rs) = "@supports " <> toBuilder sc - <> singleton '{' <> mconcat (fmap toBuilder rs) <> singleton '}' + <> singleton '{' <> foldMap toBuilder rs <> singleton '}' toBuilder (AtImport esu mqs) = "@import " <> toBuilder esu <> mediaqueries <> singleton ';' where mediaqueries = @@ -145,25 +143,26 @@ ,singleton '}'] toBuilder (AtBlockWithRules t rs) = mconcat [singleton '@', fromText t, singleton '{' - , mconcat (fmap toBuilder rs), singleton '}'] + , foldMap toBuilder rs, singleton '}'] toBuilder (AtBlockWithDec t ds) = mconcat [singleton '@', fromText t, singleton '{' ,mconcatIntersperse id (singleton ';') (fmap toBuilder ds) ,singleton '}'] toBuilder (AtKeyframes vp n bs) = singleton '@' <> fromText vp <> "keyframes" <> singleton ' ' <> fromText n <> singleton '{' - <> mconcat (fmap toBuilder bs) <> singleton '}' + <> foldMap toBuilder bs <> singleton '}' instance Minifiable Rule where - minify (AtMedia mqs rs) = liftA2 AtMedia (mapM minify mqs) (mapM minify rs) - minify (AtSupports sc rs) = liftA2 AtSupports (minify sc) (mapM minify rs) - minify (AtKeyframes vp n bs) = AtKeyframes vp n <$> mapM minify bs - minify (AtBlockWithRules t rs) = AtBlockWithRules t <$> mapM minify rs - minify (AtBlockWithDec t ds) = do - decs <- cleanRule ds >>= collapseLonghands >>= mapM minify + -- @media all {..} == @media {..} + minify (AtMedia mqs rs) = AtMedia <$> minify mqs <*> traverse minify rs + minify (AtSupports sc rs) = liftA2 AtSupports (minify sc) (traverse minify rs) + minify (AtKeyframes vp n bs) = AtKeyframes vp n <$> traverse minify bs + minify (AtBlockWithRules t rs) = AtBlockWithRules t <$> traverse minify rs + minify (AtBlockWithDec t ds) = do + decs <- cleanRule ds >>= collapseLonghands >>= traverse minify pure $ AtBlockWithDec t decs minify (StyleRule ss ds) = do - decs <- cleanRule ds >>= collapseLonghands >>= mapM minify >>= sortDeclarations - sels <- mapM minify ss >>= removeDuplicateSelectors >>= sortSelectors + decs <- cleanRule ds >>= collapseLonghands >>= traverse minify >>= sortDeclarations + sels <- traverse minify ss >>= removeDuplicateSelectors >>= sortSelectors pure $ StyleRule sels decs where sortSelectors :: [Selector] -> Reader Config [Selector] sortSelectors sls = do @@ -179,11 +178,28 @@ pure $ if shouldRemoveDuplicateSelectors conf then nub' sls else sls - - minify (AtImport esu mqs) = AtImport esu <$> mapM minify mqs + -- convert url() to " " + minify (AtImport esu mqs) = + case esu of + Left _ -> AtImport esu <$> minify mqs + Right (Url ets) -> do a <- traverse minify ets + let na = either DoubleQuotes id a + b <- minify mqs + pure $ AtImport (Left na) b minify (AtCharset s) = AtCharset <$> mapString lowercaseText s minify x = pure x +instance Minifiable [MediaQuery] where + minify (MediaQuery1 t1 t2 xs : ys) + | T.null t1 && T.toLower t2 == "all" = + case xs of + [] -> minify ys + _ -> liftA2 (:) (MediaQuery2 <$> traverse minify xs) (minify ys) + | otherwise = liftA2 (:) (MediaQuery1 t1 t2 <$> traverse minify xs) (minify ys) + minify (MediaQuery2 es : ys) = + liftA2 (:) (MediaQuery2 <$> traverse minify es) (minify ys) + minify [] = pure [] + sortDeclarations :: [Declaration] -> Reader Config [Declaration] sortDeclarations ds = do conf <- ask @@ -252,7 +268,7 @@ nub' = go Set.empty where go _ [] = [] go s (x:xs) | Set.member x s = go s xs - | otherwise = x : go (Set.insert x s) xs + | otherwise = x : go (Set.insert x s) xs data SupportsCondition = Not SupportsCondInParens | And SupportsCondInParens (NonEmpty SupportsCondInParens) @@ -297,8 +313,8 @@ toBuilder (ParensDec x) = "(" <> toBuilder x <> ")" toBuilder (ParensCond x) = "(" <> toBuilder x <> ")" instance Minifiable SupportsCondInParens where - minify (ParensDec x) = ParensDec <$> minify x - minify (ParensCond x) = ParensCond <$> minify x + minify (ParensDec x) = ParensDec <$> minify x + minify (ParensCond x) = ParensCond <$> minify x instance Minifiable [Rule] where minify = minifyRules @@ -401,7 +417,7 @@ where thereIsAPairOfSelectorsWithTheSameSpecificity = any (\x -> any (\y -> specificity x == specificity y) ss) ss2 twoDeclarationsClash = any (\x -> any (`overlaps` x) ds) ds2 shouldSkip StyleRule{} AtKeyframes{} = False - shouldSkip StyleRule{} (AtBlockWithDec t _) + shouldSkip StyleRule{} (AtBlockWithDec t _) | t == "font-face" = False | otherwise = True -- TODO see better what needs to be skipped and what doesn't need to diff --git a/src/Hasmin/Types/Value.hs b/src/Hasmin/Types/Value.hs --- a/src/Hasmin/Types/Value.hs +++ b/src/Hasmin/Types/Value.hs @@ -217,7 +217,7 @@ then FinalBgLayer (Just $ mkOther "none") p s r a bgOrigin bgClip c else FinalBgLayer i p s r a bgOrigin bgClip c minify (SingleTransition prop tdur tf tdel) = do - let p = if prop == Just (TextV "all") + let p = if prop == Just "all" then Nothing else prop -- TODO lowercase here (tDuration, tDelay) <- handleTime tdur tdel @@ -269,21 +269,17 @@ conf <- ask pure $ replaceForSynonym (fontweightSettings conf) x where replaceForSynonym s (Other t) - | t == TextV "normal" = Nothing - | t == TextV "bold" && s == FontWeightMinOn = Just $ NumberV 700 - | otherwise = Just $ Other t + | t == "normal" = Nothing + | t == "bold" && s == FontWeightMinOn = Just $ NumberV 700 + | otherwise = Just $ Other t replaceForSynonym _ (NumberV 400) = Nothing replaceForSynonym _ y = Just y - optimizeLineHeight Nothing = pure Nothing - optimizeLineHeight (Just x) = - case x of - Other t -> if t == TextV "normal" - then pure Nothing - else Just <$> minify x - y -> Just <$> minify y + optimizeLineHeight Nothing = pure Nothing + optimizeLineHeight (Just (Other "normal")) = pure Nothing + optimizeLineHeight (Just x) = Just <$> minify x minify (GenericFunc n vs) = GenericFunc n <$> minify vs - minify (Local x) = do + minify (Local x) = do conf <- ask v <- lowercaseParameters x pure . Local $ if shouldRemoveQuotes conf @@ -322,7 +318,7 @@ handleAttachment :: Maybe TextV -> Reader Config (Maybe TextV) handleAttachment = maybe (pure Nothing) f - where f x = pure $ if x == TextV "scroll" + where f x = pure $ if x == "scroll" then Nothing else Just x -- TODO might need to lowercase here. @@ -333,7 +329,7 @@ else Just <$> minify x handleBgSize :: Maybe BgSize -> Reader Config (Maybe BgSize) -handleBgSize (Just b) = do +handleBgSize (Just b) = do minb <- minify b pure $ if minb == BgSize1 (Right Auto) then Nothing diff --git a/tests/Hasmin/Parser/InternalSpec.hs b/tests/Hasmin/Parser/InternalSpec.hs --- a/tests/Hasmin/Parser/InternalSpec.hs +++ b/tests/Hasmin/Parser/InternalSpec.hs @@ -10,6 +10,18 @@ import Data.Text (Text) import Hasmin.TestUtils +ruleParserTest :: Spec +ruleParserTest = + describe "At-rule parser tests" $ + mapM_ (matchSpecWithDesc atRule) atMediaParserTestInfo + +atMediaParserTestInfo :: [(String, Text, Text)] +atMediaParserTestInfo = + [("Doesn't choke on invalid @media expression", + "@media screen and (min-resolution: 144 dpi){}", + "@media screen and (min-resolution: 144 dpi){}") + ] + declarationParserTests :: Spec declarationParserTests = describe "declaration parser tests" $ @@ -212,6 +224,7 @@ selectorParserTests selectorParserFailures styleRuleParserTests + ruleParserTest main :: IO () main = hspec spec diff --git a/tests/Hasmin/Types/DimensionSpec.hs b/tests/Hasmin/Types/DimensionSpec.hs --- a/tests/Hasmin/Types/DimensionSpec.hs +++ b/tests/Hasmin/Types/DimensionSpec.hs @@ -62,6 +62,8 @@ Length 1.27 CM `shouldBe` Length 3 PC it "1.27cm == 48px" $ Length 1.27 CM `shouldBe` Length 48 PX + it "1in != 1em" $ + Length 1 IN `shouldNotBe` Length 1 EM -- describe "