hasmin 0.3.0.1 → 0.3.1.3
raw patch · 33 files changed
+877/−794 lines, 33 filesdep −mainland-prettydep −semigroupsdep ~basePVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies removed: mainland-pretty, semigroups
Dependency ranges changed: base
API changes (from Hackage documentation)
- Hasmin.Types.Color: instance Text.PrettyPrint.Mainland.Pretty Hasmin.Types.Color.Color
- Hasmin.Types.Declaration: instance Text.PrettyPrint.Mainland.Pretty Hasmin.Types.Declaration.Declaration
- Hasmin.Types.Dimension: instance Text.PrettyPrint.Mainland.Pretty Hasmin.Types.Dimension.Angle
- Hasmin.Types.Dimension: instance Text.PrettyPrint.Mainland.Pretty Hasmin.Types.Dimension.AngleUnit
- Hasmin.Types.Dimension: instance Text.PrettyPrint.Mainland.Pretty Hasmin.Types.Dimension.Distance
- Hasmin.Types.Dimension: instance Text.PrettyPrint.Mainland.Pretty Hasmin.Types.Dimension.DistanceUnit
- Hasmin.Types.Dimension: instance Text.PrettyPrint.Mainland.Pretty Hasmin.Types.Dimension.Duration
- Hasmin.Types.Dimension: instance Text.PrettyPrint.Mainland.Pretty Hasmin.Types.Dimension.DurationUnit
- Hasmin.Types.Dimension: instance Text.PrettyPrint.Mainland.Pretty Hasmin.Types.Dimension.Frequency
- Hasmin.Types.Dimension: instance Text.PrettyPrint.Mainland.Pretty Hasmin.Types.Dimension.FrequencyUnit
- Hasmin.Types.Dimension: instance Text.PrettyPrint.Mainland.Pretty Hasmin.Types.Dimension.Resolution
- Hasmin.Types.Dimension: instance Text.PrettyPrint.Mainland.Pretty Hasmin.Types.Dimension.ResolutionUnit
- Hasmin.Types.Numeric: instance Text.PrettyPrint.Mainland.Pretty Hasmin.Types.Numeric.Alphavalue
- Hasmin.Types.Numeric: instance Text.PrettyPrint.Mainland.Pretty Hasmin.Types.Numeric.Number
- Hasmin.Types.Numeric: instance Text.PrettyPrint.Mainland.Pretty Hasmin.Types.Numeric.Percentage
- Hasmin.Types.Stylesheet: instance Text.PrettyPrint.Mainland.Pretty Hasmin.Types.Stylesheet.KeyframeSelector
- Hasmin.Types.Stylesheet: instance Text.PrettyPrint.Mainland.Pretty Hasmin.Types.Stylesheet.Rule
- Hasmin.Types.TransformFunction: instance Text.PrettyPrint.Mainland.Pretty Hasmin.Types.TransformFunction.TransformFunction
- Hasmin.Types.Value: instance Text.PrettyPrint.Mainland.Pretty Hasmin.Types.Value.Separator
- Hasmin.Types.Value: instance Text.PrettyPrint.Mainland.Pretty Hasmin.Types.Value.Url
- Hasmin.Types.Value: instance Text.PrettyPrint.Mainland.Pretty Hasmin.Types.Value.Value
- Hasmin.Types.Value: instance Text.PrettyPrint.Mainland.Pretty Hasmin.Types.Value.Values
+ Hasmin.Parser.Internal: supportsCondition :: Parser SupportsCondition
+ Hasmin.Parser.Value: timingFunction :: Parser TimingFunction
+ Hasmin.Parser.Value: valuesInParens :: Parser Values
+ Hasmin.Types.Stylesheet: And :: SupportsCondInParens -> (NonEmpty SupportsCondInParens) -> SupportsCondition
+ Hasmin.Types.Stylesheet: AtSupports :: SupportsCondition -> [Rule] -> Rule
+ Hasmin.Types.Stylesheet: Not :: SupportsCondInParens -> SupportsCondition
+ Hasmin.Types.Stylesheet: Or :: SupportsCondInParens -> (NonEmpty SupportsCondInParens) -> SupportsCondition
+ Hasmin.Types.Stylesheet: Parens :: SupportsCondInParens -> SupportsCondition
+ Hasmin.Types.Stylesheet: ParensCond :: SupportsCondition -> SupportsCondInParens
+ Hasmin.Types.Stylesheet: ParensDec :: Declaration -> SupportsCondInParens
+ Hasmin.Types.Stylesheet: data SupportsCondInParens
+ Hasmin.Types.Stylesheet: data SupportsCondition
+ Hasmin.Types.Stylesheet: instance GHC.Show.Show Hasmin.Types.Stylesheet.GeneralEnclosed
+ Hasmin.Types.Stylesheet: instance GHC.Show.Show Hasmin.Types.Stylesheet.SupportsCondInParens
+ Hasmin.Types.Stylesheet: instance GHC.Show.Show Hasmin.Types.Stylesheet.SupportsCondition
+ Hasmin.Types.Stylesheet: instance Hasmin.Types.Class.Minifiable Hasmin.Types.Stylesheet.SupportsCondInParens
+ Hasmin.Types.Stylesheet: instance Hasmin.Types.Class.Minifiable Hasmin.Types.Stylesheet.SupportsCondition
+ Hasmin.Types.Stylesheet: instance Hasmin.Types.Class.ToText Hasmin.Types.Stylesheet.SupportsCondInParens
+ Hasmin.Types.Stylesheet: instance Hasmin.Types.Class.ToText Hasmin.Types.Stylesheet.SupportsCondition
Files
- Main.hs +1/−3
- README.md +12/−2
- hasmin.cabal +8/−10
- src/Hasmin.hs +3/−3
- src/Hasmin/Config.hs +1/−0
- src/Hasmin/Parser/Internal.hs +67/−18
- src/Hasmin/Parser/Value.hs +28/−25
- src/Hasmin/Properties.hs +4/−3
- src/Hasmin/Selector.hs +0/−339
- src/Hasmin/Types/BgSize.hs +1/−1
- src/Hasmin/Types/Class.hs +3/−2
- src/Hasmin/Types/Color.hs +16/−35
- src/Hasmin/Types/Declaration.hs +4/−7
- src/Hasmin/Types/Dimension.hs +0/−23
- src/Hasmin/Types/FilterFunction.hs +1/−1
- src/Hasmin/Types/Gradient.hs +14/−19
- src/Hasmin/Types/Numeric.hs +4/−11
- src/Hasmin/Types/RepeatStyle.hs +21/−24
- src/Hasmin/Types/Selector.hs +311/−0
- src/Hasmin/Types/Shadow.hs +3/−3
- src/Hasmin/Types/String.hs +8/−11
- src/Hasmin/Types/Stylesheet.hs +99/−19
- src/Hasmin/Types/TimingFunction.hs +30/−27
- src/Hasmin/Types/TransformFunction.hs +45/−82
- src/Hasmin/Types/Value.hs +21/−34
- src/Hasmin/Utils.hs +1/−0
- tests/Hasmin/SelectorSpec.hs +0/−58
- tests/Hasmin/Types/DimensionSpec.hs +19/−19
- tests/Hasmin/Types/SelectorSpec.hs +79/−0
- tests/Hasmin/Types/StringSpec.hs +3/−3
- tests/Hasmin/Types/StylesheetSpec.hs +25/−9
- tests/Hasmin/Types/TimingFunctionSpec.hs +42/−0
- tests/Hasmin/Types/TransformFunctionSpec.hs +3/−3
Main.hs view
@@ -24,7 +24,6 @@ import qualified Data.Text.IO as TIO import qualified Data.Text.Lazy as TL import System.Exit (die)-import Text.PrettyPrint.Mainland (line, punctuate, putDoc, ppr) import Hasmin.Config import Hasmin.Parser.Internal import Hasmin.Types.Class@@ -108,7 +107,7 @@ process :: [Rule] -> Commands -> Config -> IO () process r comm conf- | shouldBeautify comm = printBeautified $ fmap ppr sheet+ | shouldBeautify comm = error "Currently unsupported" | shouldCompress comm = B.writeFile "output.gz" . compressWith defaultCompressOptions GZIP . TE.encodeUtf8 $ output | otherwise = TIO.putStr output where sheet = let ruleList = fmap (\x -> runReader (minifyWith x) conf) r@@ -116,4 +115,3 @@ then filter (not . isEmpty) ruleList else ruleList output = TL.toStrict . toLazyText $ mconcat (fmap toBuilder sheet)- printBeautified = putDoc . mconcat . punctuate (line <> line)
README.md view
@@ -1,10 +1,12 @@ Hasmin - A Haskell CSS Minifier ==== [](https://travis-ci.org/contivero/hasmin)+[](http://hackage.haskell.org/package/hasmin)+[](http://packdeps.haskellers.com/specific?package=hasmin) [](https://opensource.org/licenses/BSD-3-Clause) -Hasmin is a CSS minifier. To use it as a library, refer to the Hasmin module-documentation.+Hasmin is a CSS minifier written entirely in Haskell. To use it as a library,+see [below](https://github.com/contivero/hasmin#library) Aside from the usual techniques (e.g. whitespace removal, color minification, etc.), the idea was to explore new possibilities, by implementing things@@ -36,6 +38,14 @@ `--convert-escaped-characters` flag to enable the conversion of escaped characters. A workaround is changing the code page, which can be done by running `chcp 65001` in the terminal (whether cmd, or cygwin).++## Library+The preferable way to use Hasmin as a library is to `import Hasmin`, as+exemplified in the module's documentation. That is currently the only module+that is sure to abide by [PVP](https://pvp.haskell.org/). Most other exposed+modules are so because tests need it, and thus definitions there may be changed+anytime. In case something internal is needed though, feel free to open an issue+about it. ## Zopfli Integration Hasmin uses bindings to Google's
hasmin.cabal view
@@ -1,5 +1,5 @@ name: hasmin -version: 0.3.0.1 +version: 0.3.1.3 license: BSD3 license-file: LICENSE author: (c) 2017 Cristian Adrián Ontivero <cristianontivero@gmail.com> @@ -31,12 +31,11 @@ ghc-options: -O2 -Wall -fwarn-tabs -fwarn-unused-do-bind main-is: Main.hs other-modules: Paths_hasmin - build-depends: base >=4.8 && <5.1 + build-depends: base >=4.9 && <5.1 , attoparsec >=0.12 && <0.14 , containers >=0.5 && <0.6 , optparse-applicative >=0.11 && <0.14 , parsers >=0.12.3 && <0.13 - , mainland-pretty >=0.4.1 && <0.5 , text >=1.2 && <1.3 , hopfli >=0.2 && <0.3 , bytestring >=0.10.2.0 && <0.11 @@ -66,7 +65,7 @@ , Hasmin.Utils other-modules: Hasmin.Parser.Utils , Hasmin.Properties - , Hasmin.Selector + , Hasmin.Types.Selector , Hasmin.Types.BgSize , Hasmin.Types.FilterFunction , Hasmin.Types.Gradient @@ -76,16 +75,14 @@ , Hasmin.Types.Shadow , Hasmin.Types.String , Hasmin.Types.TimingFunction - build-depends: base >=4.8 && <5.1 + build-depends: base >=4.9 && <5.1 , attoparsec >=0.12 && <0.14 , bytestring >=0.10.2.0 && <0.11 , containers >=0.5 && <0.6 - , mainland-pretty >=0.4.1 && <0.5 , matrix >=0.3.4 && <0.4 , mtl >=2.2.1 && <2.3 , numbers >=3000.2.0.0 && <3000.3 , parsers >=0.12.3 && <0.13 - , semigroups >=0.16 && <0.19 , text >=1.2 && <1.3 test-suite spec @@ -97,7 +94,6 @@ default-extensions: OverloadedStrings other-modules: Hasmin.Parser.InternalSpec , Hasmin.Parser.ValueSpec - , Hasmin.SelectorSpec , Hasmin.TestUtils , Hasmin.Types.ColorSpec , Hasmin.Types.DeclarationSpec @@ -106,11 +102,13 @@ , Hasmin.Types.GradientSpec , Hasmin.Types.PositionSpec , Hasmin.Types.RepeatStyleSpec + , Hasmin.Types.SelectorSpec , Hasmin.Types.ShadowSpec , Hasmin.Types.StringSpec , Hasmin.Types.StylesheetSpec + , Hasmin.Types.TimingFunctionSpec , Hasmin.Types.TransformFunctionSpec - build-depends: base >=4.7 && <5.1 + build-depends: base >=4.9 && <5.1 , attoparsec >=0.12 && <0.14 , hspec >=2.2 && <3.0 , hspec-attoparsec >=0.1.0.0 && <0.2 @@ -125,7 +123,7 @@ hs-source-dirs: tests main-is: DocTest.hs ghc-options: -threaded -Wall -fno-warn-orphans - build-depends: base >=4.8 && <5.1 + build-depends: base >=4.9 && <5.1 , doctest >=0.11 && <0.12 , doctest-discover >=0.1.0.0 && <0.2 , doctest >=0.10
src/Hasmin.hs view
@@ -53,7 +53,7 @@ -- Minify it with 'minifyCSS'. In ghci: -- -- > > minifyCSS sampleSheet--- > Just "body{color:red}div{margin:0}"+-- > Right "body{color:red}div{margin:0}" -- -- To modify the minification settings, just use another 'Config', e.g.: --@@ -62,8 +62,8 @@ -- -- Once more in ghci, this time using 'minifyCSSWith': ----- > > minifyStylesheet cfg sampleSheet--- > Just "body{color:#ff0000}div{margin:0}"+-- > > minifyCSSWith cfg sampleSheet+-- > Right "body{color:#ff0000}div{margin:0}" -- -- The output is once more minified, but this time leaving colors as they were -- originally.
src/Hasmin/Config.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Module : Hasmin.Config
src/Hasmin/Parser/Internal.hs view
@@ -14,11 +14,13 @@ , declaration , declarations , selector+ , supportsCondition ) where import Control.Arrow (first)-import Control.Applicative ((<|>), many)+import Control.Applicative ((<|>), many, some) import Control.Monad (mzero)+import qualified Data.List.NonEmpty as NE import Data.Functor (($>)) import Data.Attoparsec.Combinator (lookAhead, sepBy, endOfInput) import Data.Attoparsec.Text (asciiCI, char, many1, manyTill,@@ -38,13 +40,14 @@ import Hasmin.Parser.Utils import Hasmin.Parser.Value-import Hasmin.Selector+import Hasmin.Types.Selector import Hasmin.Types.Stylesheet import Hasmin.Types.Declaration+import Hasmin.Types.String selector :: Parser Selector selector = Selector <$> compoundSelector- <*> many ((,) <$> (combinator <* skipComments) <*> compoundSelector)+ <*> many ((,) <$> combinator <* skipComments <*> compoundSelector) -- First tries with '>>' (descendant), '>' (child), '+' (adjacent sibling), and -- '~' (general sibling) combinators. If those fail, it tries with the@@ -53,10 +56,10 @@ -- | Parser for selector combinators, i.e. ">>" (descendant), '>' (child), '+' -- (adjacent sibling), '~' (general sibling), and ' ' (descendant) combinators. combinator :: Parser Combinator-combinator = (skipComments *> ((string ">>" $> Descendant)- <|> (char '>' $> Child)- <|> (char '+' $> AdjacentSibling)- <|> (char '~' $> GeneralSibling)))+combinator = (skipComments *> ((string ">>" $> Descendant)+ <|> (char '>' $> Child)+ <|> (char '+' $> AdjacentSibling)+ <|> (char '~' $> GeneralSibling))) <|> (satisfy ws $> Descendant) where ws c = c == ' ' || c == '\t' || c == '\n' || c == '\r' || c == '\f' @@ -93,8 +96,8 @@ -- but they should be. attributeSel :: Parser SimpleSelector attributeSel = do- _ <- char '[' *> skipComments- attId <- ident <* skipComments+ _ <- char '['+ attId <- lexeme ident g <- option Attribute attValue _ <- char ']' pure $ AttributeSel (g attId)@@ -105,9 +108,12 @@ (string "=" $> (:=:)) <|> (string "~=" $> (:~=:)) <|> (string "|=" $> (:|=:))) <* skipComments- attval <- ((Left <$> ident) <|> (Right <$> stringtype)) <* skipComments+ attval <- identOrString <* skipComments pure (`f` attval) +identOrString :: Parser (Either Text StringType)+identOrString = (Left <$> ident) <|> (Right <$> stringtype)+ {- -- string1: \"([^\n\r\f\\"]|\\{nl}|{escape})*\" string1 = char '\"' *> many (o1 <|> o2 <|> escape)@@ -193,6 +199,7 @@ ,buildTuple "matches" (\x -> FunctionalPseudoClass1 x <$> compoundSelectorList) ,buildTuple "nth-child" (anbAndSelectors . FunctionalPseudoClass3) ,buildTuple "nth-last-child" (anbAndSelectors . FunctionalPseudoClass3)+ ,buildTuple "lang" (const (Lang <$> identOrString)) -- -- :drop( [ active || valid || invalid ]? ) -- The :drop() functional pseudo-class is identical to :drop@@ -222,8 +229,8 @@ declaration = do p <- property <* colon v <- values p <|> valuesFallback- i <- important <* skipComments- ie <- iehack <* skipComments+ i <- important+ ie <- lexeme iehack pure $ Declaration p v i ie -- | Parser for property names. Usually, 'ident' would be enough, but this@@ -258,7 +265,7 @@ ,("import", atImport) ,("namespace", atNamespace) ,("media", atMedia)- -- ,("supports", atSupports)+ ,("supports", atSupports) -- ,("document", atDocument) -- ,("page", atPage) ,("font-face", skipComments *> atBlock "font-face")@@ -280,7 +287,7 @@ atCharset :: Parser Rule atCharset = do- st <- skipComments *> stringtype <* skipComments <* char ';'+ st <- lexeme stringtype <* char ';' pure $ AtCharset st -- @namespace <namespace-prefix>? [ <string> | <uri> ];@@ -305,15 +312,14 @@ atKeyframe :: Text -> Parser Rule atKeyframe t = do- _ <- skipComments- name <- ident <* skipComments <* char '{'+ name <- lexeme ident <* char '{' bs <- many (keyframeBlock <* skipComments) _ <- char '}' pure $ AtKeyframes t name bs keyframeBlock :: Parser KeyframeBlock keyframeBlock = do- sel <- skipComments *> kfsList <* skipComments+ sel <- lexeme kfsList ds <- char '{' *> skipComments *> declarations <* char '}' pure $ KeyframeBlock sel ds where from = asciiCI "from" $> From@@ -329,6 +335,49 @@ _ <- char '}' pure $ AtMedia m r +atSupports :: Parser Rule+atSupports = do+ sc <- satisfy C.isSpace *> supportsCondition+ _ <- lexeme (char '{')+ r <- manyTill (rule <* skipComments) (lookAhead (char '}'))+ _ <- char '}'+ pure $ AtSupports sc r++supportsCondition :: Parser SupportsCondition+supportsCondition = asciiCI "not" *> skipComments *> (Not <$> supportsCondInParens)+ <|> supportsConjunction+ <|> supportsDisjunction+ <|> (Parens <$> supportsCondInParens)++supportsCondInParens :: Parser SupportsCondInParens+supportsCondInParens = do+ _ <- char '('+ x <- lexeme ((ParensCond <$> supportsCondition) <|> (ParensDec <$> atSupportsDeclaration))+ _ <- char ')'+ pure x++atSupportsDeclaration :: Parser Declaration+atSupportsDeclaration = do+ p <- property <* colon+ v <- values p <|> valuesInParens+ pure $ Declaration p v False False++-- customPropertyIdent :: Parser Text+-- customPropertyIdent = (<>) <$> string "-" <*> ident++supportsHelper :: (SupportsCondInParens -> NonEmpty SupportsCondInParens -> SupportsCondition)+ -> Text -> Parser SupportsCondition+supportsHelper c t = do+ x <- supportsCondInParens <* skipComments+ xs <- some (asciiCI t *> lexeme supportsCondInParens)+ pure $ c x (NE.fromList xs)++supportsConjunction :: Parser SupportsCondition+supportsConjunction = supportsHelper And "and"++supportsDisjunction :: Parser SupportsCondition+supportsDisjunction = supportsHelper Or "or"+ -- TODO clean code -- the "manyTill .. lookAhead" was added because if we only used "rules", it -- doesn't know when to stop, and breaks the parser@@ -396,7 +445,7 @@ mediaQuery2 = MediaQuery2 <$> ((:) <$> expression <*> andExpressions) mediaType = lexeme ident andExpressions = many (h *> expression)- h = skipComments *> asciiCI "and" *> satisfy C.isSpace *> skipComments+ h = lexeme (asciiCI "and" *> satisfy C.isSpace) optionalNotOrOnly = option mempty (asciiCI "not" <|> asciiCI "only") expression :: Parser Expression
src/Hasmin/Parser/Value.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE OverloadedStrings, TupleSections #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- -- |--- Module : Hasmin.Parser.Internal+-- Module : Hasmin.Parser.Value -- Copyright : (c) 2017 Cristian Adrián Ontivero -- License : BSD3 -- Stability : experimental@@ -15,6 +16,7 @@ , percentage , value , valuesFallback+ , valuesInParens , stringOrUrl , url , stringtype@@ -22,6 +24,7 @@ , textualvalue , stringvalue , shadowList+ , timingFunction , repeatStyle , position , color@@ -29,7 +32,7 @@ , fontStyle ) where -import Control.Applicative ((<|>), many, liftA2, liftA3)+import Control.Applicative ((<|>), many, liftA3) import Control.Arrow (first, (&&&)) import Control.Monad (mzero) import Data.Functor (($>))@@ -68,8 +71,8 @@ values :: Text -> Parser Values values p = case Map.lookup (T.toLower p) propertyValueParsersMap of- Just x -> x <* skipComments -- mappend <$> (x <|> ((:[]) <$> csswideKeyword))- Nothing -> valuesFallback+ Just x -> x <* skipComments+ Nothing -> mzero number :: Parser Number number = Number <$> rational@@ -238,7 +241,7 @@ 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)+ pure . fst . head $ readSigned readFloat (sign ++ dgts ++ e) where fractionalPart = (:) <$> char '.' <*> digits expo = (:) <$> satisfy (\c -> c == 'e' || c == 'E') <*> int' wrapMinus x = if x == '-' -- we use this since read fails with leading '+'@@ -584,10 +587,11 @@ <|> (StringV <$> stringtype) <|> invalidvalue --- | Parses until the end of the declaration, i.e. ';' or '}'--- Used to deal with invalid input, or some of the IE specific things+-- | 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 (\c -> c /= '\\' && c /= ';' && c /= '}' && c /= '!')+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'> ] |@@ -743,8 +747,10 @@ genericFunc :: Text -> Parser Value genericFunc i = (GenericFunc i <$> valuesInParens) <* char ')'- where valuesInParens = Values <$> v <*> many ((,) <$> separator <*> v) <* skipComments- v = textualvalue++valuesInParens :: Parser Values+valuesInParens = Values <$> v <*> many ((,) <$> separator <*> v) <* skipComments+ where v = textualvalue <|> numericalvalue <|> hexvalue <|> (StringV <$> stringtype)@@ -869,25 +875,22 @@ dropShadow :: Parser FilterFunction dropShadow = functionParser $ do- l1 <- distance <* skipComments- l2 <- distance <* skipComments+ l1 <- distance+ l2 <- lexeme distance l3 <- option Nothing ((Just <$> distance) <* skipComments) c <- option Nothing (Just <$> color) pure $ DropShadow l1 l2 l3 c textShadow :: Parser Values-textShadow = do- v <- shadowText <* skipComments- vs <- many (liftA2 (,) commaSeparator shadowText) <* skipComments- pure $ Values v vs+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 <* skipComments- l2 <- distance <* skipComments+ l1 <- distance+ l2 <- lexeme distance l3 <- option Nothing ((Just <$> distance) <* skipComments) pure (l1,l2,l3) @@ -899,9 +902,9 @@ parseCommaSeparated :: Parser Value -> Parser Values parseCommaSeparated p = do- v <- p <* skipComments- vs <- many ((,) <$> commaSeparator <*> p) <* skipComments- c <- A.peekChar+ v <- p+ vs <- lexeme $ many ((,) <$> commaSeparator <*> p)+ c <- A.peekChar case c of Just x -> if x `elem` ['!', ';', '}'] then pure $ Values v vs@@ -915,8 +918,8 @@ <|?> (Nothing , Just <$> color <* skipComments)) where mkShadow i (l1,l2,l3,l4) = Shadow i l1 l2 l3 l4 fourLengths = do- l1 <- distance <* skipComments- l2 <- distance <* skipComments+ l1 <- distance+ l2 <- lexeme distance l3 <- option Nothing ((Just <$> distance) <* skipComments) l4 <- option Nothing ((Just <$> distance) <* skipComments) pure (l1,l2,l3,l4)@@ -933,7 +936,7 @@ 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 <* skipComments <*> percentageLength <* skipComments)))+ 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))
src/Hasmin/Properties.hs view
@@ -9,13 +9,14 @@ -- ----------------------------------------------------------------------------- module Hasmin.Properties (- PropertyInfo(..)+ PropertyInfo(..) , shorthandAndLonghandsMap , propertiesTraits ) where import Data.Attoparsec.Text (parseOnly)-import Data.Text (Text)+import Data.Text (Text, unpack)+import Control.Applicative ((<|>)) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Hasmin.Types.Value@@ -496,6 +497,6 @@ -- propertiesTraits table more readable and maintainable in general. replaceTextWithValues :: [(Text, (Text, Bool))] -> [(Text, (Maybe Values, Bool))] replaceTextWithValues = foldr (\(p,(t,i)) xs -> (p, (getValues p t,i)) : xs) []- where getValues p s = case parseOnly (values p) s of+ where getValues p s = case parseOnly (values p <|> valuesFallback) s of Right initialValues -> Just initialValues Left _ -> Nothing
− src/Hasmin/Selector.hs
@@ -1,339 +0,0 @@-{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}--------------------------------------------------------------------------------- |--- Module : Hasmin.Selector--- Copyright : (c) 2017 Cristian Adrián Ontivero--- License : BSD3--- Stability : experimental--- Portability : unknown----------------------------------------------------------------------------------module Hasmin.Selector (- Selector(..)- , SimpleSelector(..)- , CompoundSelector- , Combinator(..)- , Sign(..)- , AnPlusB(..)- , AValue(..)- , Att(..)- , specialPseudoElements- ) where--import Control.Applicative (liftA2)-import Control.Monad.Reader (ask)-import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Lazy.Builder (fromText, singleton, Builder)-import Data.Monoid ((<>))-import Data.List.NonEmpty (NonEmpty((:|)))-import qualified Data.List.NonEmpty as N-import Text.PrettyPrint.Mainland (Pretty, char, ppr, strictText)--import Hasmin.Config-import Hasmin.Types.Class-import Hasmin.Types.String-import Hasmin.Utils--{--class Specificity a where- specificity :: a -> (Int, Int, Int, Int)--addSpecificity :: (Int, Int, Int, Int)- -> (Int, Int, Int, Int)- -> (Int, Int, Int, Int)-addSpecificity (a1,b1,c1,d1) (a2,b2,c2,d2) = (a1 + a2, b1 + b2, c1 + c2, d1 + d2)--}---- | Combinators are: whitespace, "greater-than sign" (U+003E, >), "plus sign"--- (U+002B, +) and "tilde" (U+007E, ~). White space may appear between a--- combinator and the simple selectors around it. Only the characters "space"--- (U+0020), "tab" (U+0009), "line feed" (U+000A), "carriage return" (U+000D),--- and "form feed" (U+000C) can occur in whitespace. Other space-like--- characters, such as "em-space" (U+2003) and "ideographic space" (U+3000), are--- never part of whitespace.-data Combinator = Descendant -- ^ ' '- | Child -- ^ '>'- | AdjacentSibling -- ^ '+'- | GeneralSibling -- ^ '~'- deriving (Eq, Show)--instance ToText Combinator where- toBuilder Descendant = " "- toBuilder Child = ">"- toBuilder AdjacentSibling = "+"- toBuilder GeneralSibling = "~"-instance Pretty Combinator where- ppr = strictText . toText---- An empty selector, containing no sequence of simple selectors and no--- pseudo-element, is an invalid selector.-data Selector = Selector CompoundSelector [(Combinator, CompoundSelector)]- deriving (Eq, Show)--instance Ord Selector where- -- Lexicographical order- s1 <= s2 = toText s1 <= toText s2--instance Pretty Selector where- ppr (Selector cs ccss) = ppr cs- <> mconcat (fmap toDocument ccss)- where toDocument (comb, compSel) = ppr comb <> ppr compSel-instance ToText Selector where- toBuilder (Selector cs ccss) = toBuilder cs- <> mconcat (fmap build ccss)- where build (comb, compSel) = toBuilder comb <> toBuilder compSel-instance Minifiable Selector where- minifyWith (Selector c xs) = do- newC <- minifyWith c- newCs <- (mapM . mapM) minifyWith xs- pure $ Selector newC newCs--{--instance Specificity Selector where- specificity (Selector (x :| xs) ss) =- case x of- (Type _ _) -> f (0,0,0,1) xs `addSpecificity` g (0,0,0,0) ss- (Universal _) -> f (0,0,0,0) xs `addSpecificity` g (0,0,0,0) ss- where f = foldr (addSpecificity . specificity)- g = foldr (addSpecificity . specificity . snd)--}---- | Called <https://www.w3.org/TR/css3-selectors/#grammar simple_sequence_selector>--- in CSS2.1, but <https://drafts.csswg.org/selectors-4/#typedef-compound-selector--- compound-selector> in CSS Syntax Module Level 3.-type CompoundSelector = NonEmpty SimpleSelector---- instance ToText a => ToText (NonEmpty a) where-instance ToText CompoundSelector where- toBuilder ns@(Universal{} :| xs)- | length ns > 1 = mconcat $ fmap toBuilder xs- toBuilder ns = mconcat $ N.toList (fmap toBuilder ns)--instance Pretty CompoundSelector where- ppr ns@(Universal{} :| xs)- | length ns > 1 = mconcat $ fmap ppr xs- ppr ns = mconcat $ N.toList (fmap ppr ns)--instance Minifiable CompoundSelector where- minifyWith (a :| xs) = liftA2 (:|) (minifyWith a) (mapM minifyWith xs)--{--instance Specificity a => Specificity (NonEmpty a) where- specificity = foldr (\x y -> specificity x `addSpecificity` y) (0,0,0,0)--}---- | Certain selectors support namespace prefixes. Namespace prefixes are--- declared with the @namespace rule. A type selector containing a namespace--- prefix that has not been previously declared for namespaced selectors is an--- invalid selector.-type Namespace = Text-type Element = Text -- e.g.: h1, em, body, ...-type Identifier = Text---- Characters in Selectors can be escaped with a backslash according to the same--- escaping rules as CSS. [CSS21].---- If a universal selector represented by * (i.e. without a namespace prefix)--- is not the only component of a sequence of simple selectors selectors or is--- immediately followed by a pseudo-element, then the * may be omitted and the--- universal selector's presence implied.---- | A simple selector is either a type selector, universal selector, attribute--- selector, class selector, ID selector, or pseudo-class. The first selector--- must be a type or universal selector. When none is specified, the universal--- selector is implied, i.e.: #myId is the same as *#myId--- mempty is used to denote an empty namespace-data SimpleSelector = Type Namespace Element -- ^ e.g.: *, ns|*, h1, em, body- | Universal Namespace -- ^ '*'- | AttributeSel Att- | ClassSel Identifier- | IdSel Identifier- | PseudoElem Identifier- | PseudoClass Identifier- -- generic functional pseudo class- | FunctionalPseudoClass Identifier Text- -- :not() and :matches() fpc- | FunctionalPseudoClass1 Identifier [CompoundSelector] -- :not( <selector># )- -- :nth-of-type(), :nth-last-of-type(), :nth-column(), and- -- :nth-of-last-column() fpc- | FunctionalPseudoClass2 Identifier AnPlusB- -- :nth-child(), nth-last-child()- | FunctionalPseudoClass3 Identifier AnPlusB [CompoundSelector]- deriving (Eq, Show)--instance Pretty SimpleSelector where- ppr (Type n e)- | T.null n = strictText e- | otherwise = strictText n <> char '|' <> strictText e- ppr (Universal n)- | T.null n = char '*'- | otherwise = strictText n <> strictText "|*"- ppr (AttributeSel att) = char '[' <> ppr att <> char ']'- ppr (ClassSel t) = char '.' <> strictText t- ppr (IdSel t) = char '#' <> strictText t- ppr (PseudoClass t) = char ':' <> strictText t- ppr (PseudoElem t) = if T.toCaseFold t `elem` specialPseudoElements- then strictText ":" <> strictText t- else strictText "::" <> strictText t- ppr (FunctionalPseudoClass i t) = strictText i <> char '(' <> ppr t <> char ')'- -- ppr (FunctionalPseudoClass1 i cs) = strictText i <>--instance ToText SimpleSelector where- toBuilder (Type n e)- | T.null n = fromText e- | otherwise = fromText n <> singleton '|' <> fromText e- toBuilder (Universal n)- | T.null n = singleton '*'- | otherwise = fromText n <> fromText "|*"- toBuilder (AttributeSel att) = singleton '[' <> toBuilder att <> singleton ']'- toBuilder (ClassSel t) = singleton '.' <> fromText t- toBuilder (IdSel t) = singleton '#' <> fromText t- toBuilder (PseudoClass t) = singleton ':' <> fromText t- toBuilder (PseudoElem t)- | T.toCaseFold t `elem` specialPseudoElements = fromText ":" <> fromText t- | otherwise = fromText "::" <> fromText t- toBuilder (FunctionalPseudoClass t x) = fromText t <> singleton '(' <> fromText x <> singleton ')'- toBuilder (FunctionalPseudoClass1 t ss) = singleton ':' <> fromText t <> singleton '('- <> mconcatIntersperse toBuilder (singleton ',') ss- <> singleton ')'- toBuilder (FunctionalPseudoClass2 t x) = singleton ':' <> fromText t- <> singleton '(' <> toBuilder x <> singleton ')'- toBuilder (FunctionalPseudoClass3 t a xs) = singleton ':' <> fromText t- <> singleton '(' <> toBuilder a <> f xs <> singleton ')'- where f [] = mempty- f (y:ys) = " of " <> toBuilder y- <> mconcat (fmap (\z -> singleton ',' <> toBuilder z) ys)---- Pseudo-elements that support the old pseudo-element syntax of a single--- semicolon, as well as the new one of two semicolons.-specialPseudoElements :: [Text]-specialPseudoElements = fmap T.toCaseFold- ["after", "before", "first-line", "first-letter"]--instance Minifiable SimpleSelector where- minifyWith a@(AttributeSel att) = do- conf <- ask- pure $ if shouldRemoveQuotes conf- then AttributeSel (removeAttributeQuotes att)- else a- minifyWith a@(FunctionalPseudoClass2 i n) = do- conf <- ask- pure $ if shouldMinifyMicrosyntax conf- then FunctionalPseudoClass2 i (minifyAnPlusB n)- else a- minifyWith a@(FunctionalPseudoClass3 i n cs) = do- conf <- ask- pure $ if shouldMinifyMicrosyntax conf- then FunctionalPseudoClass3 i (minifyAnPlusB n) cs- else a- minifyWith (FunctionalPseudoClass1 i cs) = do- newcs <- mapM minifyWith cs- pure $ FunctionalPseudoClass1 i newcs- minifyWith x = pure x--data Sign = Plus | Minus- deriving (Eq, Show)--isPositive :: Maybe Sign -> Bool-isPositive Nothing = True-isPositive (Just Plus) = True-isPositive (Just Minus) = False--instance ToText Sign where- toBuilder Plus = singleton '+'- toBuilder Minus = singleton '-'--data AValue = Nwith (Maybe Sign) (Maybe Int) -- at least a lone 'n'- | NoValue -- The "An" part is omitted.- deriving (Eq, Show)-instance ToText AValue where- toBuilder NoValue = mempty- toBuilder (Nwith s i) = maybeToBuilder s <> maybeToBuilder i <> singleton 'n'- where maybeToBuilder :: ToText a => Maybe a -> Builder- maybeToBuilder = maybe mempty toBuilder--minifyAValue :: AValue -> AValue-minifyAValue (Nwith _ (Just 0)) = NoValue-minifyAValue (Nwith s a)- | isPositive s = Nwith Nothing (maybe Nothing droppedOne a)- | otherwise = Nwith s (maybe Nothing droppedOne a)- where droppedOne x = if x == 1- then Nothing- else Just x-minifyAValue NoValue = NoValue---- We could maybe model the AB constructor with an Either,--- to make sure AB NoValue Nothing isn't possible (which is invalid).--- Also, modelling a BValue would cover all remaining cases,--- for example +6 vs 6, -0 vs 0 vs +0.-data AnPlusB = Even- | Odd- | AB AValue (Maybe Int)- deriving (Eq, Show)-instance ToText AnPlusB where- toBuilder Even = "even"- toBuilder Odd = "odd"- toBuilder (AB a b) = toBuilder a <> bToBuilder b- where bToBuilder- | a == NoValue = maybe (singleton '0') toBuilder- | otherwise = maybe mempty (\x -> bSign x <> toBuilder x)- bSign x- | x < 0 = mempty- | otherwise = singleton '+'--minifyAnPlusB :: AnPlusB -> AnPlusB-minifyAnPlusB Even = AB (Nwith Nothing (Just 2)) Nothing-minifyAnPlusB (AB n@(Nwith s a) (Just b))- | isPositive s && a == Just 2 =- if b == 1 || odd b && b < 0- then Odd- else if even b && b <= 0- then minifyAnPlusB Even- else AB (minifyAValue n) (Just b)- | otherwise = AB (minifyAValue n) $ if b == 0- then Nothing- else Just b-minifyAnPlusB (AB n@Nwith{} Nothing) = AB (minifyAValue n) Nothing-minifyAnPlusB x = x--- instance Specificity SimpleSelector where- -- specificity (IdSel _) = (0,1,0,0)- -- specificity (ClassSel _) = (0,0,1,0)--type AttId = Text-type AttValue = Either Text StringType--data Att = Attribute AttId- | AttId :=: AttValue -- ^ \'=\'- | AttId :~=: AttValue -- ^ \'~=\'- | AttId :|=: AttValue -- ^ \'|=\'- | AttId :^=: AttValue -- ^ \'^=\'- | AttId :$=: AttValue -- ^ \'$=\'- | AttId :*=: AttValue -- ^ \'*=\'- deriving (Eq, Show)--removeAttributeQuotes :: Att -> Att-removeAttributeQuotes (attId :=: val) = attId :=: either Left removeQuotes val-removeAttributeQuotes (attId :~=: val) = attId :~=: either Left removeQuotes val-removeAttributeQuotes (attId :|=: val) = attId :|=: either Left removeQuotes val-removeAttributeQuotes (attId :^=: val) = attId :^=: either Left removeQuotes val-removeAttributeQuotes (attId :$=: val) = attId :$=: either Left removeQuotes val-removeAttributeQuotes (attId :*=: val) = attId :*=: either Left removeQuotes val-removeAttributeQuotes a@Attribute{} = a--instance Pretty Att where- ppr (Attribute t) = strictText t- ppr (attid :=: attval) = strictText attid <> char '=' <> ppr attval- ppr (attid :~=: attval) = strictText attid <> strictText "~=" <> ppr attval- ppr (attid :|=: attval) = strictText attid <> strictText "|=" <> ppr attval- ppr (attid :^=: attval) = strictText attid <> strictText "^=" <> ppr attval- ppr (attid :$=: attval) = strictText attid <> strictText "$=" <> ppr attval- ppr (attid :*=: attval) = strictText attid <> strictText "*=" <> ppr attval-instance ToText Att where- toBuilder (Attribute t) = fromText t- toBuilder (attid :=: attval) = fromText attid <> singleton '=' <> toBuilder attval- toBuilder (attid :~=: attval) = fromText attid <> fromText "~=" <> toBuilder attval- toBuilder (attid :|=: attval) = fromText attid <> fromText "|=" <> toBuilder attval- toBuilder (attid :^=: attval) = fromText attid <> fromText "^=" <> toBuilder attval- toBuilder (attid :$=: attval) = fromText attid <> fromText "$=" <> toBuilder attval- toBuilder (attid :*=: attval) = fromText attid <> fromText "*=" <> toBuilder attval
src/Hasmin/Types/BgSize.hs view
@@ -23,7 +23,7 @@ instance ToText Auto where toBuilder Auto = "auto" -data BgSize = Cover +data BgSize = Cover | Contain | BgSize (Either PercentageLength Auto) (Maybe (Either PercentageLength Auto)) deriving (Eq, Show)
src/Hasmin/Types/Class.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Module : Hasmin.Types.Class@@ -19,13 +20,13 @@ import Hasmin.Config -- | Class for types that can be minified-class Minifiable a where +class Minifiable a where {-# MINIMAL minifyWith #-} minifyWith :: a -> Reader Config a -- Returns smallest equivalent representation for an element, using a default -- configuration. Mostly used for testing.- minify :: a -> a + minify :: a -> a minify x = runReader (minifyWith x) defaultConfig -- | Class for types that can be converted to Text. Used for priting the
src/Hasmin/Types/Color.hs view
@@ -10,15 +10,26 @@ -- \<color> data type. -- ------------------------------------------------------------------------------module Hasmin.Types.Color- ( Color(Named)- , mkHex3, mkHex4, mkHex6, mkHex8, mkNamed- , mkHSL, mkHSLA, mkRGBInt, mkRGBPer, mkRGBAInt, mkRGBAPer- , keywordColors, minifyColor+module Hasmin.Types.Color (+ Color(Named)+ , mkHex3+ , mkHex4+ , mkHex6+ , mkHex8+ , mkNamed+ , mkHSL+ , mkHSLA+ , mkRGBInt+ , mkRGBPer+ , mkRGBAInt+ , mkRGBAPer+ , keywordColors+ , minifyColor ) where import Control.Arrow (first) import Control.Monad.Reader (ask)+import Data.Monoid ((<>)) import Data.Char (isHexDigit, digitToInt, intToDigit, toLower) import Data.Maybe (fromMaybe) import Data.Ratio ((%))@@ -27,7 +38,6 @@ import Data.Word (Word8) import qualified Data.Map.Strict as Map import qualified Data.Text as T-import Text.PrettyPrint.Mainland (Pretty, ppr, strictText, string, char, (<>), (<+>), comma, rparen) import Hasmin.Config import Hasmin.Types.Class@@ -86,35 +96,6 @@ | a == "ff" = r1 < r2 || r1 == r2 && (g1 < g2 || (g1 == g2 && b1 <= b2)) | otherwise = False c1 <= c2 = toLongHex c1 <= toLongHex c2--instance Pretty Color where- ppr (Hex3 r g b) = char '#' <> char r <> char g <> char b- ppr (Hex4 r g b a) = char '#' <> char r <> char g <> char b <> char a- ppr (Hex6 r g b) = char '#' <> string r <> string g <> string b- ppr (Hex8 r g b a) = char '#' <> string r <> string g <> string b <> string a- ppr (Named n) = strictText n- ppr (RGBInt r g b) = strictText "rgb(" <> ppr r <> comma- <+> ppr g <> comma- <+> ppr b <> rparen- ppr (RGBPer r g b) = strictText "rgb(" <> ppr r <> comma- <+> ppr g <> comma- <+> ppr b <> rparen- ppr (RGBAInt r g b a) = strictText "rgba(" <> ppr r <> comma- <+> ppr g <> comma- <+> ppr b <> comma- <+> ppr a <> rparen- ppr (RGBAPer r g b a) = strictText "rgba(" <> ppr r <> comma- <+> ppr g <> comma- <+> ppr b <> comma- <+> ppr a <> rparen- ppr (HSL h s l) = strictText "hsl(" <> ppr h <> comma- <+> ppr s <> comma- <+> ppr l <> rparen- ppr (HSLA h s l a) = strictText "hsla(" <> ppr h <> comma- <+> ppr s <> comma- <+> ppr l <> comma- <+> ppr a <> rparen- instance Minifiable Color where minifyWith c = do conf <- ask
src/Hasmin/Types/Declaration.hs view
@@ -24,7 +24,6 @@ import Data.Text.Lazy.Builder (singleton, fromText) import qualified Data.Map.Strict as Map import qualified Data.Text as T-import Text.PrettyPrint.Mainland (Pretty, ppr, strictText, colon, (<+>)) import Hasmin.Config import Hasmin.Properties@@ -43,12 +42,6 @@ , isImportant :: Bool -- ends with !important , hasIEhack :: Bool -- ends with \9 } deriving (Eq, Show)--instance Pretty Declaration where- ppr (Declaration p v i h) = strictText p <> colon <+> ppr v <> imp- <> (if h then " \\9" else mempty)- where imp | i = strictText " !important" - | otherwise = mempty instance ToText Declaration where toBuilder (Declaration p vs i h) = fromText p <> singleton ':' <> toBuilder vs <> imp <> (if h then " \\9" else mempty)@@ -318,6 +311,10 @@ [("background-size", backgroundSizeReduce) ,("-webkit-background-size", backgroundSizeReduce) ,("font-synthesis", fontSynthesisReduce)+ -- Needed because otherwise the reducer replaces commas by spaces.+ -- i.e. text-shadow: 1px 1px red,2px 2px blue ==>+ -- text-shadow: 1px 1px red 2px 2px blue.+ ,("text-shadow", \d _ _ -> d) ] combineTransformFunctions :: Declaration -> Reader Config Declaration
src/Hasmin/Types/Dimension.hs view
@@ -37,14 +37,10 @@ import Hasmin.Types.Numeric import Hasmin.Config import Hasmin.Utils-import Text.PrettyPrint.Mainland (char, Pretty, ppr, strictText) -- | The \<length\> CSS data type data Distance = Distance Number DistanceUnit deriving (Show)-instance Pretty Distance where- ppr (Distance 0 _) = char '0'- ppr (Distance r u) = ppr r <> ppr u instance Eq Distance where (Distance r1 u1) == (Distance r2 u2) | u1 == u2 = r1 == r2@@ -67,9 +63,6 @@ -- | The \<angle\> CSS data type data Angle = Angle Number AngleUnit deriving (Show)-instance Pretty Angle where- ppr (Angle 0 _) = char '0'- ppr (Angle r u) = ppr r <> ppr u instance Eq Angle where (Angle r1 u1) == (Angle r2 u2) | u1 == u2 = r1 == r2@@ -92,8 +85,6 @@ -- | The \<duration\> CSS data type data Duration = Duration Number DurationUnit deriving (Show)-instance Pretty Duration where- ppr (Duration r u) = ppr r <> ppr u instance Eq Duration where (Duration r1 u1) == (Duration r2 u2) | u1 == u2 = r1 == r2@@ -110,8 +101,6 @@ -- | The \<frequency\> CSS data type data Frequency = Frequency Number FrequencyUnit deriving (Show)-instance Pretty Frequency where- ppr (Frequency r u) = ppr r <> ppr u instance Eq Frequency where (Frequency r1 u1) == (Frequency r2 u2) | u1 == u2 = r1 == r2@@ -128,8 +117,6 @@ -- | The \<resolution\> CSS data type data Resolution = Resolution Number ResolutionUnit deriving (Show)-instance Pretty Resolution where- ppr (Resolution r u) = ppr r <> ppr u instance Eq Resolution where (Resolution r1 u1) == (Resolution r2 u2) | u1 == u2 = r1 == r2@@ -177,8 +164,6 @@ toBuilder VMIN = "vmin" toBuilder VMAX = "vmax" toBuilder REM = "rem"-instance Pretty DistanceUnit where- ppr = strictText . toText instance Unit DistanceUnit where convertTo IN = toInches convertTo CM = toCentimeters@@ -196,8 +181,6 @@ toBuilder Grad = "grad" toBuilder Rad = "rad" toBuilder Turn = "turn"-instance Pretty AngleUnit where- ppr = strictText . toText instance Unit AngleUnit where convertTo Deg = toDegrees convertTo Grad = toGradians@@ -210,8 +193,6 @@ instance ToText DurationUnit where toBuilder S = "s" toBuilder Ms = "ms"-instance Pretty DurationUnit where- ppr = strictText . toText instance Unit DurationUnit where convertTo S = toSeconds convertTo Ms = toMiliseconds@@ -221,8 +202,6 @@ instance ToText FrequencyUnit where toBuilder Hz = "hz" toBuilder Khz = "khz"-instance Pretty FrequencyUnit where- ppr = strictText . toText instance Unit FrequencyUnit where convertTo Hz = toHertz convertTo Khz = toKilohertz@@ -233,8 +212,6 @@ toBuilder Dpi = "dpi" toBuilder Dpcm = "dpcm" toBuilder Dppx = "dppx"-instance Pretty ResolutionUnit where- ppr = strictText . toText instance Unit ResolutionUnit where convertTo Dpi = toDpi convertTo Dpcm = toDpcm
src/Hasmin/Types/FilterFunction.hs view
@@ -14,7 +14,7 @@ ) where import Control.Monad.Reader (Reader, ask)-import Data.Semigroup ((<>))+import Data.Monoid ((<>)) import Data.Text.Lazy.Builder (singleton, Builder) import Hasmin.Config import Hasmin.Types.Class
src/Hasmin/Types/Gradient.hs view
@@ -13,7 +13,7 @@ ) where import Control.Monad.Reader (Reader, ask) -import Data.Semigroup ((<>)) +import Data.Monoid ((<>)) import Data.Text.Lazy.Builder (singleton) import Data.Maybe (catMaybes, fromJust, isNothing, isJust) import Hasmin.Config @@ -24,7 +24,6 @@ import Hasmin.Types.PercentageLength import Hasmin.Types.Position import Hasmin.Utils -import Text.PrettyPrint.Mainland (Pretty, ppr, strictText) -- | CSS <side-or-corner> data type data Side = LeftSide | RightSide | TopSide | BottomSide @@ -34,24 +33,20 @@ toBuilder RightSide = "right" toBuilder TopSide = "top" toBuilder BottomSide = "bottom" -instance Pretty Side where - ppr = strictText . toText -- Possible pair of values, as expected by linear-gradient() type SideOrCorner = (Side, Maybe Side) -- | CSS <color-stop> data type -data ColorStop = ColorStop { csColor :: Color +data ColorStop = ColorStop { csColor :: Color , colorHint :: Maybe PercentageLength } deriving (Show, Eq) instance ToText ColorStop where toBuilder (ColorStop c mpl) = toBuilder c <> maybe mempty f mpl where f (Left p) = singleton ' ' <> toBuilder p f (Right l) = singleton ' ' <> toBuilder l -instance Pretty ColorStop where - ppr = strictText . toText instance Minifiable ColorStop where - minifyWith (ColorStop c mlp) = do + minifyWith (ColorStop c mlp) = do newC <- minifyWith c newMlp <- (mapM . mapM) minifyWith mlp pure $ ColorStop newC newMlp @@ -70,7 +65,7 @@ ch2 = colorHint c2 newC1 | isJust ch1 && isZero (fromJust ch1) = c1 {colorHint = Nothing} - | otherwise = c1 + | otherwise = c1 newC2 | ch2 == Just (Left (Percentage 100)) = c2 {colorHint = Nothing} | otherwise = if ch2 `notGreaterThan` ch1 @@ -104,7 +99,7 @@ -> [ColorStop] -> [ColorStop] analyzeList start n list (ColorStop _ mpl:xs) | n < 2 = analyzeList start (n+1) list xs - | otherwise = + | otherwise = case mpl of Just y -> let (newList, remainingList, startVal) = minifySegment start y n list in newList ++ analyzeList startVal 2 remainingList xs @@ -139,9 +134,9 @@ in (newList, remainingList, Left newStartVal) where newStartVal = maybe (last interpolation) fromLeft' (colorHint $ head remainingList) step = (end - start) / toPercentage n - interpolation = [start + (toPercentage x) * step | x <- [1..n-1]] + interpolation = [start + toPercentage x * step | x <- [1..n-1]] simplifyValue (ColorStop x mpl) y = ColorStop x $ mpl >>= \v -> - if fromLeft' v == y + if fromLeft' v == y then Nothing else if fromLeft' v <= start then Just $ Right (Distance 0 PX) @@ -157,7 +152,7 @@ -- ,| RepeatingRadialGradient -{- +{- radial-gradient() = radial-gradient( [ <ending-shape> || <size> ]? [ at <position> ]? , <color-stop-list> @@ -172,7 +167,7 @@ <color-stop> [ , <color-stop> ]+ ) where <extent-keyword> = closest-corner | closest-side | farthest-corner | farthest-side - and <color-stop> = <color> [ <percentage> | <length> ]? + and <color-stop> = <color> [ <percentage> | <length> ]? -} data Size = ClosestCorner | ClosestSide | FarthestCorner | FarthestSide @@ -250,7 +245,7 @@ -> Reader Config (Maybe (Either Angle SideOrCorner)) minifyAngleOrSide mas = case mas of - Nothing -> pure Nothing + Nothing -> pure Nothing Just y -> case y of Left a -> if a == defaultGradientAngle then pure Nothing @@ -274,19 +269,19 @@ toBuilder (OldLinearGradient mas csl) = maybe mempty f mas <> mconcatIntersperse id (singleton ',') (fmap toBuilder csl) where f = either ((<> singleton ',') . toBuilder) g - g (s, ms) = toBuilder s + g (s, ms) = toBuilder s <> maybe mempty (\x -> singleton ' ' <> toBuilder x) ms <> singleton ',' toBuilder (LinearGradient mas csl) = maybe mempty f mas <> mconcatIntersperse id (singleton ',') (fmap toBuilder csl) where f = either ((<> singleton ',') . toBuilder) g - g (s, ms) = "to " <> toBuilder s + g (s, ms) = "to " <> toBuilder s <> maybe mempty (\x -> singleton ' ' <> toBuilder x) ms <> singleton ',' - toBuilder (RadialGradient sh sz p cs) = firstPart + 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 + firstPart = if null l then mempty else mconcatIntersperse id (singleton ' ') l <> singleton ','
src/Hasmin/Types/Numeric.hs view
@@ -20,7 +20,6 @@ import Data.Text (pack) import Hasmin.Types.Class import Hasmin.Utils-import Text.PrettyPrint.Mainland (strictText, text, Pretty, ppr) import Text.Printf (printf) -- | The \<number\> data type. Real numbers, possibly with a fractional component.@@ -40,11 +39,9 @@ instance ToText Number where toText = pack . trimLeadingZeros . showRat . toRational -- check if scientific notation is shorter!-instance Pretty Number where- ppr = strictText . toText toNumber :: Real a => a -> Number-toNumber = Number . toRational +toNumber = Number . toRational fromNumber :: Fractional a => Number -> a fromNumber = fromRational . toRational@@ -68,8 +65,6 @@ instance ToText Alphavalue where toText = pack . trimLeadingZeros . showRat . toRational-instance Pretty Alphavalue where- ppr = text . showRat . toRational instance Bounded Alphavalue where minBound = 0 maxBound = 1@@ -77,7 +72,7 @@ fromRational = mkAlphavalue (Alphavalue a) / (Alphavalue b) = mkAlphavalue (toRational a / toRational b) toAlphavalue :: Real a => a -> Alphavalue-toAlphavalue = mkAlphavalue . toRational +toAlphavalue = mkAlphavalue . toRational mkAlphavalue :: Rational -> Alphavalue mkAlphavalue = Alphavalue . restrict 0 1@@ -93,13 +88,11 @@ newtype Percentage = Percentage Rational deriving (Eq, Show, Ord, Num, Fractional, Real, RealFrac) -instance Pretty Percentage where- ppr = strictText . toText instance ToText Percentage where toText = pack . (++ "%") . trimLeadingZeros . showRat . toRational toPercentage :: Real a => a -> Percentage-toPercentage = Percentage . toRational +toPercentage = Percentage . toRational -- Note: printf used instead of show to avoid scientific notation -- | Show a Rational in decimal notation, removing leading zeros,@@ -107,7 +100,7 @@ showRat :: Rational -> String showRat r | abs (r - fromInteger x) < eps = printf "%d" x | otherwise = printf "%f" d- where x = round r + where x = round r d = fromRational r :: Double trimLeadingZeros :: String -> String
src/Hasmin/Types/RepeatStyle.hs view
@@ -5,14 +5,15 @@ -- Copyright : (c) 2017 Cristian Adrián Ontivero -- License : BSD3 -- Stability : experimental--- Portability : non-portable+-- Portability : unknown -- -- \<repeat-style> data type used in background-repeat. Specification: -- <https://drafts.csswg.org/css-backgrounds-3/#the-background-repeat CSS Backgrounds and Borders Module Level 3 (§3.4)>--- +-- ----------------------------------------------------------------------------- module Hasmin.Types.RepeatStyle (- RepeatStyle(..), RSKeyword(..)+ RepeatStyle(..)+ , RSKeyword(..) ) where import Control.Monad.Reader (ask)@@ -20,14 +21,20 @@ import Data.Text.Lazy.Builder (singleton) import Hasmin.Types.Class -data RepeatStyle = RepeatX +data RepeatStyle = RepeatX | RepeatY | RSPair RSKeyword (Maybe RSKeyword)- deriving (Show)--data RSKeyword = RsRepeat | RsSpace | RsRound | RsNoRepeat- deriving (Eq, Show)-+ deriving Show+instance ToText RepeatStyle where+ toBuilder RepeatX = "repeat-x"+ toBuilder RepeatY = "repeat-y"+ toBuilder (RSPair r1 r2 ) = toBuilder r1 <> maybe mempty (\x -> singleton ' ' <> toBuilder x) r2+instance Minifiable RepeatStyle where+ minifyWith r = do+ conf <- ask+ pure $ if True {- shouldMinifyRepeatStyle conf -}+ then minifyRepeatStyle r+ else r instance Eq RepeatStyle where RepeatX == RepeatX = True a@RepeatX == b@RSPair{} = b == a@@ -49,28 +56,18 @@ a@(RSPair _ Nothing) == b@(RSPair _ _) = b == a _ == _ = False +data RSKeyword = RsRepeat | RsSpace | RsRound | RsNoRepeat+ deriving (Eq, Show) instance ToText RSKeyword where toBuilder RsRepeat = "repeat" toBuilder RsSpace = "space" toBuilder RsRound = "round" toBuilder RsNoRepeat = "no-repeat" -instance ToText RepeatStyle where- toBuilder RepeatX = "repeat-x"- toBuilder RepeatY = "repeat-y"- toBuilder (RSPair r1 r2 ) = toBuilder r1 <> maybe mempty (\x -> singleton ' ' <> toBuilder x) r2--instance Minifiable RepeatStyle where- minifyWith r = do- conf <- ask- pure $ if True {- shouldMinifyRepeatStyle conf -}- then minifyRepeatStyle r- else r- minifyRepeatStyle :: RepeatStyle -> RepeatStyle minifyRepeatStyle (RSPair RsRepeat (Just RsNoRepeat)) = RepeatX minifyRepeatStyle (RSPair RsNoRepeat (Just RsRepeat)) = RepeatY-minifyRepeatStyle (RSPair x (Just y)) = if x == y- then RSPair x Nothing- else RSPair x (Just y)+minifyRepeatStyle (RSPair x (Just y))+ | x == y = RSPair x Nothing+ | otherwise = RSPair x (Just y) minifyRepeatStyle x = x
+ src/Hasmin/Types/Selector.hs view
@@ -0,0 +1,311 @@+{-# LANGUAGE OverloadedStrings+ , FlexibleInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Hasmin.Types.Selector+-- Copyright : (c) 2017 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : unknown+--+-----------------------------------------------------------------------------+module Hasmin.Types.Selector (+ Selector(..)+ , SimpleSelector(..)+ , CompoundSelector+ , Combinator(..)+ , Sign(..)+ , AnPlusB(..)+ , AValue(..)+ , Att(..)+ , specialPseudoElements+ ) where++import Control.Applicative (liftA2)+import Control.Monad.Reader (ask)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Lazy.Builder (fromText, singleton, Builder)+import Data.Monoid ((<>))+import Data.List.NonEmpty (NonEmpty((:|)))+import qualified Data.List.NonEmpty as N++import Hasmin.Config+import Hasmin.Types.Class+import Hasmin.Types.String+import Hasmin.Utils++{-+class Specificity a where+ specificity :: a -> (Int, Int, Int, Int)++addSpecificity :: (Int, Int, Int, Int)+ -> (Int, Int, Int, Int)+ -> (Int, Int, Int, Int)+addSpecificity (a1,b1,c1,d1) (a2,b2,c2,d2) = (a1 + a2, b1 + b2, c1 + c2, d1 + d2)+-}++-- | Combinators are: whitespace, "greater-than sign" (U+003E, >), "plus sign"+-- (U+002B, +) and "tilde" (U+007E, ~). White space may appear between a+-- combinator and the simple selectors around it. Only the characters "space"+-- (U+0020), "tab" (U+0009), "line feed" (U+000A), "carriage return" (U+000D),+-- and "form feed" (U+000C) can occur in whitespace. Other space-like+-- characters, such as "em-space" (U+2003) and "ideographic space" (U+3000), are+-- never part of whitespace.+data Combinator = Descendant -- ^ ' '+ | Child -- ^ '>'+ | AdjacentSibling -- ^ '+'+ | GeneralSibling -- ^ '~'+ deriving (Eq, Show)++instance ToText Combinator where+ toBuilder Descendant = " "+ toBuilder Child = ">"+ toBuilder AdjacentSibling = "+"+ toBuilder GeneralSibling = "~"++-- An empty selector, containing no sequence of simple selectors and no+-- pseudo-element, is an invalid selector.+data Selector = Selector CompoundSelector [(Combinator, CompoundSelector)]+ deriving (Eq, Show)++instance Ord Selector where+ -- Lexicographical order+ s1 <= s2 = toText s1 <= toText s2++instance ToText Selector where+ toBuilder (Selector cs ccss) = toBuilder cs+ <> mconcat (fmap build ccss)+ where build (comb, compSel) = toBuilder comb <> toBuilder compSel+instance Minifiable Selector where+ minifyWith (Selector c xs) = do+ newC <- minifyWith c+ newCs <- (mapM . mapM) minifyWith xs+ pure $ Selector newC newCs++{-+instance Specificity Selector where+ specificity (Selector (x :| xs) ss) =+ case x of+ (Type _ _) -> f (0,0,0,1) xs `addSpecificity` g (0,0,0,0) ss+ (Universal _) -> f (0,0,0,0) xs `addSpecificity` g (0,0,0,0) ss+ where f = foldr (addSpecificity . specificity)+ g = foldr (addSpecificity . specificity . snd)+-}++-- | Called <https://www.w3.org/TR/css3-selectors/#grammar simple_sequence_selector>+-- in CSS2.1, but <https://drafts.csswg.org/selectors-4/#typedef-compound-selector+-- compound-selector> in CSS Syntax Module Level 3.+type CompoundSelector = NonEmpty SimpleSelector++-- instance ToText a => ToText (NonEmpty a) where+instance ToText CompoundSelector where+ toBuilder ns@(Universal{} :| xs)+ | length ns > 1 = mconcat $ fmap toBuilder xs+ toBuilder ns = mconcat $ N.toList (fmap toBuilder ns)++instance Minifiable CompoundSelector where+ minifyWith (a :| xs) = liftA2 (:|) (minifyWith a) (mapM minifyWith xs)++{-+instance Specificity a => Specificity (NonEmpty a) where+ specificity = foldr (\x y -> specificity x `addSpecificity` y) (0,0,0,0)+-}++-- | Certain selectors support namespace prefixes. Namespace prefixes are+-- declared with the @namespace rule. A type selector containing a namespace+-- prefix that has not been previously declared for namespaced selectors is an+-- invalid selector.+type Namespace = Text+type Element = Text -- e.g.: h1, em, body, ...+type Identifier = Text++-- Characters in Selectors can be escaped with a backslash according to the same+-- escaping rules as CSS. [CSS21].++-- If a universal selector represented by * (i.e. without a namespace prefix)+-- is not the only component of a sequence of simple selectors selectors or is+-- immediately followed by a pseudo-element, then the * may be omitted and the+-- universal selector's presence implied.++-- | A simple selector is either a type selector, universal selector, attribute+-- selector, class selector, ID selector, or pseudo-class. The first selector+-- must be a type or universal selector. When none is specified, the universal+-- selector is implied, i.e.: #myId is the same as *#myId+-- mempty is used to denote an empty namespace+data SimpleSelector = Type Namespace Element -- ^ e.g.: *, ns|*, h1, em, body+ | Universal Namespace -- ^ '*'+ | AttributeSel Att+ | ClassSel Identifier+ | IdSel Identifier+ | PseudoElem Identifier+ | PseudoClass Identifier+ | Lang (Either Text StringType)+ -- generic functional pseudo class+ | FunctionalPseudoClass Identifier Text+ -- :not() and :matches() fpc+ | FunctionalPseudoClass1 Identifier [CompoundSelector] -- :not( <selector># )+ -- :nth-of-type(), :nth-last-of-type(), :nth-column(), and+ -- :nth-of-last-column() fpc+ | FunctionalPseudoClass2 Identifier AnPlusB+ -- :nth-child(), nth-last-child()+ | FunctionalPseudoClass3 Identifier AnPlusB [CompoundSelector]+ deriving (Eq, Show)++instance ToText SimpleSelector where+ toBuilder (Type n e)+ | T.null n = fromText e+ | otherwise = fromText n <> singleton '|' <> fromText e+ toBuilder (Universal n)+ | T.null n = singleton '*'+ | otherwise = fromText n <> fromText "|*"+ toBuilder (AttributeSel att) = singleton '[' <> toBuilder att <> singleton ']'+ toBuilder (ClassSel t) = singleton '.' <> fromText t+ toBuilder (IdSel t) = singleton '#' <> fromText t+ toBuilder (PseudoClass t) = singleton ':' <> fromText t+ toBuilder (PseudoElem t)+ | T.toCaseFold t `elem` specialPseudoElements = fromText ":" <> fromText t+ | otherwise = fromText "::" <> fromText t+ toBuilder (Lang x) = ":lang" <> singleton '(' <> toBuilder x <> singleton ')'+ toBuilder (FunctionalPseudoClass t x) = fromText t <> singleton '(' <> fromText x <> singleton ')'+ toBuilder (FunctionalPseudoClass1 t ss) = singleton ':' <> fromText t <> singleton '('+ <> mconcatIntersperse toBuilder (singleton ',') ss+ <> singleton ')'+ toBuilder (FunctionalPseudoClass2 t x) = singleton ':' <> fromText t+ <> singleton '(' <> toBuilder x <> singleton ')'+ toBuilder (FunctionalPseudoClass3 t a xs) = singleton ':' <> fromText t+ <> singleton '(' <> toBuilder a <> f xs <> singleton ')'+ where f [] = mempty+ f (y:ys) = " of " <> toBuilder y+ <> mconcat (fmap (\z -> singleton ',' <> toBuilder z) ys)++-- Pseudo-elements that support the old pseudo-element syntax of a single+-- semicolon, as well as the new one of two semicolons.+specialPseudoElements :: [Text]+specialPseudoElements = fmap T.toCaseFold+ ["after", "before", "first-line", "first-letter"]++instance Minifiable SimpleSelector where+ minifyWith a@(AttributeSel att) = do+ conf <- ask+ pure $ if shouldRemoveQuotes conf+ then AttributeSel (removeAttributeQuotes att)+ else a+ minifyWith a@(Lang x) = do+ conf <- ask+ pure $ if shouldRemoveQuotes conf+ then case x of+ Left _ -> a+ Right s -> Lang (removeQuotes s)+ else a+ minifyWith a@(FunctionalPseudoClass2 i n) = do+ conf <- ask+ pure $ if shouldMinifyMicrosyntax conf+ then FunctionalPseudoClass2 i (minifyAnPlusB n)+ else a+ minifyWith a@(FunctionalPseudoClass3 i n cs) = do+ conf <- ask+ pure $ if shouldMinifyMicrosyntax conf+ then FunctionalPseudoClass3 i (minifyAnPlusB n) cs+ else a+ minifyWith (FunctionalPseudoClass1 i cs) = do+ newcs <- mapM minifyWith cs+ pure $ FunctionalPseudoClass1 i newcs+ minifyWith x = pure x++data Sign = Plus | Minus+ deriving (Eq, Show)++isPositive :: Maybe Sign -> Bool+isPositive Nothing = True+isPositive (Just Plus) = True+isPositive (Just Minus) = False++instance ToText Sign where+ toBuilder Plus = singleton '+'+ toBuilder Minus = singleton '-'++data AValue = Nwith (Maybe Sign) (Maybe Int) -- at least a lone 'n'+ | NoValue -- The "An" part is omitted.+ deriving (Eq, Show)+instance ToText AValue where+ toBuilder NoValue = mempty+ toBuilder (Nwith s i) = maybeToBuilder s <> maybeToBuilder i <> singleton 'n'+ where maybeToBuilder :: ToText a => Maybe a -> Builder+ maybeToBuilder = maybe mempty toBuilder++minifyAValue :: AValue -> AValue+minifyAValue (Nwith _ (Just 0)) = NoValue+minifyAValue (Nwith s a)+ | isPositive s = Nwith Nothing (maybe Nothing droppedOne a)+ | otherwise = Nwith s (maybe Nothing droppedOne a)+ where droppedOne x = if x == 1+ then Nothing+ else Just x+minifyAValue NoValue = NoValue++-- We could maybe model the AB constructor with an Either,+-- to make sure AB NoValue Nothing isn't possible (which is invalid).+-- Also, modelling a BValue would cover all remaining cases,+-- for example +6 vs 6, -0 vs 0 vs +0.+data AnPlusB = Even+ | Odd+ | AB AValue (Maybe Int)+ deriving (Eq, Show)+instance ToText AnPlusB where+ toBuilder Even = "even"+ toBuilder Odd = "odd"+ toBuilder (AB a b) = toBuilder a <> bToBuilder b+ where bToBuilder+ | a == NoValue = maybe (singleton '0') toBuilder+ | otherwise = maybe mempty (\x -> bSign x <> toBuilder x)+ bSign x+ | x < 0 = mempty+ | otherwise = singleton '+'++minifyAnPlusB :: AnPlusB -> AnPlusB+minifyAnPlusB Even = AB (Nwith Nothing (Just 2)) Nothing+minifyAnPlusB (AB n@(Nwith s a) (Just b))+ | isPositive s && a == Just 2 =+ if b == 1 || odd b && b < 0+ then Odd+ else if even b && b <= 0+ then minifyAnPlusB Even+ else AB (minifyAValue n) (Just b)+ | otherwise = AB (minifyAValue n) $ if b == 0+ then Nothing+ else Just b+minifyAnPlusB (AB n@Nwith{} Nothing) = AB (minifyAValue n) Nothing+minifyAnPlusB x = x+-- instance Specificity SimpleSelector where+ -- specificity (IdSel _) = (0,1,0,0)+ -- specificity (ClassSel _) = (0,0,1,0)++type AttId = Text+type AttValue = Either Text StringType++data Att = Attribute AttId+ | AttId :=: AttValue -- ^ \'=\'+ | AttId :~=: AttValue -- ^ \'~=\'+ | AttId :|=: AttValue -- ^ \'|=\'+ | AttId :^=: AttValue -- ^ \'^=\'+ | AttId :$=: AttValue -- ^ \'$=\'+ | AttId :*=: AttValue -- ^ \'*=\'+ deriving (Eq, Show)+instance ToText Att where+ toBuilder (Attribute t) = fromText t+ toBuilder (attid :=: attval) = fromText attid <> singleton '=' <> toBuilder attval+ toBuilder (attid :~=: attval) = fromText attid <> fromText "~=" <> toBuilder attval+ toBuilder (attid :|=: attval) = fromText attid <> fromText "|=" <> toBuilder attval+ toBuilder (attid :^=: attval) = fromText attid <> fromText "^=" <> toBuilder attval+ toBuilder (attid :$=: attval) = fromText attid <> fromText "$=" <> toBuilder attval+ toBuilder (attid :*=: attval) = fromText attid <> fromText "*=" <> toBuilder attval++removeAttributeQuotes :: Att -> Att+removeAttributeQuotes (attId :=: val) = attId :=: either Left removeQuotes val+removeAttributeQuotes (attId :~=: val) = attId :~=: either Left removeQuotes val+removeAttributeQuotes (attId :|=: val) = attId :|=: either Left removeQuotes val+removeAttributeQuotes (attId :^=: val) = attId :^=: either Left removeQuotes val+removeAttributeQuotes (attId :$=: val) = attId :$=: either Left removeQuotes val+removeAttributeQuotes (attId :*=: val) = attId :*=: either Left removeQuotes val+removeAttributeQuotes a@Attribute{} = a
src/Hasmin/Types/Shadow.hs view
@@ -9,11 +9,11 @@ -- ----------------------------------------------------------------------------- module Hasmin.Types.Shadow (- Shadow(..)+ Shadow(..) ) where import Control.Monad.Reader (ask)-import Data.Semigroup ((<>))+import Data.Monoid ((<>)) import Data.Text.Lazy.Builder (singleton) import Data.Bool (bool) import Hasmin.Types.Class@@ -33,7 +33,7 @@ bool mempty "inset " i <> toBuilder ox <> singleton ' ' <> toBuilder oy <> f br <> f sr <> f c- where f c = maybe mempty (\y -> singleton ' ' <> toBuilder y) c -- don't eta reduce this!+ where f x = maybe mempty (\y -> singleton ' ' <> toBuilder y) x -- don't eta reduce this! instance Minifiable Shadow where minifyWith (Shadow i ox oy br sr c) = do
src/Hasmin/Types/String.hs view
@@ -5,11 +5,14 @@ -- Copyright : (c) 2017 Cristian Adrián Ontivero -- License : BSD3 -- Stability : experimental--- Portability : non-portable+-- Portability : unknown -- ------------------------------------------------------------------------------module Hasmin.Types.String - ( removeQuotes, unquoteUrl, unquoteFontFamily, mapString+module Hasmin.Types.String (+ removeQuotes+ , unquoteUrl+ , unquoteFontFamily+ , mapString , StringType(..) ) where @@ -23,10 +26,10 @@ import qualified Data.Char as C import qualified Data.Text as T import qualified Data.Text.Lazy as TL++import Hasmin.Config import Hasmin.Parser.Utils import Hasmin.Types.Class-import Hasmin.Config-import Text.PrettyPrint.Mainland (Pretty, ppr, strictText) -- | The \<string\> data type represents a string, formed by Unicode -- characters, delimited by either double (") or single (') quotes.@@ -40,8 +43,6 @@ instance ToText StringType where toBuilder (DoubleQuotes t) = singleton '\"' <> fromText t <> singleton '\"' toBuilder (SingleQuotes t) = singleton '\'' <> fromText t <> singleton '\''-instance Pretty StringType where- ppr = strictText . toText instance Minifiable StringType where minifyWith (DoubleQuotes t) = do conf <- ask@@ -111,7 +112,3 @@ Just '\\' -> A.char '\\' *> liftA2 (mappend . mappend t . singleton) utf8 go _ -> pure t utf8 = C.chr <$> A.hexadecimal--instance Pretty (Either Text StringType) where- ppr (Left i) = strictText i- ppr (Right s) = ppr s
src/Hasmin/Types/Stylesheet.hs view
@@ -9,32 +9,41 @@ -- ----------------------------------------------------------------------------- module Hasmin.Types.Stylesheet (- Expression(..), MediaQuery(..), Rule(..), KeyframeSelector(..),- KeyframeBlock(..), isEmpty+ Expression(..)+ , MediaQuery(..)+ , Rule(..)+ , KeyframeSelector(..)+ , KeyframeBlock(..)+ , SupportsCondition(..)+ , SupportsCondInParens(..)+ , isEmpty ) where import Control.Monad.Reader (Reader, ask) import Control.Applicative (liftA2) import Data.Monoid ((<>)) import Data.Text (Text)-import Data.Text.Lazy.Builder (singleton, fromText)+import Data.Text.Lazy.Builder (singleton, fromText, Builder) import Data.List (sortBy, (\\)) import Data.Map.Strict (Map)+import Data.List.NonEmpty (NonEmpty((:|)))+import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import qualified Data.Set as S import qualified Data.Text as T-import Text.PrettyPrint.Mainland (Pretty, ppr, strictText,- lbrace, rbrace, (</>), (<+>), comma, folddoc, nest, semi, stack, char) import Hasmin.Config-import Hasmin.Selector+import Hasmin.Types.Selector import Hasmin.Types.Class import Hasmin.Types.Value import Hasmin.Types.Declaration import Hasmin.Types.String import Hasmin.Types.Numeric+import Hasmin.Types.Dimension import Hasmin.Utils +-- | Data type for media queries. For the syntax, see+-- <https://www.w3.org/TR/css3-mediaqueries/#syntax media query syntax>. data MediaQuery = MediaQuery1 Text Text [Expression] -- ^ First possibility in the grammar | MediaQuery2 [Expression] -- ^ Second possibility in the grammar deriving (Show, Eq)@@ -68,8 +77,6 @@ toText From = "from" toText To = "to" toText (KFPercentage p) = toText p-instance Pretty KeyframeSelector where- ppr = strictText . toText instance Minifiable KeyframeSelector where minifyWith x = do conf <- ask@@ -103,23 +110,16 @@ | AtNamespace Text (Either StringType Url) | AtMedia [MediaQuery] [Rule] | AtKeyframes VendorPrefix Text [KeyframeBlock]+ | AtSupports SupportsCondition [Rule] | AtBlockWithRules Text [Rule] | AtBlockWithDec Text [Declaration] | StyleRule [Selector] [Declaration] deriving (Show)-instance Pretty Rule where- ppr (StyleRule ss ds) = folddoc (\x y -> x <> comma <+> y) (fmap ppr ss)- <+> nest 4 (lbrace </> stack (fmap ((<> semi) . ppr) ds))- </> rbrace- ppr (AtBlockWithRules t rs) = char '@' <> strictText t- <+> nest 4 (lbrace </> stack (fmap ppr rs)) </> rbrace- ppr (AtBlockWithDec t ds) = char '@' <> strictText t- <+> nest 4 (lbrace </> stack (fmap ppr ds)) </> rbrace- ppr _ = error "not implemented (TODO)"- instance ToText Rule where toBuilder (AtMedia mqs rs) = "@media " <> mconcatIntersperse toBuilder (singleton ',') mqs <> singleton '{' <> mconcat (fmap toBuilder rs) <> singleton '}'+ toBuilder (AtSupports sc rs) = "@supports " <> toBuilder sc+ <> singleton '{' <> mconcat (fmap toBuilder rs) <> singleton '}' toBuilder (AtImport esu mqs) = "@import " <> toBuilder esu <> mediaqueries <> singleton ';' where mediaqueries =@@ -147,9 +147,9 @@ toBuilder (AtKeyframes vp n bs) = singleton '@' <> fromText vp <> "keyframes" <> singleton ' ' <> fromText n <> singleton '{' <> mconcat (fmap toBuilder bs) <> singleton '}'- instance Minifiable Rule where minifyWith (AtMedia mqs rs) = liftA2 AtMedia (mapM minifyWith mqs) (mapM minifyWith rs)+ minifyWith (AtSupports sc rs) = liftA2 AtSupports (minifyWith sc) (mapM minifyWith rs) minifyWith (AtKeyframes vp n bs) = AtKeyframes vp n <$> mapM minifyWith bs minifyWith (AtBlockWithRules t rs) = AtBlockWithRules t <$> mapM minifyWith rs minifyWith (AtBlockWithDec t ds) = do@@ -251,3 +251,83 @@ where go _ [] = [] go s (x:xs) | S.member x s = go s xs | otherwise = x : go (S.insert x s) xs+++data SupportsCondition = Not SupportsCondInParens+ | And SupportsCondInParens (NonEmpty SupportsCondInParens)+ | Or SupportsCondInParens (NonEmpty SupportsCondInParens)+ | Parens SupportsCondInParens+ deriving (Show)+instance ToText SupportsCondition where+ toBuilder (Not x) = "not " <> toBuilder x+ toBuilder (And x y) = appendWith " and " x y+ toBuilder (Or x y) = appendWith " or " x y+ toBuilder (Parens x) = toBuilder x+instance Minifiable SupportsCondition where+ minifyWith (And x y) = And <$> pure x <*> mapM pure y+ minifyWith (Or x y) = Or <$> pure x <*> mapM pure y+ minifyWith (Parens x) = Parens <$> pure x+ minifyWith (Not x) =+ case x of+ ParensCond (Not y) -> case y of+ ParensCond a@And{} -> pure a+ ParensCond o@Or{} -> pure o+ ParensCond n@Not{} -> pure n+ ParensCond (Parens c) -> Parens <$> pure c+ ParensDec d -> (Parens . ParensDec) <$> pure d+ ParensCond y -> (Not . ParensCond) <$> pure y+ ParensDec y -> (Not . ParensDec) <$> pure y++appendWith :: Builder -> SupportsCondInParens -> NonEmpty SupportsCondInParens -> Builder+appendWith s x y = toBuilder x <> s <> mconcatIntersperse toBuilder s (NE.toList y)++-- Note that "general_enclosed" is not included, because, per the spec:+--+-- The result is always false. Additionally, style sheets must+-- not write @supports rules that match this grammar production. (In other+-- words, this production exists only for future extensibility, and is not part+-- of the description of a valid style sheet in this level of the+-- specification.) Note that future levels may define functions or other+-- parenthesized expressions that can evaluate to true.+data SupportsCondInParens = ParensCond SupportsCondition+ | ParensDec Declaration+ deriving (Show)+instance ToText SupportsCondInParens where+ toBuilder (ParensDec x) = "(" <> toBuilder x <> ")"+ toBuilder (ParensCond x) = "(" <> toBuilder x <> ")"+instance Minifiable SupportsCondInParens where+ minifyWith (ParensDec x) = ParensDec <$> minifyWith x+ minifyWith (ParensCond x) = ParensCond <$> minifyWith x++data GeneralEnclosed = GEFunction+ deriving (Show)++{-+supports_rule+ : SUPPORTS_SYM S* supports_condition group_rule_body+ ;++supports_condition+ : supports_negation | supports_conjunction | supports_disjunction |+ supports_condition_in_parens+ ;++supports_condition_in_parens+ : ( '(' S* supports_condition ')' S* ) | supports_declaration_condition |++supports_negation+ : NOT S* supports_condition_in_parens+ ;++supports_conjunction+ : supports_condition_in_parens ( AND S* supports_condition_in_parens )++ ;++supports_disjunction+ : supports_condition_in_parens ( OR S* supports_condition_in_parens )++ ;++supports_declaration_condition+ : '(' S* declaration ')' S*+ ;+ -}
src/Hasmin/Types/TimingFunction.hs view
@@ -13,7 +13,7 @@ ) where import Control.Monad.Reader (ask)-import Data.Semigroup ((<>))+import Data.Monoid ((<>)) import Prelude hiding (sin, cos, acos, tan, atan) import Data.Maybe (isNothing, fromJust) import Data.Text.Lazy.Builder (singleton)@@ -21,7 +21,6 @@ import Hasmin.Types.Class import Hasmin.Utils import Hasmin.Types.Numeric---import Text.PrettyPrint.Mainland (Pretty, ppr, strictText) -- | CSS \<single-transition-timing-function\> data type. Specifications: --@@ -30,17 +29,17 @@ -- 3. <https://developer.mozilla.org/en-US/docs/Web/CSS/timing-function Mozilla summary> data TimingFunction = CubicBezier Number Number Number Number | Steps Int (Maybe StepsSecondParam)- | Ease | EaseIn | EaseInOut | EaseOut - | Linear | StepEnd | StepStart + | Ease | EaseIn | EaseInOut | EaseOut+ | Linear | StepEnd | StepStart deriving (Show) instance Eq TimingFunction where- Steps i1 ms1 == Steps i2 ms2 = i1 == i2 && (ms1 == ms2 + Steps i1 ms1 == Steps i2 ms2 = i1 == i2 && (ms1 == ms2 || (isNothing ms1 && fromJust ms2 == End) || (fromJust ms1 == End && isNothing ms2)) s@Steps{} == x = maybe False (== s) (toSteps x) x == s@Steps{} = s == x- CubicBezier x1 x2 x3 x4 == CubicBezier y1 y2 y3 y4 = + CubicBezier x1 x2 x3 x4 == CubicBezier y1 y2 y3 y4 = x1 == y1 && x2 == y2 && x3 == y3 && x4 == y4 c@CubicBezier{} == x = maybe False (== c) (toCubicBezier x) x == c@CubicBezier{} = c == x@@ -52,14 +51,14 @@ EaseOut == EaseOut = True EaseInOut == EaseInOut = True _ == _ = False- + toCubicBezier :: TimingFunction -> Maybe TimingFunction toCubicBezier Ease = Just $ CubicBezier 0.25 0.1 0.25 1 toCubicBezier EaseIn = Just $ CubicBezier 0.42 0 1 1 toCubicBezier EaseInOut = Just $ CubicBezier 0.42 0 0.58 1 toCubicBezier Linear = Just $ CubicBezier 0 0 1 1 toCubicBezier EaseOut = Just $ CubicBezier 0 0 0.58 1-toCubicBezier _ = Nothing +toCubicBezier _ = Nothing toSteps :: TimingFunction -> Maybe TimingFunction toSteps StepEnd = Just $ Steps 1 (Just End)@@ -74,7 +73,7 @@ toBuilder End = "end" instance ToText TimingFunction where- toBuilder (CubicBezier a b c d) = "cubic-bezier(" + toBuilder (CubicBezier a b c d) = "cubic-bezier(" <> mconcatIntersperse toBuilder (singleton ',') [a,b,c,d] <> singleton ')' toBuilder (Steps i ms) = "steps(" <> toBuilder i <> sp <> singleton ')'@@ -92,24 +91,28 @@ conf <- ask if shouldMinifyTimingFunctions conf then pure $ minifyTimingFunction x- else pure x + else pure x minifyTimingFunction :: TimingFunction -> TimingFunction-minifyTimingFunction x@(CubicBezier a b c d) - | a == 0.25 && b == 0.1 && c == 0.25 && d == 1 = Ease- | a == 0.42 && b == 0 && d == 1 = if c == 1- then EaseIn- else if c == 0.58- then EaseInOut- else x- | a == 0 && b == 0 && d == 1 = if c == 1- then Linear- else if c == 0.58 - then EaseOut- else x- | otherwise = x-minifyTimingFunction x@(Steps i ms)- | (isNothing ms || (fromJust ms == End)) && i == 1 = StepEnd- | i == 1 && (fromJust ms == Start) = StepStart- | otherwise = x+minifyTimingFunction x@(CubicBezier a b c 1)+ | a == 0.25 && b == 0.1 && c == 0.25 = Ease+ | b == 0 = if a == 0.42+ then if c == 1+ then EaseIn+ else if c == 0.58+ then EaseInOut+ else x+ else if a == 0+ then if c == 1+ then Linear+ else if c == 0.58+ then EaseOut+ else x+ else x+minifyTimingFunction x@CubicBezier{} = x+minifyTimingFunction (Steps 1 ms) =+ case ms of+ Just Start -> StepStart+ _ -> StepEnd+minifyTimingFunction (Steps i (Just End)) = Steps i Nothing minifyTimingFunction x = x
src/Hasmin/Types/TransformFunction.hs view
@@ -21,7 +21,7 @@ import Data.Number.FixedFunctions (sin, cos, acos, tan, atan) import Prelude hiding (sin, cos, acos, tan, atan) import qualified Data.Matrix as M -import Data.Matrix (Matrix) +import Data.Matrix (Matrix) import Data.List (groupBy) import Data.Maybe (fromMaybe, isNothing, isJust, fromJust) import Data.Text.Lazy.Builder (toLazyText, singleton, Builder) @@ -32,9 +32,8 @@ import Hasmin.Types.Dimension import Hasmin.Types.PercentageLength import Hasmin.Types.Numeric -import Text.PrettyPrint.Mainland (Doc, Pretty, ppr, char) --- Note: In a previous specification, translate3d() took two +-- Note: In a previous specification, translate3d() took two -- <https://www.w3.org/TR/css-transforms-1/#typedef-translation-value \<translation-value\>>, -- however in the <https://drafts.csswg.org/css-transforms/ latest draft>, it -- takes two \<length-percentage\> (which makes sense since translateX() and @@ -75,10 +74,10 @@ if shouldMinifyTransformFunction conf then case possibleRepresentations m of [] -> pure (Mat3d m) - (x:xs) -> let simplifyAndConvertUnits a = local (const $ conf { dimensionSettings = DimMinOn }) (simplify a) + (x:xs) -> let simplifyAndConvertUnits a = local (const $ conf { dimensionSettings = DimMinOn }) (simplify a) in go simplifyAndConvertUnits x xs else pure (Mat3d m) - where go f y [] = f y + where go f y [] = f y go f y (z:zs) = do currentLength <- textualLength <$> f y newLength <- textualLength <$> f z @@ -106,9 +105,9 @@ -} instance ToText TransformFunction where - toBuilder (Translate pl mpl) = "translate(" + toBuilder (Translate pl mpl) = "translate(" <> toBuilder pl <> maybeWithComma mpl <> singleton ')' - toBuilder (TranslateX pl) = "translatex(" + toBuilder (TranslateX pl) = "translatex(" <> either toBuilder toBuilder pl <> singleton ')' toBuilder (TranslateY pl) = "translatey(" <> either toBuilder toBuilder pl <> singleton ')' toBuilder (TranslateZ d) = "translatez(" <> toBuilder d <> singleton ')' @@ -123,58 +122,22 @@ toBuilder (RotateX a) = "rotatex(" <> toBuilder a <> singleton ')' toBuilder (RotateY a) = "rotatey(" <> toBuilder a <> singleton ')' toBuilder (RotateZ a) = "rotatez(" <> toBuilder a <> singleton ')' - toBuilder (Rotate3d x y z a) = "rotate3d(" <> toBuilder x <> singleton ',' - <> toBuilder y <> singleton ',' <> toBuilder z <> singleton ',' + toBuilder (Rotate3d x y z a) = "rotate3d(" <> toBuilder x <> singleton ',' + <> toBuilder y <> singleton ',' <> toBuilder z <> singleton ',' <> toBuilder a <> singleton ')' toBuilder (Scale3d x y z) = "scale3d(" <> toBuilder x <> singleton ',' <> toBuilder y <> singleton ',' <> toBuilder z <> singleton ')' toBuilder (Perspective d) = "perspective(" <> toBuilder d <> singleton ')' toBuilder (Translate3d x y z ) = "translate3d(" <> toBuilder x <> singleton ',' <> toBuilder y <> singleton ',' <> toBuilder z <> singleton ')' - toBuilder (Mat m) = "matrix(" + toBuilder (Mat m) = "matrix(" <> mconcatIntersperse toBuilder (singleton ',') (M.toList m) <> singleton ')' - toBuilder (Mat3d m) = "matrix3d(" + toBuilder (Mat3d m) = "matrix3d(" <> mconcatIntersperse toBuilder (singleton ',') (M.toList m) <> singleton ')' maybeWithComma :: ToText a => Maybe a -> Builder maybeWithComma = maybe mempty (\x -> singleton ',' <> toBuilder x) -instance Pretty TransformFunction where - ppr (Translate pl mpl) = "translate(" <> eitherToDoc pl - <> maybe mempty (\x -> char ',' <> eitherToDoc x) mpl - <> char ')' - ppr (TranslateX pl) = "translatex(" <> either ppr ppr pl <> char ')' - ppr (TranslateY pl) = "translatey(" <> either ppr ppr pl <> char ')' - ppr (TranslateZ d) = "translatez(" <> ppr d <> char ')' - ppr (Scale n mn) = "scale(" <> ppr n <> maybeToDoc mn <> char ')' - ppr (ScaleX n) = "scalex(" <> ppr n <> char ')' - ppr (ScaleY n) = "scaley(" <> ppr n <> char ')' - ppr (ScaleZ n) = "scalez(" <> ppr n <> char ')' - ppr (Skew a ma) = "skew(" <> ppr a <> maybeToDoc ma <> char ')' - ppr (SkewX a) = "skewx(" <> ppr a <> char ')' - ppr (SkewY a) = "skewy(" <> ppr a <> char ')' - ppr (Rotate a) = "rotate(" <> ppr a <> char ')' - ppr (RotateX a) = "rotatex(" <> ppr a <> char ')' - ppr (RotateY a) = "rotatey(" <> ppr a <> char ')' - ppr (RotateZ a) = "rotatez(" <> ppr a <> char ')' - ppr (Rotate3d x y z a) = "rotate3d(" <> ppr x <> char ',' <> ppr y - <> char ',' <> ppr z <> char ',' <> ppr a <> char ')' - ppr (Scale3d x y z) = "scale3d(" <> ppr x <> char ',' <> ppr y - <> char ',' <> ppr z <> char ')' - ppr (Perspective d) = "perspective(" <> ppr d <> char ')' - ppr (Translate3d x y z) = "translate3d(" <> eitherToDoc x <> char ',' - <> eitherToDoc y <> char ',' <> ppr z <> char ')' - ppr (Mat m) = "matrix(" - <> mconcatIntersperse ppr (char ',') (M.toList m) <> char ')' - ppr (Mat3d m) = "matrix3d(" - <> mconcatIntersperse ppr (char ',') (M.toList m) <> char ')' - -maybeToDoc :: Pretty a => Maybe a -> Doc -maybeToDoc = maybe mempty (\x -> char ',' <> ppr x) - -eitherToDoc :: (Pretty a, Pretty b) => Either a b -> Doc -eitherToDoc = either ppr ppr - mkMat :: [Number] -> TransformFunction mkMat = Mat . M.fromList 3 2 @@ -196,17 +159,17 @@ where x = either (const 0) fromPixelsToNum pl y = maybe 0 (fromPixelsToNum . fromRight') mpl toMatrix3d (TranslateX pl) - | isNonZeroPercentage pl = Nothing - | isRight pl && isRelativeDistance (fromRight' pl) = Nothing - | otherwise = Just . Mat3d $ mkTranslate3dMatrix x 0 0 + | isNonZeroPercentage pl = Nothing + | isRight pl && isRelativeDistance (fromRight' pl) = Nothing + | otherwise = Just . Mat3d $ mkTranslate3dMatrix x 0 0 where x = either (const 0) fromPixelsToNum pl toMatrix3d (TranslateY pl) - | isNonZeroPercentage pl = Nothing - | isRight pl && isRelativeDistance (fromRight' pl) = Nothing + | isNonZeroPercentage pl = Nothing + | isRight pl && isRelativeDistance (fromRight' pl) = Nothing | otherwise = Just . Mat3d $ mkTranslate3dMatrix 0 y 0 where y = either (const 0) fromPixelsToNum pl toMatrix3d (TranslateZ d) - | isRelativeDistance d = Nothing + | isRelativeDistance d = Nothing | otherwise = Just . Mat3d $ mkTranslate3dMatrix 0 0 z where z = fromPixelsToNum d toMatrix3d (Scale n mn) = Just . Mat3d $ mkScale3dMatrix n y 1 @@ -214,16 +177,16 @@ toMatrix3d (ScaleX n) = Just . Mat3d $ mkScale3dMatrix n 1 1 toMatrix3d (ScaleY n) = Just . Mat3d $ mkScale3dMatrix 1 n 1 toMatrix3d (ScaleZ n) = Just . Mat3d $ mkScale3dMatrix 1 1 n -toMatrix3d (Skew a ma) = Just . Mat3d $ mkSkewMatrix α β +toMatrix3d (Skew a ma) = Just . Mat3d $ mkSkewMatrix α β where α = tangent a β = maybe 0 tangent ma toMatrix3d (SkewX a) = Just . Mat3d $ mkSkewMatrix (tangent a) 0 toMatrix3d (SkewY a) = Just . Mat3d $ mkSkewMatrix 0 (tangent a) toMatrix3d (Translate3d pl1 pl2 d) - | isNonZeroPercentage pl1 || isNonZeroPercentage pl2 = Nothing + | isNonZeroPercentage pl1 || isNonZeroPercentage pl2 = Nothing | isRight pl1 && isRelativeDistance (fromRight' pl1) = Nothing - | isRight pl2 && isRelativeDistance (fromRight' pl2) = Nothing - | isRelativeDistance d = Nothing + | isRight pl2 && isRelativeDistance (fromRight' pl2) = Nothing + | isRelativeDistance d = Nothing | otherwise = let x = either (const 0) fromPixelsToNum pl1 y = either (const 0) fromPixelsToNum pl2 z = fromPixelsToNum d @@ -232,8 +195,8 @@ toMatrix3d (Perspective d) | d == Distance 0 Q = Nothing | otherwise = let c = fromPixelsToNum d - in Just . Mat3d $ mkPerspectiveMatrix c --- Note: The commented code is fine, but until we implement the + in Just . Mat3d $ mkPerspectiveMatrix c +-- Note: The commented code is fine, but until we implement the -- function that converts a matrix back to a rotate function, uncommenting this -- breaks the minification, e.g. it says that: -- minify rotate(90deg) == matrix(0,1,-1,0,0,0) @@ -254,7 +217,7 @@ [1-2*(y^2 + z^2)*sq, 2*(x*y*sq - z*sc), 2*(x*z*sq + y*sc), 0, 2*(x*y*sq + z*sc), 1-2*(x^2 + z^2)*sq, 2*(y*z*sq - x*sc), 0, 2*(x*z*sq - y*sc), 2*(y*z*sq + x*sc), 1-2*(x^2 + y^2)*sq, 0, - 0, 0, 0, 1] + 0, 0, 0, 1] where sc = sin epsilon (α/2) * cos epsilon (α/2) :: Rational sq = sin epsilon (α/2) ^ 2 :: Rational x = toRational b @@ -293,7 +256,7 @@ -- Make sure that the input is a pure rotation matrix. -- The condition for this is: -- R' * R = I, and det(R) = 1 - isRotationMatrix + isRotationMatrix | abs (m11*m12 + m12*m22 + m13*m23) > ep || abs (m11*m31 + m12*m32 + m13*m33) > ep || abs (m21*m31 + m22*m32 + m23*m33) > ep @@ -301,10 +264,10 @@ || abs (m21*m21 + m22*m11 + m23*m23 - 1) > ep || abs (m31*m31 + m32*m32 + m33*m33 - 1) > ep = False | otherwise = abs (detLU m - 1) < ep - handleSingularity - | abs (m12 + m21) < ep2 - && abs (m13 + m31) < ep2 - && abs (m23 - m32) < ep2 + handleSingularity + | abs (m12 + m21) < ep2 + && abs (m13 + m31) < ep2 + && abs (m23 - m32) < ep2 && abs (m11 + m22 + m33 - 3) < ep2 = Rotate3d 1 0 0 (Angle 0 Deg) | otherwise = let xx = (m11+1)/2 yy = (m22+1)/2 @@ -342,13 +305,13 @@ tangent = toNumber . tan epsilon . fromNumber . fromRadiansToNum arctan :: Number -> Number -arctan = toNumber . atan epsilon . fromNumber +arctan = toNumber . atan epsilon . fromNumber -- sine :: Number -> Number --- sine = toNumber . sin epsilon . fromNumber +-- sine = toNumber . sin epsilon . fromNumber -- arccos :: Number -> Number --- arccos = toNumber . acos epsilon . fromNumber +-- arccos = toNumber . acos epsilon . fromNumber getMat :: TransformFunction -> Matrix Number getMat (Mat q) = q @@ -372,7 +335,7 @@ matrixToSkewFunctions m | skewMatrix == m = Skew a (Just b) : others | otherwise = [] - where α = M.unsafeGet 1 2 m + where α = M.unsafeGet 1 2 m β = M.unsafeGet 2 1 m a = Angle (arctan α) Rad b = Angle (arctan β) Rad @@ -382,7 +345,7 @@ | β /= 0 && α == 0 = [SkewY b] | otherwise = [] -- The only case when we can use either of -- them is when both α and β are zero, but if so - -- skew is already shorter, so don't return it. + -- skew is already shorter, so don't return it. matrixToTranslateFunctions :: Matrix Number -> [TransformFunction] matrixToTranslateFunctions m @@ -394,7 +357,7 @@ ty = Right $ Distance y PX z = M.unsafeGet 3 4 m tz = Distance z PX - others + others | z == 0 && y == 0 = [TranslateX tx, Translate tx (Just ty)] | x == 0 && z == 0 = [TranslateY ty, Translate tx (Just ty)] | y == 0 && x == 0 = [TranslateZ tz] @@ -407,7 +370,7 @@ where x = M.unsafeGet 1 1 m y = M.unsafeGet 2 2 m z = M.unsafeGet 3 3 m - others + others | z == 1 && y == 1 = [ScaleX x, Scale x Nothing] | y == 1 && x == 1 = [ScaleZ z] | x == 1 && z == 1 = [ScaleY y, Scale x (Just y)] @@ -450,26 +413,26 @@ 0, 0, z, 0, 0, 0, 0, 1] -mkSkewMatrix :: Number -> Number -> Matrix Number +mkSkewMatrix :: Number -> Number -> Matrix Number mkSkewMatrix a b = mk4x4Matrix [1, a, 0, 0, b, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1] mkPerspectiveMatrix :: Number -> Matrix Number -mkPerspectiveMatrix c = let d = (-1/c) +mkPerspectiveMatrix c = let d = (-1/c) in mk4x4Matrix [1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, d, 0] mk4x4Matrix :: [Number] -> Matrix Number -mk4x4Matrix = M.fromList 4 4 +mk4x4Matrix = M.fromList 4 4 -- | Simplifies a \<transform-function\> without converting it to a 4x4 matrix, -- by doing some simple conversions between the different functions, or -- minifying the dimension arguments (\<length\> and \<angle\> values) simplify :: TransformFunction -> Reader Config TransformFunction -simplify (Translate pl mpl) +simplify (Translate pl mpl) | isNothing mpl || isZero (fromJust mpl) = do x <- mapM minifyWith pl pure $ Translate x Nothing @@ -478,7 +441,7 @@ pure $ Translate x y simplify (TranslateX pl) = do x <- mapM minifyWith pl - simplify $ Translate x Nothing + simplify $ Translate x Nothing -- Note: It always makes sense to convert from translateX to translate -- Not sure about translateY. Converting to translate(0,a) might aid -- compression, even when we are adding one character, because we might be @@ -495,7 +458,7 @@ -- TODO see if it is better to leave them as is, or convert them to scale(x,1) -- and scale(1,x), respectively, to aid gzip compression simplify s@(ScaleX _) = pure s -simplify s@(ScaleY _) = pure s +simplify s@(ScaleY _) = pure s -- In skew(), if the second parameter isn't present, it defaults to the zero. simplify (Skew a ma) | defaultSecondArgument = do ang <- minifyWith a @@ -535,7 +498,7 @@ | otherwise = fmap TranslateZ (minifyWith d) simplify s@(Scale3d x y z) | z == 1 = simplify $ Scale x (Just y) - | x == 1 && y == 1 = simplify $ ScaleZ z + | x == 1 && y == 1 = simplify $ ScaleZ z | otherwise = pure s simplify (Translate3d x y z ) | isZero y && z == Distance 0 Q = either (f TranslateX) (g TranslateX) x @@ -544,7 +507,7 @@ where f con a | a == 0 = simplify . con . Right $ Distance 0 Q | otherwise = simplify . con . Left $ a g con a = simplify . con $ Right a -- A distance, transform an minify -simplify x = pure x +simplify x = pure x -- | Combines consecutive \<transform-functions\> whenever possible, leaving -- translate functions that can't be converted to a matrix (because they use @@ -568,12 +531,12 @@ originalLength <- mapReader (getLength . asBuilder) minifiedOriginal if combinedLength < originalLength then combinedFunctions - else minifiedOriginal + else minifiedOriginal where getLength = T.length . toStrict . toLazyText asBuilder = mconcatIntersperse toBuilder (singleton ' ') combinedFunctions = mapM handleMatrices . groupByMatrices $ zip (fmap toMatrix3d xs) xs minifiedOriginal = mapM minifyWith xs - groupByMatrices = groupBy (\(a,_) (b,_) -> isJust a && isJust b) + groupByMatrices = groupBy (\(a,_) (b,_) -> isJust a && isJust b) handleMatrices l@((x,a):_) | isJust x = minifyWith . Mat3d . foldr (*) (M.identity 4 :: Matrix Number) $ fmap (getMat . fromJust . fst) l | otherwise = simplify a
src/Hasmin/Types/Value.hs view
@@ -9,8 +9,16 @@ -- ----------------------------------------------------------------------------- module Hasmin.Types.Value (- Value(..), Values(..), TextV(..), Separator(..), Url(..), mkOther,- mkValues, valuesToList, optimizeFontFamily, lowercaseText+ Value(..)+ , Values(..)+ , TextV(..)+ , Separator(..)+ , Url(..)+ , mkOther+ , mkValues+ , valuesToList+ , optimizeFontFamily+ , lowercaseText ) where import Control.Monad.Reader (ask, Reader, mapReader)@@ -20,22 +28,22 @@ import qualified Data.Text as T import Data.Text.Lazy.Builder (fromText, singleton, Builder) import Data.String (IsString)+ import Hasmin.Config+import Hasmin.Types.BgSize import Hasmin.Types.Class import Hasmin.Types.Color import Hasmin.Types.Dimension+import Hasmin.Types.FilterFunction import Hasmin.Types.Gradient import Hasmin.Types.Numeric-import Hasmin.Types.String import Hasmin.Types.Position import Hasmin.Types.RepeatStyle-import Hasmin.Types.BgSize-import Hasmin.Types.TransformFunction-import Hasmin.Types.TimingFunction-import Hasmin.Types.FilterFunction import Hasmin.Types.Shadow+import Hasmin.Types.String+import Hasmin.Types.TimingFunction+import Hasmin.Types.TransformFunction import Hasmin.Utils-import Text.PrettyPrint.Mainland (Pretty, ppr, strictText, space, comma, char) data Value = Inherit | Initial@@ -85,17 +93,6 @@ TextV t1 == TextV t2 = toCaseFold t1 == toCaseFold t2 instance ToText TextV where toText = getText-instance Pretty Value where- ppr (NumberV n) = ppr n- ppr (PercentageV p) = ppr p- ppr (DistanceV d) = ppr d- ppr (AngleV a) = ppr a- ppr (DurationV x) = ppr x- ppr (FrequencyV x) = ppr x- ppr (ResolutionV x) = ppr x- ppr (ColorV x) = ppr x- ppr (Other x) = ppr (getText x)- ppr x = (strictText . toText) x mkOther :: Text -> Value mkOther = Other . TextV@@ -104,8 +101,6 @@ deriving (Eq, Show) instance ToText Url where toBuilder (Url x) = "url(" <> toBuilder x <> singleton ')'-instance Pretty Url where- ppr (Url x) = strictText "url(" <> ppr x <> char ')' instance Minifiable Url where minifyWith u@(Url x) = do conf <- ask@@ -186,8 +181,6 @@ minifyWith (ResolutionV r) = ResolutionV <$> minifyWith r minifyWith (GradientV t g) = GradientV t <$> minifyWith g minifyWith (FilterV f) = FilterV <$> minifyWith f- minifyWith (ShadowV s) = ShadowV <$> minifyWith s- minifyWith (ShadowText l1 l2 ml mc) = minifyPseudoShadow ShadowText l1 l2 ml mc minifyWith (TransformV tf) = TransformV <$> minifyWith tf minifyWith (TimingFuncV tf) = TimingFuncV <$> minifyWith tf minifyWith (StringV s) = StringV <$> minifyWith s@@ -196,6 +189,8 @@ minifyWith (PositionV p) = PositionV <$> minifyWith p minifyWith (RepeatStyleV r) = RepeatStyleV <$> minifyWith r minifyWith (BgSizeV b) = BgSizeV <$> minifyWith b+ minifyWith (ShadowV s) = ShadowV <$> minifyWith s+ minifyWith (ShadowText l1 l2 ml mc) = minifyPseudoShadow ShadowText l1 l2 ml mc minifyWith (BgLayer img pos sz rst att b1 b2) = do conf <- ask i <- handleImage img@@ -366,29 +361,21 @@ data Values = Values Value [(Separator, Value)] deriving (Show, Eq)+instance ToText Values where+ toBuilder (Values v vs) = toBuilder v <> foldr f mempty vs+ where f (sep, val) z = toBuilder sep <> toBuilder val <> z instance Minifiable Values where minifyWith (Values v vs) = do newV <- minifyWith v newVs <- (mapM . mapM) minifyWith vs pure $ Values newV newVs -instance ToText Values where- toBuilder (Values v vs) = toBuilder v <> foldr f mempty vs- where f (sep, val) z = toBuilder sep <> toBuilder val <> z-instance Pretty Values where- ppr (Values v vs) = ppr v <> foldr f mempty vs- where f (sep, val) xs = ppr sep <> ppr val <> xs- data Separator = Space | Slash | Comma deriving (Show, Eq) instance ToText Separator where toText Space = " " toText Comma = "," toText Slash = "/" -- Used, for example, by font to separate font-size and line-height-instance Pretty Separator where- ppr Space = space- ppr Comma = comma- ppr Slash = strictText (toText Slash) valuesToList :: Values -> [Value] valuesToList (Values v vs) = v : map snd vs
src/Hasmin/Utils.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Module : Hasmin.Utils
− tests/Hasmin/SelectorSpec.hs
@@ -1,58 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Hasmin.SelectorSpec where--import Test.Hspec-import Hasmin.Parser.Internal-import Hasmin.TestUtils--import Control.Monad.Reader (runReader)-import Data.Text (Text)-import Hasmin.Types.Class-import Hasmin.Config--anplusbMinificationTests :: Spec-anplusbMinificationTests =- describe "<an+b> minification tests" $- mapM_ (matchSpec (f <$> selector)) anplusbMinificationTestsInfo- where f x = runReader (minifyWith x) defaultConfig--anplusbMinificationTestsInfo :: [(Text, Text)]-anplusbMinificationTestsInfo = - [(":nth-child(-1n)", ":nth-child(-n)")- ,(":nth-child(-n)", ":nth-child(-n)")- ,(":nth-child(+n)", ":nth-child(n)")- ,(":nth-child(+1n)", ":nth-child(n)")- ,(":nth-child( even )", ":nth-child(2n)")- ,(":nth-child( 2n - 2 )", ":nth-child(2n)")- ,(":nth-child( 2n - 4 )", ":nth-child(2n)")- ,(":nth-child( 2n + 1 )", ":nth-child(odd)")- ,(":nth-child( 2n - 1 )", ":nth-child(odd)")- ,(":nth-child( 2n - 3 )", ":nth-child(odd)")- ,(":nth-child(0n)", ":nth-child(0)")- ,(":nth-child(0n+0)", ":nth-child(0)")- ,(":nth-child(0n-0)", ":nth-child(0)")- ,(":nth-child(0n-1)", ":nth-child(-1)")- ,(":nth-child(1n+0)", ":nth-child(n)")- ,(":nth-child(1n-0)", ":nth-child(n)")- ]--attributeQuoteRemovalTest :: Spec-attributeQuoteRemovalTest =- describe "attribute quote removal tests" $- mapM_ (matchSpec (f <$> selector)) attributeQuoteRemovalTestInfo- where f x = runReader (minifyWith x) defaultConfig--attributeQuoteRemovalTestInfo :: [(Text, Text)]-attributeQuoteRemovalTestInfo =- [("[type=\"remove-double-quotes\"]", "[type=remove-double-quotes]")- ,("[type='remove-single-quotes']", "[type=remove-single-quotes]")- ,("[a^='\"']", "[a^='\"']")- ]--spec :: Spec-spec = do anplusbMinificationTests- attributeQuoteRemovalTest--main :: IO ()-main = hspec spec
tests/Hasmin/Types/DimensionSpec.hs view
@@ -10,47 +10,47 @@ import Hasmin.Types.Dimension spec :: Spec-spec = +spec = describe "<length> units equivalences" $ do describe "inches conversions" $ do it "1in == 2.54cm" $- (Distance 1 IN) `shouldBe` Distance 2.54 CM+ Distance 1 IN `shouldBe` Distance 2.54 CM it "1in == 25.4cm" $- (Distance 1 IN) `shouldBe` Distance 25.4 MM+ Distance 1 IN `shouldBe` Distance 25.4 MM it "1in == 101.6q" $- (Distance 1 IN) `shouldBe` Distance 101.6 Q+ Distance 1 IN `shouldBe` Distance 101.6 Q it "1in == 72pt" $- (Distance 1 IN) `shouldBe` Distance 72 PT+ Distance 1 IN `shouldBe` Distance 72 PT it "1in == 6pc" $- (Distance 1 IN) `shouldBe` Distance 6 PC+ Distance 1 IN `shouldBe` Distance 6 PC it "1in == 96px" $- (Distance 1 IN) `shouldBe` Distance 96 PX+ Distance 1 IN `shouldBe` Distance 96 PX describe "pixel conversions" $ do it "48px == .5in" $- (Distance 48 PX) `shouldBe` Distance 0.5 IN+ Distance 48 PX `shouldBe` Distance 0.5 IN it "72px == 1.905cm" $- (Distance 72 PX) `shouldBe` Distance 1.905 CM+ Distance 72 PX `shouldBe` Distance 1.905 CM it "72px == 19.05mm" $- (Distance 72 PX) `shouldBe` Distance 19.05 MM + Distance 72 PX `shouldBe` Distance 19.05 MM it "60px == 63.5q" $- (Distance 60 PX) `shouldBe` Distance 63.5 Q+ Distance 60 PX `shouldBe` Distance 63.5 Q it "12px == 9pt" $- (Distance 12 PX) `shouldBe` Distance 9 PT+ Distance 12 PX `shouldBe` Distance 9 PT it "16px == 1pc" $- (Distance 16 PX) `shouldBe` Distance 1 PC+ Distance 16 PX `shouldBe` Distance 1 PC describe "centimeter conversions" $ do it "5.08cm == 2in" $- (Distance 5.08 CM) `shouldBe` Distance 2 IN+ Distance 5.08 CM `shouldBe` Distance 2 IN it "1cm == 10mm" $- (Distance 1 CM) `shouldBe` Distance 10 MM + Distance 1 CM `shouldBe` Distance 10 MM it "2cm == 80q" $- (Distance 2 CM) `shouldBe` Distance 80 Q+ Distance 2 CM `shouldBe` Distance 80 Q it "1.27cm == 36pt" $- (Distance 1.27 CM) `shouldBe` Distance 36 PT+ Distance 1.27 CM `shouldBe` Distance 36 PT it "1.27cm == 3pc" $- (Distance 1.27 CM) `shouldBe` Distance 3 PC+ Distance 1.27 CM `shouldBe` Distance 3 PC it "1.27cm == 48px" $- (Distance 1.27 CM) `shouldBe` Distance 48 PX+ Distance 1.27 CM `shouldBe` Distance 48 PX main :: IO () main = hspec spec
+ tests/Hasmin/Types/SelectorSpec.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}++module Hasmin.Types.SelectorSpec where++import Test.Hspec+import Hasmin.Parser.Internal+import Hasmin.TestUtils++import Control.Monad.Reader (runReader)+import Data.Text (Text)+import Hasmin.Types.Class+import Hasmin.Config++anplusbMinificationTests :: Spec+anplusbMinificationTests =+ describe "<an+b> minification tests" $+ mapM_ (matchSpec (minify <$> selector)) anplusbMinificationTestsInfo++selectorMinificationTests :: Spec+selectorMinificationTests =+ describe "Selectors minification test" $+ mapM_ (matchSpec (minify <$> selector)) selectorTestsInfo++selectorTestsInfo :: [(Text, Text)]+selectorTestsInfo =+ [("div > p", "div>p")+ ,("div p", "div p")+ ,("div + p", "div+p")+ ,("div ~ p", "div~p")+ ,("p::selection", "p::selection")+ ,("html:lang( 'de' )", "html:lang(de)")+ ]++anplusbMinificationTestsInfo :: [(Text, Text)]+anplusbMinificationTestsInfo =+ [(":nth-child(-1n)", ":nth-child(-n)")+ ,(":nth-child(-n)", ":nth-child(-n)")+ ,(":nth-child(odd)", ":nth-child(odd)")+ ,(":nth-child(+n)", ":nth-child(n)")+ ,(":nth-child(+1n)", ":nth-child(n)")+ ,(":nth-child(1n+0)", ":nth-child(n)")+ ,(":nth-child(1n-0)", ":nth-child(n)")+ ,(":nth-child(+3n)", ":nth-child(3n)")+ ,(":nth-child( even )", ":nth-child(2n)")+ ,(":nth-child( 2n - 2 )", ":nth-child(2n)")+ ,(":nth-child( 2n - 4 )", ":nth-child(2n)")+ ,(":nth-child( 2n + 1 )", ":nth-child(odd)")+ ,(":nth-child( 2n - 1 )", ":nth-child(odd)")+ ,(":nth-child( 2n - 3 )", ":nth-child(odd)")+ ,(":nth-child(0n)", ":nth-child(0)")+ ,(":nth-child(0n+0)", ":nth-child(0)")+ ,(":nth-child(0n-0)", ":nth-child(0)")+ ,(":nth-child(0n-1)", ":nth-child(-1)")+ ,(":nth-child(3n-3)", ":nth-child(3n-3)")+ ,(":nth-child(2n+4)", ":nth-child(2n+4)")+ ,(":nth-child(+4)", ":nth-child(4)")+ ]++attributeQuoteRemovalTest :: Spec+attributeQuoteRemovalTest =+ describe "attribute quote removal tests" $+ mapM_ (matchSpec (f <$> selector)) attributeQuoteRemovalTestInfo+ where f x = runReader (minifyWith x) defaultConfig++attributeQuoteRemovalTestInfo :: [(Text, Text)]+attributeQuoteRemovalTestInfo =+ [("[type=\"remove-double-quotes\"]", "[type=remove-double-quotes]")+ ,("[type='remove-single-quotes']", "[type=remove-single-quotes]")+ ,("[a^='\"']", "[a^='\"']")+ ]++spec :: Spec+spec = do anplusbMinificationTests+ attributeQuoteRemovalTest+ selectorMinificationTests+ attributeQuoteRemovalTest++main :: IO ()+main = hspec spec
tests/Hasmin/Types/StringSpec.hs view
@@ -11,7 +11,7 @@ quotesNormalizationTests :: Spec-quotesNormalizationTests = do+quotesNormalizationTests = describe "Quotes Normalization" $ do describe "normalizes <string>s quotes in general" $ mapM_ (matchSpecWithDesc f) quotesNormalizationTestsInfo@@ -34,8 +34,8 @@ "\"\\22\"", "\"\\22\"") ] -unquotingUrlsTestsInfo :: [(Text, Text)] -unquotingUrlsTestsInfo = +unquotingUrlsTestsInfo :: [(Text, Text)]+unquotingUrlsTestsInfo = [("url(\"validUrl\")", "url(validUrl)") ,("url('validUrl')", "url(validUrl)") ,("url('a b')", "url('a b')")
tests/Hasmin/Types/StylesheetSpec.hs view
@@ -5,14 +5,23 @@ import Test.Hspec import Hasmin.Parser.Internal import Hasmin.TestUtils+import Hasmin.Types.Class import Data.Text (Text) atRuleTests :: Spec-atRuleTests =+atRuleTests = do describe "at rules parsing and printing" $ mapM_ (matchSpec atRule) atRuleTestsInfo+ describe "@supports minification" $+ mapM_ (matchSpec (minify <$> atRule)) atSupportsTestInfo +atSupportsTestInfo :: [(Text, Text)]+atSupportsTestInfo =+ [("@supports not (not (a:a)){s{b:b}}",+ "@supports (a:a){s{b:b}}")+ ]+ atRuleTestsInfo :: [(Text, Text)] atRuleTestsInfo = [("@charset \"UTF-8\";",@@ -35,18 +44,25 @@ "@keyframes p{from{background-position:40px 0}to{background-position:0 0}}") ,("@font-face /**/ {a:a;}", "@font-face{a:a}")+ -- Uncomment once custom properties are supported -- ,("@supports (--foo: green) { body { color: green; } }",- -- "@supports (--foo:green){body{color:green}}")- -- ,("@supports ( transform-style: preserve ) or ( -moz-transform-style: preserve )",- -- "@supports (transform-style:preserve) or (-moz-transform-style:preserve)")- -- ,("@supports ( display : table-cell ) and ( not ( display : list-item ) )",- -- "@supports (display:table-cell) and (not (display:list-item))")+ -- "@supports (--foo:green){body{color:green}}")+ ,("@supports ( transform-style: preserve ) or ( -moz-transform-style: preserve ){s{a:a}}",+ "@supports (transform-style:preserve) or (-moz-transform-style:preserve){s{a:a}}")+ ,("@supports ( display : table-cell ) and ( not ( display : list-item ) ){s{a:a}}",+ "@supports (display:table-cell) and (not (display:list-item)){s{a:a}}")+ ,("@supports not ( (a:a) and (b:b) ) {s{a:a}}",+ "@supports not ((a:a) and (b:b)){s{a:a}}")+ ,("@supports ((yoyo: yaya) or (margin: 0) or (answer: 42)) { div { background-color:green; } }",+ "@supports ((yoyo:yaya) or (margin:0) or (answer:42)){div{background-color:green}}")+ ,("@supports (margin: 0) {@media not all { div { background-color:red; }}}",+ "@supports (margin:0){@media not all{div{background-color:red}}}") -- ,("@document url(http://www.w3.org/) , url-prefix(http://www.w3.org/Style/),\- -- \ domain(mozilla.org), regexp(\"https:.*\")"+ -- \ domain(mozilla.org), regexp(\"https:.*\")" -- ,("@document url(http://www.w3.org/),url-prefix(http://www.w3.org/Style/),\- -- \domain(mozilla.org),regexp(\"https:.*\")"+ -- \domain(mozilla.org),regexp(\"https:.*\")" -- ,("@page { margin: 1in }",- -- "@page{margin:1in}")+ -- "@page{margin:1in}") -- ,("@page :left { font-size: 20pt; }", -- "@page:left{font-size:20pt}") -- ,("@page toc, index { size:8.5in 11in; }",
+ tests/Hasmin/Types/TimingFunctionSpec.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}++module Hasmin.Types.TimingFunctionSpec where++import Test.Hspec++import Data.Text (Text)+import Hasmin.Parser.Value+import Hasmin.Types.Class+import Hasmin.TestUtils++timingFunctionTests :: Spec+timingFunctionTests =+ describe "<timing-function> minification tests" $+ mapM_ (matchSpec f) timingFunctionTestsInfo+ where f = minify <$> timingFunction++timingFunctionTestsInfo :: [(Text, Text)]+timingFunctionTestsInfo =+ [("cubic-bezier(0.25, 0.1, 0.25, 1)", "ease")+ ,("cubic-bezier(0.42, 0, 1, 1)","ease-in")+ ,("cubic-bezier(0.42, 0, 0.58, 1)","ease-in-out")+ ,("cubic-bezier(0, 0, 1, 1)","linear")+ ,("cubic-bezier(0, 0, 0.58, 1)","ease-out")+ ,("cubic-bezier(0.42, 0, 0.5, 1)","cubic-bezier(.42,0,.5,1)")+ ,("cubic-bezier(0, 0, 0.5, 1)","cubic-bezier(0,0,.5,1)")+ ,("cubic-bezier(0, 0.3, 0.5, 1)","cubic-bezier(0,.3,.5,1)")+ ,("cubic-bezier(0.6, 0, 0.5, 1)","cubic-bezier(.6,0,.5,1)")+ ,("steps(1, end)","step-end")+ ,("steps(2, end)","steps(2)")+ ,("steps(1)","step-end")+ ,("steps(1, start)","step-start")+ ,("steps(2)","steps(2)")+ ,("steps(2, start)","steps(2,start)")+ ]++spec :: Spec+spec = timingFunctionTests++main :: IO ()+main = hspec spec+
tests/Hasmin/Types/TransformFunctionSpec.hs view
@@ -7,6 +7,7 @@ import Hasmin.TestUtils import Control.Monad.Reader (runReader)+import Control.Applicative ((<|>)) import Data.Text (Text) import Hasmin.Types.Class import Hasmin.Types.TransformFunction@@ -16,13 +17,12 @@ transformTests :: Spec transformTests = describe "transform function conversion" $- mapM_ (matchSpec (f <$> textualvalue)) transformTestsInfo- where f x = runReader (minifyWith x) defaultConfig+ mapM_ (matchSpec (minify <$> textualvalue)) transformTestsInfo combinationTests :: Spec combinationTests = describe "transform function combination" $- mapM_ (matchSpecWithDesc (g <$> values "transform")) functionCombinationTestsInfo+ mapM_ (matchSpecWithDesc (g <$> (values "transform" <|> valuesFallback))) functionCombinationTestsInfo where g = mkValues . fmap TransformV . f . fmap (\(TransformV t) -> t) . valuesToList f x = runReader (combine x) defaultConfig