{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : Hasmin.Types.Declaration -- Copyright : (c) 2017 Cristian Adrián Ontivero -- License : BSD3 -- Stability : experimental -- Portability : unknown -- ----------------------------------------------------------------------------- module Hasmin.Types.Declaration ( Declaration(..) , clean ) where import Control.Monad.Reader (Reader, ask) import Control.Arrow (first) import Control.Monad ((>=>)) import Data.Map.Strict (Map) import Data.Monoid ((<>)) import Data.Foldable (toList) import Data.Maybe (fromMaybe) import Data.Sequence (Seq, (|>)) import Data.List (find, delete, minimumBy, (\\)) import Data.Text (Text) import Data.Text.Lazy.Builder (singleton, fromText) import qualified Data.Map.Strict as Map import qualified Data.Text as T import Hasmin.Config import Hasmin.Properties import Hasmin.Types.BgSize import Hasmin.Types.Class import Hasmin.Types.Dimension import Hasmin.Types.Numeric import Hasmin.Types.PercentageLength import Hasmin.Types.Position import Hasmin.Types.TransformFunction import Hasmin.Types.Value import Hasmin.Utils data Declaration = Declaration { propertyName :: Text , valueList :: Values , isImportant :: Bool -- ends with !important , hasIEhack :: Bool -- ends with \9 } deriving (Eq, Show) instance ToText Declaration where toBuilder (Declaration p vs i h) = fromText p <> singleton ':' <> toBuilder vs <> imp <> (if h then " \\9" else mempty) where imp | i = "!important" | otherwise = mempty instance Minifiable Declaration where minifyWith d@(Declaration p vs _ _) = do minifiedValues <- minifyWith vs conf <- ask let name = case letterCase conf of Lowercase -> T.toLower p Original -> p newDec = d {propertyName = name, valueList = minifiedValues } case Map.lookup (T.toCaseFold p) propertyOptimizations of Just f -> propertyTraits newDec >>= f Nothing -> propertyTraits newDec propertyTraits :: Declaration -> Reader Config Declaration propertyTraits d@(Declaration p _ _ _) = do conf <- ask pure $ if shouldUsePropertyTraits conf then case Map.lookup (T.toCaseFold p) propertiesTraits of Just (vals, inhs) -> minifyDec d vals inhs Nothing -> d else d -- Map relating properties with specific functions to optimize them propertyOptimizations :: Map Text (Declaration -> Reader Config Declaration) propertyOptimizations = Map.fromList [("transform", combineTransformFunctions) ,("-webkit-transform", combineTransformFunctions) ,("-moz-transform", combineTransformFunctions) -- ,("font", optimizeValues optimizeFontFamily) ,("font-family", optimizeValues optimizeFontFamily) ,("font-weight", fontWeightOptimizer) ,("background-size", nullPercentageToLength) ,("width", nullPercentageToLength) ,("perspective-origin", nullPercentageToLength) ,("-o-perspective-origin", nullPercentageToLength) ,("-moz-perspective-origin", nullPercentageToLength) ,("-webkit-perspective-origin", nullPercentageToLength) ,("background-position", nullPercentageToLength) ,("top", nullPercentageToLength) ,("right", nullPercentageToLength) ,("bottom", nullPercentageToLength) ,("left", nullPercentageToLength) ,("border-color", pure . reduceTRBL) ,("border-width", pure . reduceTRBL) ,("border-style", pure . reduceTRBL) ,("padding", nullPercentageToLength >=> pure . reduceTRBL) ,("padding-top", nullPercentageToLength) ,("padding-right", nullPercentageToLength) ,("padding-bottom", nullPercentageToLength) ,("padding-left", nullPercentageToLength) ,("margin-top", nullPercentageToLength) ,("margin-right", nullPercentageToLength) ,("margin-bottom", nullPercentageToLength) ,("margin-left", nullPercentageToLength) ,("margin", nullPercentageToLength >=> pure . reduceTRBL) ,("grid-row-gap", nullPercentageToLength) ,("grid-column-gap", nullPercentageToLength) ,("line-height", nullPercentageToLength) ,("min-height", nullPercentageToLength) ,("max-width", nullPercentageToLength) ,("min-width", nullPercentageToLength) ,("text-indent", nullPercentageToLength) ,("text-transform", nullPercentageToLength) ,("font-size", nullPercentageToLength) ,("word-spacing", nullPercentageToLength >=> replaceWithZero "normal") ,("vertical-align", nullPercentageToLength >=> replaceWithZero "baseline") -- ,("outline", replaceWithZero "none") -- ,("border", replaceWithZero "none") -- ,("background", replaceWithZero "0 0") ,("transform-origin", optimizeTransformOrigin >=> nullPercentageToLength) ,("-o-transform-origin", optimizeTransformOrigin >=> nullPercentageToLength) ,("-moz-transform-origin", optimizeTransformOrigin >=> nullPercentageToLength) ,("-ms-transform-origin", optimizeTransformOrigin >=> nullPercentageToLength) ,("-webkit-transform-origin", optimizeTransformOrigin >=> nullPercentageToLength) ] -- Generic function to map some optimization to a property's values. optimizeValues :: (Value -> Reader Config Value) -> Declaration -> Reader Config Declaration optimizeValues f d@(Declaration _ vs _ _) = do newV <- mapValues f vs pure $ d {valueList = newV } -- converts 0% into 0 (of type ) -- Do NOT use it with height and max-height, since 0% /= 0 nullPercentageToLength :: Declaration -> Reader Config Declaration nullPercentageToLength d = do conf <- ask if shouldConvertNullPercentages conf then optimizeValues f d else pure d where f :: Value -> Reader Config Value f (PositionV p@(Position _ a _ b)) = pure . PositionV $ let stripPercentage Nothing = Nothing stripPercentage (Just x) = if isZero x then l0 else Just x in p { offset1 = stripPercentage a, offset2 = stripPercentage b } f (PercentageV p) = pure $ zeroPercentageToLength p where zeroPercentageToLength :: Percentage -> Value zeroPercentageToLength 0 = DistanceV (Distance 0 Q) zeroPercentageToLength x = PercentageV x f (BgSizeV (BgSize x y)) = pure . BgSizeV $ BgSize (zeroPerToLength x) (fmap zeroPerToLength y) where zeroPerToLength (Left (Left 0)) = Left $ Right (Distance 0 Q) zeroPerToLength z = z f x = pure x -- For word-spacing, normal computes to 0. -- For vertical-align, baseline is the same as 0. -- -- Careful: don't apply it for letter-spacing because there is a slight -- difference between normal and 0 for that property! replaceWithZero :: Text -> Declaration -> Reader Config Declaration replaceWithZero s d@(Declaration p (Values v vs) _ _) | not (null vs) = pure d -- Some error occured, since there should be only one value | otherwise = case Map.lookup (T.toCaseFold p) propertiesTraits of Just (iv, inhs) -> if f iv inhs == mkOther s then pure $ d { valueList = Values (DistanceV (Distance 0 Q)) [] } else pure d Nothing -> pure d where f (Just (Values x _)) inh | v == Initial || v == Unset && not inh = x | otherwise = v f _ _ = v -- 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 f x@(Other t) = do conf <- ask pure $ case fontweightSettings conf of FontWeightMinOn -> replaceForSynonym t FontWeightMinOff -> x f x = pure x replaceForSynonym :: TextV -> Value replaceForSynonym t | t == TextV "normal" = NumberV 400 | t == TextV "bold" = NumberV 700 | otherwise = Other t optimizeTransformOrigin :: Declaration -> Reader Config Declaration optimizeTransformOrigin d@(Declaration _ v _ _) = do conf <- ask pure $ if shouldMinifyTransformOrigin conf then d { valueList = optimizeTransformOrigin' v} else d 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 (DistanceV (Distance 0 Q)) = True isZeroVal (NumberV (Number 0)) = True isZeroVal (PercentageV 0) = True isZeroVal _ = False transformOrigin1 :: Value -> [Value] transformOrigin1 (Other "top") = [Other "top"] transformOrigin1 (Other "bottom") = [Other "bottom"] transformOrigin1 (Other "right") = [PercentageV (Percentage 100)] transformOrigin1 (Other "left") = [DistanceV (Distance 0 Q)] transformOrigin1 (Other "center") = [PercentageV (Percentage 50)] transformOrigin1 (PercentageV 0) = [DistanceV (Distance 0 Q)] 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 | equalsCenter y = [per50] | isYoffsetKeyword y = [y] | y == per100 = [Other "bottom"] | isZeroVal y = [Other "top"] | isPercentageOrDistance y = [per50, y] | otherwise = transformOrigin1 y secondIsCenter | equalsCenter x = [per50] | isYoffsetKeyword x || isPercentageOrDistance x = [x] | otherwise = transformOrigin1 x isPercentageOrDistance (PercentageV _) = True isPercentageOrDistance (DistanceV _) = True isPercentageOrDistance _ = False equalsCenter a = a == Other "center" || a == per50 isXoffsetKeyword a = a == Other "left" || a == Other "right" isYoffsetKeyword a = a == Other "top" || a == Other "bottom" per50 = PercentageV $ Percentage 50 per100 = PercentageV $ Percentage 100 convertValue (Other t) = fromMaybe (Other t) (Map.lookup (getText t) transformOriginKeywords) convertValue n@(PercentageV p) = if p == 0 then DistanceV (Distance 0 Q) else 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 replaceKeywords (Other t) = fromMaybe x (Map.lookup (getText t) transformOriginKeywords) replaceKeywords e = e -- transform-origin keyword meanings. transformOriginKeywords :: Map Text Value transformOriginKeywords = Map.fromList [("top", DistanceV (Distance 0 Q)) ,("right", PercentageV (Percentage 100)) ,("bottom", PercentageV (Percentage 100)) ,("left", DistanceV (Distance 0 Q)) ,("center", PercentageV (Percentage 50))] -- | Minifies a declaration, based on the property's specific traits (i.e. if -- it inherits or not, and what its initial value is), and the chosen -- configurations. minifyDec :: Declaration -> Maybe Values -> Bool -> Declaration minifyDec d@(Declaration p vs _ _) mv inherits = case mv of -- Use the found initial values to try to reduce the declaration Just vals -> 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 inherits Nothing -> reduceDeclaration d vals inherits -- Property with no defined initial values. Try to reduce css-wide keywords Nothing -> if not inherits && vs == initial || inherits && vs == inherit then d { valueList = unset } else d unset :: Values unset = Values Unset mempty initial :: Values initial = Values Initial mempty inherit :: Values inherit = Values Inherit mempty -- Map of property specific reducers, for properties that don't fit in the -- normal declaration minification scheme and need special treatment. declarationExceptions :: Map Text (Declaration -> Values -> Bool -> 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) ] 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 -> Bool -> Declaration backgroundSizeReduce d@(Declaration _ vs _ _) initVals inherits = case valuesToList vs of [v1,v2] -> if v2 == mkOther "auto" then d { valueList = mkValues [v1] } else d _ -> d { valueList = shortestEquiv vs initVals inherits } fontSynthesisReduce :: Declaration -> Values -> Bool -> Declaration fontSynthesisReduce d@(Declaration _ vs _ _) initVals inherits = case valuesToList initVals \\ valuesToList vs of [] -> d {valueList = initial} -- "initial" is shorter than "weight style" _ -> d {valueList = shortestEquiv vs initVals inherits} -- 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). reduceDeclaration :: Declaration -> Values -> Bool -> Declaration reduceDeclaration d@(Declaration _ vs _ _) initVals inherits = case analyzeValueDifference vs initVals of Just v -> d {valueList = shortestEquiv v shortestInitialValue inherits} Nothing -> d {valueList = minVal inherits shortestInitialValue} where comparator x y = compare (textualLength x) (textualLength y) shortestInitialValue = mkValues [minimumBy comparator (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 -> Bool -> Values shortestEquiv vs siv inherits | inherits && vs == inherit = unset | not inherits && vs == unset || vs == initial = minVal inherits siv | otherwise = vs -- Returns the minimum value (in character length) between the shortest initial -- value, and the shortest css-wide keyword (initial or unset) minVal :: Bool -> Values -> Values minVal inherits vs | textualLength globalKeyword <= textualLength vs = globalKeyword | otherwise = vs where globalKeyword = mkValues [if not inherits 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. analyzeValueDifference :: Values -> Values -> Maybe Values analyzeValueDifference vs initVals = case valuesDifference of [] -> Nothing -- every value was an initial one _ -> Just $ mkValues valuesDifference -- At least a value wasn't an initial one, or it was a css-wide keyword where valuesDifference = valuesToList vs \\ valuesToList initVals -- Removes longhand rules overwritten by their shorthand further down in the -- declaration list, and merges shorthand declarations with longhand properties -- later declared. clean :: [Declaration] -> [Declaration] clean [] = [] clean (d:ds) = let (newD, newDs) = solveClashes ds d pinfo in case newD of Just x -> x : clean newDs Nothing -> clean newDs -- drop and keep cleaning where pinfo = fromMaybe (PropertyInfo mempty mempty) -- No info on the property, use an empty one. (Map.lookup (propertyName d) shorthandAndLonghandsMap) -- Given a declaration, if it is a shorthand and it has a corresponding -- longhand later in the list, merges them. If it is a longhand overwritten by -- a shorthand, it deletes it. Otherwise, it keeps the value. In any case, it -- returns the new list to analyze and (if any) the value to keep. solveClashes :: [Declaration] -> Declaration -> PropertyInfo -> (Maybe Declaration, [Declaration]) solveClashes ds = solveClashes' ds ds -- Local function, only to be called by solveClashes solveClashes' :: [Declaration] -> [Declaration] -> Declaration -> PropertyInfo -> (Maybe Declaration, [Declaration]) solveClashes' newDs [] dec _ = (Just dec, newDs) solveClashes' newDs (laterDec:ds) dec pinfo -- Do not remove vendor-prefixed values, which are probably fallbacks. | hasVendorPrefix dec = (Just dec, newDs) | hasVendorPrefix laterDec || hasIEhack dec /= hasIEhack laterDec = solveClashes' newDs ds dec pinfo | propertyName laterDec `elem` subproperties pinfo = attemptMerge newDs ds dec laterDec pinfo | propertyName laterDec `elem` overwrittenBy pinfo = if isImportant dec && (not . isImportant) laterDec -- important LH with a non-important SH later, or only one of the -- two has the \9 ie hack; keep analyzing then solveClashes' newDs ds dec pinfo -- longhand overwritten by a shorthand; drop it else (Nothing, newDs) | propertyName dec == propertyName laterDec = {- && dec can be dropped (consider background-image!) -} if isImportant dec && (not . isImportant) laterDec -- drop non-important one; keep analyzing then solveClashes' (delete laterDec newDs) ds dec pinfo -- same property twice, drop the overwritten one else (Nothing, newDs) | otherwise = solveClashes' newDs ds dec pinfo -- keep analyzing the rest hasVendorPrefix :: Declaration -> Bool hasVendorPrefix (Declaration _ vs _ _) = any isVendorPrefixedValue $ valuesToList vs isVendorPrefixedValue :: Value -> Bool isVendorPrefixedValue (Other t) = T.isPrefixOf "-" $ getText t isVendorPrefixedValue (GradientV t _) = T.isPrefixOf "-" t isVendorPrefixedValue (GenericFunc t _) = T.isPrefixOf "-" t isVendorPrefixedValue _ = False attemptMerge :: [Declaration] -> [Declaration] -> Declaration -> Declaration -> PropertyInfo -> (Maybe Declaration, [Declaration]) attemptMerge newDs ds dec laterDec pinfo = case merge dec laterDec of -- Put the merged result back on the list; see if any other -- property also conflicts Just m -> (Nothing, m : delete dec (delete laterDec newDs)) -- Couldn't merge, just keep analyzing Nothing -> solveClashes' newDs ds dec pinfo -- TODO: make it such that the order of parameters doesn't matter -- First declaration = shorthand merge :: Declaration -> Declaration -> Maybe Declaration merge d1@(Declaration p1 _ _ _) d2@Declaration{} = do mergeFunction <- Map.lookup p1 propertyMergers mergeFunction d1 d2 where propertyMergers :: Map Text (Declaration -> Declaration -> Maybe Declaration) propertyMergers = Map.fromList [("margin", mergeIntoTRBL) ,("padding", mergeIntoTRBL) ,("border-color", mergeIntoTRBL) ,("border-width", mergeIntoTRBL) ,("border-style", mergeIntoTRBL) --,("animation", --,("background", --,("background-position", --,("border", --,("border-bottom", --,("border-image", --,("border-left", --,("border-radius" --,("border-right", --,("border-top" --,("column-rule", --,("columns", --,("flex", --,("flex-flow", --,("font", --,("grid", --,("grid-area" --,("grid-column" --,("grid-gap", --,("grid-row", --,("grid-template", --,("list-style", --,("mask", --,("outline", --,("padding", --,("text-decoration", --,("text-emphasis" --,("transition", ] -- TODO: consider the check in retDec. We aren't taking the minified length, -- only the one as it is. Ideally, it would take the length of the minified -- result, according to the program arguments. mergeIntoTRBL :: Declaration -- ^ A margin declaration -> Declaration -- ^ Any of the margin longhands (e.g.: margin-top) -> Maybe Declaration -- ^ If successful, the combination of both mergeIntoTRBL d1@(Declaration _ (Values v1 vs) i1 h1) d2@(Declaration p2 (Values v2 _) i2 h2) | h1 || h2 = Nothing -- TODO handle ie hacks | i1 && not i2 = Just $ reduceTRBL d1 -- margin:6px !important;margin-top:0; --> margin:6px !important | not i1 && i2 = Nothing -- margin:6px;margin-top:0!important; --> stays the same | otherwise = do (_,index) <- find (\(x,_) -> T.isInfixOf x (T.toCaseFold p2)) indexTable let mkDec ys = d1 {valueList = mkValues $ replaceAt index v2 ys} retDec ys = let mergedDec = reduceTRBL (mkDec ys) in if textualLength mergedDec <= originalLength then Just mergedDec else Nothing case trblValues of [_,_,_,_] -> retDec trblValues [t,r,b] -> retDec [t,r,b,r] [t,r] -> retDec [t,r,t,r] [t] -> retDec [t,t,t,t] _ -> Nothing -- E.g.: an iehack read as a value. where originalLength = textualLength d1 + textualLength d2 + 1 -- The (+1) is because of the ; trblValues = v1 : map snd vs indexTable = fmap (first T.toCaseFold) [("top", 0) ,("right", 1) ,("bottom", 2) ,("left", 3)] -- E.g.: margin: 6px 6px 6px 6px; --> margin: 6px; -- margin: 1px 0 2px 0; --> margin: 1px 0 2px; -- can be used with "border-image-outset" too. reduceTRBL :: Declaration -> Declaration reduceTRBL d@(Declaration _ (Values v1 vs) _ _) = case v1:map snd vs of [t,r,b,l] -> reduce4 t r b l [t,r,b] -> reduce3 t r b [t,r] -> reduce2 t r _ -> d where reduce4 tv rv bv lv | lv == rv = reduce3 tv rv bv | otherwise = d reduce3 tv rv bv | tv == bv = reduce2 tv rv | otherwise = d { valueList = mkValues [tv, rv, bv] } reduce2 tv rv | tv == rv = d { valueList = mkValues [tv] } | otherwise = d { valueList = mkValues [tv, rv] } mapValues :: (Value -> Reader Config Value) -> Values -> Reader Config Values mapValues f (Values v1 vs) = do x <- f v1 xs <- (mapM . mapM) f vs pure $ Values x xs