diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,9 +1,43 @@ # Changelog This project adheres to [PVP](https://pvp.haskell.org). +## 1.0.3 +### Fixed +* `overflow: visible hidden` minifying as `overflow:hidden`. Now it's left + untouched. It's possible that there where other instances of this, which + should now be fixed. +* quickcheck-instances upper bound not admitting version 0.3.19 + ([#5](https://github.com/contivero/hasmin/issues/5)) +* Incorrect description for two flags in the usage info (when running `--help`). + The descriptions for `-no-@kfsel-min` and `-no-transform-function-min` were + swapped. + +### Added +* Minification for properties with a pair of values whose second one defaults to + the first when missing. For example: `overflow: clip clip` is minified to + `overflow: clip`. This also properly interacts with property traits, i.e. + `overflow: visible visible` is properly minified to `overflow: unset` (since + `visible visible` is equivalent to `visible`, and `visible` is the initial + value and overflow doesn't inherit, thus `unset`). + Among the properties for which this is now done are: + + - `border-bottom-left-radius` + - `border-bottom-right-radius` + - `border-top-left-radius` + - `border-top-right-radius` + - `overscroll-behavior` + +* Property traits for `overscroll-behavior` and its longhands, + `overscroll-behavior-x` and `overscroll-behavior-y`. +* Minification for `object-position`. This property's value is now parsed as a + ``, allowing to apply all the minifications a `` allows. +* Minification for `text-emphasis-position`. This property now correctly + utilizes its traits, e.g. `text-emphasis-position: right over` minifies to + `text-emphasis-position: unset`. + ## 1.0.2.1 ### Fixed -* Parser not supporting CSS variables. #3 +* Parser choking on CSS variables. ([#3](https://github.com/contivero/hasmin/issues/3)) ## 1.0.2 ### Added @@ -96,7 +130,7 @@ This version introduced a non-exhaustive pattern bug. Don't use it. ### Added -Added a simple merging of adjacent media queries (`@media` rules), e.g.: +* Simple merging of adjacent media queries (`@media` rules), e.g.: ```css @media all and (min-width: 24rem) { a { font-size: 1.2rem; } @@ -112,6 +146,7 @@ b { padding-left: .25rem; padding-right: .25rem; } } ``` +This closes [#2](https://github.com/contivero/hasmin/issues/2). ## 0.3.2.4 * Relaxed doctest upper bound once more, see [stackage issue 2663](https://github.com/fpco/stackage/issues/2663#issuecomment-319880160). @@ -126,19 +161,24 @@ * Relaxed optparse-applicative upper bound. ## 0.3.2 -* Fixed some dimensions minifying incorrectly. -* Fixed some Eq instances. +### Fixed +* Some dimensions minifying incorrectly. +* Some Eq instances. * values data type modified to disallow invalid values. This makes the data type safer, also simplifying the Quickcheck Arbitrary instance. -* Improved test coverage. +### Improved +* Test coverage. ## 0.3.1.3 -* Added support for `@supports` rules, and a slight minification for them: it +### Added +* Support for `@supports` rules, and a slight minification for them: it removes adjacent negations, i.e.: @supports not (not ...) gets turn into @supports .... -* Fixed a small bug with `:lang()` where spaces before the right parenthesis +### Fixed +* A small bug with `:lang()` where spaces before the right parenthesis weren't being removed. -* Improved test coverage. +### Improved +* Test coverage. ## 0.3.0.1 Initial release diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -30,15 +30,14 @@ type Instructions = (Commands, Config) -data Commands = Commands { shouldBeautify :: Bool - , shouldCompress :: Bool - , file :: FilePath - } deriving (Show) +data Commands = Commands + { shouldCompress :: Bool + , file :: FilePath + } deriving (Show) command :: Parser Commands command = Commands - <$> switch (long "beautify" <> short 'b' <> help "Beautify output") - <*> switch (long "zopfli" <> short 'z' <> help "Compress result using zopfli") + <$> switch (long "zopfli" <> short 'z' <> help "Compress result using zopfli") <*> argument str (metavar "FILE") config :: Parser Config @@ -74,9 +73,9 @@ <> help "Disable minification of An+B microsyntax") <*> flag True False (long "no-@kfsel-min" <> short 'k' - <> help "Disable transform function minification") - <*> flag True False (long "no-transform-function-min" <> help "Disable @keyframe selectors minification") + <*> flag True False (long "no-transform-function-min" + <> help "Disable transform function minification") <*> switch (long "convert-escaped-characters" <> help "Convert escaped characters to their UTF-8 equivalent") <*> flag True False (long "no-null-percentage-conversion" @@ -113,6 +112,5 @@ Left e -> die e where process :: Text -> Commands -> IO () process ts comm - | shouldBeautify comm = error "Currently unsupported" | shouldCompress comm = B.writeFile "output.gz" . compressWith defaultCompressOptions GZIP . TE.encodeUtf8 $ ts | otherwise = TIO.putStr ts diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -20,14 +20,14 @@ ## Building & Installing ### Stack The easiest and prefered way is using -[stack](https://docs.haskellstack.org/en/stable/README/). Clone the repo, then: +[stack](https://docs.haskellstack.org/en/stable/README/). To directly install, use the following one-liner: ```sh -$ cd path/to/hasmin/repo -$ stack build +git clone git@github.com:contivero/hasmin.git && cd hasmin && stack install ``` -After that, you can install it with `stack install` (installs by default to `~/.local/bin`). -If you'd rather just try it out, use `stack exec hasmin` (keep in mind it has -a slight additional delay at the beginning when run this way). +Stack installs inside `~/.local/bin` by default. If you'd rather just try hasmin +out, replace `install` by `build`, and then use `stack exec hasmin` from inside +the hasmin directory (keep in mind it has a slight additional delay at the +beginning when run this way). ### Cabal Alternatively, you can use [cabal](https://www.haskell.org/cabal/): diff --git a/hasmin.cabal b/hasmin.cabal --- a/hasmin.cabal +++ b/hasmin.cabal @@ -1,8 +1,9 @@ name: hasmin -version: 1.0.2.1 +version: 1.0.3 license: BSD3 license-file: LICENSE -author: (c) 2017 Cristian Adrián Ontivero +copyright: © 2016-2018 Cristian Adrián Ontivero +author: Cristian Adrián Ontivero maintainer: Cristian Adrián Ontivero synopsis: CSS Minifier homepage: https://github.com/contivero/hasmin#readme @@ -127,7 +128,7 @@ , hspec-attoparsec >=0.1.0.0 && <0.2 , mtl >=2.2.1 && <2.3 , QuickCheck >=2.8 && <3.0 - , quickcheck-instances >=0.3.16 && <0.3.19 + , quickcheck-instances >=0.3.16 && <0.4 , text >=1.2 && <1.3 , hasmin diff --git a/src/Hasmin/Parser/Value.hs b/src/Hasmin/Parser/Value.hs --- a/src/Hasmin/Parser/Value.hs +++ b/src/Hasmin/Parser/Value.hs @@ -338,6 +338,7 @@ ,("-webkit-perspective-origin", singleValue positionvalue) ,("mask-position", positionList) ,("-webkit-mask-position", positionList) + ,("object-position", singleValue positionvalue) -- ,("transform-origin", transformOrigin) -- ,("-ms-transform-origin", transformOrigin) -- ,("-webkit-transform-origin", transformOrigin) diff --git a/src/Hasmin/Properties.hs b/src/Hasmin/Properties.hs --- a/src/Hasmin/Properties.hs +++ b/src/Hasmin/Properties.hs @@ -288,8 +288,11 @@ ,("outline-width", "medium", NonInherited, ["outline"], mempty) ,("overflow", "visible", NonInherited, mempty, mempty) ,("overflow-wrap", "normal", Inherited, mempty, mempty) -- also called word-wrap - ,("overflow-x", "visible", NonInherited, mempty, mempty) -- experimental - ,("overflow-y", "visible", NonInherited, mempty, mempty) -- experimental + ,("overflow-x", "visible", NonInherited, ["overflow"], mempty) -- experimental + ,("overflow-y", "visible", NonInherited, ["overflow"], mempty) -- experimental + ,("overscroll-behavior", "auto", NonInherited, mempty, ["overscroll-behavior-x", "overscroll-behavior-y"]) -- experimental, shorthand + ,("overscroll-behavior-x", "auto", NonInherited, ["overscroll-behavior"], mempty) -- experimental + ,("overscroll-behavior-y", "auto", NonInherited, ["overscroll-behavior"], mempty) -- experimental ,("padding", mempty {-shorthand-}, NonInherited, mempty, ["padding-top", "padding-right", "padding-bottom", "padding-left"]) -- ,("padding-block*", ("0", NonInherited)) -- experimental ,("padding-bottom", "0", NonInherited, ["padding"], mempty) @@ -307,7 +310,6 @@ ,("quotes", mempty {-UA dependent-}, Inherited, mempty, mempty) ,("resize", "none", NonInherited, mempty, mempty) ,("right", "auto", NonInherited, mempty, mempty) - ,("right", "auto", NonInherited, mempty, mempty) -- ,("ruby-*", -- experimental ,("scroll-behavior", "auto", NonInherited, mempty, mempty) -- ,("scroll-snap-coordinate", ("none", NonInherited)) -- experimental @@ -330,7 +332,7 @@ ,("text-decoration-style", "solid", NonInherited, ["text-decoration"], mempty) ,("text-emphasis", "none currentcolor", NonInherited, mempty, ["text-emphasis-color", "text-emphasis-style"]) -- shorthand ,("text-emphasis-color", "currentcolor", NonInherited, ["text-emphasis"], mempty) - ,("text-emphasis-position", mempty {-"over right"-}, NonInherited, mempty, mempty) + ,("text-emphasis-position", "over right", NonInherited, mempty, mempty) ,("text-emphasis-style", "none", NonInherited, ["text-emphasis"], mempty) ,("text-indent", "0", Inherited, mempty, mempty) ,("text-orientation", "mixed", Inherited, mempty, mempty) -- experimental diff --git a/src/Hasmin/Types/Declaration.hs b/src/Hasmin/Types/Declaration.hs --- a/src/Hasmin/Types/Declaration.hs +++ b/src/Hasmin/Types/Declaration.hs @@ -189,7 +189,7 @@ | otherwise = v f _ _ = v --- Converts the keywords "normal" and "bold" to 400 and 700, respectively. +-- | Converts the keywords "normal" and "bold" to 400 and 700, respectively. fontWeightOptimizer :: Declaration -> Reader Config Declaration fontWeightOptimizer = optimizeValues f where f :: Value -> Reader Config Value @@ -212,42 +212,35 @@ pure $ if shouldMinifyTransformOrigin conf then d { valueList = optimizeTransformOrigin' vals} else d - where optimizeTransformOrigin' :: Values -> Values - optimizeTransformOrigin' v = - mkValues $ case valuesToList v of - [x, y, z] -> if isZeroVal z - then transformOrigin2 x y - else transformOrigin3 x y z - [x, y] -> transformOrigin2 x y - [x] -> transformOrigin1 x - x -> x - --- isZeroVal is needed because we are using a generic parser for --- transform-origin, so 0 parses as a number instead of a distance. -isZeroVal :: Value -> Bool -isZeroVal (LengthV (Length 0 _)) = True -isZeroVal (LengthV NullLength) = True -isZeroVal (NumberV (Number 0)) = True -isZeroVal (PercentageV 0) = True -isZeroVal _ = False + where + optimizeTransformOrigin' :: Values -> Values + optimizeTransformOrigin' v = + mkValues $ case valuesToList v of + [x, y, z] -> if isZeroVal z + then transformOrigin2 x y + else transformOrigin3 x y z + [x, y] -> transformOrigin2 x y + [x] -> transformOrigin1 x + x -> x -transformOrigin1 :: Value -> [Value] -transformOrigin1 (Other "top") = [Other "top"] -transformOrigin1 (Other "bottom") = [Other "bottom"] -transformOrigin1 (Other "right") = [PercentageV (Percentage 100)] -transformOrigin1 (Other "left") = [LengthV NullLength] -transformOrigin1 (Other "center") = [PercentageV (Percentage 50)] -transformOrigin1 (PercentageV 0) = [LengthV NullLength] -transformOrigin1 x = [x] + transformOrigin1 :: Value -> [Value] + transformOrigin1 (Other "top") = [Other "top"] + transformOrigin1 (Other "bottom") = [Other "bottom"] + transformOrigin1 (Other "right") = [PercentageV (Percentage 100)] + transformOrigin1 (Other "left") = [LengthV NullLength] + transformOrigin1 (Other "center") = [PercentageV (Percentage 50)] + transformOrigin1 (PercentageV 0) = [LengthV NullLength] + transformOrigin1 x = [x] -transformOrigin2 :: Value -> Value -> [Value] -transformOrigin2 x y - | equalsCenter x = firstIsCenter - | equalsCenter y = secondIsCenter - | isYoffsetKeyword x = fmap convertValue [y,x] - | isXoffsetKeyword y = fmap convertValue [y,x] - | otherwise = fmap convertValue [x,y] - where firstIsCenter + transformOrigin2 :: Value -> Value -> [Value] + transformOrigin2 x y + | equalsCenter x = firstIsCenter + | equalsCenter y = secondIsCenter + | isYoffsetKeyword x = fmap convertValue [y,x] + | isXoffsetKeyword y = fmap convertValue [y,x] + | otherwise = fmap convertValue [x,y] + where + firstIsCenter | equalsCenter y = [per50] | isYoffsetKeyword y = [y] | y == per100 = [Other "bottom"] @@ -272,15 +265,26 @@ | otherwise = n convertValue i = i -transformOrigin3 :: Value -> Value -> Value -> [Value] -transformOrigin3 x y z - | x == Other "top" || x == Other "bottom" - || y == Other "left" || y == Other "right" = fmap replaceKeywords [y, x, z] - | otherwise = fmap replaceKeywords [x, y, z] - where replaceKeywords :: Value -> Value + transformOrigin3 :: Value -> Value -> Value -> [Value] + transformOrigin3 x y z + | x == Other "top" || x == Other "bottom" + || y == Other "left" || y == Other "right" = fmap replaceKeywords [y, x, z] + | otherwise = fmap replaceKeywords [x, y, z] + where + replaceKeywords :: Value -> Value replaceKeywords (Other t) = fromMaybe x (Map.lookup (getText t) transformOriginKeywords) replaceKeywords e = e +-- isZeroVal is needed because we are using a generic parser for +-- transform-origin, so 0 parses as a number instead of a distance. +isZeroVal :: Value -> Bool +isZeroVal (LengthV (Length 0 _)) = True +isZeroVal (LengthV NullLength) = True +isZeroVal (NumberV (Number 0)) = True +isZeroVal (PercentageV 0) = True +isZeroVal _ = False + + -- transform-origin keyword meanings. transformOriginKeywords :: Map Text Value transformOriginKeywords = Map.fromList @@ -297,12 +301,12 @@ minifyDec d@(Declaration p vs _ _) mv inhs = case mv of -- Use the found initial values to try to reduce the declaration - Just vals -> + Just initialVals -> case Map.lookup (T.toCaseFold p) declarationExceptions of -- Use a specific function to reduce the property if -- needed, otherwise use the general property reducer - Just f -> f d vals inhs - Nothing -> reduceDeclaration d vals inhs + Just f -> f d initialVals inhs + Nothing -> reduceDeclaration d initialVals inhs -- Property with no defined initial values. Try to reduce css-wide keywords Nothing -> if inhs == NonInherited && vs == initial || inhs == Inherited && vs == inherit @@ -322,66 +326,89 @@ -- normal declaration minification scheme and need special treatment. declarationExceptions :: Map Text (Declaration -> Values -> Inheritance -> Declaration) declarationExceptions = Map.fromList $ map (first T.toCaseFold) - [("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) - ] + [("background-size", backgroundSizeReduce) + ,("-webkit-background-size", backgroundSizeReduce) + ,("border-bottom-left-radius", reduceDefaultingToFirst) + ,("border-bottom-right-radius", reduceDefaultingToFirst) + ,("border-top-left-radius", reduceDefaultingToFirst) + ,("border-top-right-radius", reduceDefaultingToFirst) + ,("font-synthesis", reduceTwoKeywordInitial) + ,("overflow", reduceDefaultingToFirst) + ,("overscroll-behavior", reduceDefaultingToFirst) + ,("text-emphasis-position", reduceTwoKeywordInitial) + -- 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) + ] + where + -- For properties that take two keywords as initial value, such as: + -- * font-synthesis: weight style + -- * text-emphasis-position: right over + reduceTwoKeywordInitial :: Declaration -> Values -> Inheritance -> Declaration + reduceTwoKeywordInitial d@(Declaration _ vs _ _) initVals inhs = + case valuesToList initVals \\ valuesToList vs of + [] -> d {valueList = shortestEquiv initial initVals inhs} + _ -> d {valueList = shortestEquiv vs initVals inhs} + -- For properties whose second value, if omitted, is copied from the first + -- (for instance 'overflow'). + reduceDefaultingToFirst :: Declaration -> Values -> Inheritance -> Declaration + reduceDefaultingToFirst d@(Declaration _ vs _ _) initVals inhs = + case valuesToList vs of + [v1,v2] -> if v1 == v2 + then reduceDeclaration (d { valueList = mkValues [v1] }) initVals inhs + else d + _ -> reduceDeclaration d initVals inhs + + backgroundSizeReduce :: Declaration -> Values -> Inheritance -> Declaration + backgroundSizeReduce d@(Declaration _ vs _ _) initVals inhs = + case valuesToList vs of + [v1,v2] -> if v2 == mkOther "auto" + then d { valueList = mkValues [v1] } + else d + _ -> d { valueList = shortestEquiv vs initVals inhs } + combineTransformFunctions :: Declaration -> Reader Config Declaration combineTransformFunctions d@(Declaration _ vs _ _) = do combinedFuncs <- combine (toList tfValues) let newVals = fmap TransformV combinedFuncs ++ toList otherValues pure $ d { valueList = mkValues newVals} - where decValues = valuesToList vs - (tfValues, otherValues) = splitValues decValues - splitValues = splitValues' (mempty, mempty) - where splitValues' :: (Seq TransformFunction, Seq Value) -> [Value] - -> (Seq TransformFunction, Seq Value) - splitValues' (ts, os) (TransformV x:xs) = splitValues' (ts |> x, os) xs - splitValues' (ts, os) (x:xs) = splitValues' (ts, os |> x) xs - splitValues' (ts, os) [] = (ts, os) - -backgroundSizeReduce :: Declaration -> Values -> Inheritance -> Declaration -backgroundSizeReduce d@(Declaration _ vs _ _) initVals inhs = - case valuesToList vs of - [v1,v2] -> if v2 == mkOther "auto" - then d { valueList = mkValues [v1] } - else d - _ -> d { valueList = shortestEquiv vs initVals inhs } - -fontSynthesisReduce :: Declaration -> Values -> Inheritance -> Declaration -fontSynthesisReduce d@(Declaration _ vs _ _) initVals inhs = - case valuesToList initVals \\ valuesToList vs of - [] -> d {valueList = initial} -- "initial" is shorter than "weight style" - _ -> d {valueList = shortestEquiv vs initVals inhs} + where + decValues = valuesToList vs + (tfValues, otherValues) = splitValues decValues + splitValues = splitValues' (mempty, mempty) + where + splitValues' :: (Seq TransformFunction, Seq Value) -> [Value] + -> (Seq TransformFunction, Seq Value) + splitValues' (ts, os) (TransformV x:xs) = splitValues' (ts |> x, os) xs + splitValues' (ts, os) (x:xs) = splitValues' (ts, os |> x) xs + splitValues' (ts, os) [] = (ts, os) -- Function to reduce the great mayority of properties. Requires that: -- 1. The order between values doesn't matter, which is true for most -- properties because they take only one value. --- 2. Any default value may be removed, which tends to hold for shorthands --- because the default value is used when it isn't present. An example of a --- property that qualifies is border-bottom, and one that doesn't is --- font-synthesis (because it isn't a shorthand). +-- 2. Any default value may be removed until a single one remains, which tends +-- to hold for shorthands because the default value is used when it isn't +-- present. An example of a property that qualifies is border-bottom, and +-- one that doesn't is font-synthesis (because it isn't a shorthand). reduceDeclaration :: Declaration -> Values -> Inheritance -> Declaration reduceDeclaration d@(Declaration _ vs _ _) initVals inhs = case analyzeValueDifference vs initVals of Just v -> d {valueList = shortestEquiv v shortestInitialValue inhs} Nothing -> d {valueList = minVal inhs shortestInitialValue} - where comparator x y = compare (textualLength x) (textualLength y) - shortestInitialValue = mkValues [minimumBy comparator (valuesToList initVals)] + where + charLen x y = compare (textualLength x) (textualLength y) + shortestInitialValue = mkValues [minimumBy charLen (valuesToList initVals)] -- If the value was a css-wide keyword, return the shortest between css-wide -- keywords and the shortest initial value for the property. -- Otherwise, no property specific reduction could be done, so just return the -- values. shortestEquiv :: Values -> Values -> Inheritance -> Values -shortestEquiv vs siv inhs - | inhs == Inherited && vs == inherit = unset - | inhs == NonInherited && vs == unset || vs == initial = minVal inhs siv +shortestEquiv vs siv i + | i == Inherited && vs == inherit = unset + | i == NonInherited && vs == unset || vs == initial = minVal i siv | otherwise = vs -- Returns the minimum value (in character length) between the shortest initial @@ -392,10 +419,11 @@ | otherwise = vs where globalKeyword = mkValues [if inhs == NonInherited then Unset else Initial] --- Substract declaration values to the property's initial value list. --- If nothing remains (i.e. every value declared was an initial one and may be --- left implicit), then just replace it with whatever initial value is the --- shortest, otherwise whatever remains is the shortest equivalent declaration. +-- Substract the property's initial value list from the declaration values. +-- If nothing remains (i.e. every value declared was an initial one, thus all of +-- them could be left implicit), then just replace it with whatever initial +-- value is the shortest, otherwise whatever remains is the shortest equivalent +-- declaration. analyzeValueDifference :: Values -> Values -> Maybe Values analyzeValueDifference vs initVals = case valuesDifference of diff --git a/src/Hasmin/Types/Gradient.hs b/src/Hasmin/Types/Gradient.hs --- a/src/Hasmin/Types/Gradient.hs +++ b/src/Hasmin/Types/Gradient.hs @@ -1,316 +1,316 @@ -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ --- | --- Module : Hasmin.Types.Gradient --- Copyright : (c) 2017 Cristian Adrián Ontivero --- License : BSD3 --- Stability : experimental --- Portability : non-portable --- ------------------------------------------------------------------------------ -module Hasmin.Types.Gradient - ( Gradient(..) - , Side(..) - , ColorStop(..) - , Size(..) - , Shape(..) - ) where - -import Control.Monad.Reader (Reader, ask) -import Data.Monoid ((<>)) -import Data.Text.Lazy.Builder (singleton) -import Data.Maybe (catMaybes, fromJust, isNothing, isJust) -import Data.Either (isLeft) - -import Hasmin.Class -import Hasmin.Config -import Hasmin.Types.Color -import Hasmin.Types.Dimension -import Hasmin.Types.Numeric -import Hasmin.Types.PercentageLength -import Hasmin.Types.Position -import Hasmin.Utils - --- | CSS data type -data Side = LeftSide | RightSide | TopSide | BottomSide - deriving (Show, Eq) -instance ToText Side where - toBuilder LeftSide = "left" - toBuilder RightSide = "right" - toBuilder TopSide = "top" - toBuilder BottomSide = "bottom" - --- Possible pair of values, as expected by linear-gradient() -type SideOrCorner = (Side, Maybe Side) - --- | CSS data type -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 Minifiable ColorStop where - minify (ColorStop c mlp) = do - newC <- minify c - newMlp <- (mapM . mapM) minify mlp - pure $ ColorStop newC newMlp - --- minifies color hints in a \ list -minifyColorHints :: [ColorStop] -> [ColorStop] -minifyColorHints [c1,c2] = [newC1, newC2] - where ch1 = colorHint c1 - ch2 = colorHint c2 - newC1 - | isJust ch1 && isZero (fromJust ch1) = c1 {colorHint = Nothing} - | otherwise = c1 - newC2 - | ch2 == Just (Left (Percentage 100)) = c2 {colorHint = Nothing} - | ch2 `notGreaterThan` ch1 = c2 {colorHint = Just $ Right NullLength} - | otherwise = c2 -minifyColorHints (c@(ColorStop a x):xs) = case x of - Nothing -> c : analyzeList (Left $ Percentage 0) 1 (c:xs) xs - Just y -> if isZero y - then ColorStop a Nothing : analyzeList y 1 (c:xs) xs - else c: analyzeList y 1 (c:xs) xs -minifyColorHints xs = error ("invalid list: " ++ show xs) - --- Returns True if the first value is equal or less than the second one, and False --- otherwise, or if a comparison isn't possible. -notGreaterThan :: Maybe PercentageLength -> Maybe PercentageLength -> Bool -y `notGreaterThan` x - | isNothing x || isZero (fromJust x) = notPositive y - | otherwise = case fromJust x of - Left p -> maybe False (either (<= p) (const False)) y - Right d -> maybe False (either (const False) (notGreaterThanLength d)) y - where notPositive = maybe False (either (<= 0) notPositiveLength) - - notPositiveLength (Length d _) = d <= 0 - notPositiveLength NullLength = True - - notGreaterThanLength NullLength NullLength = True - notGreaterThanLength NullLength (Length r _) = r <= 0 - notGreaterThanLength (Length r _) NullLength = 0 <= r - notGreaterThanLength (Length r1 u1) (Length r2 u2) - | u1 == u2 = r2 <= r1 - | isRelative u1 || isRelative u2 = False - | otherwise = toInches r2 u2 <= toInches r1 u1 - --- Gathers at least three color stops to interpolate between the first and --- last, and see if the middle one can be removed. As long as the color hints --- are Nothing, keeps accumulating until it finds a Just it can use to interpolate. -analyzeList :: PercentageLength -> Int -> [ColorStop] - -> [ColorStop] -> [ColorStop] -analyzeList start n list (ColorStop _ mpl:xs) - | n < 2 = analyzeList start (n+1) list xs - | otherwise = - case mpl of - Just y -> let (newList, remainingList, startVal) = minifySegment start y n list - in newList ++ analyzeList startVal 2 remainingList xs - Nothing -> analyzeList start (n+1) list xs -analyzeList start n list [] = - case mpl of - Just (Left (Percentage 100)) -> [ColorStop x Nothing] - Nothing -> let end = Left $ Percentage 100 - (newList, _, _) = minifySegment start end (n-1) list - in newList ++ [(last list) {colorHint = Nothing}] - _ -> [c] - where c@(ColorStop x mpl) = last list - --- Given two values and a count of values, uses them to create a list of --- interpolated values, and based on the list decides if it should remove a --- color hint or not. -minifySegment :: PercentageLength -> PercentageLength -> Int -> [ColorStop] - -> ([ColorStop], [ColorStop], PercentageLength) -minifySegment start end n list - | all isPercentage segment = handlePercentages (fromLeft' start) (fromLeft' end) n remainingList - -- add here support for dimension interpolation - | otherwise = (take (n-1) remainingList, remainingList, fromJust $ colorHint (head remainingList)) - where segment = take (n+1) list - (_, remainingList) = splitAt (n-1) list - isPercentage x = maybe True isLeft (colorHint x) - --- Handles the minification of color hint values between percentages -handlePercentages :: Percentage -> Percentage -> Int - -> [ColorStop] -> ([ColorStop], [ColorStop], PercentageLength) -handlePercentages start end n remainingList = - let newList = zipWith simplifyValue remainingList interpolation - 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]] - simplifyValue (ColorStop x mpl) y = ColorStop x $ mpl >>= \v -> - if fromLeft' v == y - then Nothing - else if fromLeft' v <= start - then Just $ Right NullLength - else Just v - --- | CSS > --- data type. -data Gradient = OldLinearGradient (Maybe (Either Angle SideOrCorner)) [ColorStop] - -- OldLinearGradient is for the old syntax. It should eventually be deleted. - | LinearGradient (Maybe (Either Angle SideOrCorner)) [ColorStop] - | RadialGradient (Maybe Shape) (Maybe Size) (Maybe Position) [ColorStop] - -- TODO: replace with Maybe (These Shape Size) - deriving (Show) - -- ,| RepeatingLinearGradient - -- ,| RepeatingRadialGradient - - -{- - radial-gradient() = radial-gradient( - [ || ]? [ at ]? , - - ) - - radial-gradient( - [ [ circle || ] [ at ]? , | - [ ellipse || [ | ]{2} ] [ at ]? , | - [ [ circle | ellipse ] || ] [ at ]? , | - at , - ]? - [ , ]+ - ) - where = closest-corner | closest-side | farthest-corner | farthest-side - and = [ | ]? --} - --- | CSS > data --- type, used by @radial-gradient()@. -data Size = ClosestCorner - | ClosestSide - | FarthestCorner - | FarthestSide - | SL Length - | PL PercentageLength PercentageLength - deriving (Eq, Show) - -instance ToText Size where - toBuilder ClosestCorner = "closest-corner" - toBuilder ClosestSide = "closest-side" - toBuilder FarthestCorner = "farthest-corner" - toBuilder FarthestSide = "farthest-side" - toBuilder (SL d) = toBuilder d - toBuilder (PL pl1 pl2) = toBuilder pl1 <> singleton ' ' <> toBuilder pl2 - --- TODO rename to EndingShape --- | CSS > data type, used by @radial-gradient()@. -data Shape = Circle | Ellipse - deriving (Eq, Show) - -instance ToText Shape where - toBuilder Circle = "circle" - toBuilder Ellipse = "ellipse" - --- If the argument is to top, to right, to bottom, or to left, the angle of --- the gradient line is 0deg, 90deg, 180deg, or 270deg, respectively. -instance Minifiable Gradient where - minify g@(OldLinearGradient x cs) = do - conf <- ask - case gradientSettings conf of - GradientMinOn -> do css <- mapM minify cs - pure $ OldLinearGradient x (minifyColorHints css) - GradientMinOff -> pure g - minify g@(LinearGradient x cs) = do - conf <- ask - case gradientSettings conf of - GradientMinOn -> do css <- mapM minify cs - newX <- minifyAngleOrSide x - pure $ LinearGradient newX (minifyColorHints css) - GradientMinOff -> pure g - minify g@(RadialGradient sh sz p cs) = do - conf <- ask - case gradientSettings conf of - GradientMinOn -> do css <- mapM minify cs - let np = minifyRadialPosition True {-shouldMinifyPosition conf-} p - pure $ minShapeAndSize sh sz np (minifyColorHints css) - GradientMinOff -> pure g - --- If a single length was used, the default shape is circle, otherwise ellipse. --- circle farthest-corner == circle --- ellipse farthest-corner == ellipse == farthest-corner -minShapeAndSize :: Maybe Shape -> Maybe Size -> Maybe Position -> [ColorStop] -> Gradient -minShapeAndSize (Just Circle) sz@(Just (SL _)) = RadialGradient Nothing sz -minShapeAndSize (Just Circle) (Just FarthestCorner) = RadialGradient (Just Circle) Nothing -minShapeAndSize (Just Ellipse) sz@(Just (PL _ _)) = RadialGradient Nothing sz -minShapeAndSize (Just Ellipse) (Just FarthestCorner) = RadialGradient Nothing Nothing -minShapeAndSize (Just Ellipse) sz@(Just _) = RadialGradient Nothing sz -minShapeAndSize (Just Ellipse) Nothing = RadialGradient Nothing Nothing -minShapeAndSize Nothing (Just FarthestCorner) = RadialGradient Nothing Nothing -minShapeAndSize x sz = RadialGradient x sz - --- Minifies the position in the radial gradient based on the position --- minification settings. If positions should be minified, and if it is --- equivalent to 'center', it is removed. If positions should not be minified, --- it still removes it if it is equivalent to 'center', but leaves it untouched --- otherwise. -minifyRadialPosition :: Bool -> Maybe Position -> Maybe Position -minifyRadialPosition _ Nothing = Nothing -minifyRadialPosition cond (Just p) - | minifiedPos == centerPos = Nothing - | cond = Just minifiedPos - | otherwise = Just p - where centerPos = Position Nothing p50 Nothing Nothing - minifiedPos = minifyPosition p - -minifyAngleOrSide :: Maybe (Either Angle SideOrCorner) - -> Reader Config (Maybe (Either Angle SideOrCorner)) -minifyAngleOrSide Nothing = pure Nothing -minifyAngleOrSide (Just (Left a)) - | a == defaultGradientAngle = pure Nothing - | otherwise = (Just . Left) <$> minify a - where defaultGradientAngle = Angle 180 Deg -minifyAngleOrSide (Just (Right b)) - | b == defaultGradientSideOrCorner = pure Nothing - | otherwise = pure $ Just (minifySide b) - where defaultGradientSideOrCorner = (BottomSide, Nothing) - minifySide (TopSide, Nothing) = Left NullAngle - minifySide (RightSide, Nothing) = Left (Angle 90 Deg) - minifySide (BottomSide, Nothing) = Left (Angle 180 Deg) - minifySide (LeftSide, Nothing) = Left (Angle 270 Deg) - minifySide z = Right z - -instance ToText Gradient where - 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 - <> 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 - <> maybe mempty (\x -> singleton ' ' <> toBuilder x) ms - <> singleton ',' - 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 - | null l = mempty - | otherwise = mconcatIntersperse id (singleton ' ') l <> singleton ',' - -instance Eq Gradient where - LinearGradient x1 csl1 == LinearGradient x2 csl2 = - handleMaybe x1 x2 && csl1 == csl2 - where handleMaybe Nothing Nothing = True - handleMaybe (Just x) (Just y) = handleEither x y - handleMaybe _ _ = False - handleEither (Left a1) (Left a2) = a1 == a2 - handleEither (Left a) (Right s) = angleSideEq a s - handleEither (Right s) (Left a) = angleSideEq a s - handleEither s1 s2 = s1 == s2 - LinearGradient{} == _ = False - _ == LinearGradient{} = False - _ == _ = False -- TODO implement other comparisons - -angleSideEq :: Angle -> SideOrCorner -> Bool -angleSideEq (Angle 90 Deg) (RightSide, Nothing) = True -angleSideEq (Angle 180 Deg) (BottomSide, Nothing) = True -angleSideEq (Angle 270 Deg) (LeftSide, Nothing) = True -angleSideEq a (TopSide, Nothing) - | isZeroAngle a = True - | otherwise = False -angleSideEq _ _ = False +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Hasmin.Types.Gradient +-- Copyright : (c) 2017 Cristian Adrián Ontivero +-- License : BSD3 +-- Stability : experimental +-- Portability : non-portable +-- +----------------------------------------------------------------------------- +module Hasmin.Types.Gradient + ( Gradient(..) + , Side(..) + , ColorStop(..) + , Size(..) + , Shape(..) + ) where + +import Control.Monad.Reader (Reader, ask) +import Data.Monoid ((<>)) +import Data.Text.Lazy.Builder (singleton) +import Data.Maybe (catMaybes, fromJust, isNothing, isJust) +import Data.Either (isLeft) + +import Hasmin.Class +import Hasmin.Config +import Hasmin.Types.Color +import Hasmin.Types.Dimension +import Hasmin.Types.Numeric +import Hasmin.Types.PercentageLength +import Hasmin.Types.Position +import Hasmin.Utils + +-- | CSS data type +data Side = LeftSide | RightSide | TopSide | BottomSide + deriving (Show, Eq) +instance ToText Side where + toBuilder LeftSide = "left" + toBuilder RightSide = "right" + toBuilder TopSide = "top" + toBuilder BottomSide = "bottom" + +-- Possible pair of values, as expected by linear-gradient() +type SideOrCorner = (Side, Maybe Side) + +-- | CSS data type +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 Minifiable ColorStop where + minify (ColorStop c mlp) = do + newC <- minify c + newMlp <- (mapM . mapM) minify mlp + pure $ ColorStop newC newMlp + +-- minifies color hints in a \ list +minifyColorHints :: [ColorStop] -> [ColorStop] +minifyColorHints [c1,c2] = [newC1, newC2] + where ch1 = colorHint c1 + ch2 = colorHint c2 + newC1 + | isJust ch1 && isZero (fromJust ch1) = c1 {colorHint = Nothing} + | otherwise = c1 + newC2 + | ch2 == Just (Left (Percentage 100)) = c2 {colorHint = Nothing} + | ch2 `notGreaterThan` ch1 = c2 {colorHint = Just $ Right NullLength} + | otherwise = c2 +minifyColorHints (c@(ColorStop a x):xs) = case x of + Nothing -> c : analyzeList (Left $ Percentage 0) 1 (c:xs) xs + Just y -> if isZero y + then ColorStop a Nothing : analyzeList y 1 (c:xs) xs + else c: analyzeList y 1 (c:xs) xs +minifyColorHints xs = error ("invalid list: " ++ show xs) + +-- Returns True if the first value is equal or less than the second one, and False +-- otherwise, or if a comparison isn't possible. +notGreaterThan :: Maybe PercentageLength -> Maybe PercentageLength -> Bool +y `notGreaterThan` x + | isNothing x || isZero (fromJust x) = notPositive y + | otherwise = case fromJust x of + Left p -> maybe False (either (<= p) (const False)) y + Right d -> maybe False (either (const False) (notGreaterThanLength d)) y + where notPositive = maybe False (either (<= 0) notPositiveLength) + + notPositiveLength (Length d _) = d <= 0 + notPositiveLength NullLength = True + + notGreaterThanLength NullLength NullLength = True + notGreaterThanLength NullLength (Length r _) = r <= 0 + notGreaterThanLength (Length r _) NullLength = 0 <= r + notGreaterThanLength (Length r1 u1) (Length r2 u2) + | u1 == u2 = r2 <= r1 + | isRelative u1 || isRelative u2 = False + | otherwise = toInches r2 u2 <= toInches r1 u1 + +-- Gathers at least three color stops to interpolate between the first and +-- last, and see if the middle one can be removed. As long as the color hints +-- are Nothing, keeps accumulating until it finds a Just it can use to interpolate. +analyzeList :: PercentageLength -> Int -> [ColorStop] + -> [ColorStop] -> [ColorStop] +analyzeList start n list (ColorStop _ mpl:xs) + | n < 2 = analyzeList start (n+1) list xs + | otherwise = + case mpl of + Just y -> let (newList, remainingList, startVal) = minifySegment start y n list + in newList ++ analyzeList startVal 2 remainingList xs + Nothing -> analyzeList start (n+1) list xs +analyzeList start n list [] = + case mpl of + Just (Left (Percentage 100)) -> [ColorStop x Nothing] + Nothing -> let end = Left $ Percentage 100 + (newList, _, _) = minifySegment start end (n-1) list + in newList ++ [(last list) {colorHint = Nothing}] + _ -> [c] + where c@(ColorStop x mpl) = last list + +-- Given two values and a count of values, uses them to create a list of +-- interpolated values, and based on the list decides if it should remove a +-- color hint or not. +minifySegment :: PercentageLength -> PercentageLength -> Int -> [ColorStop] + -> ([ColorStop], [ColorStop], PercentageLength) +minifySegment start end n list + | all isPercentage segment = handlePercentages (fromLeft' start) (fromLeft' end) n remainingList + -- add here support for dimension interpolation + | otherwise = (take (n-1) remainingList, remainingList, fromJust $ colorHint (head remainingList)) + where segment = take (n+1) list + (_, remainingList) = splitAt (n-1) list + isPercentage x = maybe True isLeft (colorHint x) + +-- Handles the minification of color hint values between percentages +handlePercentages :: Percentage -> Percentage -> Int + -> [ColorStop] -> ([ColorStop], [ColorStop], PercentageLength) +handlePercentages start end n remainingList = + let newList = zipWith simplifyValue remainingList interpolation + 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]] + simplifyValue (ColorStop x mpl) y = ColorStop x $ mpl >>= \v -> + if fromLeft' v == y + then Nothing + else if fromLeft' v <= start + then Just $ Right NullLength + else Just v + +-- | CSS > +-- data type. +data Gradient = OldLinearGradient (Maybe (Either Angle SideOrCorner)) [ColorStop] + -- OldLinearGradient is for the old syntax. It should eventually be deleted. + | LinearGradient (Maybe (Either Angle SideOrCorner)) [ColorStop] + | RadialGradient (Maybe Shape) (Maybe Size) (Maybe Position) [ColorStop] + -- TODO: replace with Maybe (These Shape Size) + deriving (Show) + -- ,| RepeatingLinearGradient + -- ,| RepeatingRadialGradient + + +{- + radial-gradient() = radial-gradient( + [ || ]? [ at ]? , + + ) + + radial-gradient( + [ [ circle || ] [ at ]? , | + [ ellipse || [ | ]{2} ] [ at ]? , | + [ [ circle | ellipse ] || ] [ at ]? , | + at , + ]? + [ , ]+ + ) + where = closest-corner | closest-side | farthest-corner | farthest-side + and = [ | ]? +-} + +-- | CSS > data +-- type, used by @radial-gradient()@. +data Size = ClosestCorner + | ClosestSide + | FarthestCorner + | FarthestSide + | SL Length + | PL PercentageLength PercentageLength + deriving (Eq, Show) + +instance ToText Size where + toBuilder ClosestCorner = "closest-corner" + toBuilder ClosestSide = "closest-side" + toBuilder FarthestCorner = "farthest-corner" + toBuilder FarthestSide = "farthest-side" + toBuilder (SL d) = toBuilder d + toBuilder (PL pl1 pl2) = toBuilder pl1 <> singleton ' ' <> toBuilder pl2 + +-- TODO rename to EndingShape +-- | CSS > data type, used by @radial-gradient()@. +data Shape = Circle | Ellipse + deriving (Eq, Show) + +instance ToText Shape where + toBuilder Circle = "circle" + toBuilder Ellipse = "ellipse" + +-- If the argument is to top, to right, to bottom, or to left, the angle of +-- the gradient line is 0deg, 90deg, 180deg, or 270deg, respectively. +instance Minifiable Gradient where + minify g@(OldLinearGradient x cs) = do + conf <- ask + case gradientSettings conf of + GradientMinOn -> do css <- mapM minify cs + pure $ OldLinearGradient x (minifyColorHints css) + GradientMinOff -> pure g + minify g@(LinearGradient x cs) = do + conf <- ask + case gradientSettings conf of + GradientMinOn -> do css <- mapM minify cs + newX <- minifyAngleOrSide x + pure $ LinearGradient newX (minifyColorHints css) + GradientMinOff -> pure g + minify g@(RadialGradient sh sz p cs) = do + conf <- ask + case gradientSettings conf of + GradientMinOn -> do css <- mapM minify cs + let np = minifyRadialPosition True {-shouldMinifyPosition conf-} p + pure $ minShapeAndSize sh sz np (minifyColorHints css) + GradientMinOff -> pure g + +-- If a single length was used, the default shape is circle, otherwise ellipse. +-- circle farthest-corner == circle +-- ellipse farthest-corner == ellipse == farthest-corner +minShapeAndSize :: Maybe Shape -> Maybe Size -> Maybe Position -> [ColorStop] -> Gradient +minShapeAndSize (Just Circle) sz@(Just (SL _)) = RadialGradient Nothing sz +minShapeAndSize (Just Circle) (Just FarthestCorner) = RadialGradient (Just Circle) Nothing +minShapeAndSize (Just Ellipse) sz@(Just (PL _ _)) = RadialGradient Nothing sz +minShapeAndSize (Just Ellipse) (Just FarthestCorner) = RadialGradient Nothing Nothing +minShapeAndSize (Just Ellipse) sz@(Just _) = RadialGradient Nothing sz +minShapeAndSize (Just Ellipse) Nothing = RadialGradient Nothing Nothing +minShapeAndSize Nothing (Just FarthestCorner) = RadialGradient Nothing Nothing +minShapeAndSize x sz = RadialGradient x sz + +-- Minifies the position in the radial gradient based on the position +-- minification settings. If positions should be minified, and if it is +-- equivalent to 'center', it is removed. If positions should not be minified, +-- it still removes it if it is equivalent to 'center', but leaves it untouched +-- otherwise. +minifyRadialPosition :: Bool -> Maybe Position -> Maybe Position +minifyRadialPosition _ Nothing = Nothing +minifyRadialPosition cond (Just p) + | minifiedPos == centerPos = Nothing + | cond = Just minifiedPos + | otherwise = Just p + where centerPos = Position Nothing p50 Nothing Nothing + minifiedPos = minifyPosition p + +minifyAngleOrSide :: Maybe (Either Angle SideOrCorner) + -> Reader Config (Maybe (Either Angle SideOrCorner)) +minifyAngleOrSide Nothing = pure Nothing +minifyAngleOrSide (Just (Left a)) + | a == defaultGradientAngle = pure Nothing + | otherwise = (Just . Left) <$> minify a + where defaultGradientAngle = Angle 180 Deg +minifyAngleOrSide (Just (Right b)) + | b == defaultGradientSideOrCorner = pure Nothing + | otherwise = pure $ Just (minifySide b) + where defaultGradientSideOrCorner = (BottomSide, Nothing) + minifySide (TopSide, Nothing) = Left NullAngle + minifySide (RightSide, Nothing) = Left (Angle 90 Deg) + minifySide (BottomSide, Nothing) = Left (Angle 180 Deg) + minifySide (LeftSide, Nothing) = Left (Angle 270 Deg) + minifySide z = Right z + +instance ToText Gradient where + 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 + <> 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 + <> maybe mempty (\x -> singleton ' ' <> toBuilder x) ms + <> singleton ',' + 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 + | null l = mempty + | otherwise = mconcatIntersperse id (singleton ' ') l <> singleton ',' + +instance Eq Gradient where + LinearGradient x1 csl1 == LinearGradient x2 csl2 = + handleMaybe x1 x2 && csl1 == csl2 + where handleMaybe Nothing Nothing = True + handleMaybe (Just x) (Just y) = handleEither x y + handleMaybe _ _ = False + handleEither (Left a1) (Left a2) = a1 == a2 + handleEither (Left a) (Right s) = angleSideEq a s + handleEither (Right s) (Left a) = angleSideEq a s + handleEither s1 s2 = s1 == s2 + LinearGradient{} == _ = False + _ == LinearGradient{} = False + _ == _ = False -- TODO implement other comparisons + +angleSideEq :: Angle -> SideOrCorner -> Bool +angleSideEq (Angle 90 Deg) (RightSide, Nothing) = True +angleSideEq (Angle 180 Deg) (BottomSide, Nothing) = True +angleSideEq (Angle 270 Deg) (LeftSide, Nothing) = True +angleSideEq a (TopSide, Nothing) + | isZeroAngle a = True + | otherwise = False +angleSideEq _ _ = False diff --git a/src/Hasmin/Types/TransformFunction.hs b/src/Hasmin/Types/TransformFunction.hs --- a/src/Hasmin/Types/TransformFunction.hs +++ b/src/Hasmin/Types/TransformFunction.hs @@ -1,550 +1,550 @@ -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ --- | --- Module : Hasmin.Types.TransformFunction --- Copyright : (c) 2017 Cristian Adrián Ontivero --- License : BSD3 --- Stability : experimental --- Portability : non-portable --- ------------------------------------------------------------------------------ -module Hasmin.Types.TransformFunction - ( TransformFunction(..) - , mkMat - , mkMat3d - , combine - , simplify - ) where - -import Control.Monad.Reader (mapReader, Reader, ask, local) -import Control.Applicative (liftA2) -import Data.Monoid ((<>)) -import Data.Either (isRight) -import qualified Data.Text as T -import Data.Number.FixedFunctions (tan, atan) -import Prelude hiding (sin, cos, acos, tan, atan) -import qualified Data.Matrix as M -import Data.Matrix (Matrix) -import Data.List (groupBy) -import Data.Maybe (fromMaybe, isNothing, isJust, fromJust) -import Data.Text.Lazy.Builder (toLazyText, singleton, Builder) -import Data.Text.Lazy (toStrict) - -import Hasmin.Config -import Hasmin.Class -import Hasmin.Utils -import Hasmin.Types.Dimension -import Hasmin.Types.PercentageLength -import Hasmin.Types.Numeric - --- Note: In a previous specification, translate3d() took two --- >, --- however in the , it --- takes two \ (which makes sense since translateX() and --- translateY() also do). - --- | CSS > --- data type. -data TransformFunction = Mat (Matrix Number) - | Mat3d (Matrix Number) - | Perspective Length - | Rotate Angle - | RotateX Angle - | RotateY Angle - | RotateZ Angle - | Rotate3d Number Number Number Angle - | Scale Number (Maybe Number) - | ScaleX Number - | ScaleY Number - | ScaleZ Number - | Scale3d Number Number Number - | Skew Angle (Maybe Angle) - | SkewX Angle - | SkewY Angle - | Translate PercentageLength (Maybe PercentageLength) - | TranslateX PercentageLength - | TranslateY PercentageLength - | TranslateZ Length - | Translate3d PercentageLength PercentageLength Length - deriving (Eq, Show) - --- There are a series of equivalences to keep in mind: translate(0), --- translate3d(0, 0, 0), translateX(0), translateY(0), translateZ(0), scale(1), --- scaleX(1), scaleY(1), scaleZ(1), rotate(0), rotate3d(1,1,1,0), rotateX(0), --- rotateY(0), rotateZ(0), perspective(infinity), matrix(1,0,0,1,0,0), --- matrix3d(1,0,0,0,0,1,0,0,0,0,1,0,0,0,0,1), skewX(0), skewY(0), and the --- shortest of them all: skew(0) --- All of these translate to the 4x4 identity matrix. -instance Minifiable TransformFunction where - minify (Mat3d m) = do - conf <- ask - if shouldMinifyTransformFunction conf - then case possibleRepresentations m of - [] -> pure (Mat3d m) - (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 - go f y (z:zs) = do - currentLength <- textualLength <$> f y - newLength <- textualLength <$> f z - if currentLength < newLength - then go f y zs - else go f z zs - minify x = do - conf <- ask - if shouldMinifyTransformFunction conf - then case toMatrix3d x of - Just mat3d -> minify mat3d - Nothing -> simplify x - else simplify x - -{- -s = SkewX (Angle 45 Deg) -tx = TranslateX (Right $ Length (-6) PX) -ry = RotateY (Angle (-9) Deg) -ry2 = Rotate3d 0 (-1) 0 (Angle 9 Deg) -t = TranslateZ (Length 100 PX) -t2 = Translate (Right (Length 100 PX)) Nothing -tr = Rotate3d 0 0 1 (Angle 90 Deg) -tr1 = Rotate3d 0 0 1 (Angle 45 Deg) -g x = runReader x defaultConfig --} - -instance ToText TransformFunction where - toBuilder (Translate pl mpl) = "translate(" - <> toBuilder pl <> maybeWithComma mpl <> singleton ')' - 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 ')' - toBuilder (Scale n mn) = "scale(" <> toBuilder n <> maybeWithComma mn <> singleton ')' - toBuilder (ScaleX n) = "scalex(" <> toBuilder n <> singleton ')' - toBuilder (ScaleY n) = "scaley(" <> toBuilder n <> singleton ')' - toBuilder (ScaleZ n) = "scalez(" <> toBuilder n <> singleton ')' - toBuilder (Skew a ma) = "skew(" <> toBuilder a <> maybeWithComma ma <> singleton ')' - toBuilder (SkewX a) = "skewx(" <> toBuilder a <> singleton ')' - toBuilder (SkewY a) = "skewy(" <> toBuilder a <> singleton ')' - toBuilder (Rotate a) = "rotate(" <> toBuilder a <> singleton ')' - 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 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(" - <> mconcatIntersperse toBuilder (singleton ',') (M.toList m) <> singleton ')' - toBuilder (Mat3d m) = "matrix3d(" - <> mconcatIntersperse toBuilder (singleton ',') (M.toList m) <> singleton ')' - -maybeWithComma :: ToText a => Maybe a -> Builder -maybeWithComma = maybe mempty (\x -> singleton ',' <> toBuilder x) - -mkMat :: [Number] -> TransformFunction -mkMat = Mat . M.fromList 3 2 - -mkMat3d :: [Number] -> TransformFunction -mkMat3d = Mat3d . M.fromList 4 4 - -toMatrix3d :: TransformFunction -> Maybe TransformFunction -toMatrix3d m@Mat3d{} = Just m -toMatrix3d (Mat x) = Just $ toMat3d (M.toList x) - where toMat3d [a,b,c,d,e,f] = mkMat3d [a, c, 0, e, - b, d, 0, f, - 0, 0, 1, 0, - 0, 0, 0, 1] - toMat3d _ = error "invalid matrix size!" -toMatrix3d (Translate pl mpl) - | isNonZeroPercentage pl = Nothing - | isJust mpl && isNonZeroPercentage (fromJust mpl) = Nothing - | otherwise = Just . Mat3d $ mkTranslate3dMatrix x y 0 - where x = either (const 0) fromPixelsToNum pl - y = maybe 0 (fromPixelsToNum . fromRight') mpl -toMatrix3d (TranslateX pl) - | isNonZeroPercentage pl = Nothing - | isRight pl && isRelativeLength (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 && isRelativeLength (fromRight' pl) = Nothing - | otherwise = Just . Mat3d $ mkTranslate3dMatrix 0 y 0 - where y = either (const 0) fromPixelsToNum pl -toMatrix3d (TranslateZ d) - | isRelativeLength d = Nothing - | otherwise = Just . Mat3d $ mkTranslate3dMatrix 0 0 z - where z = fromPixelsToNum d -toMatrix3d (Scale n mn) = Just . Mat3d $ mkScale3dMatrix n y 1 - where y = fromMaybe n mn -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 α β - 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 - | isRight pl1 && isRelativeLength (fromRight' pl1) = Nothing - | isRight pl2 && isRelativeLength (fromRight' pl2) = Nothing - | isRelativeLength d = Nothing - | otherwise = let x = either (const 0) fromPixelsToNum pl1 - y = either (const 0) fromPixelsToNum pl2 - z = fromPixelsToNum d - in Just . Mat3d $ mkTranslate3dMatrix x y z -toMatrix3d (Scale3d x y z) = Just . Mat3d $ mkScale3dMatrix x y z -toMatrix3d (Perspective d) - | isZeroLen d = Nothing - | otherwise = let c = fromPixelsToNum d - 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) -{- -toMatrix3d (Rotate a) = Just $ rotateIn3d (0,0,1) (fromRadiansToNum a) -toMatrix3d (Rotate3d x y z a) = Just $ rotateIn3d (x,y,z) (fromRadiansToNum a) -toMatrix3d (RotateX a) = Just $ rotateIn3d (1,0,0) (fromRadiansToNum a) -toMatrix3d (RotateY a) = Just $ rotateIn3d (0,1,0) (fromRadiansToNum a) -toMatrix3d (RotateZ a) = Just $ rotateIn3d (0,0,1) (fromRadiansToNum a) --} -toMatrix3d _ = Nothing - --- Used for the rotate3d(), rotate(), ..., functions. Given an [x,y,z] vector --- and an angle, create its corresponding rotation matrix. -{- -rotateIn3d :: (Number, Number, Number) -> Number -> TransformFunction -rotateIn3d (b,c,d) a = mkMat3d $ fmap toNumber - [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] - where sc = sin epsilon (α/2) * cos epsilon (α/2) :: Rational - sq = sin epsilon (α/2) ^ 2 :: Rational - x = toRational b - y = toRational c - z = toRational d - α = toRational a --} - --- Code translated from: http://www.euclideanspace.com/maths/geometry/rotations/conversions/matrixToAngle/ --- TODO: see how to get different representations, so that negative values are --- still properly handled, i.e. make things such as rotateY(-9deg) work. -matrixToRotate3d :: Matrix Number -> [TransformFunction] -matrixToRotate3d _ = [] -{- - -- if it has translation values, then we can't convert it to a rotation function - | M.unsafeGet 3 4 m /= 0 || M.unsafeGet 2 4 m /= 0 || M.unsafeGet 1 4 m /= 0 = [] - -- | not isRotationMatrix = [] - | abs (m12 - m21) < ep && abs (m13 - m31) < ep - && abs (m23 - m32) < ep = [handleSingularity] - | otherwise = let a = arccos $ (m11 + m22 + m33 - 1)/2 - qx = (m32 - m23)/(2 * sine a) - qy = (m13 - m31)/(2 * sine a) - qz = (m21 - m12)/(2 * sine a) - in [Rotate3d qx qy qz (Angle a Rad)] - where m11 = M.unsafeGet 1 1 m - m22 = M.unsafeGet 2 2 m - m33 = M.unsafeGet 3 3 m - m32 = M.unsafeGet 3 2 m - m23 = M.unsafeGet 2 3 m - m13 = M.unsafeGet 1 3 m - m31 = M.unsafeGet 3 1 m - m21 = M.unsafeGet 2 1 m - m12 = M.unsafeGet 1 2 m - ep = 0.01 -- margin to allow for rounding errors - ep2 = 0.1 --- Make sure that the input is a pure rotation matrix. --- The condition for this is: --- R' * R = I, and det(R) = 1 - 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 - || abs (m11*m11 + m12*m12 + m13*m13 - 1) > ep - || 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 - && abs (m11 + m22 + m33 - 3) < ep2 = Rotate3d 1 0 0 NullAngle - | otherwise = let xx = (m11+1)/2 - yy = (m22+1)/2 - zz = (m33+1)/2 - xy = (m12 + m21)/4 - xz = (m13 + m31)/4 - yz = (m23 + m32)/4 - in handle180Singularity xx yy zz xy xz yz - where handle180Singularity xx yy zz xy xz yz - | xx > yy && xx > zz = if xx < ep - then result 0 0.7071 0.7071 - else let x = toNumber . sqrt $ fromNumber xx - in result x (xy/x) (xz/x) - | yy > zz = if yy < ep - then result 0.7071 0 0.7071 - else let y = toNumber . sqrt $ fromNumber yy - in result (xy/y) y (yz/y) - | otherwise = if zz < ep - then result 0.7071 0.7071 0 - else let z = toNumber . sqrt $ fromNumber zz - in result (xz/z) (yz/z) z - where result vx vy vz = Rotate3d vx vy vz (Angle 180 Deg) --} - -fromPixelsToNum :: Length -> Number -fromPixelsToNum (Length n u) = toPixels n u -fromPixelsToNum NullLength = 0 - -fromRadiansToNum :: Angle -> Number -fromRadiansToNum (Angle n u) = toRadians n u -fromRadiansToNum NullAngle = 0 - -tangent :: Angle -> Number -tangent = toNumber . tan epsilon . fromNumber . fromRadiansToNum - -arctan :: Number -> Number -arctan = toNumber . atan epsilon . fromNumber - --- sine :: Number -> Number --- sine = toNumber . sin epsilon . fromNumber - --- arccos :: Number -> Number --- arccos = toNumber . acos epsilon . fromNumber - -getMat :: TransformFunction -> Matrix Number -getMat (Mat q) = q -getMat (Mat3d q) = q -getMat _ = error "getMat: not a matrix!" - --- toMat :: TransformFunction -> Matrix Number --- toMat x = getMat . fromJust $ toMatrix3d x - ------------------------------------------------------------------------------- - --- | Convert a matrix to all the other possible equivalent --- transformation functions (if any). -possibleRepresentations :: Matrix Number -> [TransformFunction] -possibleRepresentations m = matrixToRotate3d m ++ mconcat - [matrixToSkewFunctions m, matrixToTranslateFunctions m - ,matrixToMat m, matrixToPerspective m - ,matrixToScaleFunctions m] -- TODO add rotation when implemented - -matrixToSkewFunctions :: Matrix Number -> [TransformFunction] -matrixToSkewFunctions m - | skewMatrix == m = Skew a (Just b) : others - | otherwise = [] - where α = M.unsafeGet 1 2 m - β = M.unsafeGet 2 1 m - a = Angle (arctan α) Rad - b = Angle (arctan β) Rad - skewMatrix = mkSkewMatrix α β - others - | α /= 0 && β == 0 = [SkewX a] - | β /= 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. - -matrixToTranslateFunctions :: Matrix Number -> [TransformFunction] -matrixToTranslateFunctions m - | mkTranslate3dMatrix x y z == m = Translate3d tx ty tz : others - | otherwise = [] - where x = M.unsafeGet 1 4 m - tx = Right $ Length x PX - y = M.unsafeGet 2 4 m - ty = Right $ Length y PX - z = M.unsafeGet 3 4 m - tz = Length z PX - 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] - | otherwise = [] - -matrixToScaleFunctions :: Matrix Number -> [TransformFunction] -matrixToScaleFunctions m - | mkScale3dMatrix x y z == m = Scale3d x y z : others - | otherwise = [] - where x = M.unsafeGet 1 1 m - y = M.unsafeGet 2 2 m - z = M.unsafeGet 3 3 m - 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)] - | otherwise = [] - -matrixToPerspective :: Matrix Number -> [TransformFunction] -matrixToPerspective m - | c /= 0 && mkPerspectiveMatrix d == m = [Perspective $ Length d PX] - | otherwise = [] - where c = M.unsafeGet 4 3 m - d = (-1)/c - -matrixToMat :: Matrix Number -> [TransformFunction] -matrixToMat m - | matrix == m = [mkMat [a,b,c,d,e,f]] - | otherwise = [] - where a = M.unsafeGet 1 1 m - b = M.unsafeGet 2 1 m - c = M.unsafeGet 1 2 m - d = M.unsafeGet 2 2 m - e = M.unsafeGet 1 4 m - f = M.unsafeGet 2 4 m - matrix = mkMatMatrix a b c d e f - -mkMatMatrix :: Number -> Number -> Number -> Number - -> Number -> Number -> Matrix Number -mkMatMatrix a b c d e f = mk4x4Matrix [a, c, 0, e, - b, d, 0, f, - 0, 0, 1, 0, - 0, 0, 0, 1] -mkTranslate3dMatrix :: Number -> Number -> Number -> Matrix Number -mkTranslate3dMatrix x y z = mk4x4Matrix [1, 0, 0, x, - 0, 1, 0, y, - 0, 0, 1, z, - 0, 0, 0, 1] - -mkScale3dMatrix :: Number -> Number -> Number -> Matrix Number -mkScale3dMatrix x y z = mk4x4Matrix [x, 0, 0, 0, - 0, y, 0, 0, - 0, 0, z, 0, - 0, 0, 0, 1] - -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) - 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 - --- | Simplifies a \ without converting it to a 4x4 matrix, --- by doing some simple conversions between the different functions, or --- minifying the dimension arguments (\ and \ values) -simplify :: TransformFunction -> Reader Config TransformFunction -simplify (Translate pl mpl) - | isNothing mpl || isZero (fromJust mpl) = do - x <- mapM minify pl - pure $ Translate x Nothing - | otherwise = do x <- mapM minify pl - y <- (mapM . mapM) minify mpl - pure $ Translate x y -simplify (TranslateX pl) = do - x <- mapM minify pl - 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 --- reducing entropy. -simplify (TranslateY pl) = do - y <- mapM minify pl - pure $ TranslateY y --- In scale(), if the second parameter isn't present, it defaults to the first. --- Therefore: scale(a,a) == scale(a) -simplify s@(Scale n mn) = pure $ maybe s removeDefaultArgument mn - where removeDefaultArgument x - | n == x = Scale n Nothing - | otherwise = s --- 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 --- In skew(), if the second parameter isn't present, it defaults to the zero. -simplify (Skew a Nothing) = liftA2 Skew (minify a) (pure Nothing) -simplify (Skew a (Just x)) - | isZeroAngle x = liftA2 Skew (minify a) (pure Nothing) - | otherwise = liftA2 Skew (minify a) (Just <$> minify x) -simplify (SkewY a) - | isZeroAngle a = pure $ Skew NullAngle Nothing - | otherwise = fmap SkewY (minify a) -simplify (SkewX a) - | isZeroAngle a = pure $ Skew NullAngle Nothing - | otherwise = fmap SkewX (minify a) -simplify (Rotate a) - | isZeroAngle a = pure $ Skew NullAngle Nothing - | otherwise = fmap Rotate (minify a) -simplify (RotateX a) - | isZeroAngle a = pure $ Skew NullAngle Nothing - | otherwise = fmap RotateX (minify a) -simplify (RotateY a) - | isZeroAngle a = pure $ Skew NullAngle Nothing - | otherwise = fmap RotateY (minify a) --- rotateZ(a) is the same as rotate3d(0,0,1,a), which also equals rotate(a) -simplify (RotateZ a) - | isZeroAngle a = pure $ Skew NullAngle Nothing - | otherwise = fmap Rotate (minify a) -simplify (Rotate3d x y z a) - | abs (x - 1) < ep && abs y < ep && abs z < ep = simplify $ RotateX a - | abs x < ep && abs (y - 1) < ep && abs z < ep = simplify $ RotateY a - | abs x < ep && abs y < ep && abs (z - 1) < ep = fmap Rotate (minify a) - where ep = toNumber epsilon -simplify (ScaleZ n) - | n == 1 = pure $ Skew NullAngle Nothing - | otherwise = pure $ ScaleZ n -simplify (Perspective d) = fmap Perspective (minify d) -simplify (TranslateZ d) - | isZeroLen d = pure $ Skew NullAngle Nothing - | otherwise = fmap TranslateZ (minify d) -simplify s@(Scale3d x y z) - | z == 1 = simplify $ Scale x (Just y) - | x == 1 && y == 1 = simplify $ ScaleZ z - | otherwise = pure s -simplify (Translate3d x y z ) - | isZero y && isZeroLen z = either (f TranslateX) (g TranslateX) x - | isZero x && isZero y = simplify $ TranslateZ z - | isZero x && isZeroLen z = either (f TranslateY) (g TranslateY) y - where f con a | a == 0 = simplify . con . Right $ NullLength - | otherwise = simplify . con . Left $ a - g con a = simplify . con $ Right a -- A distance, transform an minify -simplify x = pure x - --- | Combines consecutive @\@ whenever possible, leaving --- translate functions that can't be converted to a matrix (because they use --- percentages or relative units) as they are, in the position they are in the --- list (since matrix multiplication isn't commutative) --- Example: --- --- >>> import Control.Monad.Reader --- >>> let t10 = Translate (Right (Length 10 PX)) Nothing --- >>> let s45 = Skew (Angle 45 Deg) Nothing --- >>> let sx5 = ScaleX 5 --- >>> let f x = runReader (combine x) defaultConfig --- --- >>> fmap toText $ f [t10, s45, sx5] --- ["matrix(5,0,1,1,10,0)"] --- --- >>> let tp = Translate (Left (Percentage 100)) Nothing --- >>> fmap toText $ f [s45,tp,sx5,sx5,sx5] --- ["skew(45deg)","translate(100%)","scale(125)"] -combine :: [TransformFunction] -> Reader Config [TransformFunction] -combine xs = do - combinedLength <- mapReader (getLength . asBuilder) combinedFunctions - originalLength <- mapReader (getLength . asBuilder) minifiedOriginal - if combinedLength < originalLength - then combinedFunctions - else minifiedOriginal - where getLength = T.length . toStrict . toLazyText - asBuilder = mconcatIntersperse toBuilder (singleton ' ') - combinedFunctions = mapM handleMatrices . groupByMatrices $ zip (fmap toMatrix3d xs) xs - minifiedOriginal = mapM minify xs - groupByMatrices = groupBy (\(a,_) (b,_) -> isJust a && isJust b) - handleMatrices l@((x,a):_) - | isJust x = minify . Mat3d . foldr (*) (M.identity 4 :: Matrix Number) $ fmap (getMat . fromJust . fst) l - | otherwise = simplify a - handleMatrices [] = error "empty list as argument to handleMatrices" +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Hasmin.Types.TransformFunction +-- Copyright : (c) 2017 Cristian Adrián Ontivero +-- License : BSD3 +-- Stability : experimental +-- Portability : non-portable +-- +----------------------------------------------------------------------------- +module Hasmin.Types.TransformFunction + ( TransformFunction(..) + , mkMat + , mkMat3d + , combine + , simplify + ) where + +import Control.Monad.Reader (mapReader, Reader, ask, local) +import Control.Applicative (liftA2) +import Data.Monoid ((<>)) +import Data.Either (isRight) +import qualified Data.Text as T +import Data.Number.FixedFunctions (tan, atan) +import Prelude hiding (sin, cos, acos, tan, atan) +import qualified Data.Matrix as M +import Data.Matrix (Matrix) +import Data.List (groupBy) +import Data.Maybe (fromMaybe, isNothing, isJust, fromJust) +import Data.Text.Lazy.Builder (toLazyText, singleton, Builder) +import Data.Text.Lazy (toStrict) + +import Hasmin.Config +import Hasmin.Class +import Hasmin.Utils +import Hasmin.Types.Dimension +import Hasmin.Types.PercentageLength +import Hasmin.Types.Numeric + +-- Note: In a previous specification, translate3d() took two +-- >, +-- however in the , it +-- takes two \ (which makes sense since translateX() and +-- translateY() also do). + +-- | CSS > +-- data type. +data TransformFunction = Mat (Matrix Number) + | Mat3d (Matrix Number) + | Perspective Length + | Rotate Angle + | RotateX Angle + | RotateY Angle + | RotateZ Angle + | Rotate3d Number Number Number Angle + | Scale Number (Maybe Number) + | ScaleX Number + | ScaleY Number + | ScaleZ Number + | Scale3d Number Number Number + | Skew Angle (Maybe Angle) + | SkewX Angle + | SkewY Angle + | Translate PercentageLength (Maybe PercentageLength) + | TranslateX PercentageLength + | TranslateY PercentageLength + | TranslateZ Length + | Translate3d PercentageLength PercentageLength Length + deriving (Eq, Show) + +-- There are a series of equivalences to keep in mind: translate(0), +-- translate3d(0, 0, 0), translateX(0), translateY(0), translateZ(0), scale(1), +-- scaleX(1), scaleY(1), scaleZ(1), rotate(0), rotate3d(1,1,1,0), rotateX(0), +-- rotateY(0), rotateZ(0), perspective(infinity), matrix(1,0,0,1,0,0), +-- matrix3d(1,0,0,0,0,1,0,0,0,0,1,0,0,0,0,1), skewX(0), skewY(0), and the +-- shortest of them all: skew(0) +-- All of these translate to the 4x4 identity matrix. +instance Minifiable TransformFunction where + minify (Mat3d m) = do + conf <- ask + if shouldMinifyTransformFunction conf + then case possibleRepresentations m of + [] -> pure (Mat3d m) + (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 + go f y (z:zs) = do + currentLength <- textualLength <$> f y + newLength <- textualLength <$> f z + if currentLength < newLength + then go f y zs + else go f z zs + minify x = do + conf <- ask + if shouldMinifyTransformFunction conf + then case toMatrix3d x of + Just mat3d -> minify mat3d + Nothing -> simplify x + else simplify x + +{- +s = SkewX (Angle 45 Deg) +tx = TranslateX (Right $ Length (-6) PX) +ry = RotateY (Angle (-9) Deg) +ry2 = Rotate3d 0 (-1) 0 (Angle 9 Deg) +t = TranslateZ (Length 100 PX) +t2 = Translate (Right (Length 100 PX)) Nothing +tr = Rotate3d 0 0 1 (Angle 90 Deg) +tr1 = Rotate3d 0 0 1 (Angle 45 Deg) +g x = runReader x defaultConfig +-} + +instance ToText TransformFunction where + toBuilder (Translate pl mpl) = "translate(" + <> toBuilder pl <> maybeWithComma mpl <> singleton ')' + 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 ')' + toBuilder (Scale n mn) = "scale(" <> toBuilder n <> maybeWithComma mn <> singleton ')' + toBuilder (ScaleX n) = "scalex(" <> toBuilder n <> singleton ')' + toBuilder (ScaleY n) = "scaley(" <> toBuilder n <> singleton ')' + toBuilder (ScaleZ n) = "scalez(" <> toBuilder n <> singleton ')' + toBuilder (Skew a ma) = "skew(" <> toBuilder a <> maybeWithComma ma <> singleton ')' + toBuilder (SkewX a) = "skewx(" <> toBuilder a <> singleton ')' + toBuilder (SkewY a) = "skewy(" <> toBuilder a <> singleton ')' + toBuilder (Rotate a) = "rotate(" <> toBuilder a <> singleton ')' + 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 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(" + <> mconcatIntersperse toBuilder (singleton ',') (M.toList m) <> singleton ')' + toBuilder (Mat3d m) = "matrix3d(" + <> mconcatIntersperse toBuilder (singleton ',') (M.toList m) <> singleton ')' + +maybeWithComma :: ToText a => Maybe a -> Builder +maybeWithComma = maybe mempty (\x -> singleton ',' <> toBuilder x) + +mkMat :: [Number] -> TransformFunction +mkMat = Mat . M.fromList 3 2 + +mkMat3d :: [Number] -> TransformFunction +mkMat3d = Mat3d . M.fromList 4 4 + +toMatrix3d :: TransformFunction -> Maybe TransformFunction +toMatrix3d m@Mat3d{} = Just m +toMatrix3d (Mat x) = Just $ toMat3d (M.toList x) + where toMat3d [a,b,c,d,e,f] = mkMat3d [a, c, 0, e, + b, d, 0, f, + 0, 0, 1, 0, + 0, 0, 0, 1] + toMat3d _ = error "invalid matrix size!" +toMatrix3d (Translate pl mpl) + | isNonZeroPercentage pl = Nothing + | isJust mpl && isNonZeroPercentage (fromJust mpl) = Nothing + | otherwise = Just . Mat3d $ mkTranslate3dMatrix x y 0 + where x = either (const 0) fromPixelsToNum pl + y = maybe 0 (fromPixelsToNum . fromRight') mpl +toMatrix3d (TranslateX pl) + | isNonZeroPercentage pl = Nothing + | isRight pl && isRelativeLength (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 && isRelativeLength (fromRight' pl) = Nothing + | otherwise = Just . Mat3d $ mkTranslate3dMatrix 0 y 0 + where y = either (const 0) fromPixelsToNum pl +toMatrix3d (TranslateZ d) + | isRelativeLength d = Nothing + | otherwise = Just . Mat3d $ mkTranslate3dMatrix 0 0 z + where z = fromPixelsToNum d +toMatrix3d (Scale n mn) = Just . Mat3d $ mkScale3dMatrix n y 1 + where y = fromMaybe n mn +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 α β + 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 + | isRight pl1 && isRelativeLength (fromRight' pl1) = Nothing + | isRight pl2 && isRelativeLength (fromRight' pl2) = Nothing + | isRelativeLength d = Nothing + | otherwise = let x = either (const 0) fromPixelsToNum pl1 + y = either (const 0) fromPixelsToNum pl2 + z = fromPixelsToNum d + in Just . Mat3d $ mkTranslate3dMatrix x y z +toMatrix3d (Scale3d x y z) = Just . Mat3d $ mkScale3dMatrix x y z +toMatrix3d (Perspective d) + | isZeroLen d = Nothing + | otherwise = let c = fromPixelsToNum d + 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) +{- +toMatrix3d (Rotate a) = Just $ rotateIn3d (0,0,1) (fromRadiansToNum a) +toMatrix3d (Rotate3d x y z a) = Just $ rotateIn3d (x,y,z) (fromRadiansToNum a) +toMatrix3d (RotateX a) = Just $ rotateIn3d (1,0,0) (fromRadiansToNum a) +toMatrix3d (RotateY a) = Just $ rotateIn3d (0,1,0) (fromRadiansToNum a) +toMatrix3d (RotateZ a) = Just $ rotateIn3d (0,0,1) (fromRadiansToNum a) +-} +toMatrix3d _ = Nothing + +-- Used for the rotate3d(), rotate(), ..., functions. Given an [x,y,z] vector +-- and an angle, create its corresponding rotation matrix. +{- +rotateIn3d :: (Number, Number, Number) -> Number -> TransformFunction +rotateIn3d (b,c,d) a = mkMat3d $ fmap toNumber + [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] + where sc = sin epsilon (α/2) * cos epsilon (α/2) :: Rational + sq = sin epsilon (α/2) ^ 2 :: Rational + x = toRational b + y = toRational c + z = toRational d + α = toRational a +-} + +-- Code translated from: http://www.euclideanspace.com/maths/geometry/rotations/conversions/matrixToAngle/ +-- TODO: see how to get different representations, so that negative values are +-- still properly handled, i.e. make things such as rotateY(-9deg) work. +matrixToRotate3d :: Matrix Number -> [TransformFunction] +matrixToRotate3d _ = [] +{- + -- if it has translation values, then we can't convert it to a rotation function + | M.unsafeGet 3 4 m /= 0 || M.unsafeGet 2 4 m /= 0 || M.unsafeGet 1 4 m /= 0 = [] + -- | not isRotationMatrix = [] + | abs (m12 - m21) < ep && abs (m13 - m31) < ep + && abs (m23 - m32) < ep = [handleSingularity] + | otherwise = let a = arccos $ (m11 + m22 + m33 - 1)/2 + qx = (m32 - m23)/(2 * sine a) + qy = (m13 - m31)/(2 * sine a) + qz = (m21 - m12)/(2 * sine a) + in [Rotate3d qx qy qz (Angle a Rad)] + where m11 = M.unsafeGet 1 1 m + m22 = M.unsafeGet 2 2 m + m33 = M.unsafeGet 3 3 m + m32 = M.unsafeGet 3 2 m + m23 = M.unsafeGet 2 3 m + m13 = M.unsafeGet 1 3 m + m31 = M.unsafeGet 3 1 m + m21 = M.unsafeGet 2 1 m + m12 = M.unsafeGet 1 2 m + ep = 0.01 -- margin to allow for rounding errors + ep2 = 0.1 +-- Make sure that the input is a pure rotation matrix. +-- The condition for this is: +-- R' * R = I, and det(R) = 1 + 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 + || abs (m11*m11 + m12*m12 + m13*m13 - 1) > ep + || 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 + && abs (m11 + m22 + m33 - 3) < ep2 = Rotate3d 1 0 0 NullAngle + | otherwise = let xx = (m11+1)/2 + yy = (m22+1)/2 + zz = (m33+1)/2 + xy = (m12 + m21)/4 + xz = (m13 + m31)/4 + yz = (m23 + m32)/4 + in handle180Singularity xx yy zz xy xz yz + where handle180Singularity xx yy zz xy xz yz + | xx > yy && xx > zz = if xx < ep + then result 0 0.7071 0.7071 + else let x = toNumber . sqrt $ fromNumber xx + in result x (xy/x) (xz/x) + | yy > zz = if yy < ep + then result 0.7071 0 0.7071 + else let y = toNumber . sqrt $ fromNumber yy + in result (xy/y) y (yz/y) + | otherwise = if zz < ep + then result 0.7071 0.7071 0 + else let z = toNumber . sqrt $ fromNumber zz + in result (xz/z) (yz/z) z + where result vx vy vz = Rotate3d vx vy vz (Angle 180 Deg) +-} + +fromPixelsToNum :: Length -> Number +fromPixelsToNum (Length n u) = toPixels n u +fromPixelsToNum NullLength = 0 + +fromRadiansToNum :: Angle -> Number +fromRadiansToNum (Angle n u) = toRadians n u +fromRadiansToNum NullAngle = 0 + +tangent :: Angle -> Number +tangent = toNumber . tan epsilon . fromNumber . fromRadiansToNum + +arctan :: Number -> Number +arctan = toNumber . atan epsilon . fromNumber + +-- sine :: Number -> Number +-- sine = toNumber . sin epsilon . fromNumber + +-- arccos :: Number -> Number +-- arccos = toNumber . acos epsilon . fromNumber + +getMat :: TransformFunction -> Matrix Number +getMat (Mat q) = q +getMat (Mat3d q) = q +getMat _ = error "getMat: not a matrix!" + +-- toMat :: TransformFunction -> Matrix Number +-- toMat x = getMat . fromJust $ toMatrix3d x + +------------------------------------------------------------------------------ + +-- | Convert a matrix to all the other possible equivalent +-- transformation functions (if any). +possibleRepresentations :: Matrix Number -> [TransformFunction] +possibleRepresentations m = matrixToRotate3d m ++ mconcat + [matrixToSkewFunctions m, matrixToTranslateFunctions m + ,matrixToMat m, matrixToPerspective m + ,matrixToScaleFunctions m] -- TODO add rotation when implemented + +matrixToSkewFunctions :: Matrix Number -> [TransformFunction] +matrixToSkewFunctions m + | skewMatrix == m = Skew a (Just b) : others + | otherwise = [] + where α = M.unsafeGet 1 2 m + β = M.unsafeGet 2 1 m + a = Angle (arctan α) Rad + b = Angle (arctan β) Rad + skewMatrix = mkSkewMatrix α β + others + | α /= 0 && β == 0 = [SkewX a] + | β /= 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. + +matrixToTranslateFunctions :: Matrix Number -> [TransformFunction] +matrixToTranslateFunctions m + | mkTranslate3dMatrix x y z == m = Translate3d tx ty tz : others + | otherwise = [] + where x = M.unsafeGet 1 4 m + tx = Right $ Length x PX + y = M.unsafeGet 2 4 m + ty = Right $ Length y PX + z = M.unsafeGet 3 4 m + tz = Length z PX + 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] + | otherwise = [] + +matrixToScaleFunctions :: Matrix Number -> [TransformFunction] +matrixToScaleFunctions m + | mkScale3dMatrix x y z == m = Scale3d x y z : others + | otherwise = [] + where x = M.unsafeGet 1 1 m + y = M.unsafeGet 2 2 m + z = M.unsafeGet 3 3 m + 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)] + | otherwise = [] + +matrixToPerspective :: Matrix Number -> [TransformFunction] +matrixToPerspective m + | c /= 0 && mkPerspectiveMatrix d == m = [Perspective $ Length d PX] + | otherwise = [] + where c = M.unsafeGet 4 3 m + d = (-1)/c + +matrixToMat :: Matrix Number -> [TransformFunction] +matrixToMat m + | matrix == m = [mkMat [a,b,c,d,e,f]] + | otherwise = [] + where a = M.unsafeGet 1 1 m + b = M.unsafeGet 2 1 m + c = M.unsafeGet 1 2 m + d = M.unsafeGet 2 2 m + e = M.unsafeGet 1 4 m + f = M.unsafeGet 2 4 m + matrix = mkMatMatrix a b c d e f + +mkMatMatrix :: Number -> Number -> Number -> Number + -> Number -> Number -> Matrix Number +mkMatMatrix a b c d e f = mk4x4Matrix [a, c, 0, e, + b, d, 0, f, + 0, 0, 1, 0, + 0, 0, 0, 1] +mkTranslate3dMatrix :: Number -> Number -> Number -> Matrix Number +mkTranslate3dMatrix x y z = mk4x4Matrix [1, 0, 0, x, + 0, 1, 0, y, + 0, 0, 1, z, + 0, 0, 0, 1] + +mkScale3dMatrix :: Number -> Number -> Number -> Matrix Number +mkScale3dMatrix x y z = mk4x4Matrix [x, 0, 0, 0, + 0, y, 0, 0, + 0, 0, z, 0, + 0, 0, 0, 1] + +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) + 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 + +-- | Simplifies a \ without converting it to a 4x4 matrix, +-- by doing some simple conversions between the different functions, or +-- minifying the dimension arguments (\ and \ values) +simplify :: TransformFunction -> Reader Config TransformFunction +simplify (Translate pl mpl) + | isNothing mpl || isZero (fromJust mpl) = do + x <- mapM minify pl + pure $ Translate x Nothing + | otherwise = do x <- mapM minify pl + y <- (mapM . mapM) minify mpl + pure $ Translate x y +simplify (TranslateX pl) = do + x <- mapM minify pl + 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 +-- reducing entropy. +simplify (TranslateY pl) = do + y <- mapM minify pl + pure $ TranslateY y +-- In scale(), if the second parameter isn't present, it defaults to the first. +-- Therefore: scale(a,a) == scale(a) +simplify s@(Scale n mn) = pure $ maybe s removeDefaultArgument mn + where removeDefaultArgument x + | n == x = Scale n Nothing + | otherwise = s +-- 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 +-- In skew(), if the second parameter isn't present, it defaults to the zero. +simplify (Skew a Nothing) = liftA2 Skew (minify a) (pure Nothing) +simplify (Skew a (Just x)) + | isZeroAngle x = liftA2 Skew (minify a) (pure Nothing) + | otherwise = liftA2 Skew (minify a) (Just <$> minify x) +simplify (SkewY a) + | isZeroAngle a = pure $ Skew NullAngle Nothing + | otherwise = fmap SkewY (minify a) +simplify (SkewX a) + | isZeroAngle a = pure $ Skew NullAngle Nothing + | otherwise = fmap SkewX (minify a) +simplify (Rotate a) + | isZeroAngle a = pure $ Skew NullAngle Nothing + | otherwise = fmap Rotate (minify a) +simplify (RotateX a) + | isZeroAngle a = pure $ Skew NullAngle Nothing + | otherwise = fmap RotateX (minify a) +simplify (RotateY a) + | isZeroAngle a = pure $ Skew NullAngle Nothing + | otherwise = fmap RotateY (minify a) +-- rotateZ(a) is the same as rotate3d(0,0,1,a), which also equals rotate(a) +simplify (RotateZ a) + | isZeroAngle a = pure $ Skew NullAngle Nothing + | otherwise = fmap Rotate (minify a) +simplify (Rotate3d x y z a) + | abs (x - 1) < ep && abs y < ep && abs z < ep = simplify $ RotateX a + | abs x < ep && abs (y - 1) < ep && abs z < ep = simplify $ RotateY a + | abs x < ep && abs y < ep && abs (z - 1) < ep = fmap Rotate (minify a) + where ep = toNumber epsilon +simplify (ScaleZ n) + | n == 1 = pure $ Skew NullAngle Nothing + | otherwise = pure $ ScaleZ n +simplify (Perspective d) = fmap Perspective (minify d) +simplify (TranslateZ d) + | isZeroLen d = pure $ Skew NullAngle Nothing + | otherwise = fmap TranslateZ (minify d) +simplify s@(Scale3d x y z) + | z == 1 = simplify $ Scale x (Just y) + | x == 1 && y == 1 = simplify $ ScaleZ z + | otherwise = pure s +simplify (Translate3d x y z ) + | isZero y && isZeroLen z = either (f TranslateX) (g TranslateX) x + | isZero x && isZero y = simplify $ TranslateZ z + | isZero x && isZeroLen z = either (f TranslateY) (g TranslateY) y + where f con a | a == 0 = simplify . con . Right $ NullLength + | otherwise = simplify . con . Left $ a + g con a = simplify . con $ Right a -- A distance, transform an minify +simplify x = pure x + +-- | Combines consecutive @\@ whenever possible, leaving +-- translate functions that can't be converted to a matrix (because they use +-- percentages or relative units) as they are, in the position they are in the +-- list (since matrix multiplication isn't commutative) +-- Example: +-- +-- >>> import Control.Monad.Reader +-- >>> let t10 = Translate (Right (Length 10 PX)) Nothing +-- >>> let s45 = Skew (Angle 45 Deg) Nothing +-- >>> let sx5 = ScaleX 5 +-- >>> let f x = runReader (combine x) defaultConfig +-- +-- >>> fmap toText $ f [t10, s45, sx5] +-- ["matrix(5,0,1,1,10,0)"] +-- +-- >>> let tp = Translate (Left (Percentage 100)) Nothing +-- >>> fmap toText $ f [s45,tp,sx5,sx5,sx5] +-- ["skew(45deg)","translate(100%)","scale(125)"] +combine :: [TransformFunction] -> Reader Config [TransformFunction] +combine xs = do + combinedLength <- mapReader (getLength . asBuilder) combinedFunctions + originalLength <- mapReader (getLength . asBuilder) minifiedOriginal + if combinedLength < originalLength + then combinedFunctions + else minifiedOriginal + where getLength = T.length . toStrict . toLazyText + asBuilder = mconcatIntersperse toBuilder (singleton ' ') + combinedFunctions = mapM handleMatrices . groupByMatrices $ zip (fmap toMatrix3d xs) xs + minifiedOriginal = mapM minify xs + groupByMatrices = groupBy (\(a,_) (b,_) -> isJust a && isJust b) + handleMatrices l@((x,a):_) + | isJust x = minify . Mat3d . foldr (*) (M.identity 4 :: Matrix Number) $ fmap (getMat . fromJust . fst) l + | otherwise = simplify a + handleMatrices [] = error "empty list as argument to handleMatrices" diff --git a/tests/DocTest.hs b/tests/DocTest.hs --- a/tests/DocTest.hs +++ b/tests/DocTest.hs @@ -1,6 +1,6 @@ --- {-# OPTIONS_GHC -F -pgmF doctest-discover #-} - -import Test.DocTest (doctest) - -main :: IO () -main = doctest ["src"] +-- {-# OPTIONS_GHC -F -pgmF doctest-discover #-} + +import Test.DocTest (doctest) + +main :: IO () +main = doctest ["src"] diff --git a/tests/Hasmin/Types/DeclarationSpec.hs b/tests/Hasmin/Types/DeclarationSpec.hs --- a/tests/Hasmin/Types/DeclarationSpec.hs +++ b/tests/Hasmin/Types/DeclarationSpec.hs @@ -1,445 +1,473 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Hasmin.Types.DeclarationSpec where - -import Data.Foldable (traverse_) -import Data.Monoid ((<>)) -import Data.Text (Text) - -import Hasmin.Parser.Internal -import Hasmin.TestUtils -import Hasmin.Types.Declaration - -declarationTests :: Spec -declarationTests = - describe "declaration" $ - mapM_ (matchSpec declaration) declarationTestsInfo - -propertySpecificTests :: Spec -propertySpecificTests = - describe "property specific changes" $ - mapM_ (matchSpec f) propertySpecificTestsInfo - where f = minifyWithTestConfig <$> declaration - -propertySpecificTestsInfo :: [(Text, Text)] -propertySpecificTestsInfo = - [("font-family:Arial Black Long Name", "font-family:arial black long name") - ,("font:9px Arial Black Long Name", "font:9px arial black long name") - ,("font-family:\"SANS-SERIF\"", "font-family:\"sans-serif\"") - ,("font-family:'Helvetica','Arial',sans-serif", "font-family:helvetica,arial,sans-serif") - -- TODO make this work - -- should fallback and parse till ';' - -- ,("font-size:1em\nline-height:1.38;", "font-size:1em\nline-height:1.38;") - - ,("background-size:1px auto, 2px auto", "background-size:1px,2px") - - ,("text-shadow: 1px 1px 1px #ff0000", "text-shadow:1px 1px 1px red") - ,("text-shadow: 12px 12px 12px", "text-shadow:9pt 9pt 9pt") - ,("text-shadow: 1px 1px 0 green", "text-shadow:1px 1px green") - ,("text-shadow: 1px 1px 0 green, 2px 2px 0 blue", "text-shadow:1px 1px green,2px 2px blue") - - ,("font-weight:normal", "font-weight:400") - ,("font-weight:bold", "font-weight:700") - - ,("word-spacing:normal", "word-spacing:0") - ,("word-spacing:initial", "word-spacing:0") - ,("word-spacing:unset", "word-spacing:unset") - ,("word-spacing:inherit", "word-spacing:unset") - - ,("vertical-align:baseline", "vertical-align:0") - ,("vertical-align:initial", "vertical-align:0") - ,("vertical-align:unset", "vertical-align:0") - - ,("transform-origin:left top", "transform-origin:0 0") - ,("transform-origin:left 0", "transform-origin:0 0") - ,("transform-origin:0 top", "transform-origin:0 0") - ,("transform-origin:0 0", "transform-origin:0 0") - ,("transform-origin:top left", "transform-origin:0 0") - ,("transform-origin:top 0", "transform-origin:0 0") - ,("transform-origin:0 left", "transform-origin:0 0") - - ,("transform-origin:left bottom", "transform-origin:0 100%") - ,("transform-origin:0 bottom", "transform-origin:0 100%") - ,("transform-origin:left 100%", "transform-origin:0 100%") - ,("transform-origin:0 100%", "transform-origin:0 100%") - ,("transform-origin:bottom left", "transform-origin:0 100%") - ,("transform-origin:100% left", "transform-origin:0 100%") - ,("transform-origin:bottom 0", "transform-origin:0 100%") - - ,("transform-origin:right top", "transform-origin:100% 0") - ,("transform-origin:100% top", "transform-origin:100% 0") - ,("transform-origin:right 0", "transform-origin:100% 0") - ,("transform-origin:top 100%", "transform-origin:100% 0") - ,("transform-origin:0% right", "transform-origin:100% 0") - ,("transform-origin:top right", "transform-origin:100% 0") - - ,("transform-origin:right bottom", "transform-origin:100% 100%") - ,("transform-origin:100% bottom", "transform-origin:100% 100%") - ,("transform-origin:right 100%", "transform-origin:100% 100%") - ,("transform-origin:bottom 100%", "transform-origin:100% 100%") - ,("transform-origin:100% right", "transform-origin:100% 100%") - ,("transform-origin:bottom right", "transform-origin:100% 100%") - - ,("transform-origin:center bottom", "transform-origin:bottom") - ,("transform-origin:50% bottom", "transform-origin:bottom") - ,("transform-origin:center 100%", "transform-origin:bottom") - ,("transform-origin:bottom 50%", "transform-origin:bottom") - ,("transform-origin:bottom center", "transform-origin:bottom") - - ,("transform-origin:center top", "transform-origin:top") - ,("transform-origin:50% top", "transform-origin:top") - ,("transform-origin:center 0px", "transform-origin:top") - ,("transform-origin:top 50%", "transform-origin:top") - ,("transform-origin:top center", "transform-origin:top") - - ,("transform-origin:center right", "transform-origin:100%") - ,("transform-origin:50% right", "transform-origin:100%") - ,("transform-origin:right 50%", "transform-origin:100%") - ,("transform-origin:100% center", "transform-origin:100%") - ,("transform-origin:right center", "transform-origin:100%") - - ,("transform-origin:center left", "transform-origin:0") - ,("transform-origin:50% left", "transform-origin:0") - ,("transform-origin:left 50%", "transform-origin:0") - ,("transform-origin:0% center", "transform-origin:0") - ,("transform-origin:left center", "transform-origin:0") - - ,("transform-origin:center", "transform-origin:50%") - ,("transform-origin:center center", "transform-origin:50%") - ,("transform-origin:center 50%", "transform-origin:50%") - ,("transform-origin:50% center", "transform-origin:50%") - ,("transform-origin:50% 50%", "transform-origin:50%") - ,("transform-origin:center center 0", "transform-origin:50%") - ,("transform-origin:center center 1px", "transform-origin:50% 50% 1px") - - ,("transform-origin:left 30px", "transform-origin:0 30px") - ,("transform-origin:30px left", "transform-origin:0 30px") - ,("transform-origin:right 30px", "transform-origin:100% 30px") - ,("transform-origin:30px right", "transform-origin:100% 30px") - ,("transform-origin:bottom 30px", "transform-origin:30px 100%") - ,("transform-origin:30px bottom", "transform-origin:30px 100%") - ,("transform-origin:top 30px", "transform-origin:30px 0") - ,("transform-origin:30px top", "transform-origin:30px 0") - ,("transform-origin:center 30px", "transform-origin:50% 30px") - ,("transform-origin:30px center", "transform-origin:30px") - - -- 3 value syntax - ,("transform-origin:left top 1px", "transform-origin:0 0 1px") - ,("transform-origin:top left 1px", "transform-origin:0 0 1px") - ,("transform-origin:left bottom 1px", "transform-origin:0 100% 1px") - ,("transform-origin:bottom left 1px", "transform-origin:0 100% 1px") - ,("transform-origin:right top 1px", "transform-origin:100% 0 1px") - ,("transform-origin:top right 1px", "transform-origin:100% 0 1px") - ,("transform-origin:right bottom 1px", "transform-origin:100% 100% 1px") - ,("transform-origin:bottom right 1px", "transform-origin:100% 100% 1px") - ,("transform-origin:center bottom 1px", "transform-origin:50% 100% 1px") - ,("transform-origin:bottom center 1px", "transform-origin:50% 100% 1px") - ,("transform-origin:center top 1px", "transform-origin:50% 0 1px") - ,("transform-origin:top center 1px", "transform-origin:50% 0 1px") - ,("transform-origin:center right 1px", "transform-origin:100% 50% 1px") - ,("transform-origin:right center 1px", "transform-origin:100% 50% 1px") - ,("transform-origin:center left 1px", "transform-origin:0 50% 1px") - ,("transform-origin:left center 1px", "transform-origin:0 50% 1px") - ] - - -declarationTestsInfo :: [(Text, Text)] -declarationTestsInfo = - [("box-shadow:0 7px 0 #fefefe, 0 14px 0 #fefefe", - "box-shadow:0 7px 0 #fefefe,0 14px 0 #fefefe") - ] - -cleaningTests :: Spec -cleaningTests = - describe "cleaning function" $ - mapM_ (matchSpecWithDesc f) cleaningTestsInfo - where f = (Declarations . clean) <$> declarations - -cleaningTestsInfo :: [(String, Text, Text)] -cleaningTestsInfo = - [("Merge margin with later margin-top", - "margin:0;margin-top:5px", - "margin:5px 0 0") - ,("Merge margin with later margin-right", - "margin:2px;margin-right:1in", - "margin:2px 1in 2px 2px") - ,("Merge margin with later margin-bottom", - "margin:auto;margin-bottom:.2em", - "margin:auto auto .2em") - ,("Merge margin with later margin-left", - "margin:fill;margin-left:9px", - "margin:fill fill fill 9px") - ,("Merge margin with later margin-top, with declaration in-between", - "margin:0;color:red;margin-top:5px", - "margin:5px 0 0;color:red") - ,("Merge margin with later margin-right, with declaration in-between", - "margin:2px;color:red;margin-right:1in", - "margin:2px 1in 2px 2px;color:red") - ,("Merge margin with later margin-bottom, with declaration in-between", - "margin:auto;color:red;margin-bottom:.2em", - "margin:auto auto .2em;color:red") - ,("Merge margin with later margin-left, with declaration in-between", - "margin:fill;color:red;margin-left:9px", - "margin:fill fill fill 9px;color:red") - ,("Drop a margin-top overwritten by a following margin", - "margin-top:5px;margin:0", - "margin:0") - ,("Drop a margin-right overwritten by a following margin", - "margin-right:1px;margin:2px", - "margin:2px") - ,("Drop a margin-bottom overwritten by a following margin", - "margin-bottom:.2em;margin:auto", - "margin:auto") - ,("Drop a margin-left overwritten by a following margin", - "margin-left:9px;margin:fill", - "margin:fill") - ,("Drop a margin-top overwritten by later margin, with a declaration in-between", - "margin-top:5px;padding:0;margin:0", - "padding:0;margin:0") - ,("Drop a margin-right overwritten by later margin, with a declaration in-between", - "margin-right:1px;padding:0;margin:2px", - "padding:0;margin:2px") - ,("Drop a margin-bottom overwritten by later margin, with a declaration in-between", - "margin-bottom:.2em;padding:0;margin:auto", - "padding:0;margin:auto") - ,("Drop a margin-left overwritten by later margin, with a declaration in-between", - "margin-left:9px;padding:0;margin:fill", - "padding:0;margin:fill") - ,("Drop a margin-top overwritten by a later margin-top, with a declaration in-between", - "margin-top:99px;color:red;margin-top:0", - "color:red;margin-top:0") - ,("Drop a margin-right overwritten by a later margin-right, with a declaration in-between", - "margin-right:99px;color:red;margin-right:0", - "color:red;margin-right:0") - ,("Drop a margin-bottom overwritten by a later margin-bottom, with a declaration in-between", - "margin-bottom:99px;color:red;margin-bottom:0", - "color:red;margin-bottom:0") - ,("Drop a margin-left overwritten by a later margin-left, with a declaration in-between", - "margin-left:99px;color:red;margin-left:0", - "color:red;margin-left:0") - ,("Drop a margin-top overwritten by a previous margin-top with !important", - "margin-top:99px!important;margin-top:0", - "margin-top:99px!important") - ,("Drop a margin-right overwritten by a previous margin-right with !important", - "margin-right:99px!important;margin-right:0", - "margin-right:99px!important") - ,("Drop a margin-bottom overwritten by a previous margin-bottom with !important", - "margin-bottom:99px!important;margin-bottom:0", - "margin-bottom:99px!important") - ,("Drop a margin-left overwritten by a previous margin-left with !important", - "margin-left:99px!important;margin-left:0", - "margin-left:99px!important") - ,("Drop a margin-top overwritten by a previous margin-top with !important, with a declaration in-between", - "margin-top:99px!important;margin:auto;margin-top:0", - "margin-top:99px!important;margin:auto") - ,("Drop a margin-right overwritten by a previous margin-right with !important, with a declaration in-between", - "margin-right:99px!important;margin:auto;margin-right:0", - "margin-right:99px!important;margin:auto") - ,("Drop a margin-bottom overwritten by a previous margin-bottom with !important, with a declaration in-between", - "margin-bottom:99px!important;margin:auto;margin-bottom:0", - "margin-bottom:99px!important;margin:auto") - ,("Drop a margin-left overwritten by a previous margin-left with !important, with a declaration in-between", - "margin-left:99px!important;margin:auto;margin-left:0", - "margin-left:99px!important;margin:auto") - -- ,("When merging, translate initial keyword to the initial value", - -- "margin:0;margin-top:initial", - -- "margin:0") - -- ,("When merging, translate unset keyword of a property that inherits to the initial value", - -- "margin:0;margin-top:unset", - -- "margin:0") - -- ,("Don't merge properties with inherit keyword", - -- "margin:0;margin-top:inherit", - -- "margin:0;margin-top:inherit") - ] - -minifyDecTests :: Spec -minifyDecTests = - describe "minifyDec function" $ - mapM_ (matchSpec (minifyWithTestConfig <$> declaration)) minifyDecTestsInfo - -shorthandInitialValuesTests :: Spec -shorthandInitialValuesTests = do - testMatches "background minification" backgroundTestsInfo - testMatches "transition minification" transitionTestsInfo - testMatches "animation minification" animationTestsInfo - testMatches "font minification" fontTestsInfo - testMatches "outline minification" outlineTestsInfo - anyOrderShorthandTests - where testMatches :: String -> [(String, Text, Text)] -> SpecWith () - testMatches desc i = describe desc $ - mapM_ (matchSpecWithDesc (minifyWithTestConfig <$> declaration)) i - -backgroundTestsInfo :: [(String, Text, Text)] -backgroundTestsInfo = - [("Does not remove from background when the cannot be removed", - "background: 0 0 / 3px", "background:0 0/3px") - ,("Removes when it is the default and no is present", - "background: #fff 0 0", "background:#fff") - ,("Removes both and when they are the default", - "background: #fff 0 0/auto", "background:#fff") - ,("Removes background-clip keyword when it equals the background-origin keyword", - "background: border-box #fff border-box", "background:border-box #fff") - ,("Removes the keywords for background-origin and background-clip when both are the initial ones", - "background: #fff padding-box border-box", "background:#fff") - ,("Removes the background-attachment keyword when it is the initial one", - "background: #fff scroll", "background:#fff") - ,("Removes the background-color value when it is the initial one", - "background: url(img.png) transparent", "background:url(img.png)") - ,("Removes background-image when it is the default (i.e. none)", - "background: none #fff", "background:#fff") - ,("Removes background-repeat when it is the default (i.e. repeat)", - "background: repeat #fff", "background:#fff") - ] - -transitionTestsInfo :: [(String, Text, Text)] -transitionTestsInfo = - [("Removes transition-duration when it is the default", - "transition: ease-out some-property 0s", "transition:ease-out some-property") - ,("Removes transition-delay when it is the default", - "transition: ease-out 1s some-property 0s", "transition:ease-out 1s some-property") - ,("Leaves an initial (i.e. 0s) transition-duration when the transition-delay is not initial (i.e. also 0s)", - "transition: all 0s 1s ease", "transition:0s 1s") - ,("Removes transition-timing-function when it is the default", - "transition: some-property 1s ease", "transition:1s some-property") - ,("Removes transition-property when it is the default", - "transition: ease-out all 1s", "transition:ease-out 1s") - ,("Leaves only 0s when every present value is initial", - "transition: all 0s 0s ease", "transition:0s") - ] - -animationTestsInfo :: [(String, Text, Text)] -animationTestsInfo = - [("Removes default animation-fill-mode when the animation-name doesn't overlap with its keywords", - "animation:none animName", "animation:animName") - ,("Leaves default animation-fill-mode when the animation-name overlaps with one of its keywords", - "animation:none backwards", "animation:none backwards") - ,("Removes default animation-fill-mode and default animation-name when both are used simultaneously", - "animation:ease-out none none", "animation:ease-out") - ,("Removes default animation-timing-function", - "animation:animName ease", "animation:animName") - ,("Removes default animation-duration", - "animation:0s ease-out", "animation:ease-out") - ,("Removes default animation-delay", - "animation:1s 0s ease-out", "animation:1s ease-out") - ,("Leaves default animation-duration when animation-delay is not the default", - "animation:0s 1s ease-out", "animation:0s 1s ease-out") - ,("Removes default animation-iteration-count", - "animation:1 ease-out", "animation:ease-out") - ,("Removes default animation-direction when the animation-name doesn't overlap with its keywords", - "animation:normal animName", "animation:animName") - ,("Leaves default animation-direction when the animation-name overlaps with one of its keywords", - "animation:normal alternate", "animation:normal alternate") - ,("Removes default animation-play-state when the animation-name doesn't overlap with its keywords", - "animation:running animName", "animation:animName") - ,("Leaves default animation-play-state when the animation-name overlaps with one of its keywords", - "animation:running paused", "animation:running paused") - ] - -fontTestsInfo :: [(String, Text, Text)] -fontTestsInfo = - [("Removes default font-style", - "font:normal condensed bolder small-caps 9px/1 sans", "font:small-caps bolder condensed 9px/1 sans") - ,("Removes default font-variant", - "font:normal italic condensed bolder 9px/1 sans", "font:italic bolder condensed 9px/1 sans") - ,("Removes default font-weight", - "font:italic normal condensed small-caps 9px/1 sans", "font:italic small-caps condensed 9px/1 sans") - ,("Converts bold font-weight into 700", - "font:bold 9px sans", "font:700 9px sans") - ,("Removes default font-stretch", - "font:italic normal small-caps bolder 9px/1 sans", "font:italic small-caps bolder 9px/1 sans") - ,("Removes default line-height", - "font:9px/normal sans", "font:9px sans") - ,("Lowercases and removes quotes from font-family values", - "font:9px 'Arial Black', \"sans-serif\", sans", "font:9px arial black,\"sans-serif\",sans") - ] - --- Tests for the removal of outline initial values. Almost identical to those --- shorthands in the anyOrderShorthandTests, except for the invert color. -outlineTestsInfo :: [(String, Text, Text)] -outlineTestsInfo = - [("Removes default outline-color", - "outline:invert solid 1px", "outline:solid 1px") - ,("Removes default outline-style", - "outline:#fff none 1px", "outline:#fff 1px") - ,("Removes default outline-width", - "outline:#fff solid medium", "outline:#fff solid") - ,("Leaves none as the shortest initial value", - "outline:invert", "outline:none") - ] - --- Tests for shorthands whose initial values are "medium none currentColor", --- and can go on any order. -anyOrderShorthandTests :: Spec -anyOrderShorthandTests = - describe "Shorthands that accept values in any order (mostly: medium none currentColor)" $ - traverse_ (mapM_ (matchSpec (minifyWithTestConfig <$> declaration))) d - where d = fmap f shorthandsToTest - f z = fmap (\(x,y) -> (z <> ":" <> x, z <> ":" <> y)) shorthandEquivalences - shorthandsToTest = ["border" - ,"border-top" - ,"border-right" - ,"border-bottom" - ,"border-left" - ,"column-rule"] - shorthandEquivalences = [("initial", "none") - ,("unset", "none") - ,("none", "none") - ,("medium", "none") - ,("currentColor", "none") - ,("medium none", "none") - ,("medium currentColor", "none") - ,("none currentColor", "none") - ,("medium none currentColor", "none") - ,("medium none red", "red") - ,("thick none currentColor", "thick") - ,("thick dotted currentColor", "thick dotted")] - -minifyDecTestsInfo :: [(Text, Text)] -minifyDecTestsInfo = - [("BORDER-bottom: initial", "border-bottom:none") - ,("BORDER-bottom: unset", "border-bottom:none") - ,("BORDER-bottom: none", "border-bottom:none") - ,("BORDER-bottom: medium", "border-bottom:none") - ,("BORDER-bottom: currentColor", "border-bottom:none") - ,("BORDER-bottom: medium none", "border-bottom:none") - ,("BORDER-bottom: medium currentColor", "border-bottom:none") - ,("BORDER-bottom: none currentColor", "border-bottom:none") - ,("BORDER-bottom: medium none currentColor", "border-bottom:none") - ,("BORDER-bottom: medium none red", "border-bottom:red") - ,("BORDER-bottom: thick none currentColor", "border-bottom:thick") - ,("BORDER-bottom: thick dotted currentColor", "border-bottom:thick dotted") - ,("BORDER-bottom: 12px red", "border-bottom:9pt red") --- widows inherits, and its initial value is 2 - ,("widows: unset", "widows:unset") - ,("widows: inherit", "widows:unset") - ,("widows: initial", "widows:2") --- font-synthesis inherits, and its initial value is "weight style", --- which are two keywords, both needed, in any order. - ,("font-synthesis: unset", "font-synthesis:unset") - ,("font-synthesis: inherit", "font-synthesis:unset") - ,("font-synthesis: initial", "font-synthesis:initial") - ,("Font-synthesis: weight style", "font-synthesis:initial") - ,("font-synthesis: style weight", "font-synthesis:initial") - ,("font-synthesis: weight", "font-synthesis:weight") - ,("font-synthesis: style", "font-synthesis:style") --- background-size: The first value gives the width of the corresponding image, --- the second value its height. Its initial value is 'auto', and it doesn't --- inherit. If only one value is given the second is assumed to be ‘auto’. - ,("background-size: 96px", "background-size:6pc") - ,("background-size: auto", "background-size:auto") - ,("background-size: unset", "background-size:auto") - ,("background-size: initial", "background-size:auto") - ,("background-size: auto auto", "background-size:auto") - ,("background-size: auto 96px", "background-size:auto 6pc") - ,("background-size: 96px auto", "background-size:6pc") - ] - -spec :: Spec -spec = do cleaningTests - minifyDecTests - shorthandInitialValuesTests - declarationTests - propertySpecificTests - -main :: IO () -main = hspec spec +{-# LANGUAGE OverloadedStrings #-} + +module Hasmin.Types.DeclarationSpec where + +import Data.Foldable (traverse_) +import Data.Monoid ((<>)) +import Data.Text (Text) + +import Hasmin.Parser.Internal +import Hasmin.TestUtils +import Hasmin.Types.Declaration + +declarationTests :: Spec +declarationTests = + describe "declaration" $ + mapM_ (matchSpec declaration) declarationTestsInfo + +propertySpecificTests :: Spec +propertySpecificTests = + describe "property specific changes" $ + mapM_ (matchSpec f) propertySpecificTestsInfo + where f = minifyWithTestConfig <$> declaration + +propertySpecificTestsInfo :: [(Text, Text)] +propertySpecificTestsInfo = + [("font-family:Arial Black Long Name", "font-family:arial black long name") + ,("font:9px Arial Black Long Name", "font:9px arial black long name") + ,("font-family:\"SANS-SERIF\"", "font-family:\"sans-serif\"") + ,("font-family:'Helvetica','Arial',sans-serif", "font-family:helvetica,arial,sans-serif") + -- TODO make this work + -- should fallback and parse till ';' + -- ,("font-size:1em\nline-height:1.38;", "font-size:1em\nline-height:1.38;") + + ,("background-size:1px auto, 2px auto", "background-size:1px,2px") + + ,("text-shadow: 1px 1px 1px #ff0000", "text-shadow:1px 1px 1px red") + ,("text-shadow: 12px 12px 12px", "text-shadow:9pt 9pt 9pt") + ,("text-shadow: 1px 1px 0 green", "text-shadow:1px 1px green") + ,("text-shadow: 1px 1px 0 green, 2px 2px 0 blue", "text-shadow:1px 1px green,2px 2px blue") + + ,("font-weight:normal", "font-weight:400") + ,("font-weight:bold", "font-weight:700") + + ,("word-spacing:normal", "word-spacing:0") + ,("word-spacing:initial", "word-spacing:0") + ,("word-spacing:unset", "word-spacing:unset") + ,("word-spacing:inherit", "word-spacing:unset") + + ,("vertical-align:baseline", "vertical-align:0") + ,("vertical-align:initial", "vertical-align:0") + ,("vertical-align:unset", "vertical-align:0") + + ,("transform-origin:left top", "transform-origin:0 0") + ,("transform-origin:left 0", "transform-origin:0 0") + ,("transform-origin:0 top", "transform-origin:0 0") + ,("transform-origin:0 0", "transform-origin:0 0") + ,("transform-origin:top left", "transform-origin:0 0") + ,("transform-origin:top 0", "transform-origin:0 0") + ,("transform-origin:0 left", "transform-origin:0 0") + + ,("transform-origin:left bottom", "transform-origin:0 100%") + ,("transform-origin:0 bottom", "transform-origin:0 100%") + ,("transform-origin:left 100%", "transform-origin:0 100%") + ,("transform-origin:0 100%", "transform-origin:0 100%") + ,("transform-origin:bottom left", "transform-origin:0 100%") + ,("transform-origin:100% left", "transform-origin:0 100%") + ,("transform-origin:bottom 0", "transform-origin:0 100%") + + ,("transform-origin:right top", "transform-origin:100% 0") + ,("transform-origin:100% top", "transform-origin:100% 0") + ,("transform-origin:right 0", "transform-origin:100% 0") + ,("transform-origin:top 100%", "transform-origin:100% 0") + ,("transform-origin:0% right", "transform-origin:100% 0") + ,("transform-origin:top right", "transform-origin:100% 0") + + ,("transform-origin:right bottom", "transform-origin:100% 100%") + ,("transform-origin:100% bottom", "transform-origin:100% 100%") + ,("transform-origin:right 100%", "transform-origin:100% 100%") + ,("transform-origin:bottom 100%", "transform-origin:100% 100%") + ,("transform-origin:100% right", "transform-origin:100% 100%") + ,("transform-origin:bottom right", "transform-origin:100% 100%") + + ,("transform-origin:center bottom", "transform-origin:bottom") + ,("transform-origin:50% bottom", "transform-origin:bottom") + ,("transform-origin:center 100%", "transform-origin:bottom") + ,("transform-origin:bottom 50%", "transform-origin:bottom") + ,("transform-origin:bottom center", "transform-origin:bottom") + + ,("transform-origin:center top", "transform-origin:top") + ,("transform-origin:50% top", "transform-origin:top") + ,("transform-origin:center 0px", "transform-origin:top") + ,("transform-origin:top 50%", "transform-origin:top") + ,("transform-origin:top center", "transform-origin:top") + + ,("transform-origin:center right", "transform-origin:100%") + ,("transform-origin:50% right", "transform-origin:100%") + ,("transform-origin:right 50%", "transform-origin:100%") + ,("transform-origin:100% center", "transform-origin:100%") + ,("transform-origin:right center", "transform-origin:100%") + + ,("transform-origin:center left", "transform-origin:0") + ,("transform-origin:50% left", "transform-origin:0") + ,("transform-origin:left 50%", "transform-origin:0") + ,("transform-origin:0% center", "transform-origin:0") + ,("transform-origin:left center", "transform-origin:0") + + ,("transform-origin:center", "transform-origin:50%") + ,("transform-origin:center center", "transform-origin:50%") + ,("transform-origin:center 50%", "transform-origin:50%") + ,("transform-origin:50% center", "transform-origin:50%") + ,("transform-origin:50% 50%", "transform-origin:50%") + ,("transform-origin:center center 0", "transform-origin:50%") + ,("transform-origin:center center 1px", "transform-origin:50% 50% 1px") + + ,("transform-origin:left 30px", "transform-origin:0 30px") + ,("transform-origin:30px left", "transform-origin:0 30px") + ,("transform-origin:right 30px", "transform-origin:100% 30px") + ,("transform-origin:30px right", "transform-origin:100% 30px") + ,("transform-origin:bottom 30px", "transform-origin:30px 100%") + ,("transform-origin:30px bottom", "transform-origin:30px 100%") + ,("transform-origin:top 30px", "transform-origin:30px 0") + ,("transform-origin:30px top", "transform-origin:30px 0") + ,("transform-origin:center 30px", "transform-origin:50% 30px") + ,("transform-origin:30px center", "transform-origin:30px") + + -- 3 value syntax + ,("transform-origin:left top 1px", "transform-origin:0 0 1px") + ,("transform-origin:top left 1px", "transform-origin:0 0 1px") + ,("transform-origin:left bottom 1px", "transform-origin:0 100% 1px") + ,("transform-origin:bottom left 1px", "transform-origin:0 100% 1px") + ,("transform-origin:right top 1px", "transform-origin:100% 0 1px") + ,("transform-origin:top right 1px", "transform-origin:100% 0 1px") + ,("transform-origin:right bottom 1px", "transform-origin:100% 100% 1px") + ,("transform-origin:bottom right 1px", "transform-origin:100% 100% 1px") + ,("transform-origin:center bottom 1px", "transform-origin:50% 100% 1px") + ,("transform-origin:bottom center 1px", "transform-origin:50% 100% 1px") + ,("transform-origin:center top 1px", "transform-origin:50% 0 1px") + ,("transform-origin:top center 1px", "transform-origin:50% 0 1px") + ,("transform-origin:center right 1px", "transform-origin:100% 50% 1px") + ,("transform-origin:right center 1px", "transform-origin:100% 50% 1px") + ,("transform-origin:center left 1px", "transform-origin:0 50% 1px") + ,("transform-origin:left center 1px", "transform-origin:0 50% 1px") + + ,("overflow:unset", "overflow:unset") + ,("overflow:initial", "overflow:unset") + ,("overflow:visible", "overflow:unset") + ,("overflow:visible visible", "overflow:unset") + ,("overflow:clip visible", "overflow:clip visible") + ,("overflow:visible clip", "overflow:visible clip") + ,("overflow:clip clip", "overflow:clip") + + ,("overscroll-behavior:unset", "overscroll-behavior:auto") + ,("overscroll-behavior:initial", "overscroll-behavior:auto") + ,("overscroll-behavior:auto", "overscroll-behavior:auto") + ,("overscroll-behavior:auto auto", "overscroll-behavior:auto") + ,("overscroll-behavior:none auto", "overscroll-behavior:none auto") + ,("overscroll-behavior:auto none", "overscroll-behavior:auto none") + ,("overscroll-behavior:contain contain", "overscroll-behavior:contain") + ,("overscroll-behavior:none none", "overscroll-behavior:none") + + ,("border-bottom-left-radius:40% 40%", "border-bottom-left-radius:40%") + ,("border-bottom-right-radius:0 0", "border-bottom-right-radius:0") + ,("border-top-left-radius:initial", "border-top-left-radius:0") + ,("border-top-right-radius:5px 6px", "border-top-right-radius:5px 6px") + + ,("text-emphasis-position:right over", "text-emphasis-position:unset") + ,("text-emphasis-position:over right", "text-emphasis-position:unset") + ,("text-emphasis-position:initial", "text-emphasis-position:unset") + ,("text-emphasis-position:over left", "text-emphasis-position:over left") + ,("text-emphasis-position:right under", "text-emphasis-position:right under") + ] + + +declarationTestsInfo :: [(Text, Text)] +declarationTestsInfo = + [("box-shadow:0 7px 0 #fefefe, 0 14px 0 #fefefe", + "box-shadow:0 7px 0 #fefefe,0 14px 0 #fefefe") + ] + +cleaningTests :: Spec +cleaningTests = + describe "cleaning function" $ + mapM_ (matchSpecWithDesc f) cleaningTestsInfo + where f = (Declarations . clean) <$> declarations + +cleaningTestsInfo :: [(String, Text, Text)] +cleaningTestsInfo = + [("Merge margin with later margin-top", + "margin:0;margin-top:5px", + "margin:5px 0 0") + ,("Merge margin with later margin-right", + "margin:2px;margin-right:1in", + "margin:2px 1in 2px 2px") + ,("Merge margin with later margin-bottom", + "margin:auto;margin-bottom:.2em", + "margin:auto auto .2em") + ,("Merge margin with later margin-left", + "margin:fill;margin-left:9px", + "margin:fill fill fill 9px") + ,("Merge margin with later margin-top, with declaration in-between", + "margin:0;color:red;margin-top:5px", + "margin:5px 0 0;color:red") + ,("Merge margin with later margin-right, with declaration in-between", + "margin:2px;color:red;margin-right:1in", + "margin:2px 1in 2px 2px;color:red") + ,("Merge margin with later margin-bottom, with declaration in-between", + "margin:auto;color:red;margin-bottom:.2em", + "margin:auto auto .2em;color:red") + ,("Merge margin with later margin-left, with declaration in-between", + "margin:fill;color:red;margin-left:9px", + "margin:fill fill fill 9px;color:red") + ,("Drop a margin-top overwritten by a following margin", + "margin-top:5px;margin:0", + "margin:0") + ,("Drop a margin-right overwritten by a following margin", + "margin-right:1px;margin:2px", + "margin:2px") + ,("Drop a margin-bottom overwritten by a following margin", + "margin-bottom:.2em;margin:auto", + "margin:auto") + ,("Drop a margin-left overwritten by a following margin", + "margin-left:9px;margin:fill", + "margin:fill") + ,("Drop a margin-top overwritten by later margin, with a declaration in-between", + "margin-top:5px;padding:0;margin:0", + "padding:0;margin:0") + ,("Drop a margin-right overwritten by later margin, with a declaration in-between", + "margin-right:1px;padding:0;margin:2px", + "padding:0;margin:2px") + ,("Drop a margin-bottom overwritten by later margin, with a declaration in-between", + "margin-bottom:.2em;padding:0;margin:auto", + "padding:0;margin:auto") + ,("Drop a margin-left overwritten by later margin, with a declaration in-between", + "margin-left:9px;padding:0;margin:fill", + "padding:0;margin:fill") + ,("Drop a margin-top overwritten by a later margin-top, with a declaration in-between", + "margin-top:99px;color:red;margin-top:0", + "color:red;margin-top:0") + ,("Drop a margin-right overwritten by a later margin-right, with a declaration in-between", + "margin-right:99px;color:red;margin-right:0", + "color:red;margin-right:0") + ,("Drop a margin-bottom overwritten by a later margin-bottom, with a declaration in-between", + "margin-bottom:99px;color:red;margin-bottom:0", + "color:red;margin-bottom:0") + ,("Drop a margin-left overwritten by a later margin-left, with a declaration in-between", + "margin-left:99px;color:red;margin-left:0", + "color:red;margin-left:0") + ,("Drop a margin-top overwritten by a previous margin-top with !important", + "margin-top:99px!important;margin-top:0", + "margin-top:99px!important") + ,("Drop a margin-right overwritten by a previous margin-right with !important", + "margin-right:99px!important;margin-right:0", + "margin-right:99px!important") + ,("Drop a margin-bottom overwritten by a previous margin-bottom with !important", + "margin-bottom:99px!important;margin-bottom:0", + "margin-bottom:99px!important") + ,("Drop a margin-left overwritten by a previous margin-left with !important", + "margin-left:99px!important;margin-left:0", + "margin-left:99px!important") + ,("Drop a margin-top overwritten by a previous margin-top with !important, with a declaration in-between", + "margin-top:99px!important;margin:auto;margin-top:0", + "margin-top:99px!important;margin:auto") + ,("Drop a margin-right overwritten by a previous margin-right with !important, with a declaration in-between", + "margin-right:99px!important;margin:auto;margin-right:0", + "margin-right:99px!important;margin:auto") + ,("Drop a margin-bottom overwritten by a previous margin-bottom with !important, with a declaration in-between", + "margin-bottom:99px!important;margin:auto;margin-bottom:0", + "margin-bottom:99px!important;margin:auto") + ,("Drop a margin-left overwritten by a previous margin-left with !important, with a declaration in-between", + "margin-left:99px!important;margin:auto;margin-left:0", + "margin-left:99px!important;margin:auto") + -- ,("When merging, translate initial keyword to the initial value", + -- "margin:0;margin-top:initial", + -- "margin:0") + -- ,("When merging, translate unset keyword of a property that inherits to the initial value", + -- "margin:0;margin-top:unset", + -- "margin:0") + -- ,("Don't merge properties with inherit keyword", + -- "margin:0;margin-top:inherit", + -- "margin:0;margin-top:inherit") + ] + +minifyDecTests :: Spec +minifyDecTests = + describe "minifyDec function" $ + mapM_ (matchSpec (minifyWithTestConfig <$> declaration)) minifyDecTestsInfo + +shorthandInitialValuesTests :: Spec +shorthandInitialValuesTests = do + testMatches "background minification" backgroundTestsInfo + testMatches "transition minification" transitionTestsInfo + testMatches "animation minification" animationTestsInfo + testMatches "font minification" fontTestsInfo + testMatches "outline minification" outlineTestsInfo + anyOrderShorthandTests + where testMatches :: String -> [(String, Text, Text)] -> SpecWith () + testMatches desc i = describe desc $ + mapM_ (matchSpecWithDesc (minifyWithTestConfig <$> declaration)) i + +backgroundTestsInfo :: [(String, Text, Text)] +backgroundTestsInfo = + [("Does not remove from background when the cannot be removed", + "background: 0 0 / 3px", "background:0 0/3px") + ,("Removes when it is the default and no is present", + "background: #fff 0 0", "background:#fff") + ,("Removes both and when they are the default", + "background: #fff 0 0/auto", "background:#fff") + ,("Removes background-clip keyword when it equals the background-origin keyword", + "background: border-box #fff border-box", "background:border-box #fff") + ,("Removes the keywords for background-origin and background-clip when both are the initial ones", + "background: #fff padding-box border-box", "background:#fff") + ,("Removes the background-attachment keyword when it is the initial one", + "background: #fff scroll", "background:#fff") + ,("Removes the background-color value when it is the initial one", + "background: url(img.png) transparent", "background:url(img.png)") + ,("Removes background-image when it is the default (i.e. none)", + "background: none #fff", "background:#fff") + ,("Removes background-repeat when it is the default (i.e. repeat)", + "background: repeat #fff", "background:#fff") + ] + +transitionTestsInfo :: [(String, Text, Text)] +transitionTestsInfo = + [("Removes transition-duration when it is the default", + "transition: ease-out some-property 0s", "transition:ease-out some-property") + ,("Removes transition-delay when it is the default", + "transition: ease-out 1s some-property 0s", "transition:ease-out 1s some-property") + ,("Leaves an initial (i.e. 0s) transition-duration when the transition-delay is not initial (i.e. also 0s)", + "transition: all 0s 1s ease", "transition:0s 1s") + ,("Removes transition-timing-function when it is the default", + "transition: some-property 1s ease", "transition:1s some-property") + ,("Removes transition-property when it is the default", + "transition: ease-out all 1s", "transition:ease-out 1s") + ,("Leaves only 0s when every present value is initial", + "transition: all 0s 0s ease", "transition:0s") + ] + +animationTestsInfo :: [(String, Text, Text)] +animationTestsInfo = + [("Removes default animation-fill-mode when the animation-name doesn't overlap with its keywords", + "animation:none animName", "animation:animName") + ,("Leaves default animation-fill-mode when the animation-name overlaps with one of its keywords", + "animation:none backwards", "animation:none backwards") + ,("Removes default animation-fill-mode and default animation-name when both are used simultaneously", + "animation:ease-out none none", "animation:ease-out") + ,("Removes default animation-timing-function", + "animation:animName ease", "animation:animName") + ,("Removes default animation-duration", + "animation:0s ease-out", "animation:ease-out") + ,("Removes default animation-delay", + "animation:1s 0s ease-out", "animation:1s ease-out") + ,("Leaves default animation-duration when animation-delay is not the default", + "animation:0s 1s ease-out", "animation:0s 1s ease-out") + ,("Removes default animation-iteration-count", + "animation:1 ease-out", "animation:ease-out") + ,("Removes default animation-direction when the animation-name doesn't overlap with its keywords", + "animation:normal animName", "animation:animName") + ,("Leaves default animation-direction when the animation-name overlaps with one of its keywords", + "animation:normal alternate", "animation:normal alternate") + ,("Removes default animation-play-state when the animation-name doesn't overlap with its keywords", + "animation:running animName", "animation:animName") + ,("Leaves default animation-play-state when the animation-name overlaps with one of its keywords", + "animation:running paused", "animation:running paused") + ] + +fontTestsInfo :: [(String, Text, Text)] +fontTestsInfo = + [("Removes default font-style", + "font:normal condensed bolder small-caps 9px/1 sans", "font:small-caps bolder condensed 9px/1 sans") + ,("Removes default font-variant", + "font:normal italic condensed bolder 9px/1 sans", "font:italic bolder condensed 9px/1 sans") + ,("Removes default font-weight", + "font:italic normal condensed small-caps 9px/1 sans", "font:italic small-caps condensed 9px/1 sans") + ,("Converts bold font-weight into 700", + "font:bold 9px sans", "font:700 9px sans") + ,("Removes default font-stretch", + "font:italic normal small-caps bolder 9px/1 sans", "font:italic small-caps bolder 9px/1 sans") + ,("Removes default line-height", + "font:9px/normal sans", "font:9px sans") + ,("Lowercases and removes quotes from font-family values", + "font:9px 'Arial Black', \"sans-serif\", sans", "font:9px arial black,\"sans-serif\",sans") + ] + +-- Tests for the removal of outline initial values. Almost identical to those +-- shorthands in the anyOrderShorthandTests, except for the invert color. +outlineTestsInfo :: [(String, Text, Text)] +outlineTestsInfo = + [("Removes default outline-color", + "outline:invert solid 1px", "outline:solid 1px") + ,("Removes default outline-style", + "outline:#fff none 1px", "outline:#fff 1px") + ,("Removes default outline-width", + "outline:#fff solid medium", "outline:#fff solid") + ,("Leaves none as the shortest initial value", + "outline:invert", "outline:none") + ] + +-- Tests for shorthands whose initial values are "medium none currentColor", +-- and can go on any order. +anyOrderShorthandTests :: Spec +anyOrderShorthandTests = + describe "Shorthands that accept values in any order (mostly: medium none currentColor)" $ + traverse_ (mapM_ (matchSpec (minifyWithTestConfig <$> declaration))) d + where d = fmap f shorthandsToTest + f z = fmap (\(x,y) -> (z <> ":" <> x, z <> ":" <> y)) shorthandEquivalences + shorthandsToTest = ["border" + ,"border-top" + ,"border-right" + ,"border-bottom" + ,"border-left" + ,"column-rule"] + shorthandEquivalences = [("initial", "none") + ,("unset", "none") + ,("none", "none") + ,("medium", "none") + ,("currentColor", "none") + ,("medium none", "none") + ,("medium currentColor", "none") + ,("none currentColor", "none") + ,("medium none currentColor", "none") + ,("medium none red", "red") + ,("thick none currentColor", "thick") + ,("thick dotted currentColor", "thick dotted")] + +minifyDecTestsInfo :: [(Text, Text)] +minifyDecTestsInfo = + [("BORDER-bottom: initial", "border-bottom:none") + ,("BORDER-bottom: unset", "border-bottom:none") + ,("BORDER-bottom: none", "border-bottom:none") + ,("BORDER-bottom: medium", "border-bottom:none") + ,("BORDER-bottom: currentColor", "border-bottom:none") + ,("BORDER-bottom: medium none", "border-bottom:none") + ,("BORDER-bottom: medium currentColor", "border-bottom:none") + ,("BORDER-bottom: none currentColor", "border-bottom:none") + ,("BORDER-bottom: medium none currentColor", "border-bottom:none") + ,("BORDER-bottom: medium none red", "border-bottom:red") + ,("BORDER-bottom: thick none currentColor", "border-bottom:thick") + ,("BORDER-bottom: thick dotted currentColor", "border-bottom:thick dotted") + ,("BORDER-bottom: 12px red", "border-bottom:9pt red") +-- widows inherits, and its initial value is 2 + ,("widows: unset", "widows:unset") + ,("widows: inherit", "widows:unset") + ,("widows: initial", "widows:2") +-- font-synthesis inherits, and its initial value is "weight style", +-- which are two keywords, both needed, in any order. + ,("font-synthesis: unset", "font-synthesis:unset") + ,("font-synthesis: inherit", "font-synthesis:unset") + ,("font-synthesis: initial", "font-synthesis:initial") + ,("Font-synthesis: weight style", "font-synthesis:initial") + ,("font-synthesis: style weight", "font-synthesis:initial") + ,("font-synthesis: weight", "font-synthesis:weight") + ,("font-synthesis: style", "font-synthesis:style") +-- background-size: The first value gives the width of the corresponding image, +-- the second value its height. Its initial value is 'auto', and it doesn't +-- inherit. If only one value is given the second is assumed to be ‘auto’. + ,("background-size: 96px", "background-size:6pc") + ,("background-size: auto", "background-size:auto") + ,("background-size: unset", "background-size:auto") + ,("background-size: initial", "background-size:auto") + ,("background-size: auto auto", "background-size:auto") + ,("background-size: auto 96px", "background-size:auto 6pc") + ,("background-size: 96px auto", "background-size:6pc") + ] + +spec :: Spec +spec = do cleaningTests + minifyDecTests + shorthandInitialValuesTests + declarationTests + propertySpecificTests + +main :: IO () +main = hspec spec