hasmin (empty) → 0.3.0.1
raw patch · 47 files changed
+8800/−0 lines, 47 filesdep +QuickCheckdep +attoparsecdep +basesetup-changed
Dependencies added: QuickCheck, attoparsec, base, bytestring, containers, doctest, doctest-discover, gitrev, hasmin, hopfli, hspec, hspec-attoparsec, mainland-pretty, matrix, mtl, numbers, optparse-applicative, parsers, semigroups, text
Files
- LICENSE +26/−0
- Main.hs +119/−0
- README.md +50/−0
- Setup.hs +2/−0
- hasmin.cabal +132/−0
- src/Hasmin.hs +71/−0
- src/Hasmin/Config.hs +95/−0
- src/Hasmin/Parser/Internal.hs +499/−0
- src/Hasmin/Parser/Utils.hs +125/−0
- src/Hasmin/Parser/Value.hs +1184/−0
- src/Hasmin/Properties.hs +501/−0
- src/Hasmin/Selector.hs +339/−0
- src/Hasmin/Types/BgSize.hs +52/−0
- src/Hasmin/Types/Class.hs +47/−0
- src/Hasmin/Types/Color.hs +510/−0
- src/Hasmin/Types/Declaration.hs +555/−0
- src/Hasmin/Types/Dimension.hs +362/−0
- src/Hasmin/Types/FilterFunction.hs +103/−0
- src/Hasmin/Types/Gradient.hs +309/−0
- src/Hasmin/Types/Numeric.hs +118/−0
- src/Hasmin/Types/PercentageLength.hs +39/−0
- src/Hasmin/Types/Position.hs +214/−0
- src/Hasmin/Types/RepeatStyle.hs +76/−0
- src/Hasmin/Types/Shadow.hs +59/−0
- src/Hasmin/Types/String.hs +117/−0
- src/Hasmin/Types/Stylesheet.hs +253/−0
- src/Hasmin/Types/TimingFunction.hs +115/−0
- src/Hasmin/Types/TransformFunction.hs +580/−0
- src/Hasmin/Types/Value.hs +454/−0
- src/Hasmin/Utils.hs +67/−0
- tests/DocTest.hs +6/−0
- tests/Hasmin/Parser/InternalSpec.hs +207/−0
- tests/Hasmin/Parser/ValueSpec.hs +120/−0
- tests/Hasmin/SelectorSpec.hs +58/−0
- tests/Hasmin/TestUtils.hs +28/−0
- tests/Hasmin/Types/ColorSpec.hs +155/−0
- tests/Hasmin/Types/DeclarationSpec.hs +446/−0
- tests/Hasmin/Types/DimensionSpec.hs +56/−0
- tests/Hasmin/Types/FilterFunctionSpec.hs +56/−0
- tests/Hasmin/Types/GradientSpec.hs +89/−0
- tests/Hasmin/Types/PositionSpec.hs +138/−0
- tests/Hasmin/Types/RepeatStyleSpec.hs +32/−0
- tests/Hasmin/Types/ShadowSpec.hs +45/−0
- tests/Hasmin/Types/StringSpec.hs +55/−0
- tests/Hasmin/Types/StylesheetSpec.hs +66/−0
- tests/Hasmin/Types/TransformFunctionSpec.hs +69/−0
- tests/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2017 Cristian Adrián Ontivero++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Main.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE TemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- Module : Main+-- Copyright : (c) 2017 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : non-portable+--+-----------------------------------------------------------------------------+module Main where++import Codec.Compression.Hopfli+import Control.Monad.Reader+import Data.Monoid ((<>))+import Data.Attoparsec.Text (parseOnly)+import Data.Text.Lazy.Builder (toLazyText)+import Options.Applicative hiding (command)+import Data.Version (showVersion)+import Development.GitRev (gitHash)+import Paths_hasmin (version)+import qualified Data.ByteString as B+import qualified Data.Text.Encoding as TE+import qualified Data.Text.IO as TIO+import qualified Data.Text.Lazy as TL+import System.Exit (die)+import Text.PrettyPrint.Mainland (line, punctuate, putDoc, ppr)+import Hasmin.Config+import Hasmin.Parser.Internal+import Hasmin.Types.Class+import Hasmin.Types.Stylesheet++command :: Parser Commands+command = Commands <$> switch (long "beautify"+ <> short 'b' <> help "Beautify output")+ <*> switch (long "zopfli"+ <> short 'z' <> help "Compress result using zopfli")+ <*> argument str (metavar "FILE")++config :: Parser Config+config = Config+ <$> flag ColorMinOn ColorMinOff (long "no-color-min"+ <> short 'c'+ <> help "Disable <color> minification")+ <*> flag DimMinOff DimMinOn (long "dimension-min"+ <> short 'd'+ <> help "Enable normalization of absolute dimensions")+ <*> flag GradientMinOn GradientMinOff (long "-no-gradient-min"+ <> short 'g'+ <> help "Disable <gradient> minification")+ <*> flag True False (long "no-property-traits"+ <> short 't'+ <> help "Disable use of property traits for declaration minification")+ <*> flag True False (long "no-rule-cleaning"+ <> short 'a'+ <> help "Disable deletion of overwritten properties")+ <*> flag True False (long "no-timing-function-min"+ <> help "Disable <timing-function> minifications")+ <*> flag True False (long "no-filter-function-min"+ <> help "Disable <filter-function> minifications")+ <*> flag True False (long "no-quotes-removal"+ <> short 'q'+ <> help "Disable removing quotes whenever possible")+ <*> flag FontWeightMinOn FontWeightMinOff (long "no-font-weight-minification"+ <> help "Disable converting normal to 400 and bold to 700 in font-weight")+ <*> flag True False (long "no-transform-origin-minification"+ <> help "Disable converting left and top to 0%, bottom and right to 100%, and center to 50%")+ <*> flag True False (long "no-microsyntax-min"+ <> short 'm'+ <> 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")+ <*> switch (long "convert-escaped-characters"+ <> help "Convert escaped characters to their UTF-8 equivalent")+ <*> flag True False (long "no-null-percentage-conversion"+ <> help "Disable converting 0% to 0 when possible")+ <*> flag True False (long "no-empty-block-removal"+ <> short 'e'+ <> help "Disable empty block removal")+ <*> flag True False (long "no-duplicate-selector-removal"+ <> help "Disable removal of duplicate selectors")+ <*> flag True False (long "no-quote-normalization"+ <> help "Disable trying to convert all quotation marks to either \" or \'")+ <*> flag Lowercase Original (long "no-lowercasing"+ <> short 'l'+ <> help "Disable lowercasing everything possible")+ <*> flag Lexicographical NoSorting (long "no-selector-sorting"+ <> help "Disable sorting selectors lexicographically")+ <*> flag Lexicographical NoSorting (long "no-property-sorting"+ <> help "Disable sorting properties lexicographically")++instructions :: ParserInfo Instructions+instructions = info (helper <*> versionOption <*> ((,) <$> command <*> config))+ (fullDesc <> header "Hasmin - A Haskell CSS Minifier")+ where versionOption = infoOption (showVersion version <> " " <> $(gitHash))+ (long "version" <> help "Show version and commit hash")++main :: IO ()+main = do+ (comm, conf) <- execParser instructions+ text <- TIO.readFile (file comm)+ case parseOnly stylesheet text of+ Right r -> process r comm conf+ Left e -> die e++process :: [Rule] -> Commands -> Config -> IO ()+process r comm conf+ | shouldBeautify comm = printBeautified $ fmap ppr sheet+ | shouldCompress comm = B.writeFile "output.gz" . compressWith defaultCompressOptions GZIP . TE.encodeUtf8 $ output+ | otherwise = TIO.putStr output+ where sheet = let ruleList = fmap (\x -> runReader (minifyWith x) conf) r+ in if shouldRemoveEmptyBlocks conf+ then filter (not . isEmpty) ruleList+ else ruleList+ output = TL.toStrict . toLazyText $ mconcat (fmap toBuilder sheet)+ printBeautified = putDoc . mconcat . punctuate (line <> line)
+ README.md view
@@ -0,0 +1,50 @@+Hasmin - A Haskell CSS Minifier+====+[](https://travis-ci.org/contivero/hasmin)+[](https://opensource.org/licenses/BSD-3-Clause)++Hasmin is a CSS minifier. To use it as a library, refer to the Hasmin module+documentation.++Aside from the usual techniques (e.g. whitespace removal, color minification,+etc.), the idea was to explore new possibilities, by implementing things+other minifiers weren't doing, or they were, but not taking full advantage of.++Also, the minifier implements some techniques that do nothing for minified+sizes, but attempt to improve post-compression sizes (at least when using+DEFLATE, i.e. gzip).++For a list of techniques, see [Minification Techniques](https://github.com/contivero/hasmin/wiki/Minification-Techniques).++## Building+To compile, just run `stack build`.++## Minifier Usage+Hasmin expects a path to the CSS file, and outputs the minified result to+stdout.++Every technique is enabled by default, except for:+ 1. Escaped character conversions (e.g. converting `\2714` to `✔`, which can be enabled with `--convert-escaped-characters`)+ 2. Dimension minifications (e.g. converting `12px` to `9pt`, which can be enabled with `--dimension-min`, or just `-d`)++These two are disabled mainly because they are—on average, not+always—detrimental for DEFLATE compression. When something needs to be+disabled, use the appropriate flag. Not every technique can be toggled yet, but+a good amount of them allow it.++Note: there is a problem in Windows when using the+`--convert-escaped-characters` flag to enable the conversion of escaped+characters. A workaround is changing the code page, which can be done by running+`chcp 65001` in the terminal (whether cmd, or cygwin).++## Zopfli Integration+Hasmin uses bindings to Google's+[Zopfli library](https://en.wikipedia.org/wiki/Zopfli), allowing the+possibility to compress the result.++Since the output is a gzip file, it can be used for the web. It tipically+produces files 3~8% smaller than zlib, at the cost of being around 80 times+slower, so it is only a good idea if you don't need compression on the fly.+++Zopfli is released under the Apache License, Version 2.0.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ hasmin.cabal view
@@ -0,0 +1,132 @@+name: hasmin +version: 0.3.0.1 +license: BSD3 +license-file: LICENSE +author: (c) 2017 Cristian Adrián Ontivero <cristianontivero@gmail.com> +maintainer: Cristian Adrián Ontivero <cristianontivero@gmail.com> +synopsis: "A CSS Minifier" +homepage: https://github.com/contivero/hasmin/ +bug-reports: https://github.com/contivero/hasmin/issues +category: Text +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 +description: + A CSS minifier which not only aims at reducing the amount of bytes of the + output, but also at improving gzip compression. By default, the output is the + minified CSS file, but hasmin allows also its compression into gzip using + Google's Zopfli library. + . + To use it: ./hasmin input.css > output.css + . + By default, most minification techniques are enabled. For a list of + available flags, do: ./hasmin --help + +source-repository head + type: git + location: https://github.com/contivero/hasmin.git + +executable hasmin + default-language: Haskell2010 + ghc-options: -O2 -Wall -fwarn-tabs -fwarn-unused-do-bind + main-is: Main.hs + other-modules: Paths_hasmin + build-depends: base >=4.8 && <5.1 + , attoparsec >=0.12 && <0.14 + , containers >=0.5 && <0.6 + , optparse-applicative >=0.11 && <0.14 + , parsers >=0.12.3 && <0.13 + , mainland-pretty >=0.4.1 && <0.5 + , text >=1.2 && <1.3 + , hopfli >=0.2 && <0.3 + , bytestring >=0.10.2.0 && <0.11 + , gitrev >=1.0.0 && <=1.2.0 + , matrix >=0.3.4 && <0.4 + , mtl >=2.2.1 && <2.3 + , numbers >=3000.2.0.0 && <3000.3 + , hasmin + +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -O2 -Wall -fwarn-tabs -fwarn-unused-do-bind + exposed-modules: Hasmin + , Hasmin.Config + , Hasmin.Types.Class + , Hasmin.Types.Stylesheet + -- exposed because it is needed by tests: + , Hasmin.Parser.Internal + , Hasmin.Parser.Value + , Hasmin.Types.Color + , Hasmin.Types.Declaration + , Hasmin.Types.Dimension + , Hasmin.Types.Numeric + , Hasmin.Types.TransformFunction + , Hasmin.Types.Value + , Hasmin.Utils + other-modules: Hasmin.Parser.Utils + , Hasmin.Properties + , Hasmin.Selector + , Hasmin.Types.BgSize + , Hasmin.Types.FilterFunction + , Hasmin.Types.Gradient + , Hasmin.Types.PercentageLength + , Hasmin.Types.Position + , Hasmin.Types.RepeatStyle + , Hasmin.Types.Shadow + , Hasmin.Types.String + , Hasmin.Types.TimingFunction + build-depends: base >=4.8 && <5.1 + , attoparsec >=0.12 && <0.14 + , bytestring >=0.10.2.0 && <0.11 + , containers >=0.5 && <0.6 + , mainland-pretty >=0.4.1 && <0.5 + , matrix >=0.3.4 && <0.4 + , mtl >=2.2.1 && <2.3 + , numbers >=3000.2.0.0 && <3000.3 + , parsers >=0.12.3 && <0.13 + , semigroups >=0.16 && <0.19 + , text >=1.2 && <1.3 + +test-suite spec + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Spec.hs + ghc-options: -Wall -fno-warn-orphans + default-extensions: OverloadedStrings + other-modules: Hasmin.Parser.InternalSpec + , Hasmin.Parser.ValueSpec + , Hasmin.SelectorSpec + , Hasmin.TestUtils + , Hasmin.Types.ColorSpec + , Hasmin.Types.DeclarationSpec + , Hasmin.Types.DimensionSpec + , Hasmin.Types.FilterFunctionSpec + , Hasmin.Types.GradientSpec + , Hasmin.Types.PositionSpec + , Hasmin.Types.RepeatStyleSpec + , Hasmin.Types.ShadowSpec + , Hasmin.Types.StringSpec + , Hasmin.Types.StylesheetSpec + , Hasmin.Types.TransformFunctionSpec + build-depends: base >=4.7 && <5.1 + , attoparsec >=0.12 && <0.14 + , hspec >=2.2 && <3.0 + , hspec-attoparsec >=0.1.0.0 && <0.2 + , mtl >=2.2.1 && <2.3 + , QuickCheck >=2.8 && <3.0 + , text >=1.2 && <1.3 + , hasmin + +test-suite doctest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: DocTest.hs + ghc-options: -threaded -Wall -fno-warn-orphans + build-depends: base >=4.8 && <5.1 + , doctest >=0.11 && <0.12 + , doctest-discover >=0.1.0.0 && <0.2 + , doctest >=0.10 + , hasmin
+ src/Hasmin.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module : Hasmin+-- Copyright : (c) 2017 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : unknown+--+-- Recommended module to use the library.+--+-----------------------------------------------------------------------------+module Hasmin (+ -- * Using the library+ -- $use+ minifyCSS+ , minifyCSSWith+ , module Hasmin.Config+ ) where++import Control.Monad.Reader (runReader)+import Data.Attoparsec.Text (parseOnly)+import Data.Text.Lazy.Builder (toLazyText)+import Data.Text (Text)+import qualified Data.Text.Lazy as TL++import Hasmin.Parser.Internal+import Hasmin.Types.Class+import Hasmin.Config++-- | Minify Text, based on a 'Config'. To just use a default set of+-- configurations (i.e. 'defaultConfig'), use 'minifyCSS'.+minifyCSSWith :: Config -> Text -> Either String Text+minifyCSSWith cfg t = do+ sheet <- parseOnly stylesheet t+ pure . TL.toStrict . toLazyText . mconcat $ map f sheet+ where f x = toBuilder $ runReader (minifyWith x) cfg++-- | Minify Text CSS, using a default set of configurations (with most+-- minification techniques enabled).+minifyCSS :: Text -> Either String Text+minifyCSS = minifyCSSWith defaultConfig++-- $use+--+-- This section shows a basic library use case.+--+-- Given a style sheet, say:+--+-- > sampleSheet :: Text+-- > sampleSheet = "body { color: #ff0000 } div { margin: 0 0 0 0 }"+--+-- Minify it with 'minifyCSS'. In ghci:+--+-- > > minifyCSS sampleSheet+-- > Just "body{color:red}div{margin:0}"+--+-- To modify the minification settings, just use another 'Config', e.g.:+--+-- > cfg :: Config+-- > cfg = defaultConfig { colorSettings = ColorMinOff }+--+-- Once more in ghci, this time using 'minifyCSSWith':+--+-- > > minifyStylesheet cfg sampleSheet+-- > Just "body{color:#ff0000}div{margin:0}"+--+-- The output is once more minified, but this time leaving colors as they were+-- originally.+--+-- For the complete list of possible options, refer to 'Config'.
+ src/Hasmin/Config.hs view
@@ -0,0 +1,95 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hasmin.Config+-- Copyright : (c) 2017 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : non-portable+--+-----------------------------------------------------------------------------+module Hasmin.Config (+ Config(..)+ , ColorSettings(..)+ , DimensionSettings(..)+ , GradientSettings(..)+ , FontWeightSettings(..)+ , LetterCase(..)+ , SortingMethod(..)+ , defaultConfig+ , Instructions+ , Commands(..)+ ) where++type Instructions = (Commands, Config)++data Commands = Commands { shouldBeautify :: Bool+ , shouldCompress :: Bool+ , file :: FilePath+ } deriving (Show)++data ColorSettings = ColorMinOff | ColorMinOn+ deriving (Show, Eq)+data DimensionSettings = DimMinOff | DimMinOn+ deriving (Show, Eq)+data GradientSettings = GradientMinOff | GradientMinOn+ deriving (Show, Eq)+data LetterCase = Original -- ^ Leave letter casing as is.+ | Lowercase -- ^ Lowercase whatever possible to improve gzip compression.+ deriving (Show, Eq)+data SortingMethod = NoSorting | Lexicographical+ deriving (Show, Eq)+data FontWeightSettings = FontWeightMinOff | FontWeightMinOn+ deriving (Show, Eq)++-- TODO: * avoid boolean blindness+-- * Use a more declarative style for the names, e.g. shouldLowercase vs.+-- preferredCasing, shouldSortSelectors vs. selectorSorting, etc.+-- | The configuration used for minifying.+data Config = Config { colorSettings :: ColorSettings+ , dimensionSettings :: DimensionSettings+ , gradientSettings :: GradientSettings+ , shouldUsePropertyTraits :: Bool+ , shouldCleanRules :: Bool+ , shouldMinifyTimingFunctions :: Bool+ , shouldMinifyFilterFunctions :: Bool+ , shouldRemoveQuotes :: Bool+ , fontweightSettings :: FontWeightSettings+ , shouldMinifyTransformOrigin :: Bool+ , shouldMinifyMicrosyntax :: Bool+ , shouldMinifyKeyframeSelectors :: Bool+ , shouldMinifyTransformFunction :: Bool+ , shouldConvertEscaped :: Bool+ , shouldConvertNullPercentages :: Bool+ , shouldRemoveEmptyBlocks :: Bool+ , shouldRemoveDuplicateSelectors :: Bool+ , shouldNormalizeQuotes :: Bool+ , letterCase :: LetterCase+ , selectorSorting :: SortingMethod+ , declarationSorting :: SortingMethod+ } deriving (Show)++-- | A default config with most settings enabled. Used by the minify function,+-- mainly for testing purposes.+defaultConfig :: Config+defaultConfig = Config { colorSettings = ColorMinOn+ , dimensionSettings = DimMinOn+ , gradientSettings = GradientMinOn+ , shouldUsePropertyTraits = True+ , shouldCleanRules = True+ , shouldMinifyTimingFunctions = True+ , shouldMinifyFilterFunctions = True+ , shouldRemoveQuotes = True+ , fontweightSettings = FontWeightMinOn+ , shouldMinifyTransformOrigin = True+ , shouldMinifyMicrosyntax = True+ , shouldMinifyKeyframeSelectors = True+ , shouldMinifyTransformFunction = True+ , shouldConvertEscaped = True+ , shouldConvertNullPercentages = True+ , shouldRemoveEmptyBlocks = True+ , shouldRemoveDuplicateSelectors = True+ , shouldNormalizeQuotes = True+ , letterCase = Lowercase+ , selectorSorting = NoSorting+ , declarationSorting = NoSorting+ }
+ src/Hasmin/Parser/Internal.hs view
@@ -0,0 +1,499 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module : Hasmin.Parser.Internal+-- Copyright : (c) 2017 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : unknown+--+-----------------------------------------------------------------------------+module Hasmin.Parser.Internal (+ stylesheet+ , atRule+ , declaration+ , declarations+ , selector+ ) where++import Control.Arrow (first)+import Control.Applicative ((<|>), many)+import Control.Monad (mzero)+import Data.Functor (($>))+import Data.Attoparsec.Combinator (lookAhead, sepBy, endOfInput)+import Data.Attoparsec.Text (asciiCI, char, many1, manyTill,+ option, Parser, satisfy, string)+import Data.List.NonEmpty (NonEmpty( (:|) ))+import Data.Monoid ((<>))+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text.Lazy.Builder as LB+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.Attoparsec.Text as A+import qualified Data.Char as C+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++import Hasmin.Parser.Utils+import Hasmin.Parser.Value+import Hasmin.Selector+import Hasmin.Types.Stylesheet+import Hasmin.Types.Declaration++selector :: Parser Selector+selector = Selector <$> compoundSelector+ <*> many ((,) <$> (combinator <* skipComments) <*> compoundSelector)++-- First tries with '>>' (descendant), '>' (child), '+' (adjacent sibling), and+-- '~' (general sibling) combinators. If those fail, it tries with the+-- descendant (whitespace) combinator. This is done to allow comments in-between.+--+-- | Parser for selector combinators, i.e. ">>" (descendant), '>' (child), '+'+-- (adjacent sibling), '~' (general sibling), and ' ' (descendant) combinators.+combinator :: Parser Combinator+combinator = (skipComments *> ((string ">>" $> Descendant)+ <|> (char '>' $> Child)+ <|> (char '+' $> AdjacentSibling)+ <|> (char '~' $> GeneralSibling)))+ <|> (satisfy ws $> Descendant)+ where ws c = c == ' ' || c == '\t' || c == '\n' || c == '\r' || c == '\f'++compoundSelector :: Parser CompoundSelector+compoundSelector =+ (:|) <$> (typeSelector <|> universal)+ <*> many p+ <|> ((Universal mempty :|) <$> many1 p)+ where p = idSel <|> classSel <|> attributeSel <|> pseudo++idSel :: Parser SimpleSelector+idSel = do+ _ <- char '#'+ name <- mconcat <$> many1 nmchar+ pure $ IdSel (TL.toStrict (toLazyText name))++-- class: '.' IDENT+classSel :: Parser SimpleSelector+classSel = char '.' *> (ClassSel <$> ident)++{-+attrib+ : '[' S* [ namespace_prefix ]? IDENT S*+ [ [ PREFIXMATCH |+ SUFFIXMATCH |+ SUBSTRINGMATCH |+ '=' |+ INCLUDES |+ DASHMATCH ] S* [ IDENT | STRING ] S*+ ]? ']'+ ;+-}+-- FIXME namespace prefixes aren't allowed inside attribute selectors,+-- but they should be.+attributeSel :: Parser SimpleSelector+attributeSel = do+ _ <- char '[' *> skipComments+ attId <- ident <* skipComments+ g <- option Attribute attValue+ _ <- char ']'+ pure $ AttributeSel (g attId)+ where attValue = do+ f <- ((string "^=" $> (:^=:)) <|>+ (string "$=" $> (:$=:)) <|>+ (string "*=" $> (:*=:)) <|>+ (string "=" $> (:=:)) <|>+ (string "~=" $> (:~=:)) <|>+ (string "|=" $> (:|=:))) <* skipComments+ attval <- ((Left <$> ident) <|> (Right <$> stringtype)) <* skipComments+ pure (`f` attval)++{-+-- string1: \"([^\n\r\f\\"]|\\{nl}|{escape})*\"+string1 = char '\"' *> many (o1 <|> o2 <|> escape)+ where o1 = satisfy (c -> c /= '\"' && c /= '\\' && c /= '\n')+ o2 = char '\\' *> newline $> mempty+-}++-- type_selector: [namespace_prefix]? element_name+typeSelector :: Parser SimpleSelector+typeSelector = Type <$> opt namespacePrefix <*> ident++-- universal: [ namespace_prefix ]? '*'+universal :: Parser SimpleSelector+universal = Universal <$> opt namespacePrefix <* char '*'++-- namespace_prefix: [ IDENT | '*' ]? '|'+namespacePrefix :: Parser Text+namespacePrefix = opt (ident <|> string "*") <* char '|'++{- '::' starts a pseudo-element, ':' a pseudo-class+ Exceptions: :first-line, :first-letter, :before and :after.+ Note that pseudo-elements are restricted to one per selector and+ occur only in the last simple_selector_sequence.++ <pseudo-class-selector> = ':' <ident-token> |+ ':' <function-token> <any-value> ')'+ <pseudo-element-selector> = ':' <pseudo-class-selector>+-}+-- pseudo: ':' ':'? [ IDENT | functional_pseudo ]+pseudo :: Parser SimpleSelector+pseudo = char ':' *> (pseudoElementSelector <|> pseudoClassSelector)+ where pseudoClassSelector = do+ i <- ident+ c <- A.peekChar+ case c of+ Just '(' -> char '(' *> case Map.lookup (T.toCaseFold i) fpcMap of+ Just p -> functionParser p+ Nothing -> functionParser (FunctionalPseudoClass i <$> A.takeWhile (/= ')'))+ _ -> pure $ PseudoClass i+ pseudoElementSelector = do+ parsedColon <- option False (char ':' $> True)+ if parsedColon+ then PseudoElem <$> ident+ else ident >>= handleSpecialCase+ where handleSpecialCase :: Text -> Parser SimpleSelector+ handleSpecialCase t = if T.toCaseFold t `elem` specialPseudoElements+ then pure $ PseudoElem t+ else mzero++-- \<An+B> microsyntax parser.+anplusb :: Parser AnPlusB+anplusb = (asciiCI "even" $> Even)+ <|> (asciiCI "odd" $> Odd)+ <|> do+ s <- option Nothing (Just <$> parseSign)+ x <- option mempty digits+ case x of+ [] -> ciN *> (AB (Nwith s Nothing) <$> (skipComments *> option Nothing (Just <$> bValue)))+ _ -> do n <- option False (ciN $> True)+ let a = read x :: Int+ if n+ then AB (Nwith s (Just a)) <$> (skipComments *> option Nothing (Just <$> bValue))+ else pure $ AB NoValue (Just $ getSign s * a)+ where ciN = satisfy (\c -> c == 'N' || c == 'n')+ parseSign = (char '-' $> Minus) <|> (char '+' $> Plus)+ getSign (Just Minus) = -1+ getSign _ = 1+ bValue = do+ readPlus <- (char '-' $> False) <|> (char '+' $> True)+ d <- skipComments *> digits+ if readPlus+ then pure $ read d+ else pure $ read ('-':d)++-- Functional pseudo classes parsers map+fpcMap :: Map Text (Parser SimpleSelector)+fpcMap = Map.fromList $ fmap (first T.toCaseFold)+ [buildTuple "nth-of-type" (\x -> FunctionalPseudoClass2 x <$> anplusb)+ ,buildTuple "nth-last-of-type" (\x -> FunctionalPseudoClass2 x <$> anplusb)+ ,buildTuple "nth-column" (\x -> FunctionalPseudoClass2 x <$> anplusb)+ ,buildTuple "nth-last-column" (\x -> FunctionalPseudoClass2 x <$> anplusb)+ ,buildTuple "not" (\x -> FunctionalPseudoClass1 x <$> compoundSelectorList)+ ,buildTuple "matches" (\x -> FunctionalPseudoClass1 x <$> compoundSelectorList)+ ,buildTuple "nth-child" (anbAndSelectors . FunctionalPseudoClass3)+ ,buildTuple "nth-last-child" (anbAndSelectors . FunctionalPseudoClass3)+ --+ -- :drop( [ active || valid || invalid ]? )+ -- The :drop() functional pseudo-class is identical to :drop+ -- ,("drop", anplusb)+ --+ -- It accepts a comma-separated list of one or more language ranges as its+ -- argument. Each language range in :lang() must be a valid CSS <ident> or+ -- <string>.+ -- ,("lang", anplusb)+ --+ -- ,("dir", text)+ -- ,("has", relative selectors)+ ]+ where buildTuple t c = (t, c t)+ compoundSelectorList = (:) <$> compoundSelector <*> many (comma *> compoundSelector)+ anbAndSelectors constructor = do+ a <- anplusb <* skipComments+ o <- option [] (asciiCI "of" *> skipComments *> compoundSelectorList)+ pure $ constructor a o++-- | Parse a list of comma-separated selectors, ignoring whitespace and+-- comments.+selectors :: Parser [Selector]+selectors = lexeme selector `sepBy` char ','++declaration :: Parser Declaration+declaration = do+ p <- property <* colon+ v <- values p <|> valuesFallback+ i <- important <* skipComments+ ie <- iehack <* skipComments+ pure $ Declaration p v i ie++-- | Parser for property names. Usually, 'ident' would be enough, but this+-- parser adds support for IE hacks (e.g. *width), which deviate from the CSS+-- grammar.+property :: Parser Text+property = mappend <$> opt ie7orLessHack <*> ident+ where ie7orLessHack = T.singleton <$> satisfy (`Set.member` ie7orLessHacks)+ ie7orLessHacks = Set.fromList ("!$&*()=%+@,./`[]#~?:<>|" :: String)++-- | Used to parse the "!important" at the end of declarations, ignoring spaces+-- and comments after the '!'.+important :: Parser Bool+important = option False (char '!' *> skipComments *> asciiCI "important" $> True)++iehack :: Parser Bool+iehack = option False (string "\\9" $> True)++-- | Parses a list of declarations, ignoring spaces, comments, and empty+-- declarations (e.g. ; ;)+declarations :: Parser [Declaration]+declarations = many (declaration <* handleSemicolons)+ where handleSemicolons = many (string ";" *> skipComments)++-- | Parser for CSS at-rules (e.g. \@keyframes, \@media)+atRule :: Parser Rule+atRule = do+ _ <- char '@'+ ruleType <- ident+ fromMaybe (atBlock ruleType) (Map.lookup ruleType m)+ where m = Map.fromList [("charset", atCharset)+ ,("import", atImport)+ ,("namespace", atNamespace)+ ,("media", atMedia)+ -- ,("supports", atSupports)+ -- ,("document", atDocument)+ -- ,("page", atPage)+ ,("font-face", skipComments *> atBlock "font-face")+ ,("keyframes", atKeyframe mempty )+ ,("-webkit-keyframes", atKeyframe "-webkit-")+ ,("-moz-keyframes", atKeyframe "-moz-")+ ,("-o-keyframes", atKeyframe "-o-")+ -- ,("viewport", atViewport)+ -- ,("counter-style", atCounterStyle)+ -- ,("font-feature-value", atFontFeatureValue)+ ]+-- @import [ <string> | <url> ] [<media-query-list>]?;+atImport :: Parser Rule+atImport = do+ esu <- skipComments *> stringOrUrl+ mql <- option [] mediaQueryList+ _ <- skipComments <* char ';'+ pure $ AtImport esu mql++atCharset :: Parser Rule+atCharset = do+ st <- skipComments *> stringtype <* skipComments <* char ';'+ pure $ AtCharset st++-- @namespace <namespace-prefix>? [ <string> | <uri> ];+-- where+-- <namespace-prefix> = IDENT+atNamespace :: Parser Rule+atNamespace = do+ i <- skipComments *> option mempty ident+ ret <- if T.null i+ then (AtNamespace i . Left) <$> stringtype+ else decideBasedOn i+ _ <- skipComments <* char ';'+ pure ret+ where decideBasedOn x =+ let urltext = T.toCaseFold "url"+ in if T.toCaseFold x == urltext+ then do c <- A.peekChar+ case c of+ Just '(' -> AtNamespace mempty <$> (char '(' *> (Right <$> url))+ _ -> AtNamespace x <$> (skipComments *> stringOrUrl)+ else AtNamespace x <$> (skipComments *> stringOrUrl)++atKeyframe :: Text -> Parser Rule+atKeyframe t = do+ _ <- skipComments+ name <- ident <* skipComments <* char '{'+ bs <- many (keyframeBlock <* skipComments)+ _ <- char '}'+ pure $ AtKeyframes t name bs++keyframeBlock :: Parser KeyframeBlock+keyframeBlock = do+ sel <- skipComments *> kfsList <* skipComments+ ds <- char '{' *> skipComments *> declarations <* char '}'+ pure $ KeyframeBlock sel ds+ where from = asciiCI "from" $> From+ to = asciiCI "to" $> To+ keyframeSelector = from <|> to <|> (KFPercentage <$> percentage)+ kfsList = (:) <$> keyframeSelector <*> many (comma *> keyframeSelector)++atMedia :: Parser Rule+atMedia = do+ m <- satisfy C.isSpace *> mediaQueryList+ _ <- char '{' <* skipComments+ r <- manyTill (rule <* skipComments) (lookAhead (char '}'))+ _ <- char '}'+ pure $ AtMedia m r++-- TODO clean code+-- the "manyTill .. lookAhead" was added because if we only used "rules", it+-- doesn't know when to stop, and breaks the parser+atBlock :: Text -> Parser Rule+atBlock i = do+ t <- mappend i <$> A.takeWhile (/= '{') <* char '{'+ r <- skipComments *> ((AtBlockWithDec t <$> declarations) <|> (AtBlockWithRules t <$> manyTill (rule <* skipComments) (lookAhead (char '}'))))+ _ <- char '}'+ pure r++-- | Parses a CSS style rule, e.g. @body { padding: 0; }@+styleRule :: Parser Rule+styleRule = do+ sels <- selectors <* char '{' <* skipComments+ decs <- declarations <* char '}'+ pure $ StyleRule sels decs++-- | Parser for a CSS rule, which can be either an at-rule (e.g. \@charset), or a style+-- rule.+rule :: Parser Rule+rule = atRule <|> styleRule++-- | Parser for CSS rules (both style rules, and at-rules), which can be+-- separated by whitespace or comments.+rules :: Parser [Rule]+rules = manyTill (rule <* skipComments) endOfInput++stylesheet :: Parser [Rule]+stylesheet = do+ charset <- option [] ((:[]) <$> atCharset <* skipComments)+ imports <- many (atImport <* skipComments)+ namespaces <- many (atNamespace <* skipComments)+ _ <- skipComments -- if there is no charset, import, or namespace at rule we need this here.+ rest <- rules+ pure $ charset <> imports <> namespaces <> rest++-- data AtRule = AtMedia (Maybe [MediaQuery])++-- | Media Feature values. Per the+-- <https://www.w3.org/TR/css3-mediaqueries/#values original spec (6.1)>,+-- \<resolution\> only accepts dpi and dpcm units, dppx was added later.+-- However, the w3c validator considers it valid, so we make no exceptions.+{-+data MediaFeatureValue = MFV_Length Length+ | MFV_Ratio Ratio+ | MFV_Number Number+ | MFV_Resolution Resolution+ | MFV_Other Text+-}++-- | Specs:+--+-- https://drafts.csswg.org/mediaqueries-3/#syntax+-- https://www.w3.org/TR/css3-mediaqueries/+-- https://www.w3.org/TR/CSS21/grammar.html+--+-- Implementation based on mozilla's pseudo BNF:+-- https://developer.mozilla.org/en-US/docs/Web/CSS/Media_Queries/Using_media_queries+mediaQueryList :: Parser [MediaQuery]+mediaQueryList = lexeme ((:) <$> mediaQuery <*> many (char ',' *> skipComments *> mediaQuery))++mediaQuery :: Parser MediaQuery+mediaQuery = mediaQuery1 <|> mediaQuery2+ where mediaQuery1 = MediaQuery1 <$> optionalNotOrOnly <*> mediaType <*> andExpressions+ mediaQuery2 = MediaQuery2 <$> ((:) <$> expression <*> andExpressions)+ mediaType = lexeme ident+ andExpressions = many (h *> expression)+ h = skipComments *> asciiCI "and" *> satisfy C.isSpace *> skipComments+ optionalNotOrOnly = option mempty (asciiCI "not" <|> asciiCI "only")++expression :: Parser Expression+expression = char '(' *> skipComments *> (expr <|> expFallback)+ where expr = do+ e <- ident <* skipComments+ v <- option Nothing (char ':' *> lexeme (Just <$> value))+ _ <- char ')'+ pure $ Expression e v+ expFallback = InvalidExpression <$> A.takeWhile (/= ')') <* char ')'++++-- Note: The code below pertains to CSS Media Queries Level 4.+-- Since it is still too new and nobody implements it (afaik),+-- I leave it here for future reference, when the need to cater for it+-- arrives.+{-+mediaCondition = asciiCI "not"+ <|> asciiCI "and"+ <|> asciiCI "or"+ <|> mediaInParens++mediaInParens = char '(' *> skipComments *> mediaCondition <* skipComments <* char ')'++mediaFeature :: Parser MediaFeature+mediaFeature = mfPlain <|> mfRange <|> mfBoolean+ where mfBoolean = ident++mfRange = ident++data MediaFeature = MFPlain Text Value+ | MFBoolean Text+ | MFRange Range++data Range = Range1 Text RangeOp Value+ | Range2 Value RangeOp Text+ | Range3 Value RangeOp Text RangeOp Value++data RangeOp = LTOP | GTOP | EQOP | GEQOP | LEQOP++-- = <mf-name> [ '<' | '>' ]? '='? <mf-value>+-- | <mf-value> [ '<' | '>' ]? '='? <mf-name>+-- | <mf-value> '<' '='? <mf-name> '<' '='? <mf-value>+-- | <mf-value> '>' '='? <mf-name> '>' '='? <mf-value>++mfPlain = ident *> skipComments *> char ':' *> skipComments *> mfValue++mfValue :: Parser Value+mfValue = number <|> dimension <|> ident <|> ratio++-- TODO check if both integers are positive (required by the spec)+ratio :: Parser Value+ratio = do+ n <- digits+ _ <- skipComments *> char '/' <* skipComments+ m <- digits+ pure $ Other (mconcat [n, "/", m])++++-- expr+-- : term [ operator? term ]*+-- ;+--+--term+-- : unary_operator?+-- [ NUMBER S* | PERCENTAGE S* | LENGTH S* | EMS S* | EXS S* | ANGLE S* |+-- TIME S* | FREQ S* ]+-- | STRING S* | IDENT S* | URI S* | hexcolor | function+-- ;+--++data MediaFeatureType = Range | Discrete++t =+ [("width", Range)+ ,("height", Range)+ ,("aspect-ratio", Range)+ ,("orientation", Discrete)+ ,("resolution", Range)+ ,("scan", Discrete)+ ,("grid", Discrete)+ ,("update", Discrete)+ ,("overflow-block", Discrete)+ ,("overflow-inline", Discrete)+ ,("color", Range)+ ,("color-index", Range)+ ,("monochrome", Range)+ ,("color-gamut", Discrete)+ ,("pointer", Discrete)+ ,("hover", Discrete)+ ,("any-pointer", Discrete)+ ,("any-hover", Discrete)+ ,("scripting", Discrete)+ ,("device-width", Range)+ ,("device-height", Range)+ ,("device-aspect-ratio", Range)+ ]+-}
+ src/Hasmin/Parser/Utils.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module : Hasmin.Parser.Internal+-- Copyright : (c) 2017 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : unknown+--+-----------------------------------------------------------------------------+module Hasmin.Parser.Utils (+ ident+ , fontfamilyname+ , nonquotedurl+ , skipComments+ , lexeme+ , functionParser+ , comma+ , colon+ , opt+ , nmchar+ ) where++import Control.Applicative ((<|>), many)+import Control.Monad (void, mzero)+import Data.Attoparsec.Text (char,+ option, Parser, satisfy, skipSpace, string, takeWhile1, (<?>))+import Data.Monoid ((<>))+import Data.Text (Text)+import Data.Text.Lazy.Builder as LB+import qualified Data.Attoparsec.Text as A+import qualified Data.Char as C+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++-- | Skip whatever comments and whitespaces are found.+skipComments :: Parser ()+skipComments = void $ many (skipSpace *> comment) <* skipSpace++comment :: Parser Text+comment = mappend <$> string "/*" <*> (string "*/" <|> untilAsterisk)+ where untilAsterisk = mappend <$> A.takeWhile (/= '*') <*> checkAsterisk+ checkAsterisk = mappend <$> string "*" <*> (string "/" <|> untilAsterisk)++comma :: Parser Char+comma = lexeme $ char ','++colon :: Parser Char+colon = lexeme $ char ':'++lexeme :: Parser a -> Parser a+lexeme p = skipComments *> p <* skipComments++opt :: Monoid m => Parser m -> Parser m+opt = option mempty++nonquotedurl :: Parser Text+nonquotedurl = do+ t <- many (escape <|> (LB.singleton <$> satisfy validChar))+ pure $ TL.toStrict (toLazyText (mconcat t))+ where validChar x = x /= '\"' && x /= '\'' && x /= '(' && x /= ')'+ && x /= '\\' && notWhitespace x && notNonprintable x+ notWhitespace x = x /= '\n' && x /= '\t' && x /= ' '+ notNonprintable x = not (C.chr 0 <= x && x <= C.chr 8)+ && x /= '\t'+ && not ('\SO' <= x && x <= C.chr 31)+ && x /= '\DEL'++fontfamilyname :: Parser Text+fontfamilyname = do+ i <- ident+ is <- many (skipComments *> ident)+ if T.toLower i `elem` invalidNames+ then mzero+ else pure $ i <> mconcat (map (" "<>) is)+ where invalidNames = ["serif", "sans-serif", "monospace", "cursive",+ "fantasy", "inherit", "initial", "unset", "default"]++-- ident: -?{nmstart}{nmchar}*+ident :: Parser Text+ident = do+ dash <- option mempty (LB.singleton <$> char '-')+ ns <- nmstart+ nc <- mconcat <$> many nmchar+ pure $ TL.toStrict (toLazyText (dash <> ns <> nc))++-- nmstart: [_a-z]|{nonascii}|{escape}+nmstart :: Parser Builder+nmstart = LB.singleton <$> satisfy (\c -> C.isAlpha c || (not . C.isAscii) c || c == '_')+ <|> escape+ <?> "not an nmstart token: [_a-z]|{nonascii}|{escape}"++-- nmchar: [_a-z0-9-]|{nonascii}|{escape}+nmchar :: Parser Builder+nmchar = LB.singleton <$> satisfy cond <|> escape+ where cond x = C.isAlphaNum x || x == '_' || x == '-'+ || (not . C.isAscii) x++-- TODO combine with unicode to make it more efficient+-- escape: {unicode}|\\[^\n\r\f0-9a-f]+escape :: Parser Builder+escape = unicode+ <|> (mappend <$> (LB.singleton <$> char '\\') <*> (LB.singleton <$> satisfy cond))+ <?> "not an escape token: {unicode}|\\\\[^\\n\\r\\f0-9a-f]"+ where cond c = c /= '\n'+ && c /= '\r'+ && c /= '\f'+ && (not . C.isHexDigit) c++-- unicode \\[0-9a-f]{1,6}(\r\n|[ \n\r\t\f])?+unicode :: Parser Builder+unicode = do+ backslash <- char '\\'+ hexChars <- takeWhile1 C.isHexDigit+ _ <- opt (string "\r\n" <|> (T.singleton <$> satisfy ws))+ if T.length hexChars <= 6+ then pure $ LB.singleton backslash <> LB.fromText hexChars+ else fail "unicode escaped character with length greater than 6"+ where ws x = x == ' ' || x == '\n' || x == '\r' || x == '\t' || x == '\f'++-- | Assumes the identifier and the left parenthesis have been parsed+-- Parses p, ignoring comments before and after it, and consumes the final+-- right parenthesis+functionParser :: Parser a -> Parser a+functionParser p = lexeme p <* char ')'
+ src/Hasmin/Parser/Value.hs view
@@ -0,0 +1,1184 @@+{-# LANGUAGE OverloadedStrings, TupleSections #-}+-----------------------------------------------------------------------------+-- |+-- Module : Hasmin.Parser.Internal+-- Copyright : (c) 2017 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : unknown+--+-- Parsers for CSS values.+--+-----------------------------------------------------------------------------+module Hasmin.Parser.Value (+ values+ , percentage+ , value+ , valuesFallback+ , stringOrUrl+ , url+ , stringtype+ , digits+ , textualvalue+ , stringvalue+ , shadowList+ , repeatStyle+ , position+ , color+ , number+ , fontStyle+ ) where++import Control.Applicative ((<|>), many, liftA2, liftA3)+import Control.Arrow (first, (&&&))+import Control.Monad (mzero)+import Data.Functor (($>))+import Data.Attoparsec.Text (asciiCI, char, choice, count, many1,+ option, Parser, satisfy, skipSpace, string, digit)+import Data.Map.Strict (Map)+import Data.Monoid ((<>))+import Data.Maybe (fromMaybe, isNothing)+import Data.Text (Text)+import Data.Word (Word8)+import Data.Char (isAscii)+import Text.Parser.Permutation ((<|?>), (<$$>), (<$?>), (<||>), permute)+import qualified Data.Set as Set+import Numeric (readSigned, readFloat)+import qualified Data.Attoparsec.Text as A+import qualified Data.Char as C+import qualified Data.Map.Strict as Map+import qualified Data.Text as T++import Hasmin.Parser.Utils+import Hasmin.Types.BgSize+import Hasmin.Types.Class+import Hasmin.Types.Color+import Hasmin.Types.Dimension+import Hasmin.Types.FilterFunction+import Hasmin.Types.Gradient+import Hasmin.Types.Numeric+import Hasmin.Types.PercentageLength+import Hasmin.Types.Position+import Hasmin.Types.RepeatStyle+import Hasmin.Types.Shadow+import Hasmin.Types.String+import Hasmin.Types.TimingFunction+import Hasmin.Types.TransformFunction+import Hasmin.Types.Value++values :: Text -> Parser Values+values p = case Map.lookup (T.toLower p) propertyValueParsersMap of+ Just x -> x <* skipComments -- mappend <$> (x <|> ((:[]) <$> csswideKeyword))+ Nothing -> valuesFallback++number :: Parser Number+number = Number <$> rational++-- ---------------------------------------------------------------------------+-- Color Parsers+-- ---------------------------------------------------------------------------++-- Assumes "rgb(" has already been read+rgb :: Parser Color+rgb = functionParser (rgbInt <|> rgbPer)+ where rgbInt = mkRGBInt <$> word8 <* comma <*> word8 <* comma <*> word8+ rgbPer = mkRGBPer <$> percentage <* comma+ <*> percentage <* comma <*> percentage++-- Assumes "rgba(" has already been read+rgba :: Parser Color+rgba = functionParser (rgbaInt <|> rgbaPer)+ where rgbaInt = mkRGBAInt <$> word8 <* comma <*> word8 <* comma+ <*> word8 <* comma <*> alphavalue+ rgbaPer = mkRGBAPer <$> percentage <* comma <*> percentage <* comma+ <*> percentage <* comma <*> alphavalue++-- Assumes "hsl(" has already been read+hsl :: Parser Color+hsl = functionParser p+ where p = mkHSL <$> int <* comma <*> percentage <* comma <*> percentage++-- Assumes "hsla(" has already been read+hsla :: Parser Color+hsla = functionParser p+ where p = mkHSLA <$> int <* comma <*> percentage <* comma+ <*> percentage <* comma <*> alphavalue++alphavalue :: Parser Alphavalue+alphavalue = mkAlphavalue <$> rational++hexvalue :: Parser Value+hexvalue = ColorV <$> hex++-- TODO improve this parser+hex :: Parser Color+hex = char '#' *> (constructHex <$> choice ps)+ where hexadecimal = satisfy C.isHexDigit+ ps = [count 8 hexadecimal, count 6 hexadecimal,+ count 4 hexadecimal, count 3 hexadecimal]+ constructHex [r,g,b] = mkHex3 r g b+ constructHex [r,g,b,a] = mkHex4 r g b a+ constructHex [r1,r2,g1,g2,b1,b2] = mkHex6 [r1,r2] [g1,g2] [b1,b2]+ constructHex [r1,r2,g1,g2,b1,b2,a1,a2] = mkHex8 [r1,r2] [g1,g2] [b1,b2] [a1,a2]+ constructHex _ = error "invalid list size for a hex color"++-- ---------------------------------------------------------------------------+-- Dimensions Parsers+-- ---------------------------------------------------------------------------++-- A map relating dimension units and the percentage symbol,+-- to functions that construct that value. Meant to unify all the numerical+-- parsing in a single parse for generality without losing much efficiency.+-- See numericalvalue.+numericalConstructorsMap :: Map Text (Number -> Value)+numericalConstructorsMap = Map.fromList $ fmap (first T.toCaseFold) l+ where durationFunc u v = DurationV (Duration v u)+ frequencyFunc u v = FrequencyV (Frequency v u)+ resolutionFunc u v = ResolutionV (Resolution v u)+ l = [("s", durationFunc S)+ ,("ms", durationFunc Ms)+ ,("hz", frequencyFunc Hz)+ ,("khz", frequencyFunc Khz)+ ,("dpi", resolutionFunc Dpi)+ ,("dpcm", resolutionFunc Dpcm)+ ,("dppx", resolutionFunc Dppx)+ ,("%", \x -> PercentageV (Percentage $ toRational x))+ ] ++ (fmap . fmap) (DistanceV .) distanceConstructorsList+ ++ (fmap . fmap) (AngleV .) angleConstructorsList++-- Unified numerical parser.+-- Parses <number>, dimensions (i.e. <length>, <angle>, ...), and <percentage>+numericalvalue :: Parser Value+numericalvalue = do+ n <- number+ rest <- opt (string "%" <|> A.takeWhile1 C.isAlpha)+ if T.null rest -- if true, then it was just a <number> value+ then pure $ NumberV n+ else case Map.lookup (T.toCaseFold rest) numericalConstructorsMap of+ Just f -> pure $ f n+ Nothing -> mzero -- TODO see if we should return an "Other" value++-- Create a numerical parser based on a Map.+-- See for instance, the "angle" parser+dimensionParser :: Map Text (Number -> a) -> a -> Parser a+dimensionParser m unitlessValue = do+ n <- number+ u <- opt (A.takeWhile1 C.isAlpha)+ if T.null u+ then if n == 0+ then pure unitlessValue -- <angle> 0, without units+ else mzero -- Non-zero <number>, fail+ else case Map.lookup (T.toCaseFold u) m of+ Just f -> pure $ f n+ Nothing -> mzero -- parsed units aren't angle units, fail++distance :: Parser Distance+distance = dimensionParser distanceConstructorsMap (Distance 0 Q)+ where distanceConstructorsMap = Map.fromList distanceConstructorsList++angle :: Parser Angle+angle = dimensionParser angleConstructorsMap (Angle 0 Deg)+ where angleConstructorsMap = Map.fromList angleConstructorsList++duration :: Parser Duration+duration = do+ n <- number+ u <- opt (A.takeWhile1 C.isAlpha)+ if T.null u+ then mzero+ else case Map.lookup (T.toCaseFold u) durationConstructorsMap of+ Just f -> pure $ f n+ Nothing -> mzero -- parsed units aren't angle units, fail+ where durationConstructorsMap = Map.fromList $+ fmap (toText &&& flip Duration) [S, Ms]++angleConstructorsList :: [(Text, Number -> Angle)]+angleConstructorsList = fmap (toText &&& flip Angle)+ [Deg, Grad, Rad, Turn]++distanceConstructorsList :: [(Text, Number -> Distance)]+distanceConstructorsList = fmap (toText &&& flip Distance)+ [EM, EX, CH, VH, VW, VMIN, VMAX, REM, Q, CM, MM, IN, PC, PT, PX]++percentage :: Parser Percentage+percentage = Percentage <$> rational <* char '%'++-- ---------------------------------------------------------------------------+-- Primitives+-- ---------------------------------------------------------------------------++-- | \<integer\> data type parser, but into a String instead of an Int, for other+-- parsers to use (e.g.: see the parsers int, or rational)+int' :: Parser String+int' = do+ sign <- option '+' (char '-' <|> char '+')+ d <- digits+ case sign of+ '+' -> pure d+ '-' -> pure (sign:d)+ _ -> error "int': parsed a number starting with other than [+|-]"++-- | Parser for \<integer\>: [+|-][0-9]++int :: Parser Int+int = read <$> int'++digits :: Parser String+digits = many1 digit++word8 :: Parser Word8+word8 = read <$> digits++-- Note that many properties that allow an integer or real number as a value+-- actually restrict the value to some range, often to a non-negative value.+--+-- | Real numbers parser. \<number\>: <'int' integer> | [0-9]*.[0-9]++rational :: Parser Rational+rational = do+ sign <- option [] (wrapMinus <$> (char '-' <|> char '+'))+ dgts <- ((++) <$> digits <*> option "" fractionalPart)+ <|> ("0"++) <$> fractionalPart -- append a zero for read not to fail+ e <- option [] expo+ pure $ fst . head $ readSigned readFloat (sign ++ dgts ++ e)+ where fractionalPart = (:) <$> char '.' <*> digits+ expo = (:) <$> satisfy (\c -> c == 'e' || c == 'E') <*> int'+ wrapMinus x = if x == '-' -- we use this since read fails with leading '+'+ then [x]+ else []++fontStyle :: Parser Value+fontStyle = do+ k <- ident+ if Set.member k keywords+ then pure $ mkOther k+ else mzero+ where keywords = Set.fromList ["normal", "italic", "oblique"]++{-+fontWeight :: Parser Value+fontWeight = do+ k <- ident+ if Set.member k keywords+ then pure $ mkOther k+ else mzero+ where keywords = Set.fromList ["normal", "bold", "lighter", "bolder"]+ validNumbers = Set.fromList [100, 200, 300, 400, 500, 600, 700, 800, 900]+-}++fontSize :: Parser Value+fontSize = fontSizeKeyword+ <|> (DistanceV <$> distance)+ <|> (PercentageV <$> percentage)+ where fontSizeKeyword = do+ v1 <- ident+ if Set.member v1 keywords+ then pure $ mkOther v1+ else mzero+ keywords = Set.fromList ["medium", "xx-small", "x-small", "small"+ ,"large", "x-large", "xx-large", "smaller"+ ,"larger"]++{- [ [ <‘font-style’> || <font-variant-css21> || <‘font-weight’> ||+ - <‘font-stretch’> ]? <‘font-size’> [ / <‘line-height’> ]? <‘font-family’> ] |+ - caption | icon | menu | message-box | small-caption | status-bar+where <font-variant-css21> = [normal | small-caps]++-}++-- TODO clean this parser!!+positionvalue :: Parser Value+positionvalue = PositionV <$> position++position :: Parser Position+position = pos4 <|> pos2 <|> pos1++pos1 :: Parser Position+pos1 = (asciiCI "left" $> (f $ Just PosLeft))+ <|> (asciiCI "center" $> (f $ Just PosCenter))+ <|> (asciiCI "right" $> (f $ Just PosRight))+ <|> (asciiCI "top" $> (f $ Just PosTop))+ <|> (asciiCI "bottom" $> (f $ Just PosBottom))+ <|> ((\a -> Position Nothing a Nothing Nothing) <$> (Just <$> percentageLength))+ where f x = Position x Nothing Nothing Nothing++pos2 :: Parser Position+pos2 = firstx <|> firsty+ where firstx = do+ a <- (asciiCI "left" $> (Position (Just PosLeft) Nothing))+ <|> (asciiCI "center" $> (Position (Just PosCenter) Nothing))+ <|> (asciiCI "right" $> (Position (Just PosRight) Nothing))+ <|> ((Position Nothing . Just) <$> percentageLength)+ skipComments *> ((asciiCI "top" $> (a (Just PosTop) Nothing))+ <|> (asciiCI "center" $> (a (Just PosCenter) Nothing))+ <|> (asciiCI "bottom" $> (a (Just PosBottom) Nothing))+ <|> ((a Nothing . Just) <$> percentageLength))+ firsty = do+ a <- (asciiCI "top" $> (Position (Just PosTop) Nothing))+ <|> (asciiCI "center" $> (Position (Just PosCenter) Nothing))+ <|> (asciiCI "bottom" $> (Position (Just PosBottom) Nothing))+ <|> ((Position Nothing . Just) <$> percentageLength)+ skipComments *> ((asciiCI "left" $> (a (Just PosLeft) Nothing))+ <|> (asciiCI "center" $> (a (Just PosCenter) Nothing))+ <|> (asciiCI "right" $> (a (Just PosRight) Nothing))+ <|> ((a Nothing . Just) <$> percentageLength))++pos4 :: Parser Position+pos4 = firstx <|> firsty+ where posTop = asciiCI "top" $> (Position (Just PosTop))+ posRight = asciiCI "right" $> (Position (Just PosRight))+ posBottom = asciiCI "bottom" $> (Position (Just PosBottom))+ posLeft = asciiCI "left" $> (Position (Just PosLeft))+ firstx = do+ x <- (asciiCI "center" $> (Position (Just PosCenter) Nothing))+ <|> ((posLeft <|> posRight) <*> (skipComments *> option Nothing (Just <$> percentageLength)))+ _ <- skipComments+ (asciiCI "center" $> (x (Just PosCenter) Nothing))+ <|> (((asciiCI "top" $> (x $ Just PosTop)) <|> (asciiCI "bottom" $> (x (Just PosBottom))))+ <*> (skipComments *> option Nothing (Just <$> percentageLength)))+ firsty = do+ x <- (asciiCI "center" $> (Position (Just PosCenter) Nothing))+ <|> ((posTop <|> posBottom) <*> (skipComments *> option Nothing (Just <$> percentageLength)))+ _ <- skipComments+ (asciiCI "center" $> (x (Just PosCenter) Nothing))+ <|> (((asciiCI "left" $> (x $ Just PosLeft)) <|> (asciiCI "right" $> (x (Just PosRight))))+ <*> (skipComments *> option Nothing (Just <$> percentageLength)))++{-+transformOrigin :: Parser Values+transformOrigin = twoVal <|> oneVal+ where oneVal = (singleValue numericalvalue) <|> offsetKeyword+ offsetKeyword = do+ v1 <- ident+ if v1 == "top" || v1 == "right" || v1 == "bottom" || v1 == "left" || v1 == "center"+ then pure $ mkValues [mkOther v1]+ else mzero+ twoVal = do+ (v1, v2) <- ((,) <$> yAxis <*> (skipComments *> (xAxis <|> numericalvalue)))+ <|> ((,) <$> xAxis <*> (skipComments *> (yAxis <|> numericalvalue)))+ <|> ((,) <$> numericalvalue <*> (skipComments *> (yAxis <|> xAxis)))+ option (mkValues [v1,v2]) ((\x -> mkValues [v1,v2, DistanceV x]) <$> distance)+ yAxis = do+ v1 <- ident+ if v1 == "top" || v1 == "bottom" || v1 == "center"+ then pure $ mkOther v1+ else mzero+ xAxis = do+ v1 <- ident+ if v1 == "right" || v1 == "left" || v1 == "center"+ then pure $ mkOther v1+ else mzero+-}++bgSize :: Parser BgSize+bgSize = twovaluesyntax <|> contain <|> cover+ where cover = asciiCI "cover" $> Cover+ contain = asciiCI "contain" $> Contain+ twovaluesyntax = do+ v1 <- (Left <$> percentageLength) <|> (Right <$> auto)+ _ <- skipComments+ v2 <- option Nothing (Just <$> ((Left <$> percentageLength) <|> (Right <$> auto)))+ pure $ BgSize v1 v2++bgAttachment :: Parser TextV+bgAttachment = matchKeywords ["scroll", "fixed", "local"]++box :: Parser TextV+box = matchKeywords ["border-box", "padding-box", "content-box"]++-- [ <bg-layer> , ]* <final-bg-layer>+background :: Parser Values+background = do+ xs <- many (bgLayer <* char ',' <* skipComments)+ x <- finalBgLayer+ pure $ if null xs+ then Values x []+ else Values (head xs) (fmap (Comma,) $ tail xs ++ [x])++-- <final-bg-layer> = <bg-image> || <position> [ / <bg-size> ]? || <repeat-style> || <attachment> || <box> || <box> || <'background-color'>+finalBgLayer :: Parser Value+finalBgLayer = do+ layer <- permute (mkFinalBgLayer <$?> (Nothing, Just <$> image <* skipComments)+ <|?> (Nothing, Just <$> positionAndBgSize <* skipComments)+ <|?> (Nothing, Just <$> repeatStyle <* skipComments)+ <|?> (Nothing, Just <$> bgAttachment <* skipComments)+ <|?> (Nothing, Just <$> box <* skipComments)+ <|?> (Nothing, Just <$> box <* skipComments)+ <|?> (Nothing, Just <$> color <* skipComments))+ if finalBgLayerIsEmpty layer+ then mzero+ else pure layer+ where finalBgLayerIsEmpty (FinalBgLayer Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing) = True+ finalBgLayerIsEmpty _ = False+ -- parameters e and f are being swapped to deal with the permutation+ -- changing the original order of the parsed values.+ mkFinalBgLayer a Nothing c d e f g = FinalBgLayer a Nothing Nothing c d f e g+ mkFinalBgLayer a (Just (p,s)) c d e f g = FinalBgLayer a (Just p) s c d f e g++-- <bg-layer> = <bg-image> || <position> [ / <bg-size> ]? || <repeat-style> || <attachment> || <box>{1,2}+bgLayer :: Parser Value+bgLayer = do+ layer <- permute (mkBgLayer <$?> (Nothing, Just <$> image <* skipComments)+ <|?> (Nothing, Just <$> positionAndBgSize <* skipComments)+ <|?> (Nothing, Just <$> repeatStyle <* skipComments)+ <|?> (Nothing, Just <$> bgAttachment <* skipComments)+ <|?> (Nothing, Just <$> box2 <* skipComments))+ if bgLayerIsEmpty layer+ then mzero+ else pure layer+ where bgLayerIsEmpty (BgLayer Nothing Nothing Nothing Nothing Nothing Nothing Nothing) = True+ bgLayerIsEmpty _ = False+ mkBgLayer a Nothing c d Nothing = BgLayer a Nothing Nothing c d Nothing Nothing+ mkBgLayer a (Just (p,s)) c d Nothing = BgLayer a (Just p) s c d Nothing Nothing+ mkBgLayer a Nothing c d (Just (i,j)) = BgLayer a Nothing Nothing c d (Just i) j+ mkBgLayer a (Just (p,s)) c d (Just (i,j)) = BgLayer a (Just p) s c d (Just i) j+ box2 :: Parser (TextV, Maybe TextV)+ box2 = do+ x <- box <* skipComments+ y <- option Nothing (Just <$> box)+ pure (x,y)++-- used for the background property, which takes among other things:+-- <position> [ / <bg-size> ]?+positionAndBgSize :: Parser (Position, Maybe BgSize)+positionAndBgSize = do+ x <- position <* skipComments+ y <- option Nothing (Just <$> (char '/' *> skipComments *> bgSize))+ pure (x,y)++matchKeywords :: [Text] -> Parser TextV+matchKeywords listOfKeywords = do+ i <- ident+ if T.toCaseFold i `elem` Set.fromList listOfKeywords+ then pure $ TextV i+ else mzero++-- <image> = <url> | <image()> | <image-set()> | <element()> | <cross-fade()> | <gradient>+image :: Parser Value+image = do+ i <- ident+ let lowercased = T.toLower i+ if lowercased == "none"+ then pure $ mkOther "none"+ else do _ <- char '('+ if Set.member lowercased possibilities+ then fromMaybe mzero (Map.lookup lowercased functionsMap)+ else mzero+ where possibilities = Set.fromList $ map T.toCaseFold+ ["url", "element", "linear-gradient", "radial-gradient"]++transition :: Parser Values+transition = parseCommaSeparated singleTransition++-- [ none | <single-transition-property> ] || <time> || <single-transition-timing-function> || <time>+singleTransition :: Parser Value+singleTransition = do+ st <- permute (mkSingleTransition <$?> (Nothing, Just <$> singleTransitionProperty <* skipComments)+ <|?> (Nothing, Just <$> duration <* skipComments)+ <|?> (Nothing, Just <$> timingFunction <* skipComments)+ <|?> (Nothing, Just <$> duration <* skipComments))+ if singleTransitionIsEmpty st+ then mzero+ else pure st+ where singleTransitionIsEmpty (SingleTransition Nothing Nothing Nothing Nothing) = True+ singleTransitionIsEmpty _ = False+ -- Needed because permute is swapping the order of the time parameters.+ mkSingleTransition a b c d = SingleTransition a d c b+ singleTransitionProperty = do+ i <- ident+ let lowercased = T.toLower i+ if Set.member lowercased excludedKeywords+ then mzero+ else pure $ TextV i+ excludedKeywords = Set.fromList ["initial", "inherit", "unset", "default", "none"]++timingFunction :: Parser TimingFunction+timingFunction = do+ i <- ident+ let lowercased = T.toLower i+ case Map.lookup lowercased timingFunctionKeywords of+ Just x -> x+ Nothing -> char '(' *> (if lowercased == "steps"+ then steps+ else if lowercased == "cubic-bezier"+ then cubicbezier+ else mzero)+ where timingFunctionKeywords = Map.fromList [("ease", pure Ease)+ ,("ease-in", pure EaseIn)+ ,("ease-in-out", pure EaseInOut)+ ,("ease-out", pure EaseOut)+ ,("linear", pure Linear)+ ,("step-end", pure StepEnd)+ ,("step-start", pure StepStart)]++backgroundSize :: Parser Values+backgroundSize = parseCommaSeparated (BgSizeV <$> bgSize)++auto :: Parser Auto+auto = asciiCI "auto" $> Auto++propertyValueParsersMap :: Map Text (Parser Values)+propertyValueParsersMap = Map.fromList+ [--("color", (:[]) <$> colorvalue)+ ("display", singleValue textualvalue)+ ,("font", singleValue font)+ ,("font-size", singleValue fontSize)+ ,("font-style", singleValue fontStyle)+ ,("font-weight", singleValue numberOrText)+ ,("font-family", fontFamilyValues)+ ,("background", background)+ ,("background-repeat", parseCommaSeparated (RepeatStyleV <$> repeatStyle))+ ,("background-size", backgroundSize)+ ,("box-shadow", shadowList)+ ,("-o-box-shadow", shadowList)+ ,("-moz-box-shadow", shadowList)+ ,("-webkit-box-shadow", shadowList)+ ,("text-shadow", textShadow)++ ,("animation", animation)+ ,("-o-animation", animation)+ ,("-ms-animation", animation)+ ,("-moz-animation", animation)+ ,("-webkit-animation", animation)++ ,("transition", transition)+ ,("-o-transition", transition)+ ,("-ms-transition", transition)+ ,("-moz-transition", transition)+ ,("-webkit-transition", transition)++ ,("height", singleValue numberOrText) -- <length>|<percentage>|auto+ ,("margin-bottom", singleValue numberOrText)+ ,("margin-left", singleValue numberOrText)+ ,("background-position", singleValue positionvalue)+ ,("perspective-origin", singleValue positionvalue)+ ,("-o-perspective-origin", singleValue positionvalue)+ ,("-moz-perspective-origin", singleValue positionvalue)+ ,("-webkit-perspective-origin", singleValue positionvalue)+ ,("mask-position", positionList)+ ,("-webkit-mask-position", positionList)+ -- ,("transform-origin", transformOrigin)+ -- ,("-ms-transform-origin", transformOrigin)+ -- ,("-webkit-transform-origin", transformOrigin)+ -- ,("font",+ -- ,("margin-right", numberOrText)+ -- ,("margin-top", numberOrText)+ -- ,("opacity", someNumericalValue)+ -- ,("overflow", someText)+ -- ,("padding-bottom", someNumericalValue)+ -- ,("padding-left", someNumericalValue)+ -- ,("padding-right", someNumericalValue)+ -- ,("padding-top", someNumericalValue)+ -- ,("position", someText)+ -- ,("text-align", someText)+ -- ,("width", numberOrText)+ ]+ where numberOrText = numericalvalue <|> textualvalue++-- helper wrapper+singleValue :: Parser Value -> Parser Values+singleValue = (flip Values [] <$>)++value :: Parser Value+value = textualvalue+ <|> numericalvalue+ <|> hexvalue+ <|> (StringV <$> stringtype)+ <|> invalidvalue++-- | Parses until the end of the declaration, i.e. ';' or '}'+-- Used to deal with invalid input, or some of the IE specific things+invalidvalue :: Parser Value+invalidvalue = mkOther <$> A.takeWhile1 (\c -> c /= '\\' && c /= ';' && c /= '}' && c /= '!')++-- [ [ <'font-style'> || <font-variant-css21> || <'font-weight'> ||+-- <'font-stretch'> ]? <'font-size'> [ / <'line-height'> ]? <'font-family'> ] |+font :: Parser Value+font = systemFonts <|> do+ (fsty, fvar, fwgt, fstr) <- parse4+ (fsz, lh) <- fontSizeAndLineHeight+ ff <- ((:) <$> fontfamily <* skipComments) <*> many (char ',' *> lexeme fontfamily)+ pure $ FontV fsty fvar fwgt fstr fsz lh ff+ where systemFonts = Other <$> parseIdents ["caption", "icon", "menu", "message-box", "small-caption", "status-bar"]+ fontSizeAndLineHeight = do+ fsz <- fontSize <* skipComments+ lh <- option Nothing (Just <$> (char '/' *> lexeme lineHeight))+ pure (fsz, lh)+ lineHeight = let validNum = do n <- numericalvalue+ case n of+ NumberV _ -> pure n+ PercentageV _ -> pure n+ DistanceV _ -> pure n+ _ -> mzero+ in (Other <$> parseIdents ["normal"]) <|> validNum+ fontWeightNumber :: Parser Value+ fontWeightNumber = do+ n <- number+ if Set.notMember n (Set.fromList [100, 200, 300, 400, 500, 600, 700, 800, 900])+ then mzero+ else do c <- A.peekChar+ case c of+ Nothing -> mzero+ Just x -> if isAscii x || x == '%'+ then mzero+ else pure $ NumberV n+ parseFirstFour j = (storeProperty' j <$> fontWeightNumber <* skipComments) <|> do+ i <- ident+ case Map.lookup (T.toLower i) m of+ Just x -> case x of+ FontWeight -> pure $ storeProperty' j (mkOther i)+ _ -> pure $ storeProperty j x (TextV i)+ Nothing -> mzero+ where m = Map.fromList $ zip ["ultra-condensed", "extra-condensed", "condensed", "semi-condensed", "semi-expanded", "expanded", "extra-expanded", "ultra-expanded"] (repeat FontStretch)+ ++ zip ["small-caps"] (repeat FontVariant)+ ++ zip ["italic", "oblique"] (repeat FontStyle)+ ++ zip ["bold", "bolder", "lighter"] (repeat FontWeight)+ ++ [("normal", Ambiguous)]+ parse4 :: Parser (Maybe TextV, Maybe TextV, Maybe Value, Maybe TextV)+ parse4 = do+ let initialized = (Nothing, Nothing, Nothing, Nothing, 0)+ w <- option initialized (parseFirstFour initialized <* skipComments)+ x <- option w (parseFirstFour w <* skipComments)+ y <- option x (parseFirstFour x <* skipComments)+ (a,b,c,d,e) <- option y (parseFirstFour y <* skipComments)+ pure $ fillTuple (a,b,c,d) e+ fillTuple (a,b,c,d) 0 = (a,b,c,d)+ fillTuple (a,b,c,d) x+ | isNothing a = fillTuple (Just nrml,b,c,d) (x-1)+ | isNothing b = fillTuple (a, Just nrml,c,d) (x-1)+ | isNothing c = fillTuple (a,b, Just $ Other nrml,d) (x-1)+ | isNothing d = fillTuple (a,b,c, Just nrml) (x-1)+ | otherwise = (a,b,c,d)+ where nrml = TextV "normal"++data FontProperty = FontStyle | FontVariant | FontWeight | FontStretch | Ambiguous+ deriving (Eq, Show)++storeProperty :: (Maybe TextV, Maybe TextV, Maybe Value, Maybe TextV, Int) -> FontProperty -> TextV+ -> (Maybe TextV, Maybe TextV, Maybe Value, Maybe TextV, Int)+storeProperty (a,b,c,d,i) y x = replace y+ where replace FontStyle = (Just x,b,c,d,i)+ replace FontVariant = (a, Just x,c,d,i)+ replace FontStretch = (a,b,c, Just x,i)+ replace Ambiguous = (a,b,c,d,i + 1)+ replace _ = (a,b,c,d,i)++storeProperty' :: (Maybe TextV, Maybe TextV, Maybe Value, Maybe TextV, Int) -> Value+ -> (Maybe TextV, Maybe TextV, Maybe Value, Maybe TextV, Int)+storeProperty' (a,b,_,d,i) x = (a,b, Just x,d,i)+++-- font-style: normal+-- font-variant: normal+-- font-weight: normal+-- font-stretch: normal+-- font-size: medium+-- line-height: normal+-- font-family: depends on user agent++fontFamilyValues :: Parser Values+fontFamilyValues = singleValue csswideKeyword <|> do+ v <- fontfamily+ vs <- many ((,) <$> separator <*> fontfamily)+ pure $ Values v vs++fontfamily :: Parser Value+fontfamily = (StringV <$> stringtype) <|> (mkOther <$> unquotedFontFamily)++local :: Parser Value+local = functionParser $+ Local <$> ((Left <$> unquotedFontFamily) <|> (Right <$> stringtype))++unquotedFontFamily :: Parser Text+unquotedFontFamily = do+ v <- ident+ vs <- many (skipComments *> ident)+ pure $ v <> mconcat (map (T.singleton ' ' <>) vs)+++textualvalue :: Parser Value+textualvalue = do+ i <- ident+ if i == "\\9" -- iehack+ then mzero+ else do c <- A.peekChar+ case c of+ Just '(' -> functionParsers i+ Just ':' -> mzero -- invalid+ _ -> textualParsers i++textualParsers :: Text -> Parser Value+textualParsers i = let t = T.toCaseFold i+ in fromMaybe (pure $ mkOther i) (Map.lookup t textualParsersMap)+ where textualParsersMap = Map.union csswideKeywordsMap namedColorsParsersMap++csswideKeyword :: Parser Value+csswideKeyword = do+ i <- ident <* skipComments+ let lowercased = T.toLower i+ case Map.lookup lowercased csswideKeywordsMap of+ Nothing -> mzero+ Just x -> do c <- A.peekChar+ case c of+ Nothing -> x+ Just y -> if y `elem` ['!', ';', '}']+ then x+ else mzero++csswideKeywordsMap :: Map Text (Parser Value)+csswideKeywordsMap = Map.fromList $ map (first T.toCaseFold)+ [("initial", pure Initial)+ ,("inherit", pure Inherit)+ ,("unset", pure Unset)]++stringvalue :: Parser Value+stringvalue = StringV <$> stringtype++functionParsers :: Text -> Parser Value+functionParsers i = char '(' *>+ case Map.lookup (T.toCaseFold i) functionsMap of+ Just x -> x <|> genericFunc i+ Nothing -> genericFunc i+ <|> (mkOther <$> (f i "(" <$> someText <*> string ")"))+ where f x y z w = x <> y <> z <> w+ someText = A.takeWhile (/= ')')++genericFunc :: Text -> Parser Value+genericFunc i = (GenericFunc i <$> valuesInParens) <* char ')'+ where valuesInParens = Values <$> v <*> many ((,) <$> separator <*> v) <* skipComments+ v = textualvalue+ <|> numericalvalue+ <|> hexvalue+ <|> (StringV <$> stringtype)++stringOrUrl :: Parser (Either StringType Url)+stringOrUrl = (Left <$> stringtype) <|> (Right <$> someUrl)+ where someUrl :: Parser Url+ someUrl = asciiCI "url" *> char '(' *> url++-- <repeat-style> parser, for background-repeat.+repeatStyle :: Parser RepeatStyle+repeatStyle = do+ i <- ident+ let lowercased = T.toLower i+ case Map.lookup lowercased singleKeywords of+ Nothing -> case Map.lookup lowercased keywordPairs of+ Nothing -> mzero+ Just y -> do j <- option Nothing secondKeyword+ pure $ RSPair y j+ Just x -> pure x+ where secondKeyword = do+ z <- skipComments *> ident+ case Map.lookup (T.toLower z) keywordPairs of+ Nothing -> mzero+ Just a -> pure $ Just a+ singleKeywords = Map.fromList [("repeat-x", RepeatX), ("repeat-y", RepeatY)]+ keywordPairs = Map.fromList [("repeat", RsRepeat)+ ,("no-repeat", RsNoRepeat)+ ,("space", RsSpace)+ ,("round", RsRound)]++functionsMap :: Map Text (Parser Value)+functionsMap = Map.fromList $ fmap (first T.toCaseFold)+ [("rgb", ColorV <$> rgb)+ ,("rgba", ColorV <$> rgba)+ ,("hsl", ColorV <$> hsl)+ ,("hsla", ColorV <$> hsla)+ ,("url", UrlV <$> url)+ ,("format", format)+ ,("local", local)+ -- <gradient> parsers+ ,("linear-gradient", GradientV "linear-gradient" <$> lineargradient)+ ,("-o-linear-gradient", GradientV "-o-linear-gradient" <$> lineargradient)+ ,("-ms-linear-gradient", GradientV "-ms-linear-gradient" <$> lineargradient)+ ,("-moz-linear-gradient", GradientV "-moz-linear-gradient" <$> lineargradient)+ ,("-webkit-linear-gradient", GradientV "-webkit-linear-gradient" <$> lineargradient)+ ,("radial-gradient", GradientV "radial-gradient" <$> radialgradient)+ ,("-o-radial-gradient", GradientV "-o-radial-gradient" <$> radialgradient)+ ,("-moz-radial-gradient", GradientV "-moz-radial-gradient" <$> radialgradient)+ ,("-webkit-radial-gradient", GradientV "-webkit-radial-gradient" <$> radialgradient)+ --,("repeating-linear-gradient", ? ) -- TODO+ --,("repeating-radial-gradient", ? ) -- TODO+ -- <shape>+ ,("rect", rect)+ -- <transform-function>+ ,("matrix", TransformV <$> matrix)+ ,("matrix3d", TransformV <$> matrix3d)+ ,("rotate", (TransformV . Rotate) <$> functionParser angle)+ ,("rotate3d", TransformV <$> rotate3d)+ ,("rotateX", (TransformV . Rotate) <$> functionParser angle)+ ,("rotateY", (TransformV . Rotate) <$> functionParser angle)+ ,("rotateZ", (TransformV . Rotate) <$> functionParser angle)+ ,("scale", TransformV <$> scale)+ ,("scale3d", TransformV <$> scale3d)+ ,("scaleX", (TransformV . ScaleY) <$> functionParser number)+ ,("scaleY", (TransformV . ScaleY) <$> functionParser number)+ ,("scaleZ", (TransformV . ScaleZ) <$> functionParser number)+ ,("skew", TransformV <$> skew)+ ,("skewX", (TransformV . SkewX) <$> functionParser angle)+ ,("skewY", (TransformV . SkewY) <$> functionParser angle)+ ,("translate", TransformV <$> translate)+ ,("translate3d", TransformV <$> translate3d)+ ,("translateX", (TransformV . TranslateX) <$> functionParser percentageLength)+ ,("translateY", (TransformV . TranslateY) <$> functionParser percentageLength)+ ,("translateZ", (TransformV . TranslateZ) <$> functionParser distance)+ ,("perspective", (TransformV . Perspective) <$> functionParser distance)+ -- <timing-function>+ ,("cubic-bezier", TimingFuncV <$> cubicbezier)+ ,("steps", TimingFuncV <$> steps)+ -- <filter-function>+ ,("blur", (FilterV . Blur) <$> functionParser distance)+ ,("contrast", (FilterV . Contrast) <$> functionParser numberPercentage)+ ,("grayscale", (FilterV . Grayscale) <$> functionParser numberPercentage)+ ,("invert", (FilterV . Invert) <$> functionParser numberPercentage)+ ,("opacity", (FilterV . Opacity) <$> functionParser numberPercentage)+ ,("saturate", (FilterV . Saturate) <$> functionParser numberPercentage)+ ,("sepia", (FilterV . Sepia) <$> functionParser numberPercentage)+ ,("brightness", (FilterV . Brightness) <$> functionParser numberPercentage)+ ,("drop-shadow", FilterV <$> dropShadow)+ ,("hue-rotate", (FilterV . HueRotate) <$> functionParser angle)+ ,("element", genericFunc "element")+ --+ -- <basic-shape>+ -- circle() = circle( [<shape-radius>]? [at <position>]? )+ -- polygon( [<fill-rule>,]? [<shape-arg> <shape-arg>]# )+ -- inset()+ -- ellipse( [<shape-radius>{2}]? [at <position>]? )+ --+ -- <image> https://drafts.csswg.org/css-images+ -- Note: <gradient> is a type of <image> !+ -- cross-fade()+ -- image()+ -- image-set()+ -- image-set()+ -- element()+ --+ --+ --,("stylistic", functionParser ident) -- IDENT+ --,("styleset", ? ) -- ident#+ --,("swash", ? ) -- ident+ --,("annotation", ? ) -- ident+ --,("attr", ? ) -- <attr-name> <type-or-unit>? [, <attr-fallback> ]?+ --,("calc", ? ) -- <calc-sum> , experimental+ --,("character-variant", ? ) -- ident#+ --,("element", ? ) -- id selector, experimental+ --,("local", ? )+ --,("ornaments", ? ) -- ident+ --,("symbols", ? ) -- <symbols-type>? [ <string> | <image> ]++ --,("var", ? ) -- experimental: <custom-property-name> [, <declaration-value> ]?+-- minmax()+ ]++dropShadow :: Parser FilterFunction+dropShadow = functionParser $ do+ l1 <- distance <* skipComments+ l2 <- distance <* skipComments+ l3 <- option Nothing ((Just <$> distance) <* skipComments)+ c <- option Nothing (Just <$> color)+ pure $ DropShadow l1 l2 l3 c++textShadow :: Parser Values+textShadow = do+ v <- shadowText <* skipComments+ vs <- many (liftA2 (,) commaSeparator shadowText) <* skipComments+ pure $ Values v vs++shadowText :: Parser Value+shadowText = permute (mkShadowText <$$> (lns <* skipComments)+ <|?> (Nothing , Just <$> color <* skipComments))+ where mkShadowText (x,y,b) = ShadowText x y b+ lns = do+ l1 <- distance <* skipComments+ l2 <- distance <* skipComments+ l3 <- option Nothing ((Just <$> distance) <* skipComments)+ pure (l1,l2,l3)++shadowList :: Parser Values+shadowList = parseCommaSeparated (ShadowV <$> shadow)++positionList :: Parser Values+positionList = parseCommaSeparated positionvalue++parseCommaSeparated :: Parser Value -> Parser Values+parseCommaSeparated p = do+ v <- p <* skipComments+ vs <- many ((,) <$> commaSeparator <*> p) <* skipComments+ c <- A.peekChar+ case c of+ Just x -> if x `elem` ['!', ';', '}']+ then pure $ Values v vs+ else mzero+ Nothing -> pure $ Values v vs+++shadow :: Parser Shadow+shadow = permute (mkShadow <$?> (False, asciiCI "inset" $> True <* skipComments)+ <||> fourLengths+ <|?> (Nothing , Just <$> color <* skipComments))+ where mkShadow i (l1,l2,l3,l4) = Shadow i l1 l2 l3 l4+ fourLengths = do+ l1 <- distance <* skipComments+ l2 <- distance <* skipComments+ l3 <- option Nothing ((Just <$> distance) <* skipComments)+ l4 <- option Nothing ((Just <$> distance) <* skipComments)+ pure (l1,l2,l3,l4)++radialgradient :: Parser Gradient+radialgradient = functionParser $ do+ (def, c) <- option (True, RadialGradient Nothing Nothing) ((False,) <$> endingShapeAndSize <* skipComments)+ p <- option Nothing (asciiCI "at" *> skipComments *> (Just <$> position))+ _ <- if def && isNothing p+ then pure '*' -- do nothing+ else comma+ cs <- colorStopList+ pure $ c p cs+ where circle = asciiCI "circle" $> Just Circle <* skipComments+ ellipse = asciiCI "ellipse" $> Just Ellipse <* skipComments+ endingShapeAndSize = r1 <|> r2 <|> r3+ where r1 = permute (RadialGradient <$?> (Nothing, ellipse) <||> (Just <$> (PL <$> percentageLength <* skipComments <*> percentageLength <* skipComments)))+ r2 = permute (RadialGradient <$?> (Nothing, circle) <||> ((Just . SL) <$> distance <* skipComments))+ r3 = permute (RadialGradient <$?> (Nothing, circle <|> ellipse) <||> extentKeyword)+ <|> permute (RadialGradient <$$> (circle <|> ellipse) <|?> (Nothing, extentKeyword))+ extentKeyword = do+ i <- ident+ _ <- skipComments+ case Map.lookup i extentKeywords of+ Just x -> pure (Just x)+ Nothing -> mzero+ extentKeywords :: Map Text Size+ extentKeywords = Map.fromList [("closest-corner", ClosestCorner)+ ,("closest-side", ClosestSide)+ ,("farthest-corner", FarthestCorner)+ ,("farthest-side", FarthestSide)]++-- | Assumes "linear-gradient(", or one of its prefixed equivalents, has been parsed.+-- : [<angle>|to <side-or-corner> ,]? <color-stop> [, <color-stop>]++lineargradient :: Parser Gradient+lineargradient = functionParser (lg <|> oldLg)+ where lg = do+ x <- option Nothing angleOrSide+ c <- colorStopList+ pure $ LinearGradient x c+ oldLg = do+ x <- option Nothing ((ga <|> ((Just . Right) <$> sideOrCorner)) <* comma)+ c <- colorStopList+ pure $ OldLinearGradient x c+ angleOrSide = (ga <|> gs) <* comma+ ga = (Just . Left) <$> angle+ gs = asciiCI "to" *> skipComments *> ((Just . Right) <$> sideOrCorner)++-- <side-or-corner> = [left | right] || [top | bottom]+sideOrCorner :: Parser (Side, Maybe Side)+sideOrCorner = orderOne <|> orderTwo+ where orderOne = (,) <$> leftright <* skipComments+ <*> option Nothing (Just <$> topbottom)+ orderTwo = (,) <$> topbottom <* skipComments+ <*> option Nothing (Just <$> leftright)++leftright :: Parser Side+leftright = (asciiCI "left" $> LeftSide)+ <|> (asciiCI "right" $> RightSide)++topbottom :: Parser Side+topbottom = (asciiCI "top" $> TopSide)+ <|> (asciiCI "bottom" $> BottomSide)++colorStopList :: Parser [ColorStop]+colorStopList = do+ c1 <- colorStop+ _ <- char ',' <* skipComments+ c2 <- colorStop+ cs <- many (char ',' *> skipComments *> colorStop)+ pure $ c1:c2:cs++colorStop :: Parser ColorStop+colorStop = ColorStop <$> color <* skipComments+ <*> option Nothing (Just <$> percentageLength <* skipComments)++color :: Parser Color+color = hex <|> othercolor+ where othercolor = do+ t <- textualvalue+ case t of+ ColorV c -> pure c+ _ -> mzero++-- TODO make parser specifically for it instead of reusing numericalvalue+percentageLength :: Parser PercentageLength+percentageLength = do+ n <- numericalvalue+ case n of+ PercentageV p -> pure $ Left p+ NumberV 0 -> pure $ Right (Distance 0 PX)+ DistanceV d -> pure $ Right d+ _ -> mzero++numberPercentage :: Parser (Either Number Percentage)+numberPercentage = do+ n <- numericalvalue+ case n of+ NumberV x -> pure $ Left x+ PercentageV p -> pure $ Right p+ _ -> mzero++-- | Assumes "rect(" has been already parsed+rect :: Parser Value+rect = functionParser $ do+ length1 <- distance <* comma+ length2 <- distance <* comma+ length3 <- distance <* comma+ length4 <- distance+ pure $ Rect length1 length2 length3 length4++-- | Assumes "translate(" has been already parsed+translate :: Parser TransformFunction+translate = functionParser $ do+ pl <- percentageLength <* skipComments+ mpl <- option Nothing (char ',' *> skipComments *> (Just <$> percentageLength))+ pure $ Translate pl mpl++-- | Parser of scale() function. Assumes "scale(" has been already parsed+scale :: Parser TransformFunction+scale = functionParser $ do+ n <- number <* skipComments+ mn <- option Nothing (char ',' *> skipComments *> (Just <$> number))+ pure $ Scale n mn++scale3d :: Parser TransformFunction+scale3d = functionParser $ liftA3 Scale3d n n number+ where n = number <* comma++skew :: Parser TransformFunction+skew = functionParser $ do+ a <- angle <* skipComments+ ma <- option Nothing (char ',' *> skipComments *> (Just <$> angle))+ pure $ Skew a ma++translate3d :: Parser TransformFunction+translate3d = functionParser $ do+ x <- percentageLength <* comma+ y <- percentageLength <* comma+ z <- distance+ pure $ Translate3d x y z++matrix :: Parser TransformFunction+matrix = functionParser $ do+ n <- number+ ns <- count 5 (comma *> number)+ pure $ mkMat (n:ns)++matrix3d :: Parser TransformFunction+matrix3d = functionParser $ do+ n <- number+ ns <- count 15 (comma *> number)+ pure $ mkMat3d (n:ns)++rotate3d :: Parser TransformFunction+rotate3d = functionParser $ do+ x <- number <* comma+ y <- number <* comma+ z <- number <* comma+ a <- angle+ pure $ Rotate3d x y z a++cubicbezier :: Parser TimingFunction+cubicbezier = functionParser $ do+ p0 <- number <* comma+ p1 <- number <* comma+ p2 <- number <* comma+ p3 <- number+ pure $ CubicBezier p0 p1 p2 p3++steps :: Parser TimingFunction+steps = functionParser $ do+ i <- int+ s <- option Nothing (comma *> (Just <$> startOrEnd))+ pure $ Steps i s+ where startOrEnd = (asciiCI "end" $> End)+ <|> (asciiCI "start" $> Start)++-- We use skipSpace instead of skipComments, since comments aren't valid inside+-- the url-token. From the spec:+-- COMMENT tokens cannot occur within other tokens: thus, "url(/*x*/pic.png)"+-- denotes the URI "/*x*/pic.png", not "pic.png".+-- Assumes "url(" has been already parsed+url :: Parser Url+url = Url <$> (skipSpace *> someUri <* skipSpace <* char ')')+ where someUri = (Right <$> stringtype) <|> (Left <$> nonQuotedUri)+ nonQuotedUri = A.takeWhile1 (/= ')') -- TODO maybe parse ident?++-- format(<string>#)+-- Assumes "format(" has been already parsed+format :: Parser Value+format = Format <$> functionParser p+ where p = (:) <$> stringtype <*> many (comma *> stringtype)++namedColorsParsersMap :: Map Text (Parser Value)+namedColorsParsersMap = Map.fromList $ foldr f [] keywordColors+ where f x xs = let a = fst x+ in (a, pure $ ColorV (Named a)) : xs++-- | For cases when CSS hacks are used, e.g.:+-- margin-top: 1px \9;+valuesFallback :: Parser Values+valuesFallback = Values <$> value <*> many ((,) <$> separator <*> value) <* skipComments++separator :: Parser Separator+separator = lexeme $ (char ',' $> Comma)+ <|> (char '/' $> Slash)+ <|> pure Space++commaSeparator :: Parser Separator+commaSeparator = lexeme (char ',' $> Comma)++-- <string> data type parser+stringtype :: Parser StringType+stringtype = doubleQuotesString <|> singleQuotesString++doubleQuotesString :: Parser StringType+doubleQuotesString = char '\"' *> (DoubleQuotes <$> untilDoubleQuotes)+ where untilDoubleQuotes = mappend <$> A.takeWhile (\c -> c /= '\\' && c /= '\"') <*> checkCharacter+ checkCharacter = (string "\"" $> mempty)+ <|> (T.cons <$> char '\\' <*> untilDoubleQuotes)++singleQuotesString :: Parser StringType+singleQuotesString = char '\'' *> (SingleQuotes <$> untilSingleQuotes)+ where untilSingleQuotes = mappend <$> A.takeWhile (\c -> c /= '\\' && c /= '\'') <*> checkCharacter+ checkCharacter = (string "\'" $> mempty)+ <|> (T.cons <$> char '\\' <*> untilSingleQuotes)++-- <single-animation>#+animation :: Parser Values+animation = parseCommaSeparated singleAnimation++-- <single-animation> = <time> || <timing-function> || <time> || <animation-iteration-count> || <animation-direction> || <animation-fill-mode> || <animation-play-state> || [ none | <keyframes-name> ]+singleAnimation :: Parser Value+singleAnimation = do+ sa <- permute (mkSingleAnimation <$?> (Nothing, Just <$> keyframesName <* skipComments)+ <|?> (Nothing, Just <$> iterationCount <* skipComments)+ <|?> (Nothing, Just <$> duration <* skipComments)+ <|?> (Nothing, Just <$> duration <* skipComments)+ <|?> (Nothing, Just <$> timingFunction <* skipComments)+ <|?> (Nothing, Just <$> animationDirection <* skipComments)+ <|?> (Nothing, Just <$> animationFillMode <* skipComments)+ <|?> (Nothing, Just <$> animationPlayState <* skipComments))+ if saIsEmpty sa+ then mzero+ else pure sa+ where -- mkSingleAnimation is used to order properly the overlapping values parsed by permute.+ mkSingleAnimation kf ic t1 t2 tf c d e = SingleAnimation t2 tf t1 ic c d e kf+ saIsEmpty (SingleAnimation Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing) = True+ saIsEmpty _ = False+ iterationCount = (mkOther <$> asciiCI "infinite") <|> (NumberV <$> number)+ animationDirection = parseIdents ["normal", "reverse", "alternate", "alternate-reverse"]+ animationFillMode = parseIdents ["none", "forwards", "backwards", "both"]+ animationPlayState = parseIdents ["running", "paused"]+ keyframesName = stringvalue <|> (mkOther <$> ident)++parseIdents :: [Text] -> Parser TextV+parseIdents ls = do+ i <- ident+ if Set.member (T.toLower i) s+ then pure $ TextV i+ else mzero+ where s = Set.fromList ls++-- <single-animation-fill-mode> = none | forwards | backwards | both
+ src/Hasmin/Properties.hs view
@@ -0,0 +1,501 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module : Hasmin.Properties+-- Copyright : (c) 2017 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : unknown+--+-----------------------------------------------------------------------------+module Hasmin.Properties (+ PropertyInfo(..)+ , shorthandAndLonghandsMap+ , propertiesTraits+ ) where++import Data.Attoparsec.Text (parseOnly)+import Data.Text (Text)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Hasmin.Types.Value+import Hasmin.Parser.Value++-- TODO see if this can be extended to contain all the information from a+-- property (such as initial value). Otherwise, delete it.+data PropertyInfo =+ PropertyInfo { overwrittenBy :: [Text] -- shorthands that overwrite it+ , subproperties :: [Text] -- longhands that can be merged into it+ } deriving (Show)++shorthandAndLonghandsMap :: Map Text PropertyInfo+shorthandAndLonghandsMap = Map.fromList properties++properties :: [(Text,PropertyInfo)]+properties =+ [("animation", PropertyInfo mempty ["animation-name","animation-duration","animation-timing-function","animation-delay","animation-iteration-count","animation-direction","animation-fill-mode","animation-play-state"])+ ,("animation-delay", PropertyInfo ["animation"] mempty)+ ,("animation-direction", PropertyInfo ["animation"] mempty)+ ,("animation-duration", PropertyInfo ["animation"] mempty)+ ,("animation-fill-mode", PropertyInfo ["animation"] mempty)+ ,("animation-iteration-count", PropertyInfo ["animation"] mempty)+ ,("animation-name", PropertyInfo ["animation"] mempty)+ ,("animation-play-state", PropertyInfo ["animation"] mempty)+ ,("animation-timing-function", PropertyInfo ["animation"] mempty)+ ,("background", PropertyInfo mempty ["background-image", "background-position", "background-size", "background-repeat", "background-origin", "background-clip", "background-attachment", "background-color"])+ ,("background-attachment", PropertyInfo ["background"] mempty)+ ,("background-clip", PropertyInfo ["background"] mempty)+ ,("background-color", PropertyInfo ["background"] mempty)+ ,("background-image", PropertyInfo ["background"] mempty)+ ,("background-origin", PropertyInfo ["background"] mempty)+ ,("background-position", PropertyInfo ["background"] ["background-position-x", "background-position-y"])+ ,("background-position-x", PropertyInfo ["background", "background-position"] mempty)+ ,("background-position-y", PropertyInfo ["background", "background-position"] mempty)+ ,("background-repeat", PropertyInfo ["background"] mempty)+ ,("background-size", PropertyInfo ["background"] mempty)+ ,("border", PropertyInfo mempty ["border-width", "border-style", "border-color"])+ ,("border-bottom", PropertyInfo ["border"] ["border-bottom-color", "border-bottom-style", "border-bottom-width"])+ ,("border-bottom-color", PropertyInfo ["border", "border-color", "border-bottom"] mempty)+ ,("border-bottom-left-radius", PropertyInfo ["border-radius"] mempty)+ ,("border-bottom-right-radius", PropertyInfo ["border-radius"] mempty)+ ,("border-bottom-style", PropertyInfo ["border", "border-style", "border-bottom"] mempty)+ ,("border-bottom-width", PropertyInfo ["border", "border-width", "border-bottom"] mempty)+ ,("border-color", PropertyInfo ["border"] ["border-top-color", "border-right-color", "border-bottom-color", "border-left-color"])+ ,("border-image", PropertyInfo ["border"] ["border-image-source", "border-image-slice", "border-image-width", "border-image-outset", "border-image-repeat"])+ ,("border-image-outset", PropertyInfo ["border", "border-image"] mempty)+ ,("border-image-repeat", PropertyInfo ["border", "border-image"] mempty)+ ,("border-image-slice", PropertyInfo ["border", "border-image"] mempty)+ ,("border-image-source", PropertyInfo ["border", "border-image"] mempty)+ ,("border-image-width", PropertyInfo ["border", "border-image"] mempty)+ ,("border-left", PropertyInfo ["border"] ["border-left-color", "border-left-style", "border-left-width"])+ ,("border-left-color", PropertyInfo ["border", "border-color", "border-left"] mempty)+ ,("border-left-style", PropertyInfo ["border", "border-style", "border-left"] mempty)+ ,("border-left-width", PropertyInfo ["border", "border-width", "border-left"] mempty)+ ,("border-radius", PropertyInfo mempty ["border-top-left-radius","border-top-right-radius","border-bottom-right-radius","border-bottom-left-radius"])+ ,("border-right", PropertyInfo ["border"] ["border-right-color", "border-right-style", "border-right-width"])+ ,("border-right-color", PropertyInfo ["border", "border-color", "border-right"] mempty)+ ,("border-right-style", PropertyInfo ["border", "border-style", "border-right"] mempty)+ ,("border-right-width", PropertyInfo ["border", "border-width", "border-right"] mempty)+ ,("border-style", PropertyInfo ["border"] ["border-top-style", "border-right-style", "border-bottom-style", "border-left-style"])+ ,("border-top", PropertyInfo ["border"] ["border-top-color", "border-top-style", "border-top-width"])+ ,("border-top-color", PropertyInfo ["border", "border-color", "border-top"] mempty)+ ,("border-top-left-radius", PropertyInfo ["border-radius"] mempty)+ ,("border-top-right-radius", PropertyInfo ["border-radius"] mempty)+ ,("border-top-style", PropertyInfo ["border", "border-style", "border-top"] mempty)+ ,("border-top-width", PropertyInfo ["border", "border-width", "border-top"] mempty)+ ,("border-width", PropertyInfo ["border"] ["border-top-width", "border-right-width", "border-bottom-width", "border-left-width"])+ ,("column-count", PropertyInfo ["columns"] mempty)+ ,("column-rule", PropertyInfo mempty ["column-rule-color", "column-rule-style", "column-rule-width"])+ ,("column-rule-color", PropertyInfo ["column-rule"] mempty)+ ,("column-rule-style", PropertyInfo ["column-rule"] mempty)+ ,("column-rule-width", PropertyInfo ["column-rule"] mempty)+ ,("columns", PropertyInfo mempty ["column-width", "column-count"])+ ,("column-width", PropertyInfo ["columns"] mempty)+ ,("flex", PropertyInfo mempty ["flex-grow", "flex-shrink", "flex-basis"])+ ,("flex-basis", PropertyInfo ["flex"] mempty)+ ,("flex-direction", PropertyInfo ["flex-flow"] mempty)+ ,("flex-flow", PropertyInfo mempty ["flex-direction", "flex-wrap"])+ ,("flex-grow", PropertyInfo ["flex"] mempty)+ ,("flex-shrink", PropertyInfo ["flex"] mempty)+ ,("flex-wrap", PropertyInfo ["flex-flow"] mempty)+ ,("font", PropertyInfo mempty ["font-style", "font-variant", "font-weight", "font-stretch", "font-size", "line-height", "font-family"])+ ,("font-family", PropertyInfo ["font"] mempty)+ ,("font-kerning", PropertyInfo ["font"] mempty)+ ,("font-language-override", PropertyInfo ["font"] mempty)+ ,("font-size", PropertyInfo ["font"] mempty)+ ,("font-size-adjust", PropertyInfo ["font"] mempty)+ ,("font-stretch", PropertyInfo ["font"] mempty)+ ,("font-style", PropertyInfo ["font"] mempty)+ ,("font-variant", PropertyInfo ["font"] mempty)+ ,("font-weight", PropertyInfo ["font"] mempty)+ ,("grid", PropertyInfo mempty ["grid-template-rows", "grid-template-columns", "grid-template-areas", "grid-auto-rows", "grid-auto-columns", "grid-auto-flow", "grid-column-gap", "grid-row-gap"])+ ,("grid-area", PropertyInfo mempty ["grid-row-start", "grid-row-end", "grid-column-start", "grid-column-end"])+ ,("grid-column", PropertyInfo mempty ["grid-column-start", "grid-column-end"])+ ,("grid-column-end", PropertyInfo ["grid-column", "grid-area"] mempty)+ ,("grid-column-end", PropertyInfo ["grid-column", "grid-area"] mempty)+ ,("grid-column-gap", PropertyInfo ["grid-gap"] mempty)+ ,("grid-gap", PropertyInfo mempty ["grid-row-gap", "grid-column-gap"])+ ,("grid-row", PropertyInfo mempty ["grid-row-start", "grid-row-end"])+ ,("grid-row-end", PropertyInfo ["grid-row", "grid-area"] mempty)+ ,("grid-row-gap", PropertyInfo ["grid-gap"] mempty)+ ,("grid-row-start", PropertyInfo ["grid-row", "grid-area"] mempty)+ ,("grid-template", PropertyInfo mempty ["grid-template-columns", "grid-template-rows", "grid-template-areas"])+ ,("grid-template-areas", PropertyInfo ["grid-template"] mempty)+ ,("grid-template-columns", PropertyInfo ["grid-template"] mempty)+ ,("grid-template-rows", PropertyInfo ["grid-template"] mempty)+ ,("line-height", PropertyInfo ["font"] mempty)+ ,("list-style", PropertyInfo mempty ["list-style-type", "list-style-position", "list-style-image"])+ ,("list-style-image", PropertyInfo ["list-style"] mempty)+ ,("list-style-position", PropertyInfo ["list-style"] mempty)+ ,("list-style-type", PropertyInfo ["list-style"] mempty)+ ,("margin", PropertyInfo mempty ["margin-top", "margin-right", "margin-bottom", "margin-left"])+ ,("margin-bottom", PropertyInfo ["margin"] mempty)+ ,("margin-left", PropertyInfo ["margin"] mempty)+ ,("margin-right", PropertyInfo ["margin"] mempty)+ ,("margin-top", PropertyInfo ["margin"] mempty)+ ,("mask", PropertyInfo mempty ["mask-clip", "mask-origin", "mask-border"])+ ,("mask-border", PropertyInfo ["mask"] ["mask-border-source", "mask-border-slice", "mask-border-width", "mask-border-outset", "mask-border-repeat"])+ ,("mask-border-outset", PropertyInfo ["mask", "mask-border"] mempty)+ ,("mask-border-repeat", PropertyInfo ["mask", "mask-border"] mempty)+ ,("mask-border-slice", PropertyInfo ["mask", "mask-border"] mempty)+ ,("mask-border-source", PropertyInfo ["mask", "mask-border"] mempty)+ ,("mask-border-width", PropertyInfo ["mask", "mask-border"] mempty)+ ,("mask-clip", PropertyInfo ["mask"] mempty)+ ,("mask-composite", PropertyInfo ["mask"] mempty)+ ,("mask-image", PropertyInfo ["mask"] mempty)+ ,("mask-mode", PropertyInfo ["mask"] mempty)+ ,("mask-origin", PropertyInfo ["mask"] mempty)+ ,("mask-position", PropertyInfo ["mask"] mempty)+ ,("mask-repeat", PropertyInfo ["mask"] mempty)+ ,("mask-size", PropertyInfo ["mask"] mempty)+ ,("outline", PropertyInfo mempty ["outline-width", "outline-style", "outline-color"])+ ,("outline-color", PropertyInfo ["outline"] mempty)+ ,("outline-style", PropertyInfo ["outline"] mempty)+ ,("outline-width", PropertyInfo ["outline"] mempty)+ ,("padding", PropertyInfo mempty ["padding-top", "padding-right", "padding-bottom", "padding-left"])+ ,("padding-bottom", PropertyInfo ["padding"] mempty)+ ,("padding-left", PropertyInfo ["padding"] mempty)+ ,("padding-right", PropertyInfo ["padding"] mempty)+ ,("padding-top", PropertyInfo ["padding"] mempty)+ ,("text-decoration", PropertyInfo mempty ["text-decoration-color", "text-decoration-style", "text-decoration-line"])+ ,("text-decoration-color", PropertyInfo ["text-decoration"] mempty)+ ,("text-decoration-line", PropertyInfo ["text-decoration"] mempty)+ ,("text-decoration-style", PropertyInfo ["text-decoration"] mempty)+ ,("text-emphasis", PropertyInfo mempty ["text-emphasis-color", "text-emphasis-style"])+ ,("text-emphasis-color", PropertyInfo ["text-emphasis"] mempty)+ ,("text-emphasis-style", PropertyInfo ["text-emphasis"] mempty)+ ,("transition", PropertyInfo mempty ["transition-property", "transition-duration", "transition-timing-function", "transition-delay"])+ ,("transition-delay", PropertyInfo ["transition"] mempty)+ ,("transition-duration", PropertyInfo ["transition"] mempty)+ ,("transition-property", PropertyInfo ["transition"] mempty)+ ,("transition-timing-function", PropertyInfo ["transition"] mempty)+ ]++-- mempty is used when there is no initial value, or for properties that need+-- special treatment, such as many of the shorthands+propertiesTraits :: Map Text (Maybe Values, Bool)+propertiesTraits = Map.fromList $ replaceTextWithValues+ [("align-content", ("stretch", False))+ ,("align-items", ("stretch", False))+ ,("align-self", ("auto", False))+ ,("all", (mempty, False)) -- No practical initial value+ ,("animation", (mempty, False)) -- shorthand+ ,("animation-delay", ("0s", False)) -- experimental+ ,("animation-direction", ("normal", False)) -- experimental+ ,("animation-duration", ("0s", False)) -- experimental+ ,("animation-fill-mode", ("none", False)) -- experimental+ ,("animation-iteration-count", ("1", False)) -- experimental+ ,("animation-name", ("none", False)) -- experimental+ ,("animation-play-state", ("running", False)) -- experimental+ ,("animation-timing-function", ("ease", False)) -- experimental+ ,("backface-visibility", ("visible", False))+ ,("-webkit-backface-visibility", ("visible", False))+ ,("backdrop-filter", ("none", False)) -- experimental+ ,("-webkit-backdrop-filter", ("none", False)) -- experimental+ ,("background", (mempty {-shorthand-}, False))+ ,("background-attachment", ("scroll", False))+ ,("background-blend-mode", ("normal", False))+ ,("background-clip", ("border-box", False))+ ,("-webkit-background-clip", ("border-box", False))+ ,("background-color", ("transparent", False))+ ,("background-image", ("none", False))+ ,("background-origin", ("padding-box", False))+ ,("background-position", (mempty, False)) --shorthand+ ,("background-position-x", ("left", False))+ ,("background-position-inline", (mempty {-not applicable-}, False))+ ,("background-position-block", (mempty {-not applicable-}, False))+ ,("background-position-y", ("top", False))+ ,("background-repeat", ("repeat", False))+ ,("background-size", ("auto", False))+ ,("block-size", ("auto", False)) -- experimental+ ,("border", ("medium none currentcolor", False)) -- shorthand!+ -- border-block-* would go here+ ,("border-bottom", ("medium none currentcolor", False)) -- shorthand!+ ,("border-bottom-color", ("currentcolor", False))+ ,("border-bottom-left-radius", ("0", False))+ ,("border-bottom-right-radius", ("0", False))+ ,("border-bottom-style", ("none", False))+ ,("border-bottom-width", ("medium", False))+ ,("border-collapse", ("separate", True))+ ,("border-color", (mempty, False)) -- shorthand!+ ,("border-image", (mempty, False)) -- shorthand+ ,("border-image-outset", ("0", False))+ ,("border-image-repeat", ("stretch", False))+ ,("border-image-slice", ("100%", False))+ ,("border-image-source", ("none", False))+ ,("border-image-width", ("1", False))+ -- border-inline-* would go here+ ,("border-left", ("medium none currentcolor", False)) -- shorthand!+ ,("border-left-color", ("currentcolor", False))+ ,("border-left-style", ("none", False))+ ,("border-left-width", ("medium", False))+ -- ,("border-radius" -- shorthand+ ,("border-right", ("medium none currentcolor", False)) -- shorthand!+ ,("border-right-color", ("currentcolor", False))+ ,("border-right-style", ("none", False))+ ,("border-right-width", ("medium", False))+ ,("border-spacing", ("0", True))+ -- ,("border-style" -- shorthand+ ,("border-top", ("medium none currentcolor", False)) -- shorthand+ ,("border-top-color", ("currentcolor", False))+ ,("border-top-style", ("none", False))+ ,("border-top-width", ("medium", False))+ ,("border-top-left-radius", ("0", False))+ ,("border-top-right-radius", ("0", False))+ -- ,("border-width" -- shorthand+ ,("bottom", ("auto", False))+ ,("box-decoration-break", ("slice", False)) -- experimental+ ,("-webkit-box-decoration-break", ("slice", False)) -- experimental+ ,("-o-box-decoration-break", ("slice", False)) -- experimental+ ,("box-shadow", ("none", False))+ ,("-webkit-box-shadow", ("none", False))+ ,("box-sizing", ("content-box", False)) -- experimental+ ,("-webkit-box-sizing", ("content-box", False)) -- experimental+ ,("-moz-box-sizing", ("content-box", False)) -- experimental+ ,("break-after", ("auto", False))+ ,("break-before", ("auto", False))+ ,("break-inside", ("auto", False))+ ,("caption-side", ("top", True))+ ,("clear", ("none", False))+ ,("clip", ("auto", False)) -- deprecated!+ ,("color", (mempty {-UA dependent-}, True))+ ,("column-count", ("auto", False))+ ,("column-fill", ("balance", False))+ ,("column-gap", ("normal", False))+ ,("column-rule", ("medium none currentcolor", False)) -- shorthand+ ,("column-rule-color", ("currentcolor", False))+ ,("column-rule-style", ("none", False))+ ,("column-rule-width", ("medium", False))+ ,("column-span", ("none", False))+ ,("column-width", ("auto", False))+ -- ,("columns", -- shorthand+ ,("content", ("normal", False))+ ,("counter-increment", ("none", False))+ ,("counter-reset", ("none", False))+ ,("cursor", ("auto", True))+ ,("direction", ("ltr", True))+ ,("display", ("inline", False))+ ,("empty-cells", ("show", True))+ ,("filter", ("none", False)) -- experimental+ ,("-webkit-filter", ("none", False)) -- experimental+ -- ,("flex", ("0", False)) -- shorthand+ ,("flex-basis", ("auto", False))+ ,("flex-direction", ("row", False))+ ,("flex-flow", ("row nowrap", False)) -- shorthand+ ,("flex-grow", ("0", False))+ ,("flex-shrink", ("1", False))+ ,("flex-wrap", ("nowrap", False))+ ,("float", ("none", False))+ ,("float", ("none", False))+ ,("font", (mempty {-shorthand-}, True))+ ,("font-family", (mempty {-UA dependent-}, True))+ ,("font-feature-settings", ("normal", True))+ ,("font-kerning", ("auto", True))+ ,("font-language-override", ("normal", True))+ ,("font-size", ("medium", True))+ ,("font-size-adjust", ("none", True))+ ,("font-stretch", ("normal", True))+ ,("font-style", ("normal", True))+ ,("font-synthesis", ("weight style", True))+ ,("font-variant", ("normal", True))+ ,("font-variant-alternates", ("normal", True))+ ,("font-variant-caps", ("normal", True))+ ,("font-variant-east-asian", ("normal", True))+ ,("font-variant-ligatures", ("normal", True))+ ,("font-variant-numeric", ("normal", True))+ ,("font-variant-position", ("normal", True))+ ,("font-weight", ("normal", True))+ -- grid -- shorthand, experimental+ -- grid-area -- shorthand, experimental+ ,("grid-auto-columns", ("auto", False)) -- experimental+ ,("-ms-grid-auto-columns", ("auto", False)) -- experimental+ ,("-webkit-grid-auto-columns", ("auto", False)) -- experimental+ ,("grid-auto-flow", ("row", False)) -- experimental+ ,("-webkit-grid-auto-flow", ("row", False)) -- experimental+ ,("grid-auto-rows", ("auto", False)) -- experimental+ ,("-ms-grid-auto-rows", ("auto", False)) -- experimental+ ,("-webkit-grid-auto-rows", ("auto", False)) -- experimental+ -- grid-column -- shorthand, experimental+ ,("grid-column-end", ("auto", False)) -- experimental+ ,("-ms-grid-column-end", ("auto", False)) -- experimental+ ,("-webkit-grid-column-end", ("auto", False)) -- experimental+ ,("grid-column-gap", ("0", False)) -- experimental+ ,("-ms-grid-column-gap", ("0", False)) -- experimental+ ,("grid-column-start", ("auto", False)) -- experimental+ ,("-ms-grid-column-start", ("auto", False)) -- experimental+ ,("-webkit-grid-column-start", ("auto", False)) -- experimental+ -- ,("grid-gap", -- shorthand, experimental+ -- ,("grid-row", -- shorthand, experimental+ ,("grid-row-end", ("auto", False)) -- experimental+ ,("-ms-grid-row-end", ("auto", False)) -- experimental+ ,("-webkit-grid-row-end", ("auto", False)) -- experimental+ ,("grid-row-gap", ("0", False)) -- experimental+ ,("-webkit-grid-row-gap", ("0", False)) -- experimental+ ,("grid-row-start", ("auto", False)) -- experimental+ ,("-ms-grid-row-start", ("auto", False)) -- experimental+ ,("-webkit-grid-row-start", ("auto", False)) -- experimental+ -- ,("grid-template", -- shorthand, experimental+ ,("grid-template-areas", ("none", False)) -- experimental+ ,("-webkit-grid-template-areas", ("none", False)) -- experimental+ ,("grid-template-columns", ("none", False)) -- experimental+ ,("-ms-grid-template-columns", ("none", False)) -- experimental+ ,("-webkit-grid-template-columns", ("none", False)) -- experimental+ ,("grid-template-rows", ("none", False)) -- experimental+ ,("-ms-grid-template-rows", ("none", False)) -- experimental+ ,("-webkit-grid-template-rows", ("none", False)) -- experimental+ ,("height", ("auto", False))+ ,("hyphens", ("manual", False))+ -- ,("image-orientation" --experimental+ -- ,("image-rendering" --experimental+ -- ,("inline-size", -- experimental+ ,("isolation", ("auto", False))+ ,("justify-content", ("flex-start", False))+ ,("left", ("auto", False))+ ,("letter-spacing", ("normal", True))+ ,("line-break", ("auto", False))+ ,("line-height", ("normal", True))+ ,("list-style", ("none disc outside", True)) -- none must go first, for entropy reasons.+ ,("list-style-image", ("none", True))+ ,("list-style-position", ("outside", True))+ ,("list-style-type", ("disc", True))+ ,("margin", (mempty {-shorthand-}, False)) -- shorthand+ -- ,("margin-block-* -- experimental+ ,("margin-bottom", ("0", False))+ -- ,("margin-inline-*" --experimental+ ,("margin-left", ("0", False))+ ,("margin-right", ("0", False))+ ,("margin-top", ("0", False))+ -- ,("mask", -- shorthand+ ,("mask-clip", ("border-box", False)) -- experimental+ ,("-webkit-mask-clip", ("border-box", False)) -- experimental+ ,("mask-composite", ("add", False)) -- experimental+ ,("mask-image", ("none", False)) -- experimental+ ,("-webkit-mask-image", ("none", False)) -- experimental+ -- ,("mask-mode", ("match-source", False)) -- experimental, no support+ ,("mask-origin", ("border-box", False)) -- experimental+ ,("-webkit-mask-origin", ("border-box", False)) -- experimental+ ,("mask-position", ("center", False)) -- experimental+ ,("-webkit-mask-position", ("center", False)) -- experimental+ ,("mask-repeat", ("no-repeat", False)) -- experimental+ ,("-webkit-mask-repeat", ("no-repeat", False)) -- experimental+ ,("mask-size", ("auto", False)) -- experimental+ ,("mask-type", ("luminance", False)) -- experimental+ -- ,("max-block-size", ("0", False)) -- experimental+ ,("max-height", ("none", False))+ -- ,("max-inline-size", ("0", False)) -- experimental+ ,("max-width", ("none", False))+ -- ,("min-block-size", ("0", False)) -- experimental+ ,("min-height", ("0", False))+ -- ,("min-inline-size", ("0", False)) -- experimental+ ,("min-width", ("0", False))+ ,("mix-blend-mode", ("normal", False))+ ,("object-fit", ("fill", True))+ ,("object-position", ("50% 50%", True))+ -- ,("offset-*", ("auto", False)) -- experimental+ ,("opacity", ("1", False))+ ,("order", ("0", False))+ ,("orphans", ("2", True))+ ,("outline", ("medium none invert", False)) -- shorthand+ ,("outline-color", ("invert" , False))+ ,("outline-offset", ("0", False))+ ,("outline-style", ("none", False))+ ,("outline-width", ("medium", False))+ ,("overflow", ("visible", False))+ ,("overflow-wrap", ("normal", True)) -- also called word-wrap+ ,("overflow-x", ("visible", False)) -- experimental+ ,("overflow-y", ("visible", False)) -- experimental+ ,("padding", (mempty, False)) -- shorthand+ -- ,("padding-block*", ("0", False)) -- experimental+ ,("padding-bottom", ("0", False))+ -- ,("padding-inline-*", ("0", False)) -- experimental+ ,("padding-left", ("0", False))+ ,("padding-right", ("0", False))+ ,("padding-top", ("0", False))+ ,("page-break-after", ("auto", False))+ ,("page-break-before", ("auto", False))+ ,("page-break-inside", ("auto", False))+ ,("perspective", ("none", False)) -- experimental+ ,("perspective-origin", ("50% 50%", False)) -- experimental+ ,("pointer-events", ("auto", True))+ ,("position", ("static", False))+ ,("quotes", (mempty {-UA dependent-}, True))+ ,("resize", ("none", False))+ ,("right", ("auto", False))+ ,("right", ("auto", False))+ -- ,("ruby-*", -- experimental+ ,("scroll-behavior", ("auto", False))+ -- ,("scroll-snap-coordinate", ("none", False)) -- experimental+ -- ,("scroll-snap-destination",("0 0", False)) -- experimental, actually 0px 0px+ -- ,("scroll-snap-type", -- experimental+ ,("shape-image-threshold", ("0", False))+ ,("shape-margin", ("0", False))+ ,("shape-outside", ("none", False))+ ,("tab-size", ("8", True)) -- experimental+ ,("-moz-tab-size", ("8", True)) -- experimental+ ,("-o-tab-size", ("8", True)) -- experimental+ ,("table-layout", ("auto", False))+ ,("text-align", ("start", False))+ ,("text-align-last", ("auto", True)) -- experimental+ ,("text-combine-upright", ("none", True)) -- experimental+ ,("-webkit-text-combine-upright", ("none", True)) -- experimental+ ,("text-decoration", ("currentcolor solid none", False)) -- shorthand+ ,("text-decoration-color", ("currentcolor", False))+ ,("text-decoration-line", ("none", False))+ ,("text-decoration-style", ("solid", False))+ ,("text-emphasis", ("none currentcolor", False)) -- shorthand+ ,("text-emphasis-color", ("currentcolor", False))+ ,("text-emphasis-position", (mempty {-"over right"-}, False))+ ,("text-emphasis-style", ("none", False))+ ,("text-indent", ("0", True))+ ,("text-orientation", ("mixed", True)) -- experimental+ ,("-webkit-text-orientation", ("mixed", True)) -- experimental+ ,("text-overflow", ("clip", False))+ ,("text-rendering", ("auto", True))+ ,("text-shadow", ("none", True))+ ,("text-transform", ("none", True))+ ,("text-underline-position", ("auto", True))+ ,("top", ("auto", False))+ ,("touch-action", ("auto", False))+ ,("transform", ("none", False)) -- experimental!+ ,("-webkit-transform", ("none", False)) -- experimental!+ ,("transform-box", ("border-box", False)) -- experimental!+ ,("transform-origin", (mempty {-"50% 50% 0"-}, False)) -- experimental!+ ,("-webkit-transform-origin", (mempty {-"50% 50% 0"-}, False)) -- experimental!+ ,("transform-style", ("flat", False)) -- experimental!+ ,("-webkit-transform-style", ("flat", False)) -- experimental!+ ,("transition", (mempty, False))-- shorthand and experimental+ ,("transition-delay", ("0s", False)) -- experimental+ ,("transition-duration", ("0s", False)) -- experimental+ ,("-webkit-transition-duration", ("0s", False)) -- experimental+ ,("-o-transition-duration", ("0s", False)) -- experimental+ ,("-webkit-transition-delay", ("0s", False)) -- experimental+ ,("transition-property", ("all", False)) -- experimental+ ,("-webkit-transition-property", ("all", False)) -- experimental+ ,("-o-transition-property", ("all", False)) -- experimental+ ,("transition-timing-function", ("ease", False)) -- experimental+ ,("-webkit-transition-timing-function", ("ease", False)) -- experimental+ ,("unicode-bidi", ("normal", False))+ ,("user-select", ("none", False)) -- experimental+ ,("-moz-user-select", ("none", False)) -- experimental+ ,("-webkit-user-select", ("none", False)) -- experimental+ ,("-ms-user-select", ("none", False)) -- experimental+ ,("vertical-align", ("baseline", False))+ ,("white-space", ("normal", True))+ ,("widows", ("2", True))+ ,("width", ("auto", False))+ ,("will-change", ("auto", False))+ ,("word-break", ("normal", True))+ ,("word-spacing", ("normal", True))+ ,("writing-mode", ("horizontal-tb", True)) -- experimental+ ,("-ms-writing-mode", ("horizontal-tb", True)) -- experimental+ ,("-webkit-writing-mode", ("horizontal-tb", True)) -- experimental+ ,("z-index", ("auto", False))+ ]++-- Parses text and replaces it with an array of values, to makes the+-- propertiesTraits table more readable and maintainable in general.+replaceTextWithValues :: [(Text, (Text, Bool))] -> [(Text, (Maybe Values, Bool))]+replaceTextWithValues = foldr (\(p,(t,i)) xs -> (p, (getValues p t,i)) : xs) []+ where getValues p s = case parseOnly (values p) s of+ Right initialValues -> Just initialValues+ Left _ -> Nothing
+ src/Hasmin/Selector.hs view
@@ -0,0 +1,339 @@+{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Hasmin.Selector+-- Copyright : (c) 2017 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : unknown+--+-----------------------------------------------------------------------------+module Hasmin.Selector (+ Selector(..)+ , SimpleSelector(..)+ , CompoundSelector+ , Combinator(..)+ , Sign(..)+ , AnPlusB(..)+ , AValue(..)+ , Att(..)+ , specialPseudoElements+ ) where++import Control.Applicative (liftA2)+import Control.Monad.Reader (ask)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Lazy.Builder (fromText, singleton, Builder)+import Data.Monoid ((<>))+import Data.List.NonEmpty (NonEmpty((:|)))+import qualified Data.List.NonEmpty as N+import Text.PrettyPrint.Mainland (Pretty, char, ppr, strictText)++import Hasmin.Config+import Hasmin.Types.Class+import Hasmin.Types.String+import Hasmin.Utils++{-+class Specificity a where+ specificity :: a -> (Int, Int, Int, Int)++addSpecificity :: (Int, Int, Int, Int)+ -> (Int, Int, Int, Int)+ -> (Int, Int, Int, Int)+addSpecificity (a1,b1,c1,d1) (a2,b2,c2,d2) = (a1 + a2, b1 + b2, c1 + c2, d1 + d2)+-}++-- | Combinators are: whitespace, "greater-than sign" (U+003E, >), "plus sign"+-- (U+002B, +) and "tilde" (U+007E, ~). White space may appear between a+-- combinator and the simple selectors around it. Only the characters "space"+-- (U+0020), "tab" (U+0009), "line feed" (U+000A), "carriage return" (U+000D),+-- and "form feed" (U+000C) can occur in whitespace. Other space-like+-- characters, such as "em-space" (U+2003) and "ideographic space" (U+3000), are+-- never part of whitespace.+data Combinator = Descendant -- ^ ' '+ | Child -- ^ '>'+ | AdjacentSibling -- ^ '+'+ | GeneralSibling -- ^ '~'+ deriving (Eq, Show)++instance ToText Combinator where+ toBuilder Descendant = " "+ toBuilder Child = ">"+ toBuilder AdjacentSibling = "+"+ toBuilder GeneralSibling = "~"+instance Pretty Combinator where+ ppr = strictText . toText++-- An empty selector, containing no sequence of simple selectors and no+-- pseudo-element, is an invalid selector.+data Selector = Selector CompoundSelector [(Combinator, CompoundSelector)]+ deriving (Eq, Show)++instance Ord Selector where+ -- Lexicographical order+ s1 <= s2 = toText s1 <= toText s2++instance Pretty Selector where+ ppr (Selector cs ccss) = ppr cs+ <> mconcat (fmap toDocument ccss)+ where toDocument (comb, compSel) = ppr comb <> ppr compSel+instance ToText Selector where+ toBuilder (Selector cs ccss) = toBuilder cs+ <> mconcat (fmap build ccss)+ where build (comb, compSel) = toBuilder comb <> toBuilder compSel+instance Minifiable Selector where+ minifyWith (Selector c xs) = do+ newC <- minifyWith c+ newCs <- (mapM . mapM) minifyWith xs+ pure $ Selector newC newCs++{-+instance Specificity Selector where+ specificity (Selector (x :| xs) ss) =+ case x of+ (Type _ _) -> f (0,0,0,1) xs `addSpecificity` g (0,0,0,0) ss+ (Universal _) -> f (0,0,0,0) xs `addSpecificity` g (0,0,0,0) ss+ where f = foldr (addSpecificity . specificity)+ g = foldr (addSpecificity . specificity . snd)+-}++-- | Called <https://www.w3.org/TR/css3-selectors/#grammar simple_sequence_selector>+-- in CSS2.1, but <https://drafts.csswg.org/selectors-4/#typedef-compound-selector+-- compound-selector> in CSS Syntax Module Level 3.+type CompoundSelector = NonEmpty SimpleSelector++-- instance ToText a => ToText (NonEmpty a) where+instance ToText CompoundSelector where+ toBuilder ns@(Universal{} :| xs)+ | length ns > 1 = mconcat $ fmap toBuilder xs+ toBuilder ns = mconcat $ N.toList (fmap toBuilder ns)++instance Pretty CompoundSelector where+ ppr ns@(Universal{} :| xs)+ | length ns > 1 = mconcat $ fmap ppr xs+ ppr ns = mconcat $ N.toList (fmap ppr ns)++instance Minifiable CompoundSelector where+ minifyWith (a :| xs) = liftA2 (:|) (minifyWith a) (mapM minifyWith xs)++{-+instance Specificity a => Specificity (NonEmpty a) where+ specificity = foldr (\x y -> specificity x `addSpecificity` y) (0,0,0,0)+-}++-- | Certain selectors support namespace prefixes. Namespace prefixes are+-- declared with the @namespace rule. A type selector containing a namespace+-- prefix that has not been previously declared for namespaced selectors is an+-- invalid selector.+type Namespace = Text+type Element = Text -- e.g.: h1, em, body, ...+type Identifier = Text++-- Characters in Selectors can be escaped with a backslash according to the same+-- escaping rules as CSS. [CSS21].++-- If a universal selector represented by * (i.e. without a namespace prefix)+-- is not the only component of a sequence of simple selectors selectors or is+-- immediately followed by a pseudo-element, then the * may be omitted and the+-- universal selector's presence implied.++-- | A simple selector is either a type selector, universal selector, attribute+-- selector, class selector, ID selector, or pseudo-class. The first selector+-- must be a type or universal selector. When none is specified, the universal+-- selector is implied, i.e.: #myId is the same as *#myId+-- mempty is used to denote an empty namespace+data SimpleSelector = Type Namespace Element -- ^ e.g.: *, ns|*, h1, em, body+ | Universal Namespace -- ^ '*'+ | AttributeSel Att+ | ClassSel Identifier+ | IdSel Identifier+ | PseudoElem Identifier+ | PseudoClass Identifier+ -- generic functional pseudo class+ | FunctionalPseudoClass Identifier Text+ -- :not() and :matches() fpc+ | FunctionalPseudoClass1 Identifier [CompoundSelector] -- :not( <selector># )+ -- :nth-of-type(), :nth-last-of-type(), :nth-column(), and+ -- :nth-of-last-column() fpc+ | FunctionalPseudoClass2 Identifier AnPlusB+ -- :nth-child(), nth-last-child()+ | FunctionalPseudoClass3 Identifier AnPlusB [CompoundSelector]+ deriving (Eq, Show)++instance Pretty SimpleSelector where+ ppr (Type n e)+ | T.null n = strictText e+ | otherwise = strictText n <> char '|' <> strictText e+ ppr (Universal n)+ | T.null n = char '*'+ | otherwise = strictText n <> strictText "|*"+ ppr (AttributeSel att) = char '[' <> ppr att <> char ']'+ ppr (ClassSel t) = char '.' <> strictText t+ ppr (IdSel t) = char '#' <> strictText t+ ppr (PseudoClass t) = char ':' <> strictText t+ ppr (PseudoElem t) = if T.toCaseFold t `elem` specialPseudoElements+ then strictText ":" <> strictText t+ else strictText "::" <> strictText t+ ppr (FunctionalPseudoClass i t) = strictText i <> char '(' <> ppr t <> char ')'+ -- ppr (FunctionalPseudoClass1 i cs) = strictText i <>++instance ToText SimpleSelector where+ toBuilder (Type n e)+ | T.null n = fromText e+ | otherwise = fromText n <> singleton '|' <> fromText e+ toBuilder (Universal n)+ | T.null n = singleton '*'+ | otherwise = fromText n <> fromText "|*"+ toBuilder (AttributeSel att) = singleton '[' <> toBuilder att <> singleton ']'+ toBuilder (ClassSel t) = singleton '.' <> fromText t+ toBuilder (IdSel t) = singleton '#' <> fromText t+ toBuilder (PseudoClass t) = singleton ':' <> fromText t+ toBuilder (PseudoElem t)+ | T.toCaseFold t `elem` specialPseudoElements = fromText ":" <> fromText t+ | otherwise = fromText "::" <> fromText t+ toBuilder (FunctionalPseudoClass t x) = fromText t <> singleton '(' <> fromText x <> singleton ')'+ toBuilder (FunctionalPseudoClass1 t ss) = singleton ':' <> fromText t <> singleton '('+ <> mconcatIntersperse toBuilder (singleton ',') ss+ <> singleton ')'+ toBuilder (FunctionalPseudoClass2 t x) = singleton ':' <> fromText t+ <> singleton '(' <> toBuilder x <> singleton ')'+ toBuilder (FunctionalPseudoClass3 t a xs) = singleton ':' <> fromText t+ <> singleton '(' <> toBuilder a <> f xs <> singleton ')'+ where f [] = mempty+ f (y:ys) = " of " <> toBuilder y+ <> mconcat (fmap (\z -> singleton ',' <> toBuilder z) ys)++-- Pseudo-elements that support the old pseudo-element syntax of a single+-- semicolon, as well as the new one of two semicolons.+specialPseudoElements :: [Text]+specialPseudoElements = fmap T.toCaseFold+ ["after", "before", "first-line", "first-letter"]++instance Minifiable SimpleSelector where+ minifyWith a@(AttributeSel att) = do+ conf <- ask+ pure $ if shouldRemoveQuotes conf+ then AttributeSel (removeAttributeQuotes att)+ else a+ minifyWith a@(FunctionalPseudoClass2 i n) = do+ conf <- ask+ pure $ if shouldMinifyMicrosyntax conf+ then FunctionalPseudoClass2 i (minifyAnPlusB n)+ else a+ minifyWith a@(FunctionalPseudoClass3 i n cs) = do+ conf <- ask+ pure $ if shouldMinifyMicrosyntax conf+ then FunctionalPseudoClass3 i (minifyAnPlusB n) cs+ else a+ minifyWith (FunctionalPseudoClass1 i cs) = do+ newcs <- mapM minifyWith cs+ pure $ FunctionalPseudoClass1 i newcs+ minifyWith x = pure x++data Sign = Plus | Minus+ deriving (Eq, Show)++isPositive :: Maybe Sign -> Bool+isPositive Nothing = True+isPositive (Just Plus) = True+isPositive (Just Minus) = False++instance ToText Sign where+ toBuilder Plus = singleton '+'+ toBuilder Minus = singleton '-'++data AValue = Nwith (Maybe Sign) (Maybe Int) -- at least a lone 'n'+ | NoValue -- The "An" part is omitted.+ deriving (Eq, Show)+instance ToText AValue where+ toBuilder NoValue = mempty+ toBuilder (Nwith s i) = maybeToBuilder s <> maybeToBuilder i <> singleton 'n'+ where maybeToBuilder :: ToText a => Maybe a -> Builder+ maybeToBuilder = maybe mempty toBuilder++minifyAValue :: AValue -> AValue+minifyAValue (Nwith _ (Just 0)) = NoValue+minifyAValue (Nwith s a)+ | isPositive s = Nwith Nothing (maybe Nothing droppedOne a)+ | otherwise = Nwith s (maybe Nothing droppedOne a)+ where droppedOne x = if x == 1+ then Nothing+ else Just x+minifyAValue NoValue = NoValue++-- We could maybe model the AB constructor with an Either,+-- to make sure AB NoValue Nothing isn't possible (which is invalid).+-- Also, modelling a BValue would cover all remaining cases,+-- for example +6 vs 6, -0 vs 0 vs +0.+data AnPlusB = Even+ | Odd+ | AB AValue (Maybe Int)+ deriving (Eq, Show)+instance ToText AnPlusB where+ toBuilder Even = "even"+ toBuilder Odd = "odd"+ toBuilder (AB a b) = toBuilder a <> bToBuilder b+ where bToBuilder+ | a == NoValue = maybe (singleton '0') toBuilder+ | otherwise = maybe mempty (\x -> bSign x <> toBuilder x)+ bSign x+ | x < 0 = mempty+ | otherwise = singleton '+'++minifyAnPlusB :: AnPlusB -> AnPlusB+minifyAnPlusB Even = AB (Nwith Nothing (Just 2)) Nothing+minifyAnPlusB (AB n@(Nwith s a) (Just b))+ | isPositive s && a == Just 2 =+ if b == 1 || odd b && b < 0+ then Odd+ else if even b && b <= 0+ then minifyAnPlusB Even+ else AB (minifyAValue n) (Just b)+ | otherwise = AB (minifyAValue n) $ if b == 0+ then Nothing+ else Just b+minifyAnPlusB (AB n@Nwith{} Nothing) = AB (minifyAValue n) Nothing+minifyAnPlusB x = x+-- instance Specificity SimpleSelector where+ -- specificity (IdSel _) = (0,1,0,0)+ -- specificity (ClassSel _) = (0,0,1,0)++type AttId = Text+type AttValue = Either Text StringType++data Att = Attribute AttId+ | AttId :=: AttValue -- ^ \'=\'+ | AttId :~=: AttValue -- ^ \'~=\'+ | AttId :|=: AttValue -- ^ \'|=\'+ | AttId :^=: AttValue -- ^ \'^=\'+ | AttId :$=: AttValue -- ^ \'$=\'+ | AttId :*=: AttValue -- ^ \'*=\'+ deriving (Eq, Show)++removeAttributeQuotes :: Att -> Att+removeAttributeQuotes (attId :=: val) = attId :=: either Left removeQuotes val+removeAttributeQuotes (attId :~=: val) = attId :~=: either Left removeQuotes val+removeAttributeQuotes (attId :|=: val) = attId :|=: either Left removeQuotes val+removeAttributeQuotes (attId :^=: val) = attId :^=: either Left removeQuotes val+removeAttributeQuotes (attId :$=: val) = attId :$=: either Left removeQuotes val+removeAttributeQuotes (attId :*=: val) = attId :*=: either Left removeQuotes val+removeAttributeQuotes a@Attribute{} = a++instance Pretty Att where+ ppr (Attribute t) = strictText t+ ppr (attid :=: attval) = strictText attid <> char '=' <> ppr attval+ ppr (attid :~=: attval) = strictText attid <> strictText "~=" <> ppr attval+ ppr (attid :|=: attval) = strictText attid <> strictText "|=" <> ppr attval+ ppr (attid :^=: attval) = strictText attid <> strictText "^=" <> ppr attval+ ppr (attid :$=: attval) = strictText attid <> strictText "$=" <> ppr attval+ ppr (attid :*=: attval) = strictText attid <> strictText "*=" <> ppr attval+instance ToText Att where+ toBuilder (Attribute t) = fromText t+ toBuilder (attid :=: attval) = fromText attid <> singleton '=' <> toBuilder attval+ toBuilder (attid :~=: attval) = fromText attid <> fromText "~=" <> toBuilder attval+ toBuilder (attid :|=: attval) = fromText attid <> fromText "|=" <> toBuilder attval+ toBuilder (attid :^=: attval) = fromText attid <> fromText "^=" <> toBuilder attval+ toBuilder (attid :$=: attval) = fromText attid <> fromText "$=" <> toBuilder attval+ toBuilder (attid :*=: attval) = fromText attid <> fromText "*=" <> toBuilder attval
+ src/Hasmin/Types/BgSize.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module : Hasmin.Types.BgSize+-- Copyright : (c) 2017 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : non-portable+--+-----------------------------------------------------------------------------+module Hasmin.Types.BgSize (+ BgSize(..), Auto(..)+ ) where+import Control.Monad.Reader (ask)+import Data.Monoid ((<>))+import Data.Text.Lazy.Builder (singleton)+import Hasmin.Types.Class+import Hasmin.Types.PercentageLength++data Auto = Auto+ deriving (Eq, Show)++instance ToText Auto where+ toBuilder Auto = "auto"++data BgSize = Cover + | Contain+ | BgSize (Either PercentageLength Auto) (Maybe (Either PercentageLength Auto))+ deriving (Eq, Show)++instance ToText BgSize where+ toBuilder Cover = "cover"+ toBuilder Contain = "contain"+ toBuilder (BgSize x y) = toBuilder x <> maybe mempty (\a -> singleton ' ' <> toBuilder a) y++instance Minifiable BgSize where+ minifyWith (BgSize x y) = do+ conf <- ask+ nx <- minFirst x+ ny <- mapM minFirst y+ let b = BgSize nx ny+ pure $ if True {- shouldMinifyBgSize conf -}+ then minifyBgSize b+ else b+ where minFirst (Left a) = Left <$> minifyWith a+ minFirst (Right Auto) = pure (Right Auto)+ minifyWith x = pure x++minifyBgSize :: BgSize -> BgSize+minifyBgSize (BgSize l (Just (Right Auto))) = BgSize l Nothing+minifyBgSize x = x+
+ src/Hasmin/Types/Class.hs view
@@ -0,0 +1,47 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hasmin.Types.Class+-- Copyright : (c) 2017 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : non-portable+--+-----------------------------------------------------------------------------+module Hasmin.Types.Class (+ ToText(..), Minifiable(..)+ ) where++import Control.Monad.Reader (Reader, runReader)+import Data.Word (Word8)+import Data.Text (pack, Text)+import Data.Text.Lazy (toStrict)+import Data.Text.Lazy.Builder (Builder, fromText, toLazyText)+import Hasmin.Config++-- | Class for types that can be minified+class Minifiable a where + {-# MINIMAL minifyWith #-}+ minifyWith :: a -> Reader Config a++ -- Returns smallest equivalent representation for an element, using a default+ -- configuration. Mostly used for testing.+ minify :: a -> a + minify x = runReader (minifyWith x) defaultConfig++-- | Class for types that can be converted to Text. Used for priting the+-- minified results.+class ToText a where+ {-# MINIMAL toText | toBuilder #-}+ toText :: a -> Text+ toBuilder :: a -> Builder+ toText = toStrict . toLazyText . toBuilder+ toBuilder = fromText . toText+instance ToText Word8 where+ toText = pack . show+instance ToText Int where+ toText = pack . show+instance ToText Text where+ toText = id+instance (ToText a, ToText b) => ToText (Either a b) where+ toText = either toText toText+ toBuilder = either toBuilder toBuilder
+ src/Hasmin/Types/Color.hs view
@@ -0,0 +1,510 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module : Hasmin.Types.Color+-- Copyright : (c) 2017 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : unknown+--+-- \<color> data type.+--+-----------------------------------------------------------------------------+module Hasmin.Types.Color+ ( Color(Named)+ , mkHex3, mkHex4, mkHex6, mkHex8, mkNamed+ , mkHSL, mkHSLA, mkRGBInt, mkRGBPer, mkRGBAInt, mkRGBAPer+ , keywordColors, minifyColor+ ) where++import Control.Arrow (first)+import Control.Monad.Reader (ask)+import Data.Char (isHexDigit, digitToInt, intToDigit, toLower)+import Data.Maybe (fromMaybe)+import Data.Ratio ((%))+import Data.Text (pack, Text)+import Data.Text.Lazy.Builder (Builder, singleton, fromText)+import Data.Word (Word8)+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import Text.PrettyPrint.Mainland (Pretty, ppr, strictText, string, char, (<>), (<+>), comma, rparen)++import Hasmin.Config+import Hasmin.Types.Class+import Hasmin.Types.Numeric+import Hasmin.Utils++-- | The \<color\> CSS data type. Specifications:+--+-- 4. <https://drafts.csswg.org/css-color/#colorunits CSS Color Module Level 4>+-- 3. <https://drafts.csswg.org/css-color-3/#colorunits CSS Color Module Level 3>+-- 2. <https://www.w3.org/TR/CSS2/syndata.html#value-def-color CSS2.1>+-- 1. <https://www.w3.org/TR/CSS1/#color-units CSS1>+data Color = Hex3 Char Char Char+ | Hex4 Char Char Char Char+ | Hex6 String String String+ | Hex8 String String String String+ | Named Text+ | RGBInt Word8 Word8 Word8+ | RGBPer Percentage Percentage Percentage+ | RGBAInt Word8 Word8 Word8 Alphavalue+ | RGBAPer Percentage Percentage Percentage Alphavalue+ | HSL Int Percentage Percentage+ | HSLA Int Percentage Percentage Alphavalue+ deriving (Show)++-- | Equality is slightly relaxed, since percentages and real numbers are mapped+-- to the [0,255] integer range, and then compared+instance Eq Color where+ (Hex6 r1 g1 b1) == (Hex6 r2 g2 b2) =+ r1 == r2 && g1 == g2 && b1 == b2+ (Hex8 r1 g1 b1 a1) == (Hex8 r2 g2 b2 a2) =+ r1 == r2 && g1 == g2 && b1 == b2 && a1 == a2+ (Hex8 r1 g1 b1 a) == (Hex6 r2 g2 b2)+ | a == "ff" = r1 == r2 && g1 == g2 && b1 == b2+ | otherwise = False+ (Hex6 r1 g1 b1) == (Hex8 r2 g2 b2 a)+ | a == "ff" = r1 == r2 && g1 == g2 && b1 == b2+ | otherwise = False+ c1 == (Named s) = case Map.lookup (T.toLower s) colorMap of+ Just a -> a == c1+ Nothing -> False+ (Named s) == c2 = case Map.lookup (T.toLower s) colorMap of+ Just a -> a == c2+ Nothing -> False+ a == b = toLongHex a == toLongHex b++instance Ord Color where+ (Hex6 r1 g1 b1) <= (Hex6 r2 g2 b2) =+ r1 < r2 || r1 == r2 && (g1 < g2 || (g1 == g2 && b1 <= b2))+ (Hex8 r1 g1 b1 a1) <= (Hex8 r2 g2 b2 a2) =+ r1 < r2 || r1 == r2 && (g1 < g2 || (g1 == g2 && (b1 < b2 || (b1 == b2 && a1 <= a2))))+ (Hex8 r1 g1 b1 a) <= (Hex6 r2 g2 b2)+ | a == "ff" = r1 < r2 || r1 == r2 && (g1 < g2 || (g1 == g2 && b1 <= b2))+ | otherwise = True+ (Hex6 r1 g1 b1) <= (Hex8 r2 g2 b2 a)+ | a == "ff" = r1 < r2 || r1 == r2 && (g1 < g2 || (g1 == g2 && b1 <= b2))+ | otherwise = False+ c1 <= c2 = toLongHex c1 <= toLongHex c2++instance Pretty Color where+ ppr (Hex3 r g b) = char '#' <> char r <> char g <> char b+ ppr (Hex4 r g b a) = char '#' <> char r <> char g <> char b <> char a+ ppr (Hex6 r g b) = char '#' <> string r <> string g <> string b+ ppr (Hex8 r g b a) = char '#' <> string r <> string g <> string b <> string a+ ppr (Named n) = strictText n+ ppr (RGBInt r g b) = strictText "rgb(" <> ppr r <> comma+ <+> ppr g <> comma+ <+> ppr b <> rparen+ ppr (RGBPer r g b) = strictText "rgb(" <> ppr r <> comma+ <+> ppr g <> comma+ <+> ppr b <> rparen+ ppr (RGBAInt r g b a) = strictText "rgba(" <> ppr r <> comma+ <+> ppr g <> comma+ <+> ppr b <> comma+ <+> ppr a <> rparen+ ppr (RGBAPer r g b a) = strictText "rgba(" <> ppr r <> comma+ <+> ppr g <> comma+ <+> ppr b <> comma+ <+> ppr a <> rparen+ ppr (HSL h s l) = strictText "hsl(" <> ppr h <> comma+ <+> ppr s <> comma+ <+> ppr l <> rparen+ ppr (HSLA h s l a) = strictText "hsla(" <> ppr h <> comma+ <+> ppr s <> comma+ <+> ppr l <> comma+ <+> ppr a <> rparen++instance Minifiable Color where+ minifyWith c = do+ conf <- ask+ pure $ case colorSettings conf of+ ColorMinOn -> minifyColor c+ ColorMinOff -> c++minifyColor :: Color -> Color+minifyColor c@Hex6{} = fromMaybe (toHexShorthand c) (Map.lookup c minimalColorMap)+minifyColor c@(Hex8 r g b a)+ | a == "ff" = minifyColor (Hex6 r g b)+ | otherwise = toHexShorthand c+minifyColor c@(RGBAPer r g b a)+ | a >= 1 = minifyColor (RGBPer r g b)+ | otherwise = minifyColor $ toLongHex c+minifyColor c@(RGBAInt r g b a)+ | a >= 1 = minifyColor (RGBInt r g b)+ | otherwise = minifyColor $ toLongHex c+minifyColor c@(HSLA h s l a)+ | a >= 1 = minifyColor (HSL h s l)+ | otherwise = minifyColor $ toLongHex c+minifyColor c = case toLongHex c of+ n@(Named _) -> n+ other -> minifyColor other++instance ToText Color where+ toBuilder (RGBInt r g b) = "rgb(" <> values <> singleton ')'+ where values = toBuilderWithCommas [toText r, toText g, toText b]+ toBuilder (RGBAInt r g b a) = "rgba(" <> values <> singleton ')'+ where values = toBuilderWithCommas [toText r, toText g, toText b, toText a]+ toBuilder (RGBPer r g b) = "rgb(" <> values <> singleton ')'+ where values = toBuilderWithCommas [toText r, toText g, toText b]+ toBuilder (RGBAPer r g b a) = "rgba(" <> values <> singleton ')'+ where values = toBuilderWithCommas [toText r, toText g, toText b, toText a]+ toBuilder (HSL h s l) = "hsl(" <> values <> singleton ')'+ where values = toBuilderWithCommas [toText h, toText s, toText l]+ toBuilder (HSLA h s l a) = "hsla(" <> values <> singleton ')'+ where values = toBuilderWithCommas [toText h, toText s, toText l, toText a]+ toBuilder (Named a) = fromText a+ toBuilder (Hex3 r g b) = singleton '#' <> singleton r <> singleton g <> singleton b+ toBuilder (Hex4 r g b a) = singleton '#' <> singleton r <> singleton g <> singleton b <> singleton a+ toBuilder (Hex6 r g b) = fromText . pack $ mconcat ["#", r, g, b]+ toBuilder (Hex8 r g b a) = fromText . pack $ mconcat ["#", r, g, b, a]++toBuilderWithCommas :: [Text] -> Builder+toBuilderWithCommas = mconcatIntersperse fromText (singleton ',')++-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- Smart constructors+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%++mkHex3 :: Char -> Char -> Char -> Color+mkHex3 r g b+ | isHexDigit r && isHexDigit g && isHexDigit b = Hex3 (toLower r) (toLower g) (toLower b)+ | otherwise = error "passing non hexadecimal arguments to mkHex3"++mkHex6 :: String -> String -> String -> Color+mkHex6 r g b+ | allHex r && allHex g && allHex b = Hex6 (strToLower r) (strToLower g) (strToLower b)+ | otherwise = error "passing non hexadecimal arguments to mkHex6"++mkHex4 :: Char -> Char -> Char -> Char -> Color+mkHex4 r g b a+ | isHexDigit r && isHexDigit g && isHexDigit b && isHexDigit a = Hex4 (toLower r) (toLower g) (toLower b) (toLower a)+ | otherwise = error "passing non hexadecimal arguments to mkHex4"++mkHex8 :: String -> String -> String -> String -> Color+mkHex8 r g b a+ | allHex r && allHex g && allHex b = Hex8 (strToLower r) (strToLower g) (strToLower b) (strToLower a)+ | otherwise = error "passing non hexadecimal arguments to mkHex6"++mkNamed :: Text -> Maybe Color+mkNamed colorName+ | Map.member name colorMap = Just (Named name)+ | otherwise = Nothing+ where name = T.toLower colorName++mkHSL :: Int -> Percentage -> Percentage -> Color+mkHSL h s l = HSL (h `mod` 360) (bound s) (bound l)+ where bound = restrict 0 100++mkHSLA :: Int -> Percentage -> Percentage -> Alphavalue -> Color+mkHSLA h s l = HSLA (h `mod` 360) (bound s) (bound l)+ where bound = restrict 0 100++mkRGBInt :: Word8 -> Word8 -> Word8 -> Color+mkRGBInt r g b = RGBInt (bound r) (bound g) (bound b)+ where bound = restrict 0 255++mkRGBPer :: Percentage -> Percentage -> Percentage -> Color+mkRGBPer r g b = RGBPer (bound r) (bound g) (bound b)+ where bound = restrict 0 100++mkRGBAInt :: Word8 -> Word8 -> Word8 -> Alphavalue -> Color+mkRGBAInt r g b = RGBAInt (bound r) (bound g) (bound b)+ where bound = restrict 0 255++mkRGBAPer :: Percentage -> Percentage -> Percentage -> Alphavalue -> Color+mkRGBAPer r g b = RGBAPer (bound r) (bound g) (bound b)+ where bound = restrict 0 100++allHex :: String -> Bool+allHex = all isHexDigit++strToLower :: String -> String+strToLower = map toLower+-------------------------------------------------------------------------------+toHexShorthand :: Color -> Color+toHexShorthand c@(Hex6 [r1,r2] [g1,g2] [b1,b2])+ | r1 == r2 && g1 == g2 && b1 == b2 = Hex3 r1 g1 b1+ | otherwise = c+toHexShorthand c@(Hex8 [r1,r2] [g1,g2] [b1,b2] [a1,a2])+ | r1 == r2 && g1 == g2 && b1 == b2 && a1 == a2 = Hex4 r1 g1 b1 a1+ | otherwise = c+toHexShorthand h = h++-- Returns hexadecimal equivalent as a string of two characters+-- (i.e. for values in the range [0,15], a leading zero is added).+word8ToHex :: Word8 -> String+word8ToHex n | 0 <= n && n < 16 = '0':[intToDigit num]+ | otherwise = intToDigit sndRemainder : [intToDigit fstRemainder]+ where num = fromIntegral n+ fstRemainder = num `mod` 16+ sndRemainder = (num `quot` 16) `mod` 16++-- Takes a color to a Hex6 or Hex8 representation unless it's an invalid+-- keyword, in which case it remains the same+toLongHex :: Color -> Color+toLongHex c@(Named s) = fromMaybe c (Map.lookup (T.toLower s) colorMap)+toLongHex (RGBAInt r g b a) = Hex8 (word8ToHex r) (word8ToHex g) (word8ToHex b) (ratToHex a)+ where ratToHex :: Alphavalue -> String+ ratToHex n = word8ToHex . round $ toRational n * 255+toLongHex (RGBInt r g b) = Hex6 (word8ToHex r) (word8ToHex g) (word8ToHex b)+toLongHex c@RGBPer{} = toLongHex $ toRGBAInt c+toLongHex c@RGBAPer{} = toLongHex $ toRGBAInt c+toLongHex c@HSL{} = toLongHex $ toRGBAInt c+toLongHex c@HSLA{} = toLongHex $ toRGBAInt c+toLongHex (Hex3 r g b) = Hex6 [r,r] [g,g] [b,b]+toLongHex (Hex4 r g b a) = Hex8 [r,r] [g,g] [b,b] [a,a]+toLongHex a = a++-- This fold works in general to convert hexadecimals into Integers, but we+-- only need it for Word8+hexToWord8 :: String -> Word8+hexToWord8 = fromIntegral . foldl (\s c -> s*16 + digitToInt c) 0++toRGBAInt :: Color -> Color+toRGBAInt (Named s) = case Map.lookup (T.toLower s) colorMap of+ Just a -> toRGBAInt a+ Nothing -> error e+ where e = T.unpack $ "Invalid color keyword (" <> s <> "). Can't convert to rgba"+toRGBAInt (Hex3 r g b) = RGBAInt (f [r,r]) (f [g,g]) (f [b,b]) 1+ where f = fromIntegral . hexToWord8+toRGBAInt (Hex6 r g b) = RGBAInt (hexToWord8 r) (hexToWord8 g) (hexToWord8 b) 1+toRGBAInt (Hex4 r g b a) = RGBAInt (f [r,r]) (f [g,g]) (f [b,b]) (h [a,a])+ where f = fromIntegral . hexToWord8+ h = toAlphavalue . hexToWord8+toRGBAInt (Hex8 r g b a) = RGBAInt (hexToWord8 r) (hexToWord8 g)+ (hexToWord8 b) (toAlphavalue $ toRational (hexToWord8 a) / 255)+toRGBAInt (RGBInt r g b) = RGBAInt r g b 1+toRGBAInt (RGBPer r g b) = RGBAInt (f r) (f g) (f b) 1+ where f = round . (2.55*)+toRGBAInt (RGBAPer r g b a) = RGBAInt (f r) (f g) (f b) a+ where f = round . (2.55*)+toRGBAInt c@RGBAInt{} = c+toRGBAInt (HSL h s l) = withAlpha 1 $ hslToRgb (h, s, l)+toRGBAInt (HSLA h s l a) = withAlpha a $ hslToRgb (h, s, l)++withAlpha :: Alphavalue -> (Word8, Word8, Word8) -> Color+withAlpha a (r, g, b) = RGBAInt r g b a++hslToRgb :: (Int, Percentage, Percentage) -> (Word8, Word8, Word8)+hslToRgb (hue, sat, light) | s == 0 = (lumToRgb, lumToRgb, lumToRgb)+ | l <= 0.5 = hslToRgb' h l (l * (s+1))+ | otherwise = hslToRgb' h l (l + s - l*s)+ where h = toPercentage hue / 360+ s = sat / 100+ l = light / 100+ lumToRgb = round (l * 255)++hslToRgb' :: Percentage -> Percentage -> Percentage -> (Word8, Word8, Word8)+hslToRgb' h l t2 = (r, g, b)+ where t1 = l*2 - t2+ r = round $ 255 * hueToRgb t1 t2 (h + Percentage (1 % 3))+ g = round $ 255 * hueToRgb t1 t2 h+ b = round $ 255 * hueToRgb t1 t2 (h - Percentage (1 % 3))++hueToRgb :: Percentage -> Percentage -> Percentage -> Percentage+hueToRgb t1 t2 hue | hue < 0 = test t1 t2 (hue+1)+ | hue > 1 = test t1 t2 (hue-1)+ | otherwise = test t1 t2 hue+ where test :: Percentage -> Percentage -> Percentage -> Percentage+ test a b h | h * 6 < 1 = a + (b-a) * 6 * h+ | h * 2 < 1 = b+ | h * 3 < 2 = a + (b-a) * (Percentage (2 % 3) - h) * 6+ | otherwise = a++-- | A map with hex values as keys, and their minimal colorname as value+minimalColorMap :: Map.Map Color Color+minimalColorMap = Map.fromList minimalColors++minimalColors :: [(Color, Color)]+minimalColors = [(Hex6 "ff" "00" "00", Named "red")+ ,(Hex6 "d2" "b4" "8c", Named "tan")+ ,(Hex6 "00" "ff" "ff", Named "aqua")+ ,(Hex6 "00" "00" "ff", Named "blue")+ ,(Hex6 "00" "ff" "ff", Named "cyan")+ ,(Hex6 "ff" "d7" "00", Named "gold")+ ,(Hex6 "80" "80" "80", Named "gray")+ ,(Hex6 "80" "80" "80", Named "grey")+ ,(Hex6 "00" "ff" "00", Named "lime")+ ,(Hex6 "00" "00" "80", Named "navy")+ ,(Hex6 "cd" "85" "3f", Named "peru")+ ,(Hex6 "ff" "c0" "cb", Named "pink")+ ,(Hex6 "dd" "a0" "dd", Named "plum")+ ,(Hex6 "ff" "fa" "fa", Named "snow")+ ,(Hex6 "00" "80" "80", Named "teal")+ ,(Hex6 "f0" "ff" "ff", Named "azure")+ ,(Hex6 "f5" "f5" "dc", Named "beige")+ ,(Hex6 "a5" "2a" "2a", Named "brown")+ ,(Hex6 "ff" "7f" "50", Named "coral")+ ,(Hex6 "00" "80" "00", Named "green")+ ,(Hex6 "ff" "ff" "f0", Named "ivory")+ ,(Hex6 "f0" "e6" "8c", Named "khaki")+ ,(Hex6 "fa" "f0" "e6", Named "linen")+ ,(Hex6 "80" "80" "00", Named "olive")+ ,(Hex6 "f5" "de" "b3", Named "wheat")+ ,(Hex6 "ff" "e4" "c4", Named "bisque")+ ,(Hex6 "4b" "00" "82", Named "indigo")+ ,(Hex6 "80" "00" "00", Named "maroon")+ ,(Hex6 "ff" "a5" "00", Named "orange")+ ,(Hex6 "da" "70" "d6", Named "orchid")+ ,(Hex6 "80" "00" "80", Named "purple")+ ,(Hex6 "fa" "80" "72", Named "salmon")+ ,(Hex6 "a0" "52" "2d", Named "sienna")+ ,(Hex6 "c0" "c0" "c0", Named "silver")+ ,(Hex6 "ff" "63" "47", Named "tomato")+ ,(Hex6 "ee" "82" "ee", Named "violet")]++-- | Mapping between color names and hex values+colorMap :: Map.Map Text Color+colorMap = Map.fromList keywordColors++keywordColors :: [(Text, Color)]+keywordColors = map (first T.toLower)+ [("aliceblue", Hex6 "f0" "f8" "ff")+ ,("antiquewhite", Hex6 "fa" "eb" "d7")+ ,("aqua", Hex6 "00" "ff" "ff")+ ,("aquamarine", Hex6 "7f" "ff" "d4")+ ,("azure", Hex6 "f0" "ff" "ff")+ ,("beige", Hex6 "f5" "f5" "dc")+ ,("bisque", Hex6 "ff" "e4" "c4")+ ,("black", Hex6 "00" "00" "00")+ ,("blanchedalmond", Hex6 "ff" "eb" "cd")+ ,("blue", Hex6 "00" "00" "ff")+ ,("blueviolet", Hex6 "8a" "2b" "e2")+ ,("brown", Hex6 "a5" "2a" "2a")+ ,("burlywood", Hex6 "de" "b8" "87")+ ,("cadetblue", Hex6 "5f" "9e" "a0")+ ,("chartreuse", Hex6 "7f" "ff" "00")+ ,("chocolate", Hex6 "d2" "69" "1e")+ ,("coral", Hex6 "ff" "7f" "50")+ ,("cornflowerblue", Hex6 "64" "95" "ed")+ ,("cornsilk", Hex6 "ff" "f8" "dc")+ ,("crimson", Hex6 "dc" "14" "3c")+ ,("cyan", Hex6 "00" "ff" "ff")+ ,("darkblue", Hex6 "00" "00" "8b")+ ,("darkcyan", Hex6 "00" "8b" "8b")+ ,("darkgoldenrod", Hex6 "b8" "86" "0b")+ ,("darkgray", Hex6 "a9" "a9" "a9")+ ,("darkgrey", Hex6 "a9" "a9" "a9")+ ,("darkgreen", Hex6 "00" "64" "00")+ ,("darkkhaki", Hex6 "bd" "b7" "6b")+ ,("darkmagenta", Hex6 "8b" "00" "8b")+ ,("darkolivegreen", Hex6 "55" "6b" "2f")+ ,("darkorange", Hex6 "ff" "8c" "00")+ ,("darkorchid", Hex6 "99" "32" "cc")+ ,("darkred", Hex6 "8b" "00" "00")+ ,("darksalmon", Hex6 "e9" "96" "7a")+ ,("darkseagreen", Hex6 "8f" "bc" "8f")+ ,("darkslateblue", Hex6 "48" "3d" "8b")+ ,("darkslategray", Hex6 "2f" "4f" "4f")+ ,("darkslategrey", Hex6 "2f" "4f" "4f")+ ,("darkturquoise", Hex6 "00" "ce" "d1")+ ,("darkviolet", Hex6 "94" "00" "d3")+ ,("deeppink", Hex6 "ff" "14" "93")+ ,("deepskyblue", Hex6 "00" "bf" "ff")+ ,("dimgray", Hex6 "69" "69" "69")+ ,("dimgrey", Hex6 "69" "69" "69")+ ,("dodgerblue", Hex6 "1e" "90" "ff")+ ,("firebrick", Hex6 "b2" "22" "22")+ ,("floralwhite", Hex6 "ff" "fa" "f0")+ ,("forestgreen", Hex6 "22" "8b" "22")+ ,("fuchsia", Hex6 "ff" "00" "ff")+ ,("gainsboro", Hex6 "dc" "dc" "dc")+ ,("ghostwhite", Hex6 "f8" "f8" "ff")+ ,("gold", Hex6 "ff" "d7" "00")+ ,("goldenrod", Hex6 "da" "a5" "20")+ ,("gray", Hex6 "80" "80" "80")+ ,("grey", Hex6 "80" "80" "80")+ ,("green", Hex6 "00" "80" "00")+ ,("greenyellow", Hex6 "ad" "ff" "2f")+ ,("honeydew", Hex6 "f0" "ff" "f0")+ ,("hotpink", Hex6 "ff" "69" "b4")+ ,("indianred", Hex6 "cd" "5c" "5c")+ ,("indigo", Hex6 "4b" "00" "82")+ ,("ivory", Hex6 "ff" "ff" "f0")+ ,("khaki", Hex6 "f0" "e6" "8c")+ ,("lavender", Hex6 "e6" "e6" "fa")+ ,("lavenderblush", Hex6 "ff" "f0" "f5")+ ,("lawngreen", Hex6 "7c" "fc" "00")+ ,("lemonchiffon", Hex6 "ff" "fa" "cd")+ ,("lightblue", Hex6 "ad" "d8" "e6")+ ,("lightcoral", Hex6 "f0" "80" "80")+ ,("lightcyan", Hex6 "e0" "ff" "ff")+ ,("lightgoldenrodyellow", Hex6 "fa" "fa" "d2")+ ,("lightgray", Hex6 "d3" "d3" "d3")+ ,("lightgrey", Hex6 "d3" "d3" "d3")+ ,("lightgreen", Hex6 "90" "ee" "90")+ ,("lightpink", Hex6 "ff" "b6" "c1")+ ,("lightsalmon", Hex6 "ff" "a0" "7a")+ ,("lightseagreen", Hex6 "20" "b2" "aa")+ ,("lightskyblue", Hex6 "87" "ce" "fa")+ ,("lightslategray", Hex6 "77" "88" "99")+ ,("lightslategrey", Hex6 "77" "88" "99")+ ,("lightsteelblue", Hex6 "b0" "c4" "de")+ ,("lightyellow", Hex6 "ff" "ff" "e0")+ ,("lime", Hex6 "00" "ff" "00")+ ,("limegreen", Hex6 "32" "cd" "32")+ ,("linen", Hex6 "fa" "f0" "e6")+ ,("magenta", Hex6 "ff" "00" "ff")+ ,("maroon", Hex6 "80" "00" "00")+ ,("mediumaquamarine", Hex6 "66" "cd" "aa")+ ,("mediumblue", Hex6 "00" "00" "cd")+ ,("mediumorchid", Hex6 "ba" "55" "d3")+ ,("mediumpurple", Hex6 "93" "70" "d8")+ ,("mediumseagreen", Hex6 "3c" "b3" "71")+ ,("mediumslateblue", Hex6 "7b" "68" "ee")+ ,("mediumspringgreen", Hex6 "00" "fa" "9a")+ ,("mediumturquoise", Hex6 "48" "d1" "cc")+ ,("mediumvioletred", Hex6 "c7" "15" "85")+ ,("midnightblue", Hex6 "19" "19" "70")+ ,("mintcream", Hex6 "f5" "ff" "fa")+ ,("mistyrose", Hex6 "ff" "e4" "e1")+ ,("moccasin", Hex6 "ff" "e4" "b5")+ ,("navajowhite", Hex6 "ff" "de" "ad")+ ,("navy", Hex6 "00" "00" "80")+ ,("oldlace", Hex6 "fd" "f5" "e6")+ ,("olive", Hex6 "80" "80" "00")+ ,("olivedrab", Hex6 "6b" "8e" "23")+ ,("orange", Hex6 "ff" "a5" "00")+ ,("orangered", Hex6 "ff" "45" "00")+ ,("orchid", Hex6 "da" "70" "d6")+ ,("palegoldenrod", Hex6 "ee" "e8" "aa")+ ,("palegreen", Hex6 "98" "fb" "98")+ ,("paleturquoise", Hex6 "af" "ee" "ee")+ ,("palevioletred", Hex6 "d8" "70" "93")+ ,("papayawhip", Hex6 "ff" "ef" "d5")+ ,("peachpuff", Hex6 "ff" "da" "b9")+ ,("peru", Hex6 "cd" "85" "3f")+ ,("pink", Hex6 "ff" "c0" "cb")+ ,("plum", Hex6 "dd" "a0" "dd")+ ,("powderblue", Hex6 "b0" "e0" "e6")+ ,("purple", Hex6 "80" "00" "80")+ ,("red", Hex6 "ff" "00" "00")+ ,("rosybrown", Hex6 "bc" "8f" "8f")+ ,("royalblue", Hex6 "41" "69" "e1")+ ,("saddlebrown", Hex6 "8b" "45" "13")+ ,("salmon", Hex6 "fa" "80" "72")+ ,("sandybrown", Hex6 "f4" "a4" "60")+ ,("seagreen", Hex6 "2e" "8b" "57")+ ,("seashell", Hex6 "ff" "f5" "ee")+ ,("sienna", Hex6 "a0" "52" "2d")+ ,("silver", Hex6 "c0" "c0" "c0")+ ,("skyblue", Hex6 "87" "ce" "eb")+ ,("slateblue", Hex6 "6a" "5a" "cd")+ ,("slategray", Hex6 "70" "80" "90")+ ,("slategrey", Hex6 "70" "80" "90")+ ,("snow", Hex6 "ff" "fa" "fa")+ ,("springgreen", Hex6 "00" "ff" "7f")+ ,("steelblue", Hex6 "46" "82" "b4")+ ,("tan", Hex6 "d2" "b4" "8c")+ ,("teal", Hex6 "00" "80" "80")+ ,("thistle", Hex6 "d8" "bf" "d8")+ ,("transparent", Hex8 "00" "00" "00" "00")+ ,("tomato", Hex6 "ff" "63" "47")+ ,("turquoise", Hex6 "40" "e0" "d0")+ ,("violet", Hex6 "ee" "82" "ee")+ ,("wheat", Hex6 "f5" "de" "b3")+ ,("white", Hex6 "ff" "ff" "ff")+ ,("whitesmoke", Hex6 "f5" "f5" "f5")+ ,("yellow", Hex6 "ff" "ff" "00")+ ,("yellowgreen", Hex6 "9a" "cd" "32")]
+ src/Hasmin/Types/Declaration.hs view
@@ -0,0 +1,555 @@+{-# 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.Maybe (fromMaybe)+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 Text.PrettyPrint.Mainland (Pretty, ppr, strictText, colon, (<+>))++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 Pretty Declaration where+ ppr (Declaration p v i h) = strictText p <> colon <+> ppr v <> imp+ <> (if h then " \\9" else mempty)+ where imp | i = strictText " !important" + | otherwise = mempty+instance ToText Declaration where+ toBuilder (Declaration p vs i h) = fromText p <> singleton ':' + <> toBuilder vs <> imp <> (if h then " \\9" else mempty)+ 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 <length>)+-- 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)+ ]++combineTransformFunctions :: Declaration -> Reader Config Declaration+combineTransformFunctions d@(Declaration _ vs _ _) = do+ combinedFuncs <- combine $ fmap (\(TransformV x) -> x) tfuncs + let newVals = fmap TransformV combinedFuncs ++ (decValues \\ tfuncs)+ pure $ d { valueList = mkValues newVals}+ where decValues = valuesToList vs+ tfuncs = filter isTransformFunction decValues+ isTransformFunction (TransformV _) = True+ isTransformFunction _ = False++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
+ src/Hasmin/Types/Dimension.hs view
@@ -0,0 +1,362 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module : Hasmin.Types.Dimension+-- Copyright : (c) 2017 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : unknown+--+-- CSS Dimension data types: \<length\> (distance), \<angle\>, \<duration\>,+-- \<frequency\>, and \<resolution\>. Provides conversion of absolute+-- dimensions into other equivalent dimensions.+--+-----------------------------------------------------------------------------+module Hasmin.Types.Dimension (+ Distance(..)+ , DistanceUnit(..)+ , Angle(..)+ , AngleUnit(..)+ , Duration(..)+ , DurationUnit(..)+ , Frequency(..)+ , FrequencyUnit(..)+ , Resolution(..)+ , ResolutionUnit(..)+ , toInches+ , toPixels+ , toRadians+ , isRelative+ ) where++import Control.Monad.Reader (asks)+import Data.Monoid ((<>))+import Data.Text.Lazy.Builder (singleton, fromText)+import Data.Typeable (Typeable)+import Hasmin.Types.Class+import Hasmin.Types.Numeric+import Hasmin.Config+import Hasmin.Utils+import Text.PrettyPrint.Mainland (char, Pretty, ppr, strictText)++-- | The \<length\> CSS data type+data Distance = Distance Number DistanceUnit+ deriving (Show)+instance Pretty Distance where+ ppr (Distance 0 _) = char '0'+ ppr (Distance r u) = ppr r <> ppr u+instance Eq Distance where+ (Distance r1 u1) == (Distance r2 u2)+ | u1 == u2 = r1 == r2+ | otherwise = toInches r1 u1 == toInches r2 u2+instance Minifiable Distance where+ minifyWith d@(Distance r u) = do+ shouldMinifyUnits <- asks ((DimMinOn ==) . dimensionSettings)+ pure $ if (not . isRelative) u && shouldMinifyUnits+ then minDim Distance r u [Q, CM, MM, IN, PC, PT, PX]+ else d++isRelative :: DistanceUnit -> Bool+isRelative x = x == EM || x == EX || x == CH || x == VH+ || x == VW || x == VMIN || x == VMAX || x == REM++instance ToText Distance where+ toBuilder (Distance 0 _) = singleton '0'+ toBuilder (Distance r u) = (fromText . toText) r <> (fromText . toText) u++-- | The \<angle\> CSS data type+data Angle = Angle Number AngleUnit+ deriving (Show)+instance Pretty Angle where+ ppr (Angle 0 _) = char '0'+ ppr (Angle r u) = ppr r <> ppr u+instance Eq Angle where+ (Angle r1 u1) == (Angle r2 u2)+ | u1 == u2 = r1 == r2+ | otherwise = toDegrees r1 u1 == toDegrees r2 u2+instance Minifiable Angle where+ minifyWith a = do+ shouldMinifyUnits <- asks ((DimMinOn ==) . dimensionSettings)+ pure $ if shouldMinifyUnits+ then minifyAngle a+ else a++minifyAngle :: Angle -> Angle+minifyAngle (Angle r u) = minDim Angle r u [Turn, Grad, Rad, Deg]++instance ToText Angle where+ toBuilder (Angle r u)+ | abs r < toNumber eps = singleton '0'+ | otherwise = toBuilder r <> toBuilder u++-- | The \<duration\> CSS data type+data Duration = Duration Number DurationUnit+ deriving (Show)+instance Pretty Duration where+ ppr (Duration r u) = ppr r <> ppr u+instance Eq Duration where+ (Duration r1 u1) == (Duration r2 u2)+ | u1 == u2 = r1 == r2+ | otherwise = toSeconds r1 u1 == toSeconds r2 u2+instance Minifiable Duration where+ minifyWith d@(Duration r u) = do+ shouldMinifyUnits <- asks ((DimMinOn ==) . dimensionSettings)+ pure $ if shouldMinifyUnits+ then minDim Duration r u [S, Ms]+ else d+instance ToText Duration where+ toBuilder (Duration r u) = toBuilder r <> toBuilder u++-- | The \<frequency\> CSS data type+data Frequency = Frequency Number FrequencyUnit+ deriving (Show)+instance Pretty Frequency where+ ppr (Frequency r u) = ppr r <> ppr u+instance Eq Frequency where+ (Frequency r1 u1) == (Frequency r2 u2)+ | u1 == u2 = r1 == r2+ | otherwise = toHertz r1 u1 == toHertz r2 u2+instance Minifiable Frequency where+ minifyWith f@(Frequency r u) = do+ dimSettings <- asks dimensionSettings+ pure $ case dimSettings of+ DimMinOn -> minDim Frequency r u [Khz, Hz]+ DimMinOff -> f+instance ToText Frequency where+ toBuilder (Frequency r u) = toBuilder r <> toBuilder u++-- | The \<resolution\> CSS data type+data Resolution = Resolution Number ResolutionUnit+ deriving (Show)+instance Pretty Resolution where+ ppr (Resolution r u) = ppr r <> ppr u+instance Eq Resolution where+ (Resolution r1 u1) == (Resolution r2 u2)+ | u1 == u2 = r1 == r2+ | otherwise = toDpi r1 u1 == toDpi r2 u2+instance Minifiable Resolution where+ minifyWith x@(Resolution r u) = do+ shouldMinifyUnits <- asks ((DimMinOn ==) . dimensionSettings)+ pure $ if shouldMinifyUnits+ then minDim Resolution r u [Dpcm, Dppx, Dpi]+ else x+instance ToText Resolution where+ toBuilder (Resolution r u) = toBuilder r <> toBuilder u++-- | Given a constructor, a number, and a unit, returns+-- the shortest equivalent representation. If there is more than one, returns+-- the latest found to "normalize" values, hopefully improving gzip compression.+minDim :: (Unit a, ToText a) => (Number -> a -> b) -> Number -> a -> [a] -> b+minDim constructor r u (x:xs)+ | currentLength < newLength = minDim constructor r u xs+ | otherwise = minDim constructor equivValue x xs+ where equivValue = convertTo x r u+ currentLength = textualLength r + textualLength u+ newLength = textualLength equivValue + textualLength x+minDim constructor r u [] = constructor r u++class Unit a where+ convertTo :: a -> Number -> a -> Number++data DistanceUnit = IN | CM | MM | Q | PC | PT | PX -- absolute+ | EM | EX | CH | VH | VW | VMIN | VMAX | REM -- relative+ deriving (Show, Eq)+instance ToText DistanceUnit where+ toBuilder IN = "in"+ toBuilder CM = "cm"+ toBuilder MM = "mm"+ toBuilder Q = "q"+ toBuilder PC = "pc"+ toBuilder PT = "pt"+ toBuilder PX = "px"+ toBuilder EM = "em"+ toBuilder EX = "ex"+ toBuilder CH = "ch"+ toBuilder VH = "vh"+ toBuilder VW = "vw"+ toBuilder VMIN = "vmin"+ toBuilder VMAX = "vmax"+ toBuilder REM = "rem"+instance Pretty DistanceUnit where+ ppr = strictText . toText+instance Unit DistanceUnit where+ convertTo IN = toInches+ convertTo CM = toCentimeters+ convertTo MM = toMilimeters+ convertTo Q = toQuarterMilimeter+ convertTo PT = toPoints+ convertTo PC = toPica+ convertTo PX = toPixels+ convertTo _ = const++data AngleUnit = Deg | Grad | Rad | Turn+ deriving (Show, Eq, Typeable)+instance ToText AngleUnit where+ toBuilder Deg = "deg"+ toBuilder Grad = "grad"+ toBuilder Rad = "rad"+ toBuilder Turn = "turn"+instance Pretty AngleUnit where+ ppr = strictText . toText+instance Unit AngleUnit where+ convertTo Deg = toDegrees+ convertTo Grad = toGradians+ convertTo Rad = toRadians+ convertTo Turn = toTurns++data DurationUnit = S -- seconds+ | Ms -- miliseconds+ deriving (Show, Eq)+instance ToText DurationUnit where+ toBuilder S = "s"+ toBuilder Ms = "ms"+instance Pretty DurationUnit where+ ppr = strictText . toText+instance Unit DurationUnit where+ convertTo S = toSeconds+ convertTo Ms = toMiliseconds++data FrequencyUnit = Hz | Khz+ deriving (Show, Eq)+instance ToText FrequencyUnit where+ toBuilder Hz = "hz"+ toBuilder Khz = "khz"+instance Pretty FrequencyUnit where+ ppr = strictText . toText+instance Unit FrequencyUnit where+ convertTo Hz = toHertz+ convertTo Khz = toKilohertz++data ResolutionUnit = Dpi | Dpcm | Dppx+ deriving (Show, Eq)+instance ToText ResolutionUnit where+ toBuilder Dpi = "dpi"+ toBuilder Dpcm = "dpcm"+ toBuilder Dppx = "dppx"+instance Pretty ResolutionUnit where+ ppr = strictText . toText+instance Unit ResolutionUnit where+ convertTo Dpi = toDpi+ convertTo Dpcm = toDpcm+ convertTo Dppx = toDppx++toInches :: Number -> DistanceUnit -> Number+toInches d CM = d / 2.54+toInches d MM = d / 25.4+toInches d Q = d / 101.6+toInches d PT = d / 72+toInches d PC = d / 6+toInches d PX = d / 96+toInches d _ = d -- IN, or any relative value++toCentimeters :: Number -> DistanceUnit -> Number+toCentimeters d IN = d * 2.54+toCentimeters d MM = d / 10+toCentimeters d Q = d / 40+toCentimeters d PT = d * (2.54 / 72)+toCentimeters d PC = d * (2.54 / 6)+toCentimeters d PX = d * (2.54 / 96)+toCentimeters d _ = d -- CM, or any relative value++toMilimeters :: Number -> DistanceUnit -> Number+toMilimeters d IN = d * 25.4+toMilimeters d CM = d * 10+toMilimeters d Q = d / 4+toMilimeters d PT = d * (25.4 / 72)+toMilimeters d PC = d * (25.4 / 6)+toMilimeters d PX = d * (25.4 / 96)+toMilimeters d _ = d++toQuarterMilimeter :: Number -> DistanceUnit -> Number+toQuarterMilimeter d IN = d * 101.6+toQuarterMilimeter d CM = d * 40+toQuarterMilimeter d MM = d * 4+toQuarterMilimeter d PT = d * (101.6 / 72)+toQuarterMilimeter d PC = d * (101.6 / 6)+toQuarterMilimeter d PX = d * (101.6 / 96)+toQuarterMilimeter d _ = d++toPoints :: Number -> DistanceUnit -> Number+toPoints d IN = d / 72+toPoints d CM = d * (72 / 2.54)+toPoints d MM = d * (72 / 25.4)+toPoints d Q = d * (72 / 101.6)+toPoints d PC = d * 12+toPoints d PX = d * (3 / 4)+toPoints d _ = d++toPica :: Number -> DistanceUnit -> Number+toPica d IN = d / 6+toPica d CM = d * (6 / 2.54)+toPica d MM = d * (6 / 25.4)+toPica d Q = d * (6 / 101.6)+toPica d PT = d / 12+toPica d PX = d / 16+toPica d _ = d++toPixels :: Number -> DistanceUnit -> Number+toPixels d IN = d * 96+toPixels d CM = d * (96 / 2.54)+toPixels d MM = d * (96 / 25.4)+toPixels d Q = d * (96 / 101.6)+toPixels d PT = d * (4 / 3)+toPixels d PC = d / 6+toPixels d _ = d+------------------------------------------------------------------------------+rationalPi :: Number+rationalPi = Number $ toRational (pi :: Double)++toDegrees :: Number -> AngleUnit -> Number+toDegrees d Deg = d+toDegrees d Grad = d * (9 / 10)+toDegrees d Rad = d * (180 / rationalPi)+toDegrees d Turn = d * 360++toGradians :: Number -> AngleUnit -> Number+toGradians d Deg = d * (10 / 9)+toGradians d Grad = d+toGradians d Rad = d * (200 / rationalPi)+toGradians d Turn = d * 400++toRadians :: Number -> AngleUnit -> Number+toRadians d Deg = d * (rationalPi / 180)+toRadians d Grad = d * (rationalPi / 200)+toRadians d Rad = d+toRadians d Turn = d * 2 * rationalPi++toTurns :: Number -> AngleUnit -> Number+toTurns d Deg = d / 360+toTurns d Grad = d / 400+toTurns d Rad = d / (2 * rationalPi)+toTurns d Turn = d+------------------------------------------------------------------------------+toSeconds :: Number -> DurationUnit -> Number+toSeconds d S = d+toSeconds d Ms = d / 1000++toMiliseconds :: Number -> DurationUnit -> Number+toMiliseconds d S = d * 1000+toMiliseconds d Ms = d+------------------------------------------------------------------------------+toHertz :: Number -> FrequencyUnit -> Number+toHertz d Hz = d+toHertz d Khz = d * 1000++toKilohertz :: Number -> FrequencyUnit -> Number+toKilohertz d Hz = d / 1000+toKilohertz d Khz = d+------------------------------------------------------------------------------+toDpi :: Number -> ResolutionUnit -> Number+toDpi d Dpi = d+toDpi d Dpcm = d * 2.54+toDpi d Dppx = d * 96++toDpcm :: Number -> ResolutionUnit -> Number+toDpcm d Dpi = d / 2.54+toDpcm d Dpcm = d+toDpcm d Dppx = d * (2.54 / 96)++toDppx :: Number -> ResolutionUnit -> Number+toDppx d Dpi = d / 96+toDppx d Dpcm = d * (96 / 2.54)+toDppx d Dppx = d
+ src/Hasmin/Types/FilterFunction.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module : Hasmin.Types.FilterFunction+-- Copyright : (c) 2017 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : unknown+--+-----------------------------------------------------------------------------+module Hasmin.Types.FilterFunction (+ FilterFunction(..)+ , minifyPseudoShadow+ ) where++import Control.Monad.Reader (Reader, ask)+import Data.Semigroup ((<>))+import Data.Text.Lazy.Builder (singleton, Builder)+import Hasmin.Config+import Hasmin.Types.Class+import Hasmin.Types.Dimension+import Hasmin.Types.Color+import Hasmin.Types.Numeric++-- Note: In a previous specification, translate3d() took two+-- <https://www.w3.org/TR/css-transforms-1/#typedef-translation-value \<translation-value\>>,+-- however in the <https://drafts.csswg.org/css-transforms/ latest draft>, it+-- takes two \<length-percentage\> (which makes sense since translateX() and+-- translateY() also do).++data FilterFunction = Blur Distance+ | Brightness (Either Number Percentage)+ | Contrast (Either Number Percentage)+ | Grayscale (Either Number Percentage)+ | Invert (Either Number Percentage)+ | Opacity (Either Number Percentage)+ | Saturate (Either Number Percentage)+ | Sepia (Either Number Percentage)+ | HueRotate Angle+ | DropShadow Distance Distance (Maybe Distance) (Maybe Color)+ deriving (Eq, Show)++instance ToText FilterFunction where+ toBuilder (Blur d) = "blur(" <> toBuilder d <> singleton ')'+ toBuilder (Brightness np) = "brightness(" <> toBuilder np <> singleton ')'+ toBuilder (HueRotate a) = "hue-rotate(" <> toBuilder a <> singleton ')'+ toBuilder (Contrast np) = "contrast(" <> toBuilder np <> singleton ')'+ toBuilder (Grayscale np) = "grayscale(" <> toBuilder np <> singleton ')'+ toBuilder (Invert np) = "invert(" <> toBuilder np <> singleton ')'+ toBuilder (Opacity np) = "opacity(" <> toBuilder np <> singleton ')'+ toBuilder (Saturate np) = "saturate(" <> toBuilder np <> singleton ')'+ toBuilder (Sepia np) = "sepia(" <> toBuilder np <> singleton ')'+ toBuilder (DropShadow l1 l2 ml mc) =+ let maybeToBuilder :: ToText a => Maybe a -> Builder+ maybeToBuilder = maybe mempty (\x -> singleton ' ' <> toBuilder x)+ in "drop-shadow(" <> toBuilder l1 <> singleton ' ' <> toBuilder l2+ <> maybeToBuilder ml <> maybeToBuilder mc <> singleton ')'++instance Minifiable FilterFunction where+ minifyWith (Blur a) = Blur <$> minifyWith a+ minifyWith (HueRotate a) = HueRotate <$> minifyWith a+ minifyWith (Contrast x) = Contrast <$> minifyNumberPercentage x+ minifyWith (Brightness x) = Brightness <$> minifyNumberPercentage x+ minifyWith (Grayscale x) = Grayscale <$> minifyNumberPercentage x+ minifyWith (Invert x) = Invert <$> minifyNumberPercentage x+ minifyWith (Opacity x) = Opacity <$> minifyNumberPercentage x+ minifyWith (Saturate x) = Saturate <$> minifyNumberPercentage x+ minifyWith (Sepia x) = Sepia <$> minifyNumberPercentage x+ minifyWith s@(DropShadow a b c d) = do+ conf <- ask+ if shouldMinifyFilterFunctions conf+ then minifyPseudoShadow DropShadow a b c d+ else pure s++minifyPseudoShadow constr a b c d = do+ x <- minifyWith a+ y <- minifyWith b+ z <- case c of+ Just r -> if r == Distance 0 Q+ then pure Nothing+ else mapM minifyWith c+ Nothing -> pure Nothing+ c2 <- mapM minifyWith d+ pure $ constr x y z c2++minifyNumberPercentage :: Either Number Percentage+ -> Reader Config (Either Number Percentage)+minifyNumberPercentage x = do+ conf <- ask+ pure $ if shouldMinifyFilterFunctions conf+ then either convertNumber convertPercentage x+ else x++convertNumber :: Number -> Either Number Percentage+convertNumber x+ | 0 < x && x < 0.1 = Right $ toPercentage (x * 100)+ | otherwise = Left x++convertPercentage :: Percentage -> Either Number Percentage+convertPercentage p+ | p == 0 = Left 0+ | 0 < p && p < 10 = Right p+ | otherwise = Left $ toNumber (p / 100)
+ src/Hasmin/Types/Gradient.hs view
@@ -0,0 +1,309 @@+{-# 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.Semigroup ((<>)) +import Data.Text.Lazy.Builder (singleton) +import Data.Maybe (catMaybes, fromJust, isNothing, isJust) +import Hasmin.Config +import Hasmin.Types.Class +import Hasmin.Types.Color +import Hasmin.Types.Dimension +import Hasmin.Types.Numeric +import Hasmin.Types.PercentageLength +import Hasmin.Types.Position +import Hasmin.Utils +import Text.PrettyPrint.Mainland (Pretty, ppr, strictText) + +-- | CSS <side-or-corner> data type +data Side = LeftSide | RightSide | TopSide | BottomSide + deriving (Show, Eq) +instance ToText Side where + toBuilder LeftSide = "left" + toBuilder RightSide = "right" + toBuilder TopSide = "top" + toBuilder BottomSide = "bottom" +instance Pretty Side where + ppr = strictText . toText + +-- Possible pair of values, as expected by linear-gradient() +type SideOrCorner = (Side, Maybe Side) + +-- | CSS <color-stop> data type +data ColorStop = ColorStop { csColor :: Color + , colorHint :: Maybe PercentageLength + } deriving (Show, Eq) +instance ToText ColorStop where + toBuilder (ColorStop c mpl) = toBuilder c <> maybe mempty f mpl + where f (Left p) = singleton ' ' <> toBuilder p + f (Right l) = singleton ' ' <> toBuilder l +instance Pretty ColorStop where + ppr = strictText . toText +instance Minifiable ColorStop where + minifyWith (ColorStop c mlp) = do + newC <- minifyWith c + newMlp <- (mapM . mapM) minifyWith mlp + pure $ ColorStop newC newMlp + +{- +percentageLengthEq :: PercentageLength -> PercentageLength -> Bool +x `percentageLengthEq` y + | isZero x = isZero y + | otherwise = x == y +-} + +-- minifies color hints in a \<color-stops\> 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} + | otherwise = if ch2 `notGreaterThan` ch1 + then c2 {colorHint = Just $ Right (Distance 0 PX)} + else 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 <color-stop> 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) (notGreaterThanDistance d)) y + where notPositive = maybe False (either (<= 0) (\(Distance d _) -> d <= 0)) + notGreaterThanDistance (Distance r1 u1) (Distance 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 (Distance 0 PX) + else Just v + +-- OldLinearGradient is for the old syntax. Eventually it can probably be deleted. +data Gradient = OldLinearGradient (Maybe (Either Angle SideOrCorner)) [ColorStop] + | 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( + [ <ending-shape> || <size> ]? [ at <position> ]? , + <color-stop-list> + ) + + radial-gradient( + [ [ circle || <length> ] [ at <position> ]? , | + [ ellipse || [ <length> | <percentage> ]{2} ] [ at <position> ]? , | + [ [ circle | ellipse ] || <extent-keyword> ] [ at <position> ]? , | + at <position> , + ]? + <color-stop> [ , <color-stop> ]+ + ) + where <extent-keyword> = closest-corner | closest-side | farthest-corner | farthest-side + and <color-stop> = <color> [ <percentage> | <length> ]? +-} + +data Size = ClosestCorner | ClosestSide | FarthestCorner | FarthestSide + | SL Distance + | 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 + +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 + minifyWith g@(OldLinearGradient x cs) = do + conf <- ask + case gradientSettings conf of + GradientMinOn -> do css <- mapM minifyWith cs + pure $ OldLinearGradient x (minifyColorHints css) + GradientMinOff -> pure g + minifyWith g@(LinearGradient x cs) = do + conf <- ask + case gradientSettings conf of + GradientMinOn -> do css <- mapM minifyWith cs + newX <- minifyAngleOrSide x + pure $ LinearGradient newX (minifyColorHints css) + GradientMinOff -> pure g + minifyWith g@(RadialGradient sh sz p cs) = do + conf <- ask + case gradientSettings conf of + GradientMinOn -> do css <- mapM minifyWith 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 mas = + case mas of + Nothing -> pure Nothing + Just y -> case y of + Left a -> if a == defaultGradientAngle + then pure Nothing + else minifyWith a >>= pure . Just . Left + Right b -> if b == defaultGradientSideOrCorner + then pure Nothing + else pure $ Just (minifySide b) + where minifySide (TopSide, Nothing) = Left (Angle 0 Deg) + minifySide (RightSide, Nothing) = Left (Angle 90 Deg) + minifySide (BottomSide, Nothing) = Left (Angle 180 Deg) + minifySide (LeftSide, Nothing) = Left (Angle 270 Deg) + minifySide z = Right z + +defaultGradientAngle :: Angle +defaultGradientAngle = Angle 180 Deg + +defaultGradientSideOrCorner :: SideOrCorner +defaultGradientSideOrCorner = (BottomSide, Nothing) + +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 = if null l + then mempty + else 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 + +angleSideEq :: Angle -> SideOrCorner -> Bool +angleSideEq (Angle 0 Deg) (TopSide, Nothing) = True +angleSideEq (Angle 90 Deg) (RightSide, Nothing) = True +angleSideEq (Angle 180 Deg) (BottomSide, Nothing) = True +angleSideEq (Angle 270 Deg) (LeftSide, Nothing) = True +angleSideEq _ _ = False
+ src/Hasmin/Types/Numeric.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module : Hasmin.Types.Numeric+-- Copyright : (c) 2017 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : non-portable+--+-- CSS Numeric data types: \<number\>, \<percentage\>, and \<alphavalue\>.+-- All Rational newtypes to ensure dimension conversion precision.+--+-----------------------------------------------------------------------------+module Hasmin.Types.Numeric (+ Percentage(..), toPercentage,+ Number(..), toNumber, fromNumber,+ Alphavalue(..), toAlphavalue, mkAlphavalue+ ) where++import Data.Text (pack)+import Hasmin.Types.Class+import Hasmin.Utils+import Text.PrettyPrint.Mainland (strictText, text, Pretty, ppr)+import Text.Printf (printf)++-- | The \<number\> data type. Real numbers, possibly with a fractional component.+-- When written literally, a number is either an integer, or zero or more+-- decimal digits followed by a dot (.) followed by one or more decimal digits+-- and optionally an exponent composed of "e" or "E" and an integer. It+-- corresponds to the \<number-token\> production in the CSS Syntax Module+-- [CSS3SYN]. As with integers, the first character of a number may be+-- immediately preceded by - or + to indicate the number’s sign.+-- Specifications:+--+-- 1. <https://drafts.csswg.org/css-values-3/#numbers CSS Values and Units Module Level 3 (§4.2)>+-- 2. <https://www.w3.org/TR/CSS2/syndata.html#numbers CSS2.1 (§4.3.1)>+-- 3. <https://www.w3.org/TR/CSS1/#units CSS1 (6 Units)>+newtype Number = Number { getRational :: Rational }+ deriving (Eq, Show, Ord, Num, Fractional, Real, RealFrac)++instance ToText Number where+ toText = pack . trimLeadingZeros . showRat . toRational -- check if scientific notation is shorter!+instance Pretty Number where+ ppr = strictText . toText++toNumber :: Real a => a -> Number+toNumber = Number . toRational ++fromNumber :: Fractional a => Number -> a+fromNumber = fromRational . toRational+-- | The \<alphavalue\> data type. Syntactically a \<number\>. It is the+-- uniform opacity setting to be applied across an entire object. Any values+-- outside the range 0.0 (fully transparent) to 1.0 (fully opaque) are clamped+-- to this range. Specification:+--+-- 1. <https://www.w3.org/TR/css3-color/#transparency CSS Color Module Level 3 (§3.2)+newtype Alphavalue = Alphavalue Rational+ deriving (Eq, Show, Ord, Real, RealFrac)++instance Num Alphavalue where+ a + b = mkAlphavalue $ toRational a + toRational b+ a * b = mkAlphavalue $ toRational a * toRational b+ abs = id -- numbers are never negative, so abs doesn't do anything+ signum a | toRational a == 0 = 0+ | otherwise = 1+ fromInteger = toAlphavalue+ a - b = mkAlphavalue $ toRational a - toRational b++instance ToText Alphavalue where+ toText = pack . trimLeadingZeros . showRat . toRational+instance Pretty Alphavalue where+ ppr = text . showRat . toRational+instance Bounded Alphavalue where+ minBound = 0+ maxBound = 1+instance Fractional Alphavalue where+ fromRational = mkAlphavalue+ (Alphavalue a) / (Alphavalue b) = mkAlphavalue (toRational a / toRational b)+toAlphavalue :: Real a => a -> Alphavalue+toAlphavalue = mkAlphavalue . toRational ++mkAlphavalue :: Rational -> Alphavalue+mkAlphavalue = Alphavalue . restrict 0 1++-- | The \<percentage\> data type. Many CSS properties can take percentage+-- values, often to define sizes in terms of parent objects. Percentages are+-- formed by a \<number\> immediately followed by the percentage sign %.+-- There is no space between the '%' and the number. Specification:+--+-- 1. <https://drafts.csswg.org/css-values-3/#percentages CSS Value and Units Module Level 3 (§4.3)+-- 2. <https://www.w3.org/TR/CSS2/syndata.html#percentage-units CSS2.1 (§4.3.3)+-- 3. <https://www.w3.org/TR/CSS1/#percentage-units CSS1 (§6.2)+newtype Percentage = Percentage Rational+ deriving (Eq, Show, Ord, Num, Fractional, Real, RealFrac)++instance Pretty Percentage where+ ppr = strictText . toText+instance ToText Percentage where+ toText = pack . (++ "%") . trimLeadingZeros . showRat . toRational++toPercentage :: Real a => a -> Percentage+toPercentage = Percentage . toRational ++-- Note: printf used instead of show to avoid scientific notation+-- | Show a Rational in decimal notation, removing leading zeros,+-- and not displaying fractional part if the number is an integer.+showRat :: Rational -> String+showRat r | abs (r - fromInteger x) < eps = printf "%d" x+ | otherwise = printf "%f" d+ where x = round r + d = fromRational r :: Double++trimLeadingZeros :: String -> String+trimLeadingZeros l@(x:xs) | x == '-' = x : go xs+ | otherwise = go l+ where go ('0':y:ys) = go (y:ys)+ go z = z+trimLeadingZeros [] = ""
+ src/Hasmin/Types/PercentageLength.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Hasmin.Types.PercentageLength+-- Copyright : (c) 2017 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : non-portable+--+-----------------------------------------------------------------------------+module Hasmin.Types.PercentageLength (+ PercentageLength, isZero, isNonZeroPercentage+ ) where++import Hasmin.Types.Dimension+import Hasmin.Types.Numeric+import Hasmin.Types.Class++-- | CSS <length-percentage> data type, i.e.: [length | percentage]+-- Though because of the name it would be more intuitive to define:+-- type LengthPercentage = Either Distance Percentage,+-- they are inverted here to make use of Either's Functor instance, because it+-- makes no sense to minify a Percentage.+type PercentageLength = Either Percentage Distance++-- TODO see if this instance can be deleted altogether.+instance Minifiable PercentageLength where+ minifyWith x@(Right _) = mapM minifyWith x+ minifyWith x@(Left p) | p == 0 = pure $ Right (Distance 0 Q) -- minifies 0% to 0+ | otherwise = pure x++isNonZeroPercentage :: PercentageLength -> Bool+isNonZeroPercentage (Left p) = p /= 0+isNonZeroPercentage _ = False++isZero :: (Num a, Eq a) => Either a Distance -> Bool+isZero = either (== 0) (== Distance 0 Q)++
+ src/Hasmin/Types/Position.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module : Hasmin.Types.Position+-- Copyright : (c) 2017 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : non-portable+--+-----------------------------------------------------------------------------+module Hasmin.Types.Position (+ Position(..), PosKeyword(..), minifyPosition, p50, l0+ ) where++import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Lazy.Builder (singleton, fromText)+import Data.Maybe (isJust)+import Hasmin.Types.Class+import Hasmin.Types.Dimension+import Hasmin.Types.PercentageLength+import Hasmin.Utils++data Position = Position { origin1 :: Maybe PosKeyword+ , offset1 :: Maybe PercentageLength+ , origin2 :: Maybe PosKeyword+ , offset2 :: Maybe PercentageLength+ } deriving (Eq, Show)++data PosKeyword = PosCenter | PosLeft | PosRight | PosTop | PosBottom+ deriving (Eq, Show)++instance ToText PosKeyword where+ toBuilder PosCenter = "center"+ toBuilder PosTop = "top"+ toBuilder PosRight = "right"+ toBuilder PosBottom = "bottom"+ toBuilder PosLeft = "left"++instance Minifiable Position where+ minifyWith p = pure $ minifyPosition p++instance ToText Position where+ toBuilder (Position a b c d) = mconcatIntersperse fromText (singleton ' ') $ filter (not . T.null) [f a, f b, f c, f d]+ where f :: ToText a => Maybe a -> Text+ f = maybe mempty toText++minifyPosition :: Position -> Position+-- Single keyword+minifyPosition p@(Position (Just x) Nothing Nothing Nothing) = f x+ where mkPos1 y = Position Nothing y Nothing Nothing+ f PosCenter = mkPos1 p50+ f PosRight = mkPos1 p100+ f PosLeft = mkPos1 l0+ f _ = p+-- Keyword and <lenght-percentage>+minifyPosition p@(Position (Just x) Nothing Nothing (Just y)) =+ minifyPos2 x y+ where mkPos2 i j = if isZero j+ then Position Nothing i Nothing l0+ else Position Nothing i Nothing (Just j)+ minifyPos2 PosLeft a = mkPos2 l0 a+ minifyPos2 PosRight a = mkPos2 p100 a+ minifyPos2 PosCenter a = mkPos2 p50 a+ minifyPos2 _ _ = p+minifyPosition p@(Position Nothing (Just x) (Just y) Nothing) =+ minifyPos2 x y+ where mkPos2 i j = if isZero i+ then Position Nothing l0 Nothing j+ else Position Nothing (Just i) Nothing j+ minifyPos2 a PosTop = mkPos2 a l0+ minifyPos2 a PosBottom = mkPos2 a p100+ minifyPos2 a PosCenter = mkPos2 a p50+ minifyPos2 _ _ = p+-- Two <lenght-percentage>+minifyPosition p@(Position Nothing (Just x) Nothing (Just y)) = f x y+ where f :: PercentageLength -> PercentageLength -> Position+ f (Left 50) (Left 50) = Position Nothing p50 Nothing Nothing+ f (Left 50) (Left 100) = Position (Just PosBottom) Nothing Nothing Nothing+ f (Left 100) (Left 100) = Position Nothing p100 Nothing p100+ f (Left 100) (Left 50) = Position Nothing p100 Nothing Nothing+ f a b+ | isZero a = if isZero b+ then Position Nothing l0 Nothing l0+ else case b of+ Left 50 -> Position Nothing l0 Nothing Nothing+ Left 100 -> Position Nothing l0 Nothing p100 + _ -> p { offset1 = l0 }+ | isZero b = case a of+ Left 50 -> Position (Just PosTop) Nothing Nothing Nothing+ Left 100 -> Position Nothing p100 Nothing l0+ _ -> p { offset2 = l0 }+ | b == Left 50 = Position Nothing (Just a) Nothing Nothing+ | otherwise = p+minifyPosition (Position (Just x) (Just y) Nothing Nothing) = + uncurry (\a b -> Position a b Nothing Nothing) (minAxis x y)+-- 2 keywords+minifyPosition p@(Position (Just x) Nothing (Just y) Nothing) = f x y+ where f :: PosKeyword -> PosKeyword -> Position+ -- 'center', 'center center' == '50% 50%'.+ f PosCenter PosCenter = Position Nothing p50 Nothing Nothing+ -- 'left', 'left center', 'center left' == '0% 50%'.+ f PosLeft PosCenter = Position Nothing l0 Nothing Nothing+ f PosCenter PosLeft = Position Nothing l0 Nothing Nothing+ -- 'top left', 'left top' == '0% 0%'.+ f PosTop PosLeft = Position Nothing l0 Nothing l0+ f PosLeft PosTop = Position Nothing l0 Nothing l0+ -- 'top', 'top center', 'center top' == '50% 0%'.+ f PosTop PosCenter = p { origin2 = Nothing }+ f PosCenter PosTop = p { origin1 = Just PosTop, origin2 = Nothing }+ -- 'right top' and 'top right' == '100% 0%'.+ f PosRight PosTop = Position Nothing p100 Nothing l0+ f PosTop PosRight = Position Nothing p100 Nothing l0 + -- 'right', 'right center', 'center right' == '100% 50%'.+ f PosRight PosCenter = Position Nothing p100 Nothing Nothing+ f PosCenter PosRight = Position Nothing p100 Nothing Nothing+ -- 'bottom left' and 'left bottom' == '0% 100%'.+ f PosBottom PosLeft = Position Nothing l0 Nothing p100+ f PosLeft PosBottom = Position Nothing l0 Nothing p100+ -- 'bottom', 'bottom center', 'center bottom' == '50% 100%'.+ f PosBottom PosCenter = p { origin2 = Nothing }+ f PosCenter PosBottom = p { origin1 = Just PosBottom, origin2 = Nothing }+ -- 'bottom right', 'right bottom' == '100% 100%'.+ f PosBottom PosRight = Position Nothing p100 Nothing p100+ f PosRight PosBottom = Position Nothing p100 Nothing p100+ f _ _ = p+-- keyword pl keyword syntax+minifyPosition p@(Position (Just x) (Just y) (Just z) Nothing)+ | x == PosTop || x == PosBottom || z == PosLeft || z == PosRight =+ minifyPosition $ Position (Just z) Nothing (Just x) (Just y) + | otherwise = minifyPos3 x y z+ where minifyPos3 PosLeft b PosBottom+ | isZero b = Position Nothing l0 Nothing p100 + | b == Left 50 = Position (Just PosBottom) Nothing Nothing Nothing + | otherwise = Position Nothing (Just b) Nothing p100 + minifyPos3 PosLeft b PosTop+ | isZero b = Position Nothing l0 Nothing l0 + | b == Left 50 = Position (Just PosTop) Nothing Nothing Nothing + | otherwise = Position Nothing (Just b) Nothing l0 + minifyPos3 PosLeft b PosCenter+ | isZero b = Position Nothing l0 Nothing Nothing + | b == Left 50 = Position Nothing p50 Nothing Nothing + | otherwise = Position Nothing (Just b) Nothing p50 + minifyPos3 PosRight b PosTop+ | isZero b = Position Nothing p100 Nothing l0 + | otherwise = Position (Just PosRight) (Just b) Nothing l0 + minifyPos3 PosRight b PosBottom+ | isZero b = Position Nothing p100 Nothing p100 + | otherwise = Position (Just PosRight) (Just b) Nothing p100+ minifyPos3 PosRight b PosCenter+ | isZero b = Position Nothing p100 Nothing Nothing + | otherwise = Position (Just PosRight) (Just b) Nothing p50 + minifyPos3 _ _ _ = p+minifyPosition p@(Position (Just c) Nothing (Just a) (Just b)) = f $ minAxis a b+ where f (x, y) + | c == PosLeft && x == Just PosTop && isJust y = minifyPosition $ Position Nothing l0 Nothing y+ | otherwise = if Just a == x && Just b == y+ then p+ else minifyPosition $ p {origin2 = x, offset2 = y }+-- 4 value syntax+minifyPosition p@(Position (Just PosLeft) (Just _) (Just PosTop) (Just _)) = + minifyPosition p { origin1 = Nothing, origin2 = Nothing }+minifyPosition (Position (Just a) (Just b) (Just c) (Just d)) = + minifyPos4 a b c d+minifyPosition p = p++-- Sort values so that the Xs are first, then the Ys, and later minify.+minifyPos4 :: PosKeyword -> PercentageLength -> PosKeyword -> PercentageLength -> Position+minifyPos4 v1 v2 v3 v4+ | v1 == PosTop || v1 == PosBottom || v3 == PosLeft || v3 == PosRight = minifyPos4' v3 v4 v1 v2+ | otherwise = minifyPos4' v1 v2 v3 v4+ where minifyPos4' PosLeft a PosTop b = minifyPosition $ Position Nothing (Just a) Nothing (Just b)+ minifyPos4' PosRight a PosTop b+ | isZero a = minifyPosition $ Position Nothing p100 Nothing (Just b)+ | isZero b = minifyPosition $ Position (Just PosRight) (Just a) (Just PosTop) Nothing+ | otherwise = Position (Just PosRight) (Just a) (Just PosTop) (Just b)+ minifyPos4' PosLeft a PosBottom b+ | isZero b = minifyPosition $ Position Nothing (Just a) Nothing p100+ | isZero a = minifyPosition $ Position (Just PosLeft) Nothing (Just PosTop) (Just b)+ | otherwise = minifyPosition $ Position (Just PosLeft) (Just a) (Just PosBottom) (Just b)+ minifyPos4' PosRight a PosBottom b+ | isZero a && isZero b = Position Nothing p100 Nothing p100+ | otherwise = Position (Just PosRight) (Just a) (Just PosBottom) (Just b)+ minifyPos4' a b c d = Position (Just a) (Just b) (Just c) (Just d)++minAxis :: PosKeyword -> PercentageLength -> (Maybe PosKeyword, Maybe PercentageLength)+minAxis PosTop x = + case x of+ Left 50 -> (Just PosCenter, Nothing)+ b -> if isZero b + then (Just PosTop, Nothing)+ else (Just PosTop, Just x)+minAxis PosLeft x =+ case x of+ Left 50 -> (Just PosCenter, Nothing)+ smth -> if isZero smth+ then (Just PosLeft, Nothing)+ else (Just PosLeft, Just x)+minAxis PosRight x+ | isZero x = (Just PosRight, Nothing)+ | otherwise = (Just PosRight, Just x)+minAxis PosBottom x+ | isZero x = (Just PosBottom, Nothing)+ | otherwise = (Just PosBottom, Just x)+minAxis PosCenter x = (Just PosCenter, Just x)++l0 :: Maybe PercentageLength+l0 = Just (Right (Distance 0 Q))++p100 :: Maybe PercentageLength+p100 = Just $ Left 100++p50 :: Maybe PercentageLength+p50 = Just $ Left 50
+ src/Hasmin/Types/RepeatStyle.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module : Hasmin.Types.RepeatStyle+-- Copyright : (c) 2017 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : non-portable+--+-- \<repeat-style> data type used in background-repeat. Specification:+-- <https://drafts.csswg.org/css-backgrounds-3/#the-background-repeat CSS Backgrounds and Borders Module Level 3 (§3.4)>+-- +-----------------------------------------------------------------------------+module Hasmin.Types.RepeatStyle (+ RepeatStyle(..), RSKeyword(..)+ ) where++import Control.Monad.Reader (ask)+import Data.Monoid ((<>))+import Data.Text.Lazy.Builder (singleton)+import Hasmin.Types.Class++data RepeatStyle = RepeatX + | RepeatY+ | RSPair RSKeyword (Maybe RSKeyword)+ deriving (Show)++data RSKeyword = RsRepeat | RsSpace | RsRound | RsNoRepeat+ deriving (Eq, Show)++instance Eq RepeatStyle where+ RepeatX == RepeatX = True+ a@RepeatX == b@RSPair{} = b == a+ RepeatY == RepeatY = True+ a@RepeatY == b@RSPair{} = b == a+ RSPair RsNoRepeat (Just RsRepeat) == RepeatY = True+ RSPair RsRepeat (Just RsNoRepeat) == RepeatX = True+ RSPair RsNoRepeat (Just RsRepeat) == RSPair RsNoRepeat (Just RsRepeat) = True+ RSPair RsRepeat (Just RsNoRepeat) == RSPair RsRepeat (Just RsNoRepeat) = True+ RSPair RsSpace (Just RsSpace) == RSPair RsSpace Nothing = True+ RSPair RsSpace (Just RsSpace) == RSPair RsSpace (Just RsSpace) = True+ RSPair RsRound (Just RsRound) == RSPair RsRound Nothing = True+ RSPair RsRound (Just RsRound) == RSPair RsRound (Just RsRound) = True+ RSPair RsNoRepeat (Just RsNoRepeat) == RSPair RsNoRepeat Nothing = True+ RSPair RsNoRepeat (Just RsNoRepeat) == RSPair RsNoRepeat (Just RsNoRepeat) = True+ RSPair RsRepeat (Just RsRepeat) == RSPair RsRepeat Nothing = True+ RSPair RsRepeat (Just RsRepeat) == RSPair RsRepeat (Just RsRepeat) = True+ RSPair x Nothing == RSPair y Nothing = x == y+ a@(RSPair _ Nothing) == b@(RSPair _ _) = b == a+ _ == _ = False++instance ToText RSKeyword where+ toBuilder RsRepeat = "repeat"+ toBuilder RsSpace = "space"+ toBuilder RsRound = "round"+ toBuilder RsNoRepeat = "no-repeat"++instance ToText RepeatStyle where+ toBuilder RepeatX = "repeat-x"+ toBuilder RepeatY = "repeat-y"+ toBuilder (RSPair r1 r2 ) = toBuilder r1 <> maybe mempty (\x -> singleton ' ' <> toBuilder x) r2++instance Minifiable RepeatStyle where+ minifyWith r = do+ conf <- ask+ pure $ if True {- shouldMinifyRepeatStyle conf -}+ then minifyRepeatStyle r+ else r++minifyRepeatStyle :: RepeatStyle -> RepeatStyle+minifyRepeatStyle (RSPair RsRepeat (Just RsNoRepeat)) = RepeatX+minifyRepeatStyle (RSPair RsNoRepeat (Just RsRepeat)) = RepeatY+minifyRepeatStyle (RSPair x (Just y)) = if x == y+ then RSPair x Nothing+ else RSPair x (Just y)+minifyRepeatStyle x = x
+ src/Hasmin/Types/Shadow.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module : Hasmin.Types.Shadow+-- Copyright : (c) 2017 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : non-portable+--+-----------------------------------------------------------------------------+module Hasmin.Types.Shadow (+ Shadow(..)+ ) where++import Control.Monad.Reader (ask)+import Data.Semigroup ((<>))+import Data.Text.Lazy.Builder (singleton)+import Data.Bool (bool)+import Hasmin.Types.Class+import Hasmin.Types.Color+import Hasmin.Types.Dimension++data Shadow = Shadow { inset :: Bool+ , sOffsetX :: Distance+ , sOffsetY :: Distance+ , blurRadius :: Maybe Distance+ , spreadRadius :: Maybe Distance+ , sColor :: Maybe Color+ } deriving (Eq, Show)++instance ToText Shadow where+ toBuilder (Shadow i ox oy br sr c) =+ bool mempty "inset " i+ <> toBuilder ox <> singleton ' '+ <> toBuilder oy <> f br <> f sr <> f c+ where f c = maybe mempty (\y -> singleton ' ' <> toBuilder y) c -- don't eta reduce this!++instance Minifiable Shadow where+ minifyWith (Shadow i ox oy br sr c) = do+ conf <- ask+ x <- minifyWith ox+ y <- minifyWith oy+ nb <- mapM minifyWith br+ ns <- mapM minifyWith sr+ c2 <- mapM minifyWith c+ pure $ if True {- shouldMinifyShadows conf -}+ then let (a, b) = minifyBlurAndSpread nb ns+ in Shadow i x y a b c2+ else Shadow i x y nb ns c2++minifyBlurAndSpread :: Maybe Distance -> Maybe Distance+ -> (Maybe Distance, Maybe Distance)+minifyBlurAndSpread (Just br) Nothing+ | br == Distance 0 Q = (Nothing, Nothing)+ | otherwise = (Just br, Nothing)+minifyBlurAndSpread (Just br) (Just sr)+ | sr == Distance 0 Q = minifyBlurAndSpread (Just br) Nothing+ | otherwise = (Just br, Just sr)+minifyBlurAndSpread x y = (x, y)
+ src/Hasmin/Types/String.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Hasmin.Types.String+-- Copyright : (c) 2017 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : non-portable+--+-----------------------------------------------------------------------------+module Hasmin.Types.String + ( removeQuotes, unquoteUrl, unquoteFontFamily, mapString+ , StringType(..)+ ) where++import Control.Applicative (liftA2)+import Control.Monad.Reader (ask, Reader)+import Data.Attoparsec.Text (Parser, parse, IResult(..), maybeResult, feed)+import Data.Monoid ((<>))+import Data.Text (Text)+import Data.Text.Lazy.Builder as LB+import qualified Data.Attoparsec.Text as A+import qualified Data.Char as C+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Hasmin.Parser.Utils+import Hasmin.Types.Class+import Hasmin.Config+import Text.PrettyPrint.Mainland (Pretty, ppr, strictText)++-- | The \<string\> data type represents a string, formed by Unicode+-- characters, delimited by either double (") or single (') quotes.+-- Specification:+--+-- 1. <https://drafts.csswg.org/css-values-3/#strings CSS Values and Units Module Level 3 (§3.3)+-- 2. <https://www.w3.org/TR/CSS2/syndata.html#strings CSS2.1 (§4.3.7)+data StringType = DoubleQuotes Text+ | SingleQuotes Text+ deriving (Show, Eq)+instance ToText StringType where+ toBuilder (DoubleQuotes t) = singleton '\"' <> fromText t <> singleton '\"'+ toBuilder (SingleQuotes t) = singleton '\'' <> fromText t <> singleton '\''+instance Pretty StringType where+ ppr = strictText . toText+instance Minifiable StringType where+ minifyWith (DoubleQuotes t) = do+ conf <- ask+ convertedText <- convertEscapedText t+ pure $ if T.any ('\"' ==) convertedText+ then DoubleQuotes t+ else if shouldNormalizeQuotes conf+ -- TODO make it so that the best quotes are used for the file+ then DoubleQuotes convertedText+ else DoubleQuotes convertedText+ minifyWith (SingleQuotes t) = do+ conf <- ask+ convertedText <- convertEscapedText t+ pure $ if T.any ('\'' ==) convertedText+ then SingleQuotes t+ else if shouldNormalizeQuotes conf && T.all ('\"' /=) convertedText+ then DoubleQuotes convertedText+ else SingleQuotes convertedText++convertEscapedText :: Text -> Reader Config Text+convertEscapedText t = do+ conf <- ask+ pure $ if shouldConvertEscaped conf+ then either (const t) id (A.parseOnly convertEscaped t)+ else t++mapString :: (Text -> Reader Config Text) -> StringType -> Reader Config StringType+mapString f (DoubleQuotes t) = f t >>= pure . DoubleQuotes+mapString f (SingleQuotes t) = f t >>= pure . SingleQuotes++unquoteStringType :: (Text -> Maybe Text) -> StringType -> Either Text StringType+unquoteStringType g x@(DoubleQuotes s) = maybe (Right x) Left (g s)+unquoteStringType g x@(SingleQuotes s) = maybe (Right x) Left (g s)++removeQuotes :: StringType -> Either Text StringType+removeQuotes = unquoteStringType toIdent++unquoteUrl :: StringType -> Either Text StringType+unquoteUrl = unquoteStringType toUnquotedURL++unquoteFontFamily :: StringType -> Either Text StringType+unquoteFontFamily = unquoteStringType toUnquotedFontFamily++unquote :: Parser Text -> Text -> Maybe Text+unquote p s = case parse p s of+ Done i r -> if T.null i+ then Just r+ else Nothing+ par@Partial{} -> maybeResult (feed par mempty)+ Fail{} -> Nothing++toIdent :: Text -> Maybe Text+toIdent = unquote ident++toUnquotedURL :: Text -> Maybe Text+toUnquotedURL = unquote nonquotedurl++toUnquotedFontFamily :: Text -> Maybe Text+toUnquotedFontFamily = unquote fontfamilyname++convertEscaped :: Parser Text+convertEscaped = (TL.toStrict . toLazyText) <$> go+ where go = do+ t <- fromText <$> A.takeWhile (/= '\\')+ c <- A.peekChar+ case c of+ Just '\\' -> A.char '\\' *> liftA2 (mappend . mappend t . singleton) utf8 go+ _ -> pure t+ utf8 = C.chr <$> A.hexadecimal++instance Pretty (Either Text StringType) where+ ppr (Left i) = strictText i+ ppr (Right s) = ppr s
+ src/Hasmin/Types/Stylesheet.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module : Hasmin.Types.Stylesheet+-- Copyright : (c) 2017 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : unknown+--+-----------------------------------------------------------------------------+module Hasmin.Types.Stylesheet (+ Expression(..), MediaQuery(..), Rule(..), KeyframeSelector(..),+ KeyframeBlock(..), isEmpty+ ) where++import Control.Monad.Reader (Reader, ask)+import Control.Applicative (liftA2)+import Data.Monoid ((<>))+import Data.Text (Text)+import Data.Text.Lazy.Builder (singleton, fromText)+import Data.List (sortBy, (\\))+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import qualified Data.Set as S+import qualified Data.Text as T+import Text.PrettyPrint.Mainland (Pretty, ppr, strictText,+ lbrace, rbrace, (</>), (<+>), comma, folddoc, nest, semi, stack, char)++import Hasmin.Config+import Hasmin.Selector+import Hasmin.Types.Class+import Hasmin.Types.Value+import Hasmin.Types.Declaration+import Hasmin.Types.String+import Hasmin.Types.Numeric+import Hasmin.Utils++data MediaQuery = MediaQuery1 Text Text [Expression] -- ^ First possibility in the grammar+ | MediaQuery2 [Expression] -- ^ Second possibility in the grammar+ deriving (Show, Eq)+instance Minifiable MediaQuery where+ minifyWith (MediaQuery1 t1 t2 es) = MediaQuery1 t1 t2 <$> mapM minifyWith es+ minifyWith (MediaQuery2 es) = MediaQuery2 <$> mapM minifyWith es++instance ToText MediaQuery where+ toBuilder (MediaQuery1 t1 t2 es) = notOrOnly <> fromText t2 <> expressions+ where notOrOnly | T.null t1 = mempty+ | otherwise = fromText t1 <> singleton ' '+ expressions = foldr (\x xs -> " and " <> toBuilder x <> xs) mempty es+ toBuilder (MediaQuery2 es) = mconcatIntersperse toBuilder " and " es++data Expression = Expression Text (Maybe Value)+ | InvalidExpression Text+ deriving (Show, Eq)+instance Minifiable Expression where+ minifyWith (Expression t mv) = Expression t <$> mapM minifyWith mv+ minifyWith x = pure x+instance ToText Expression where+ toBuilder (Expression t mv) =+ singleton '(' <> fromText t <> v <> singleton ')'+ where v = maybe mempty (\x -> singleton ':' <> toBuilder x) mv+ toBuilder (InvalidExpression t) =+ singleton '(' <> fromText t <> singleton ')'++data KeyframeSelector = From | To | KFPercentage Percentage+ deriving (Eq, Show)+instance ToText KeyframeSelector where+ toText From = "from"+ toText To = "to"+ toText (KFPercentage p) = toText p+instance Pretty KeyframeSelector where+ ppr = strictText . toText+instance Minifiable KeyframeSelector where+ minifyWith x = do+ conf <- ask+ pure $ if shouldMinifyKeyframeSelectors conf+ then minifyKFS x+ else x++minifyKFS :: KeyframeSelector -> KeyframeSelector+minifyKFS From = KFPercentage $ Percentage 0+minifyKFS (KFPercentage (Percentage 100)) = To+minifyKFS x = x++data KeyframeBlock = KeyframeBlock [KeyframeSelector] [Declaration]+ deriving (Eq, Show)+instance ToText KeyframeBlock where+ toBuilder (KeyframeBlock ss ds) =+ mconcatIntersperse toBuilder (singleton ',') ss+ <> singleton '{'+ <> mconcatIntersperse toBuilder (singleton ';') ds+ <> singleton '}'+instance Minifiable KeyframeBlock where+ minifyWith (KeyframeBlock ss ds) = do+ decs <- mapM minifyWith ds+ sels <- mapM minifyWith ss+ pure $ KeyframeBlock sels decs++type VendorPrefix = Text++data Rule = AtCharset StringType+ | AtImport (Either StringType Url) [MediaQuery]+ | AtNamespace Text (Either StringType Url)+ | AtMedia [MediaQuery] [Rule]+ | AtKeyframes VendorPrefix Text [KeyframeBlock]+ | AtBlockWithRules Text [Rule]+ | AtBlockWithDec Text [Declaration]+ | StyleRule [Selector] [Declaration]+ deriving (Show)+instance Pretty Rule where+ ppr (StyleRule ss ds) = folddoc (\x y -> x <> comma <+> y) (fmap ppr ss)+ <+> nest 4 (lbrace </> stack (fmap ((<> semi) . ppr) ds))+ </> rbrace+ ppr (AtBlockWithRules t rs) = char '@' <> strictText t+ <+> nest 4 (lbrace </> stack (fmap ppr rs)) </> rbrace+ ppr (AtBlockWithDec t ds) = char '@' <> strictText t+ <+> nest 4 (lbrace </> stack (fmap ppr ds)) </> rbrace+ ppr _ = error "not implemented (TODO)"++instance ToText Rule where+ toBuilder (AtMedia mqs rs) = "@media " <> mconcatIntersperse toBuilder (singleton ',') mqs+ <> singleton '{' <> mconcat (fmap toBuilder rs) <> singleton '}'+ toBuilder (AtImport esu mqs) = "@import " <> toBuilder esu <> mediaqueries+ <> singleton ';'+ where mediaqueries =+ case mqs of+ [] -> mempty+ _ -> singleton ' ' <> mconcatIntersperse toBuilder (singleton ',') mqs+ toBuilder (AtCharset s) = "@charset " <> toBuilder s <> singleton ';'+ toBuilder (AtNamespace t esu) = "@namespace "+ <> prefix <> toBuilder esu <> singleton ';'+ where prefix = if T.null t+ then mempty+ else toBuilder t <> singleton ' '+ toBuilder (StyleRule ss ds) =+ mconcat [mconcatIntersperse toBuilder (singleton ',') ss+ ,singleton '{'+ ,mconcatIntersperse toBuilder (singleton ';') ds+ ,singleton '}']+ toBuilder (AtBlockWithRules t rs) =+ mconcat [singleton '@', fromText t, singleton '{'+ , mconcat (fmap toBuilder rs), singleton '}']+ toBuilder (AtBlockWithDec t ds) =+ mconcat [singleton '@', fromText t, singleton '{'+ ,mconcatIntersperse id (singleton ';') (fmap toBuilder ds)+ ,singleton '}']+ toBuilder (AtKeyframes vp n bs) = singleton '@' <> fromText vp <> "keyframes"+ <> singleton ' ' <> fromText n <> singleton '{'+ <> mconcat (fmap toBuilder bs) <> singleton '}'++instance Minifiable Rule where+ minifyWith (AtMedia mqs rs) = liftA2 AtMedia (mapM minifyWith mqs) (mapM minifyWith rs)+ minifyWith (AtKeyframes vp n bs) = AtKeyframes vp n <$> mapM minifyWith bs+ minifyWith (AtBlockWithRules t rs) = AtBlockWithRules t <$> mapM minifyWith rs+ minifyWith (AtBlockWithDec t ds) = do+ decs <- cleanRule ds >>= compactLonghands >>= mapM minifyWith+ pure $ AtBlockWithDec t decs+ minifyWith (StyleRule ss ds) = do+ decs <- cleanRule ds >>= compactLonghands >>= mapM minifyWith >>= sortDeclarations+ sels <- mapM minifyWith ss >>= removeDuplicateSelectors >>= sortSelectors+ pure $ StyleRule sels decs+ minifyWith (AtImport esu mqs) = AtImport esu <$> mapM minifyWith mqs+ minifyWith (AtCharset s) = AtCharset <$> mapString lowercaseText s+ minifyWith x = pure x++cleanRule :: [Declaration] -> Reader Config [Declaration]+cleanRule ds = do+ conf <- ask+ pure $ if shouldCleanRules conf+ then clean ds+ else ds++sortSelectors :: [Selector] -> Reader Config [Selector]+sortSelectors sls = do+ conf <- ask+ pure $ case selectorSorting conf of+ Lexicographical -> sortBy lexico sls+ NoSorting -> sls+sortDeclarations :: [Declaration] -> Reader Config [Declaration]+sortDeclarations ds = do+ conf <- ask+ pure $ case declarationSorting conf of+ Lexicographical -> sortBy lexico ds+ NoSorting -> ds++removeDuplicateSelectors :: [Selector] -> Reader Config [Selector]+removeDuplicateSelectors sls = do+ conf <- ask+ pure $ if shouldRemoveDuplicateSelectors conf+ then nub' sls+ else sls++gatherLonghands :: [Declaration] -> Map (Text, Bool) Declaration+gatherLonghands = go Map.empty+ where go m [] = m+ go m (d@(Declaration p _ i _):ds)+ | S.member p longhands = go (Map.insert (p,i) d m) ds+ | otherwise = go m ds+ longhands = S.fromList (marginLonghands ++ paddingLonghands)++-- TODO delete this.+marginLonghands = ["margin-top", "margin-right", "margin-bottom", "margin-left"]+paddingLonghands = ["padding-top", "padding-right", "padding-bottom", "padding-left"]++compactTRBL :: Text -> [Text] -> Map (Text, Bool) Declaration+ -> (Maybe Declaration, [Declaration])+compactTRBL name lhs m =+ case sequenceA (map getDeclaration lhs) of+ Just l -> (Just (Declaration name (shValues l) False False), l)+ Nothing -> (Nothing, [])+ where getDeclaration x = Map.lookup (x, False) m+ shValues = mkValues . map (head . valuesToList . valueList)++compactMargin = compactTRBL "margin" marginLonghands+compactPadding = compactTRBL "padding" paddingLonghands+-- ,("border-color", mergeIntoTRBL)+-- ,("border-width", mergeIntoTRBL)+-- ,("border-style", mergeIntoTRBL)++compacter m ds = compacter' [compactMargin, compactPadding]+ where compacter' [] = ds+ compacter' (f:fs) = case f m of+ (Just sh, l) -> (compacter' fs \\ l) ++ [sh]+ (Nothing, _) -> compacter' fs++compactLonghands :: [Declaration] -> Reader Config [Declaration]+compactLonghands ds = do+ conf <- ask+ pure $ if True {- shouldGatherLonghands conf -}+ then compacter (gatherLonghands ds) ds+ else ds++-- Used for sorting selectors+-- TODO: move to the correct place, and maybe rename.+lexico :: ToText a => a -> a -> Ordering+lexico s1 s2 = compare (toText s1) (toText s2)++isEmpty :: Rule -> Bool+isEmpty (StyleRule _ ds) = null ds+isEmpty (AtMedia _ rs) = null rs || all isEmpty rs+isEmpty (AtKeyframes _ _ kfbs) = null kfbs+isEmpty (AtBlockWithDec _ ds) = null ds+isEmpty (AtBlockWithRules _ rs) = null rs || all isEmpty rs+isEmpty _ = False++-- O(n log n) implementation, vs. O(n^2) which is the normal nub.+-- Note that nub has only an Eq constraint, while this one has an Ord one.+-- taken from: http://buffered.io/posts/a-better-nub/+nub' :: (Ord a) => [a] -> [a]+nub' = go S.empty+ where go _ [] = []+ go s (x:xs) | S.member x s = go s xs+ | otherwise = x : go (S.insert x s) xs
+ src/Hasmin/Types/TimingFunction.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module : Hasmin.Types.TimingFunction+-- Copyright : (c) 2016 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : non-portable+--+-----------------------------------------------------------------------------+module Hasmin.Types.TimingFunction (+ TimingFunction(..), StepsSecondParam(..)+ ) where++import Control.Monad.Reader (ask)+import Data.Semigroup ((<>))+import Prelude hiding (sin, cos, acos, tan, atan)+import Data.Maybe (isNothing, fromJust)+import Data.Text.Lazy.Builder (singleton)+import Hasmin.Config+import Hasmin.Types.Class+import Hasmin.Utils+import Hasmin.Types.Numeric+--import Text.PrettyPrint.Mainland (Pretty, ppr, strictText)++-- | CSS \<single-transition-timing-function\> data type. Specifications:+--+-- 1. <https://drafts.csswg.org/css-transitions/#propdef-transition-timing-function CSS Transitions>+-- 2. <https://drafts.csswg.org/css-animations/#animation-timing-function CSS Animations Level 1>+-- 3. <https://developer.mozilla.org/en-US/docs/Web/CSS/timing-function Mozilla summary>+data TimingFunction = CubicBezier Number Number Number Number+ | Steps Int (Maybe StepsSecondParam)+ | Ease | EaseIn | EaseInOut | EaseOut + | Linear | StepEnd | StepStart + deriving (Show)++instance Eq TimingFunction where+ Steps i1 ms1 == Steps i2 ms2 = i1 == i2 && (ms1 == ms2 + || (isNothing ms1 && fromJust ms2 == End)+ || (fromJust ms1 == End && isNothing ms2))+ s@Steps{} == x = maybe False (== s) (toSteps x)+ x == s@Steps{} = s == x+ CubicBezier x1 x2 x3 x4 == CubicBezier y1 y2 y3 y4 = + x1 == y1 && x2 == y2 && x3 == y3 && x4 == y4+ c@CubicBezier{} == x = maybe False (== c) (toCubicBezier x)+ x == c@CubicBezier{} = c == x+ StepEnd == StepEnd = True+ StepStart == StepStart = True+ Ease == Ease = True+ Linear == Linear = True+ EaseIn == EaseIn = True+ EaseOut == EaseOut = True+ EaseInOut == EaseInOut = True+ _ == _ = False+ +toCubicBezier :: TimingFunction -> Maybe TimingFunction+toCubicBezier Ease = Just $ CubicBezier 0.25 0.1 0.25 1+toCubicBezier EaseIn = Just $ CubicBezier 0.42 0 1 1+toCubicBezier EaseInOut = Just $ CubicBezier 0.42 0 0.58 1+toCubicBezier Linear = Just $ CubicBezier 0 0 1 1+toCubicBezier EaseOut = Just $ CubicBezier 0 0 0.58 1+toCubicBezier _ = Nothing ++toSteps :: TimingFunction -> Maybe TimingFunction+toSteps StepEnd = Just $ Steps 1 (Just End)+toSteps StepStart = Just $ Steps 1 (Just Start)+toSteps _ = Nothing+++data StepsSecondParam = Start | End -- End is the default value+ deriving (Eq, Show)+instance ToText StepsSecondParam where+ toBuilder Start = "start"+ toBuilder End = "end"++instance ToText TimingFunction where+ toBuilder (CubicBezier a b c d) = "cubic-bezier(" + <> mconcatIntersperse toBuilder (singleton ',') [a,b,c,d]+ <> singleton ')'+ toBuilder (Steps i ms) = "steps(" <> toBuilder i <> sp <> singleton ')'+ where sp = maybe mempty (\x -> singleton ',' <> toBuilder x) ms+ toBuilder Ease = "ease"+ toBuilder Linear = "linear"+ toBuilder EaseIn = "ease-in"+ toBuilder EaseOut = "ease-out"+ toBuilder EaseInOut = "ease-in-out"+ toBuilder StepStart = "step-start"+ toBuilder StepEnd = "step-end"++instance Minifiable TimingFunction where+ minifyWith x = do+ conf <- ask+ if shouldMinifyTimingFunctions conf+ then pure $ minifyTimingFunction x+ else pure x ++minifyTimingFunction :: TimingFunction -> TimingFunction+minifyTimingFunction x@(CubicBezier a b c d) + | a == 0.25 && b == 0.1 && c == 0.25 && d == 1 = Ease+ | a == 0.42 && b == 0 && d == 1 = if c == 1+ then EaseIn+ else if c == 0.58+ then EaseInOut+ else x+ | a == 0 && b == 0 && d == 1 = if c == 1+ then Linear+ else if c == 0.58 + then EaseOut+ else x+ | otherwise = x+minifyTimingFunction x@(Steps i ms)+ | (isNothing ms || (fromJust ms == End)) && i == 1 = StepEnd+ | i == 1 && (fromJust ms == Start) = StepStart+ | otherwise = x+minifyTimingFunction x = x
+ src/Hasmin/Types/TransformFunction.hs view
@@ -0,0 +1,580 @@+{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Hasmin.Types.TransformFunction +-- Copyright : (c) 2017 Cristian Adrián Ontivero +-- License : BSD3 +-- Stability : experimental +-- Portability : non-portable +-- +-- CSS \<transform-function> data type. +-- +----------------------------------------------------------------------------- +module Hasmin.Types.TransformFunction ( + TransformFunction(..), mkMat, mkMat3d, combine + ) where + +import Control.Monad.Reader (mapReader, Reader, ask, local) +import Control.Applicative (liftA2) +import Data.Monoid ((<>)) +import qualified Data.Text as T +import Data.Number.FixedFunctions (sin, cos, acos, tan, atan) +import Prelude hiding (sin, cos, acos, tan, atan) +import qualified Data.Matrix as M +import Data.Matrix (Matrix) +import Data.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.Types.Class +import Hasmin.Utils +import Hasmin.Types.Dimension +import Hasmin.Types.PercentageLength +import Hasmin.Types.Numeric +import Text.PrettyPrint.Mainland (Doc, Pretty, ppr, char) + +-- Note: In a previous specification, translate3d() took two +-- <https://www.w3.org/TR/css-transforms-1/#typedef-translation-value \<translation-value\>>, +-- however in the <https://drafts.csswg.org/css-transforms/ latest draft>, it +-- takes two \<length-percentage\> (which makes sense since translateX() and +-- translateY() also do). + +data TransformFunction = Mat (Matrix Number) + | Mat3d (Matrix Number) + | Perspective Distance + | Rotate Angle + | Rotate3d Number Number Number Angle + | RotateX Angle + | RotateY Angle + | RotateZ Angle + | Scale Number (Maybe Number) + | Scale3d Number Number Number + | ScaleX Number + | ScaleY Number + | ScaleZ Number + | Skew Angle (Maybe Angle) + | SkewX Angle + | SkewY Angle + | Translate PercentageLength (Maybe PercentageLength) + | Translate3d PercentageLength PercentageLength Distance + | TranslateX PercentageLength + | TranslateY PercentageLength + | TranslateZ Distance + 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 + minifyWith (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 + minifyWith x = do + conf <- ask + if shouldMinifyTransformFunction conf + then case toMatrix3d x of + Just mat3d -> minifyWith mat3d + Nothing -> simplify x + else pure x + +{- +s = SkewX (Angle 45 Deg) +tx = TranslateX (Right $ Distance (-6) PX) +ry = RotateY (Angle (-9) Deg) +ry2 = Rotate3d 0 (-1) 0 (Angle 9 Deg) +t = TranslateZ (Distance 100 PX) +t2 = Translate (Right (Distance 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) + +instance Pretty TransformFunction where + ppr (Translate pl mpl) = "translate(" <> eitherToDoc pl + <> maybe mempty (\x -> char ',' <> eitherToDoc x) mpl + <> char ')' + ppr (TranslateX pl) = "translatex(" <> either ppr ppr pl <> char ')' + ppr (TranslateY pl) = "translatey(" <> either ppr ppr pl <> char ')' + ppr (TranslateZ d) = "translatez(" <> ppr d <> char ')' + ppr (Scale n mn) = "scale(" <> ppr n <> maybeToDoc mn <> char ')' + ppr (ScaleX n) = "scalex(" <> ppr n <> char ')' + ppr (ScaleY n) = "scaley(" <> ppr n <> char ')' + ppr (ScaleZ n) = "scalez(" <> ppr n <> char ')' + ppr (Skew a ma) = "skew(" <> ppr a <> maybeToDoc ma <> char ')' + ppr (SkewX a) = "skewx(" <> ppr a <> char ')' + ppr (SkewY a) = "skewy(" <> ppr a <> char ')' + ppr (Rotate a) = "rotate(" <> ppr a <> char ')' + ppr (RotateX a) = "rotatex(" <> ppr a <> char ')' + ppr (RotateY a) = "rotatey(" <> ppr a <> char ')' + ppr (RotateZ a) = "rotatez(" <> ppr a <> char ')' + ppr (Rotate3d x y z a) = "rotate3d(" <> ppr x <> char ',' <> ppr y + <> char ',' <> ppr z <> char ',' <> ppr a <> char ')' + ppr (Scale3d x y z) = "scale3d(" <> ppr x <> char ',' <> ppr y + <> char ',' <> ppr z <> char ')' + ppr (Perspective d) = "perspective(" <> ppr d <> char ')' + ppr (Translate3d x y z) = "translate3d(" <> eitherToDoc x <> char ',' + <> eitherToDoc y <> char ',' <> ppr z <> char ')' + ppr (Mat m) = "matrix(" + <> mconcatIntersperse ppr (char ',') (M.toList m) <> char ')' + ppr (Mat3d m) = "matrix3d(" + <> mconcatIntersperse ppr (char ',') (M.toList m) <> char ')' + +maybeToDoc :: Pretty a => Maybe a -> Doc +maybeToDoc = maybe mempty (\x -> char ',' <> ppr x) + +eitherToDoc :: (Pretty a, Pretty b) => Either a b -> Doc +eitherToDoc = either ppr ppr + +mkMat :: [Number] -> TransformFunction +mkMat = Mat . M.fromList 3 2 + +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 && isRelativeDistance (fromRight' pl) = Nothing + | otherwise = Just . Mat3d $ mkTranslate3dMatrix x 0 0 + where x = either (const 0) fromPixelsToNum pl +toMatrix3d (TranslateY pl) + | isNonZeroPercentage pl = Nothing + | isRight pl && isRelativeDistance (fromRight' pl) = Nothing + | otherwise = Just . Mat3d $ mkTranslate3dMatrix 0 y 0 + where y = either (const 0) fromPixelsToNum pl +toMatrix3d (TranslateZ d) + | isRelativeDistance 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 && isRelativeDistance (fromRight' pl1) = Nothing + | isRight pl2 && isRelativeDistance (fromRight' pl2) = Nothing + | isRelativeDistance d = Nothing + | otherwise = let x = either (const 0) fromPixelsToNum pl1 + y = either (const 0) fromPixelsToNum pl2 + z = fromPixelsToNum d + in Just . Mat3d $ mkTranslate3dMatrix x y z +toMatrix3d (Scale3d x y z) = Just . Mat3d $ mkScale3dMatrix x y z +toMatrix3d (Perspective d) + | d == Distance 0 Q = Nothing + | otherwise = let c = fromPixelsToNum d + in Just . Mat3d $ mkPerspectiveMatrix c +-- Note: The commented code is fine, but until we implement the +-- 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 (Angle 0 Deg) + | 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) +-} + +isRelativeDistance :: Distance -> Bool +isRelativeDistance (Distance _ u) = isRelative u + +fromPixelsToNum :: Distance -> Number +fromPixelsToNum (Distance n u) = toPixels n u + +fromRadiansToNum :: Angle -> Number +fromRadiansToNum (Angle n u) = toRadians n u + +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 $ Distance x PX + y = M.unsafeGet 2 4 m + ty = Right $ Distance y PX + z = M.unsafeGet 3 4 m + tz = Distance 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 $ Distance 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 \<transform-function\> without converting it to a 4x4 matrix, +-- by doing some simple conversions between the different functions, or +-- minifying the dimension arguments (\<length\> and \<angle\> values) +simplify :: TransformFunction -> Reader Config TransformFunction +simplify (Translate pl mpl) + | isNothing mpl || isZero (fromJust mpl) = do + x <- mapM minifyWith pl + pure $ Translate x Nothing + | otherwise = do x <- mapM minifyWith pl + y <- (mapM . mapM) minifyWith mpl + pure $ Translate x y +simplify (TranslateX pl) = do + x <- mapM minifyWith 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 minifyWith 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 ma) + | defaultSecondArgument = do ang <- minifyWith a + simplify $ Skew ang Nothing + | otherwise = liftA2 Skew (minifyWith a) (mapM minifyWith ma) + where defaultSecondArgument = maybe False (== Angle 0 Deg) ma +simplify (SkewY a) + | a == Angle 0 Deg = pure $ Skew (Angle 0 Deg) Nothing + | otherwise = fmap SkewY (minifyWith a) +simplify (SkewX a) + | a == Angle 0 Deg = pure $ Skew (Angle 0 Deg) Nothing + | otherwise = fmap SkewX (minifyWith a) +simplify (Rotate a) + | a == Angle 0 Deg = pure $ Skew (Angle 0 Deg) Nothing + | otherwise = fmap Rotate (minifyWith a) +simplify (RotateX a) + | a == Angle 0 Deg = pure $ Skew (Angle 0 Deg) Nothing + | otherwise = fmap RotateX (minifyWith a) +simplify (RotateY a) + | a == Angle 0 Deg = pure $ Skew (Angle 0 Deg) Nothing + | otherwise = fmap RotateY (minifyWith a) +-- rotateZ(a) is the same as rotate3d(0,0,1,a), which also equals rotate(a) +simplify (RotateZ a) + | a == Angle 0 Deg = pure $ Skew (Angle 0 Deg) Nothing + | otherwise = fmap Rotate (minifyWith 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 (minifyWith a) + where ep = toNumber epsilon +simplify (ScaleZ n) + | n == 1 = pure $ Skew (Angle 0 Deg) Nothing + | otherwise = pure $ ScaleZ n +simplify (Perspective d) = fmap Perspective (minifyWith d) +simplify (TranslateZ d) + | d == Distance 0 Q = pure $ Skew (Angle 0 Deg) Nothing + | otherwise = fmap TranslateZ (minifyWith d) +simplify s@(Scale3d x y z) + | z == 1 = simplify $ Scale x (Just y) + | x == 1 && y == 1 = simplify $ ScaleZ z + | otherwise = pure s +simplify (Translate3d x y z ) + | isZero y && z == Distance 0 Q = either (f TranslateX) (g TranslateX) x + | isZero x && isZero y = simplify $ TranslateZ z + | isZero x && z == Distance 0 Q = either (f TranslateY) (g TranslateY) y + where f con a | a == 0 = simplify . con . Right $ Distance 0 Q + | otherwise = simplify . con . Left $ a + g con a = simplify . con $ Right a -- A distance, transform an minify +simplify x = pure x + +-- | Combines consecutive \<transform-functions\> 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 conmutative) +-- Example: +-- >>> import Control.Monad.Reader +-- >>> let t10 = Translate (Right (Distance 10 PX)) Nothing +-- >>> let tp = Translate (Left (Percentage 100)) Nothing +-- >>> let s90 = Skew (Angle 90 Deg) 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)"] +-- >>> 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 minifyWith xs + groupByMatrices = groupBy (\(a,_) (b,_) -> isJust a && isJust b) + handleMatrices l@((x,a):_) + | isJust x = minifyWith . Mat3d . foldr (*) (M.identity 4 :: Matrix Number) $ fmap (getMat . fromJust . fst) l + | otherwise = simplify a + handleMatrices [] = error "empty list as argument to handleMatrices"
+ src/Hasmin/Types/Value.hs view
@@ -0,0 +1,454 @@+{-# LANGUAGE OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving #-}+-----------------------------------------------------------------------------+-- |+-- Module : Hasmin.Types.Value+-- Copyright : (c) 2017 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : unknown+--+-----------------------------------------------------------------------------+module Hasmin.Types.Value (+ Value(..), Values(..), TextV(..), Separator(..), Url(..), mkOther,+ mkValues, valuesToList, optimizeFontFamily, lowercaseText+ ) where++import Control.Monad.Reader (ask, Reader, mapReader)+import Data.Monoid ((<>))+import Data.Maybe (isJust, catMaybes, isNothing)+import Data.Text (Text, toCaseFold)+import qualified Data.Text as T+import Data.Text.Lazy.Builder (fromText, singleton, Builder)+import Data.String (IsString)+import Hasmin.Config+import Hasmin.Types.Class+import Hasmin.Types.Color+import Hasmin.Types.Dimension+import Hasmin.Types.Gradient+import Hasmin.Types.Numeric+import Hasmin.Types.String+import Hasmin.Types.Position+import Hasmin.Types.RepeatStyle+import Hasmin.Types.BgSize+import Hasmin.Types.TransformFunction+import Hasmin.Types.TimingFunction+import Hasmin.Types.FilterFunction+import Hasmin.Types.Shadow+import Hasmin.Utils+import Text.PrettyPrint.Mainland (Pretty, ppr, strictText, space, comma, char)++data Value = Inherit+ | Initial+ | Unset+ | NumberV Number+ | PercentageV Percentage+ | DistanceV Distance+ | AngleV Angle+ | DurationV Duration+ | FrequencyV Frequency+ | ResolutionV Resolution+ | ColorV Color+ | GradientV Text Gradient -- the Text is just to handle function prefixes+ | GenericFunc Text Values+ | TransformV TransformFunction+ | TimingFuncV TimingFunction+ | FilterV FilterFunction+ | ShadowV Shadow+ | ShadowText Distance Distance (Maybe Distance) (Maybe Color) -- <shadow-t> type+ | PositionV Position+ | RepeatStyleV RepeatStyle+ | BgSizeV BgSize+ -- <bg-image> || <position> [ / <bg-size> ]? || <repeat-style> || <attachment> || <box>{1,2}+ | BgLayer (Maybe Value) (Maybe Position) (Maybe BgSize) (Maybe RepeatStyle) (Maybe TextV) (Maybe TextV) (Maybe TextV)+ -- <bg-image> || <position> [ / <bg-size> ]? || <repeat-style> || <attachment> || <box> || <box> || <'background-color'>+ | FinalBgLayer (Maybe Value) (Maybe Position) (Maybe BgSize) (Maybe RepeatStyle) (Maybe TextV) (Maybe TextV) (Maybe TextV) (Maybe Color)+ -- [ none | <single-transition-property> ] || <time> || <single-transition-timing-function> || <time>+ | SingleTransition (Maybe TextV) (Maybe Duration) (Maybe TimingFunction) (Maybe Duration)+ -- <time> || <timing-function> || <time> || <iteration-count> || <animation-direction> || <animation-fill-mode> || <animation-play-state> || [ none | <keyframes-name> ]+ | SingleAnimation (Maybe Duration) (Maybe TimingFunction) (Maybe Duration) (Maybe Value) (Maybe TextV) (Maybe TextV) (Maybe TextV) (Maybe Value)+ -- [ [ <'font-style'> || <font-variant-css21> || <'font-weight'> || <'font-stretch'> ]? <'font-size'> [ / <'line-height'> ]? <'font-family'> ] |+ | FontV (Maybe TextV) (Maybe TextV) (Maybe Value) (Maybe TextV) Value (Maybe Value) [Value]+ | StringV StringType+ | UrlV Url+ | Format [StringType]+ | Local (Either Text StringType)+ | Rect Distance Distance Distance Distance -- Should be in <shape>, but that accepts only rect()+ | Other TextV+ deriving (Eq, Show)++-- | Redefines equality to be case-insensitive, since CSS literal values such as+-- "auto", "none", etc. are so.+newtype TextV = TextV { getText :: Text }+ deriving (Show, Ord, IsString)++instance Eq TextV where+ TextV t1 == TextV t2 = toCaseFold t1 == toCaseFold t2+instance ToText TextV where+ toText = getText+instance Pretty Value where+ ppr (NumberV n) = ppr n+ ppr (PercentageV p) = ppr p+ ppr (DistanceV d) = ppr d+ ppr (AngleV a) = ppr a+ ppr (DurationV x) = ppr x+ ppr (FrequencyV x) = ppr x+ ppr (ResolutionV x) = ppr x+ ppr (ColorV x) = ppr x+ ppr (Other x) = ppr (getText x)+ ppr x = (strictText . toText) x++mkOther :: Text -> Value+mkOther = Other . TextV++newtype Url = Url (Either Text StringType)+ deriving (Eq, Show)+instance ToText Url where+ toBuilder (Url x) = "url(" <> toBuilder x <> singleton ')'+instance Pretty Url where+ ppr (Url x) = strictText "url(" <> ppr x <> char ')'+instance Minifiable Url where+ minifyWith u@(Url x) = do+ conf <- ask+ pure $ if shouldRemoveQuotes conf+ then Url $ either Left unquoteUrl x+ else u++instance ToText Value where+ toBuilder Initial = "initial"+ toBuilder Inherit = "inherit"+ toBuilder Unset = "unset"+ toBuilder (NumberV n) = toBuilder n+ toBuilder (PercentageV p) = (fromText . toText) p+ toBuilder (ColorV c) = toBuilder c+ toBuilder (DistanceV d) = toBuilder d+ toBuilder (AngleV a) = toBuilder a+ toBuilder (DurationV d) = toBuilder d+ toBuilder (FrequencyV f) = toBuilder f+ toBuilder (ResolutionV r) = toBuilder r+ toBuilder (FilterV f) = toBuilder f+ toBuilder (ShadowV s) = toBuilder s+ toBuilder (StringV s) = toBuilder s+ toBuilder (Other t) = fromText (getText t)+ toBuilder (UrlV u) = toBuilder u+ toBuilder (GenericFunc n vs) = toBuilder n <> singleton '(' <> toBuilder vs <> singleton ')'+ toBuilder (Local x) = "local(" <> toBuilder x <> singleton ')'+ toBuilder (Format x) = "format(" <> formatString <> singleton ')'+ where formatString = mconcatIntersperse id (singleton ',') (fmap toBuilder x)+ toBuilder (GradientV t g) = fromText t <> singleton '(' <> toBuilder g <> singleton ')'+ toBuilder (TransformV x) = toBuilder x+ toBuilder (TimingFuncV x) = toBuilder x+ toBuilder (Rect a b c d) = "rect(" <> funcValues <> singleton ')'+ where funcValues = mconcatIntersperse toBuilder (singleton ',') [a, b, c, d]+ toBuilder (PositionV p) = toBuilder p+ toBuilder (RepeatStyleV r) = toBuilder r+ toBuilder (BgSizeV b) = toBuilder b+ toBuilder (BgLayer a b c d e f g) =+ let sz = maybe mempty (\x -> singleton '/' <> toBuilder x) c+ list = catMaybes [bld a, bld d, bld e, bld f, bld g]+ in if null list+ then maybe mempty toBuilder b <> sz+ else mconcatIntersperse id (singleton ' ') list <> maybe mempty (\x -> singleton ' ' <> toBuilder x) b <> sz+ toBuilder (FinalBgLayer a b c d e f g col) =+ let sz = maybe mempty (\x -> singleton '/' <> toBuilder x) c+ list = catMaybes [bld a, bld d, bld e, bld f, bld g]+ in if null list+ then let posAndSize = maybe mempty toBuilder b <> sz+ in if mempty == posAndSize+ then maybe mempty toBuilder col+ else posAndSize <> spacePrefixed col+ else mconcatIntersperse id (singleton ' ') list <> spacePrefixed b <> sz <> spacePrefixed col+ where spacePrefixed :: ToText a => Maybe a -> Builder+ spacePrefixed = maybe mempty (\x -> singleton ' ' <> toBuilder x)+ toBuilder (SingleTransition prop t1 tf t2) =+ mconcatIntersperse id (singleton ' ') $ catMaybes [bld tf, bld t1, bld t2, bld prop]+ toBuilder (SingleAnimation t1 tf t2 ic ad af ap kf) =+ let list = catMaybes [bld t1, bld t2, bld tf, bld ic, bld ad, bld af, bld ap, bld kf]+ in mconcatIntersperse id (singleton ' ') list+ toBuilder (FontV fsty fvar fwgt fstr fsz lh ff) =+ let bldLh = maybe mempty (\x -> singleton '/' <> toBuilder x) lh+ list = catMaybes [bld fsty, bld fvar, bld fwgt, bld fstr]+ ffam = singleton ' ' <> mconcatIntersperse toBuilder (singleton ',') ff+ in if null list+ then toBuilder fsz <> bldLh <> ffam+ else mconcatIntersperse id (singleton ' ') list <> singleton ' ' <> toBuilder fsz <> bldLh <> ffam+ toBuilder (ShadowText l1 l2 ml mc) =+ let maybeToBuilder :: ToText a => Maybe a -> Builder+ maybeToBuilder = maybe mempty (\x -> singleton ' ' <> toBuilder x)+ in toBuilder l1 <> singleton ' ' <> toBuilder l2+ <> maybeToBuilder ml <> maybeToBuilder mc++instance Minifiable Value where+ minifyWith (ColorV c) = ColorV <$> minifyWith c+ minifyWith (DistanceV d) = DistanceV <$> minifyWith d+ minifyWith (AngleV a) = AngleV <$> minifyWith a+ minifyWith (DurationV d) = DurationV <$> minifyWith d+ minifyWith (FrequencyV f) = FrequencyV <$> minifyWith f+ minifyWith (ResolutionV r) = ResolutionV <$> minifyWith r+ minifyWith (GradientV t g) = GradientV t <$> minifyWith g+ minifyWith (FilterV f) = FilterV <$> minifyWith f+ minifyWith (ShadowV s) = ShadowV <$> minifyWith s+ minifyWith (ShadowText l1 l2 ml mc) = minifyPseudoShadow ShadowText l1 l2 ml mc+ minifyWith (TransformV tf) = TransformV <$> minifyWith tf+ minifyWith (TimingFuncV tf) = TimingFuncV <$> minifyWith tf+ minifyWith (StringV s) = StringV <$> minifyWith s+ minifyWith (UrlV u) = UrlV <$> minifyWith u+ minifyWith (Format x) = Format <$> mapM minifyWith x+ minifyWith (PositionV p) = PositionV <$> minifyWith p+ minifyWith (RepeatStyleV r) = RepeatStyleV <$> minifyWith r+ minifyWith (BgSizeV b) = BgSizeV <$> minifyWith b+ minifyWith (BgLayer img pos sz rst att b1 b2) = do+ conf <- ask+ i <- handleImage img+ s <- handleBgSize sz+ p <- let cannotRemovePos = isJust s -- can only be removed if there is no later <bg-size>+ in handlePosition cannotRemovePos pos+ r <- handleRepeatStyle rst+ a <- handleAttachment att+ (bgOrigin, bgClip) <- handleBoxes b1 b2+ pure $ if isNothing i && isNothing p && isNothing s && isNothing r+ && isNothing a && isNothing bgOrigin && isNothing bgClip+ -- Shortest would be a '0 0' position, but 'none' compresses+ -- better because it is more frequent.+ then BgLayer (Just $ mkOther "none") p s r a bgOrigin bgClip+ else BgLayer i p s r a bgOrigin bgClip+ minifyWith (FinalBgLayer img pos sz rst att b1 b2 col) = do+ conf <- ask+ i <- handleImage img+ s <- handleBgSize sz+ p <- let cannotRemovePos = isJust s -- can only be removed if there is no later <bg-size>+ in handlePosition cannotRemovePos pos+ r <- handleRepeatStyle rst+ a <- handleAttachment att+ c <- handleColor col+ (bgOrigin, bgClip) <- handleBoxes b1 b2+ pure $ if isNothing i && isNothing p && isNothing s && isNothing r+ && isNothing a && isNothing bgOrigin && isNothing bgClip && isNothing c+ -- Shortest would be a '0 0' position, but 'none' compresses+ -- better because it is more frequent.+ then FinalBgLayer (Just $ mkOther "none") p s r a bgOrigin bgClip c+ else FinalBgLayer i p s r a bgOrigin bgClip c+ minifyWith (SingleTransition prop tdur tf tdel) = do+ let p = if prop == Just (TextV "all")+ then Nothing+ else prop -- TODO lowercase here+ (tDuration, tDelay) <- handleTime tdur tdel+ tfunc <- handleTimingFunction tf+ pure $ if isNothing p && isNothing tDuration && isNothing tDelay && isNothing tfunc+ then SingleTransition p (Just $ Duration 0 S) tfunc tDelay+ else SingleTransition p tDuration tfunc tDelay+ minifyWith (SingleAnimation t1 tf t2 ic ad af ap kf) = do+ (tdur, tdel) <- handleTime t1 t2+ tfunc <- handleTimingFunction tf+ icount <- handleIterationCount ic+ (kfrms, adir, afm, p) <- handleKeywords kf ad af ap+ if isNothing tdur && isNothing tdel && isNothing tfunc && isNothing+ icount && isNothing kfrms && isNothing adir && isNothing afm && isNothing p+ then pure $ SingleAnimation tdur tfunc tdel (Just $ NumberV 1) adir afm p kfrms+ else pure $ SingleAnimation tdur tfunc tdel icount adir afm p kfrms+ where handleIterationCount :: Maybe Value -> Reader Config (Maybe Value)+ handleIterationCount Nothing = pure Nothing+ handleIterationCount (Just x) =+ case x of+ NumberV 1 -> pure Nothing+ _ -> pure (Just x)+ handleKeywords Nothing x y z = pure (Nothing, simplifyDirection x, simplifyFillMode y, simplifyPauseState z)+ handleKeywords v@(Just w) x y z+ | w `elem` fmap mkOther ["normal", "reverse", "alternate", "alternate-reverse"] =+ pure (Just w, x, simplifyFillMode y, simplifyPauseState z)+ | w == mkOther "none" && v == (Other <$> y) =+ pure (Nothing, simplifyDirection x, Nothing, simplifyPauseState z)+ | w `elem` fmap mkOther ["forwards", "backwards", "both"] =+ pure (Just w, simplifyDirection x, y, simplifyPauseState z)+ | w `elem` fmap mkOther ["running", "paused"] =+ pure (Just w, simplifyDirection x, simplifyFillMode y, z)+ | otherwise = pure (Just w, simplifyDirection x, simplifyFillMode y, simplifyPauseState z)+ simplifyDirection = removeIfEqualTo "normal"+ simplifyPauseState = removeIfEqualTo "running"+ simplifyFillMode = removeIfEqualTo "none"+ minifyWith (FontV fsty fvar fwgt fstr fsz lh ff) = do+ let sty = removeIfEqualTo "normal" fsty+ var = removeIfEqualTo "normal" fvar+ str = removeIfEqualTo "normal" fstr+ wgt <- optimizeFontWeight fwgt+ sz <- minifyWith fsz+ l <- optimizeLineHeight lh+ fam <- traverse optimizeFontFamily ff+ pure $ FontV sty var wgt str sz l fam+ where optimizeFontWeight :: Maybe Value -> Reader Config (Maybe Value)+ optimizeFontWeight Nothing = pure Nothing+ optimizeFontWeight (Just x) = do+ conf <- ask+ pure $ replaceForSynonym (fontweightSettings conf) x+ where replaceForSynonym s (Other t)+ | t == TextV "normal" = Nothing+ | t == TextV "bold" && s == FontWeightMinOn = Just $ NumberV 700+ | otherwise = Just $ Other t+ replaceForSynonym _ (NumberV 400) = Nothing+ replaceForSynonym _ y = Just y+ optimizeLineHeight Nothing = pure Nothing+ optimizeLineHeight (Just x) =+ case x of+ Other t -> if t == TextV "normal"+ then pure Nothing+ else Just <$> minifyWith x+ y -> Just <$> minifyWith y++ minifyWith (GenericFunc n vs) = GenericFunc n <$> minifyWith vs+ minifyWith (Local x) = do+ conf <- ask+ v <- lowercaseParameters x+ pure . Local $ if shouldRemoveQuotes conf+ then case v of+ Right s -> unquoteFontFamily s+ _ -> v+ else v+ where lowercaseParameters :: Either Text StringType -> Reader Config (Either Text StringType)+ lowercaseParameters y = do+ conf <- ask+ case letterCase conf of+ Lowercase -> case y of+ Left a -> mapReader Left $ lowercaseText a+ Right b -> mapReader Right $ mapString lowercaseText b >>= minifyWith+ Original -> pure y+ minifyWith x = pure x++handleRepeatStyle :: Maybe RepeatStyle -> Reader Config (Maybe RepeatStyle)+handleRepeatStyle (Just x)+ | x == RSPair RsRepeat Nothing = pure Nothing+ | otherwise = Just <$> minifyWith x+handleRepeatStyle Nothing = pure Nothing++handleImage :: Maybe Value -> Reader Config (Maybe Value)+handleImage (Just x)+ | x == Other "none" = pure Nothing+ | otherwise = Just <$> minifyWith x+handleImage Nothing = pure Nothing++handleBoxes :: Maybe TextV -> Maybe TextV -> Reader Config (Maybe TextV, Maybe TextV)+handleBoxes (Just o) (Just c)+ | o == c = pure (Just o, Nothing) -- TODO need lowercasing here too.+ | o == "padding-box" && c == "border-box" = pure (Nothing, Nothing)+ | otherwise = pure (Just o, Just c)+handleBoxes x y = pure (x, y)++handleAttachment :: Maybe TextV -> Reader Config (Maybe TextV)+handleAttachment = maybe (pure Nothing) f+ where f x = pure $ if x == TextV "scroll"+ then Nothing+ else Just x -- TODO might need to lowercase here.++handleColor :: Maybe Color -> Reader Config (Maybe Color)+handleColor = maybe (pure Nothing) f+ where f x = if x == Named "transparent"+ then pure Nothing+ else Just <$> minifyWith x++handleBgSize :: Maybe BgSize -> Reader Config (Maybe BgSize)+handleBgSize (Just b@BgSize{}) = do+ minb <- minifyWith b+ pure $ if minb == BgSize (Right Auto) Nothing+ then Nothing+ else Just minb+handleBgSize x = pure x++handlePosition :: Bool -> Maybe Position -> Reader Config (Maybe Position)+handlePosition _ Nothing = pure Nothing+handlePosition cannotRemovePos (Just x)+ | cannotRemovePos = Just <$> minifyWith x+ | otherwise = do+ conf <- ask+ mx <- minifyWith x+ pure $ if mx == Position Nothing l0 Nothing l0+ then Nothing+ else Just $ if True {- shouldMinifyPosition conf -}+ then mx+ else x++data Values = Values Value [(Separator, Value)]+ deriving (Show, Eq)+instance Minifiable Values where+ minifyWith (Values v vs) = do+ newV <- minifyWith v+ newVs <- (mapM . mapM) minifyWith vs+ pure $ Values newV newVs++instance ToText Values where+ toBuilder (Values v vs) = toBuilder v <> foldr f mempty vs+ where f (sep, val) z = toBuilder sep <> toBuilder val <> z+instance Pretty Values where+ ppr (Values v vs) = ppr v <> foldr f mempty vs+ where f (sep, val) xs = ppr sep <> ppr val <> xs++data Separator = Space | Slash | Comma+ deriving (Show, Eq)+instance ToText Separator where+ toText Space = " "+ toText Comma = ","+ toText Slash = "/" -- Used, for example, by font to separate font-size and line-height+instance Pretty Separator where+ ppr Space = space+ ppr Comma = comma+ ppr Slash = strictText (toText Slash)++valuesToList :: Values -> [Value]+valuesToList (Values v vs) = v : map snd vs++lowercaseText :: Text -> Reader Config Text+lowercaseText t = do+ conf <- ask+ pure $ case letterCase conf of+ Lowercase -> T.toLower t+ Original -> t++-- Used to rewrap a list of values into the Values data type.+-- Only call it with non-empty lists!+mkValues :: [Value] -> Values+mkValues (x:xs) = Values x (zip (repeat Space) xs)+mkValues [ ] = error "An empty list of values isn't valid"++bld :: ToText a => Maybe a -> Maybe Builder+bld = fmap toBuilder++-- Used for SingleAnimation and SingleTransition minification.+handleTimingFunction :: Maybe TimingFunction -> Reader Config (Maybe TimingFunction)+handleTimingFunction Nothing = pure Nothing+handleTimingFunction (Just tfunc)+ | tfunc == Ease = pure Nothing+ | otherwise = Just <$> minifyWith tfunc++-- Used for SingleAnimation and SingleTransition minification.+handleTime :: Maybe Duration -> Maybe Duration -> Reader Config (Maybe Duration, Maybe Duration)+handleTime (Just t) Nothing = if t == Duration 0 S+ then pure (Nothing, Nothing)+ else do newT <- minifyWith t+ pure (Just newT, Nothing)+handleTime (Just t1) (Just t2)+ | t1 == Duration 0 S = if t2 == t1+ then pure (Nothing, Nothing)+ else do newT2 <- minifyWith t2+ newT1 <- minifyWith t1+ pure (Just newT1, Just newT2)+ | otherwise = do newT1 <- minifyWith t1+ if t2 == Duration 0 S+ then pure (Just t1, Nothing)+ else do newT2 <- minifyWith t2+ pure (Just newT1, Just newT2)+handleTime _ _ = pure (Nothing, Nothing)++removeIfEqualTo :: Text -> Maybe TextV -> Maybe TextV+removeIfEqualTo _ Nothing = Nothing+removeIfEqualTo s (Just x)+ | x == TextV s = Nothing+ | otherwise = Just x++-- Unquotes font family names when possible+optimizeFontFamily :: Value -> Reader Config Value+optimizeFontFamily (Other t) = mkOther <$> lowercaseText (getText t)+optimizeFontFamily (StringV s) = do+ conf <- ask+ ffamily <- mapString lowercaseText s+ pure $ if shouldRemoveQuotes conf+ then either mkOther StringV (unquoteFontFamily ffamily)+ else StringV ffamily+optimizeFontFamily x = pure x+
+ src/Hasmin/Utils.hs view
@@ -0,0 +1,67 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hasmin.Utils+-- Copyright : (c) 2017 Cristian Adrián Ontivero+-- License : BSD3+-- Stability : experimental+-- Portability : unknown+--+-----------------------------------------------------------------------------+module Hasmin.Utils (+ isRight+ , isLeft+ , epsilon+ , eps+ , fromLeft'+ , fromRight'+ , mconcatIntersperse+ , restrict+ , textualLength+ , replaceAt+ ) where++import Data.Monoid ((<>))+import qualified Data.Text as T+import Hasmin.Types.Class++textualLength :: ToText a => a -> Int+textualLength = T.length . toText++restrict :: Ord a => a -> a -> a -> a+restrict minv maxv val | val >= maxv = maxv+ | val < minv = minv+ | otherwise = val++mconcatIntersperse :: Monoid b => (a -> b) -> b -> [a] -> b+mconcatIntersperse _ _ [] = mempty+mconcatIntersperse toMonoid y (x:xs) = toMonoid x <> rest+ where rest | null xs = mempty+ | otherwise = y <> mconcatIntersperse toMonoid y xs++replaceAt :: Int -> a -> [a] -> [a]+replaceAt i v ls = let (a, _:vs) = splitAt i ls+ in a ++ (v:vs)++fromRight' :: Either a b -> b+fromRight' (Right x) = x+fromRight' _ = error "fromRight'"++fromLeft' :: Either a b -> a+fromLeft' (Left x) = x+fromLeft' _ = error "fromLeft'"++isRight :: Either a b -> Bool+isRight Right{} = True+isRight _ = False++isLeft :: Either a b -> Bool+isLeft Left{} = True+isLeft _ = False++-- TODO: Find out how precise is enough.+-- Can we use double and round when printing?+epsilon :: Rational+epsilon = 2.2204460492503131e-30 :: Rational++eps :: Rational+eps = 0.000001 -- See https://bug-30341-attachments.webkit.org/attachment.cgi?id=45276
+ tests/DocTest.hs view
@@ -0,0 +1,6 @@+-- {-# OPTIONS_GHC -F -pgmF doctest-discover #-} + +import Test.DocTest (doctest) + +main :: IO () +main = doctest ["src"]
+ tests/Hasmin/Parser/InternalSpec.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE OverloadedStrings #-}++module Hasmin.Parser.InternalSpec where++import Test.Hspec+-- import Test.QuickCheck+import Hasmin.Parser.Internal+import Hasmin.Parser.Value++import Test.Hspec.Attoparsec (shouldSucceedOn, shouldFailOn)+import Data.Text (Text)+import Hasmin.TestUtils++declarationParserTests :: Spec+declarationParserTests =+ describe "declaration parser tests" $+ mapM_ (matchSpecWithDesc declaration) declarationTestInfo++declarationTestInfo :: [(String, Text, Text)]+declarationTestInfo = + [("parses declaration with unknown property and value, ending in ';'",+ "a:b;", "a:b")+ ,("parses declaration with unknown property and value, ending in '}'",+ "a:b}", "a:b")+ ,("ignores comments before colon",+ "a/**/:b;", "a:b")+ ,("ignores comments after colon",+ "a:/**/b;", "a:b")+ ,("parses !important and prints it back without space",+ "a:b ! important;", "a:b!important")+ ,("ignores comments before semicolon",+ "a:b/**/;", "a:b")+ ,("parse declaration starting with '+' (IE <= 7)",+ "+property:a", "+property:a")+ ]++declarationParsersTests :: Spec+declarationParsersTests = + describe "Declaration parsers tests" $ do+ it "Parses valid font-style values, and fails with invalids" $ do+ fontStyle `shouldSucceedOn` ("normal" :: Text)+ fontStyle `shouldSucceedOn` ("italic" :: Text)+ fontStyle `shouldSucceedOn` ("oblique" :: Text)+ fontStyle `shouldFailOn` ("anything else" :: Text)++{-+styleRuleParser :: Spec+ describe "style rule parser" $ do+ it "parses rule whose final declaration ends in ';'" $ do+ "a { margin : 0;}" ~> (styleRule +-}++styleRuleTestInfo :: [(String, Text, Text)]+styleRuleTestInfo = + [("simple style rule",+ "a { margin : 0 ;}", "a{margin:0}")+ ,("handles unset", + "h1 {\n border: unset\n}", "h1{border:unset}")+ ,("handles initial", + "camelCase {\r color: initial;}", "camelCase{color:initial}")+ ,("handles inherit", + "h1 {\n\tpadding: inherit\f}", "h1{padding:inherit}")+ ]++selectorParserTests :: Spec+selectorParserTests =+ describe "selector parser tests" $+ mapM_ (matchSpecWithDesc selector) selectorTestInfo++selectorTestInfo :: [(String, Text, Text)]+selectorTestInfo = + [("Element", "h6", "h6")+ ,("Element with namespace", "ns|body", "ns|body")+ ,("Element with any namespace", "*|p", "*|p")+ ,("Element with '|' but no namespace", "|html", "html") -- bar shouldn't show+ ,("Class", ".class", ".class")+ ,("Class name with high BMP char", ".無", ".無")+ --,("Class name starting with number or dash", ".\\1\\#-\\.1 .\\--wie.-gehts", ".1#-.1.--wie.-gehts")+ ,("Class name with emoji", ".☺", ".☺")+ ,("Class name with multiple emoji", ".👊✊", ".👊✊")+ ,("Id", "#AnId", "#AnId")+ --,("Id starting with a number", "#\\5\\#-\\.5", "#5#-.5")+ --,("Id starting with a number", "#\\5\\#-\\.5", "#5#-.5")+ ,("Id with latin-1 character", "#ñ", "#ñ")+-- The following four have a pseudo class syntax, but are pseudo elements+ ,(":after pseudo element", ":after", ":after")+ ,(":before pseudo element", ":before", ":before")+ ,(":first-line pseudo element", ":first-line", ":first-line")+ ,(":first-letter pseudo element", ":first-letter", ":first-letter")+-- Since both syntaxes are valid, we print the shorter one (with a single ':')+ ,("::after pseudo element", "::after", ":after")+ ,("::before pseudo element", "::before", ":before")+ ,("::first-line pseudo element", "::first-line", ":first-line")+ ,("::first-letter pseudo element", "::first-letter", ":first-letter")+ ,("Pseudo class", ":link", ":link")+ --,("Pseudo class with escapes", ":na\\me", ":name")+ --,("Pseudo class with content"+ ,("Universal selector", "*", "*")+ ,("Universal selector with namespace", "n|*", "n|*")+ ,("Universal selector with any namespace", "*|*", "*|*")+ ,("Universal selector with '|' but no namespace", "|*", "*") -- bar shouldn't show+ ,(":not() functional pseudo-class of a selector list",+ ":not(:nth-last-child(2n), elem, #id, .class)", ":not(:nth-last-child(2n),elem,#id,.class)")+ ,(":matches() functional pseudo-class of a selector list",+ ".class:matches(:nth-child(2) , element, #AnID, .aClass)", ".class:matches(:nth-child(2),element,#AnID,.aClass)")+ ]+{-+ [("any element","*", "*")+ ,("an element of type E","E","E")+ ,("an E element with a \"foo\" attribute",+ "E[foo]", "E[foo]")+ ,("an E element whose \"foo\" attribute value is exactly equal to \"bar\"",+ "E[foo=\"bar\"]","E[foo=\"bar\"]" )+ ,("an E element whose \"foo\" attribute value is a list of whitespace-separated values, one of which is exactly equal to \"bar\"",+ "E[foo~=\"bar\"]","E[foo~=\"bar\"]")+ ,("an E element whose \"foo\" attribute value begins exactly with the string \"bar\"",+ "E[foo^=\"bar\"]","E[foo^=\"bar\"]")+ ,("an E element whose \"foo\" attribute value ends exactly with the string \"bar\"",+ "E[foo$=\"bar\"]","E[foo$=\"bar\"]")+ ,("an E element whose \"foo\" attribute value contains the substring \"bar\"",+ "E[foo*=\"bar\"]","E[foo*=\"bar\"]")+ ,("an E element whose \"foo\" attribute has a hyphen-separated list of values beginning (from the left) with \"en\"",+ "E[foo|=\"en\"]","E[foo|=\"en\"]")+ ,("an E element, root of the document",+ "E:root","E:root")+ ,("an E element, the n-th child of its parent",+ "E:nth-child(n)","E:nth-child(n)")+ ,("an E element, the n-th child of its parent, counting from the last one",+ "E:nth-last-child(n)","E:nth-last-child(n)")+ ,("an E element, the n-th sibling of its type",+ "E:nth-of-type(n)","E:nth-of-type(n)")+ ,("an E element, the n-th sibling of its type, counting from the last one",+ "E:nth-last-of-type(n)","E:nth-last-of-type(n)")+ ,("an E element, first child of its parent",+ "E:first-child","E:first-child")+ ,("an E element, last child of its parent",+ "E:last-child","E:last-child")+ ,("an E element, first sibling of its type",+ "E:first-of-type","E:first-of-type")+ ,("an E element, last sibling of its type",+ "E:last-of-type","E:last-of-type")+ ,("an E element, only child of its parent",+ "E:only-child","E:only-child")+ ,("an E element, only sibling of its type",+ "E:only-of-type","E:only-of-type")+ ,("an E element that has no children (including text nodes)",+ "E:empty","E:empty")+ ,("An E element being the source anchor of a hyperlink of which the target is not yet visited",+ "E:link", "E:link") + ,("An E element being the source anchor of a hyperlink of which the target is already visited",+ "E:visited", "E:visited") + ,("an E element during active action",+ "E:active","E:active")+ ,("an E element during hover action",+ "E:hover","E:hover")+ ,("an E element during focus action",+ "E:focus","E:focus")+ ,("an E element being the target of the referring URI",+ "E:target","E:target")+ ,("an element of type E in language \"fr\" (the document language specifies how language is determined)",+ "E:lang(fr)","E:lang(fr)")+ ,("a user interface element E which is enabled",+ "E:enabled", "E:enabled")+ ,("a user interface element E which is disabled",+ "E:disabled","E:disabled")+ ,("a user interface element E which is checked (for instance a radio-button or checkbox)",+ "E:checked","E:checked")+ ,("the first formatted line of an E element",+ "E::first-line","E:first-line")+ ,("the first formatted letter of an E element",+ "E::first-letter","E:first-letter")+ ,("generated content before an E element",+ "E::before","E:before")+ ,("generated content after an E element",+ "E::after","E:after")+ ,("an E element whose class is \"warning\" (the document language specifies how class is determined).",+ "E.warning","E.warning")+ ,("an E element with ID equal to \"myid\".",+ "E#myid","E#myid")+ ,("an E element that does not match simple selector s",+ "E:not(s)","E:not(s)")+ ,("An F element descendant of an E element",+ "E F", "E F")+ ,("An F element child of an E element",+ "E > F", "E>F")+ ,("An F element immediately preceded by an E element",+ "E + F", "E+F")+ ,("An F element preceded by an E element",+ "E ~ F", "E~F")+ ]+-}++--stylesheetParserTests :: Spec+--stylesheetParserTests =+-- describe "stylesheet parser tests" $+-- mapM_ (matchSpecWithDesc stylesheet) stylesheetTestInfo++--stylesheetTestInfo :: [(String, Text, Text)]+--stylesheetTestInfo = ++spec :: Spec+spec = do declarationParserTests+ selectorParserTests+ declarationParsersTests++main :: IO ()+main = hspec spec
+ tests/Hasmin/Parser/ValueSpec.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedStrings #-}++module Hasmin.Parser.ValueSpec where++import Test.Hspec+-- import Test.QuickCheck+-- import Hasmin.Parser.Internal++-- import Test.Hspec.Attoparsec (shouldParse, parseSatisfies, (~>))+import Data.Text (Text)+-- import Data.Attoparsec.Text (Parser)+import Hasmin.Parser.Value+import Hasmin.TestUtils++valueParserTest :: Spec+valueParserTest = + describe "value parser tests" $ do+ describe "dimension parsing tests" $+ mapM_ (matchSpecWithDesc value) dimensionTestsInfo+ describe "<gradient> parsing tests" $+ mapM_ (matchSpecWithDesc value) gradientTestsInfo+ describe "<transform-function> parsing tests" $+ mapM_ (matchSpec value) transformFunctionParserTestsInfo+ +dimensionTestsInfo :: [(String, Text, Text)]+dimensionTestsInfo =+ [("parse px", "-1px", "-1px")+ ,("parse em", "+1em", "1em")+ ,("parse ex", ".1e3ex", "100ex")+ ,("parse ch", "2ch", "2ch")+ ,("parse vh", "1.3vh", "1.3vh")+ ,("parse vw", "1.98vw", "1.98vw")+ ,("parse vmin", "3vmin", "3vmin")+ ,("parse vmax", "4vmax", "4vmax")+ ,("parse rem", "0.8rem", ".8rem")+ ,("parse q", "10q", "10q")+ ,("parse cm", "7cm", "7cm")+ ,("parse mm", "6mm", "6mm")+ ,("parse in", "1in", "1in")+ ,("parse pc", "1em", "1em")+ ,("parse pt", "1pt", "1pt")+ ,("parse px", "1px", "1px")+ ,("parse deg", "1deg", "1deg")+ ,("parse grad", "1grad", "1grad")+ ,("parse rad", "1rad", "1rad")+ ,("parse turn", "1turn", "1turn")+ ,("parse s", "1s", "1s")+ ,("parse ms", "1ms", "1ms")+ ,("parse hz", "1hz", "1hz")+ ,("parse khz", "1khz", "1khz")+ ,("parse dpi", "1dpi", "1dpi")+ ,("parse dpcm", "1dpcm", "1dpcm")+ ,("parse dppx", "1dppx", "1dppx")+ ,("parse %", "25e-1%", "2.5%")+ ]++numberParserTests :: Spec+numberParserTests =+ describe "number parser tests. Succeeds in parsing:" $+ mapM_ (matchSpecWithDesc number) numberTestsInfo++numberTestsInfo :: [(String, Text, Text)]+numberTestsInfo = + [("zero", "0", "0")+ ,("floating point zero",+ "0.0", "0")+ ,("zero with a leading +",+ "+0.0", "0")+ ,("zero with a leading -", -- it is a valid value!+ "-0.0", "0")+ ,("a simple case of scientific notation",+ "10e3", "10000")+ ,("a complex case of scientific notation",+ "-3.4e-2", "-.034")+ ,("number starting with a dot",+ ".60", ".6")+ ,("a positive integer without leading +",+ "12", "12")+ ,("a positive integer with a leading +",+ "+123", "123")+ ]++gradientTestsInfo :: [(String, Text, Text)]+gradientTestsInfo =+ [("linear-gradient() with default <side-or-corner> value",+ "linear-gradient(to bottom, red, green)","linear-gradient(to bottom,red,green)")+ ,("linear-gradient() with default <angle> value", + "linear-gradient(180deg, #000, white)", "linear-gradient(180deg,#000,white)")+ ,("linear-gradient() ommiting default value", + "linear-gradient(rgb(0,0,0), hsl(300,100%,25%))", "linear-gradient(rgb(0,0,0),hsl(300,100%,25%))")+ ,("linear-gradient() with comments in-between", + "linear-gradient(/**/pink/**/,/**/peru/**/)", "linear-gradient(pink,peru)")+ ]++transformFunctionParserTestsInfo :: [(Text, Text)]+transformFunctionParserTestsInfo =+ [("skew( 0deg )", "skew(0)")+ ,("skew(23GRAD /**/,/**/0deg)", "skew(23grad,0)")+ ,("sKeWY(/**/1rad)", "skewy(1rad)")+ ,("SkeWx(0.2turn/**/)", "skewx(.2turn)")+ ,("SkeWx(0.2turn)", "skewx(.2turn)")+ ,("SkeWx(0.2turn)", "skewx(.2turn)")+ ,("translate(0% )", "translate(0%)")+ ,("translate( 0 )", "translate(0)")+ ,("translate( 1in )", "translate(1in)")+ ,("translate(0%, 0%)", "translate(0%,0%)")+ ,("translate(0, 0%)", "translate(0,0%)")+ ,("translate(0%, 0)", "translate(0%,0)")+ ,("translate(0, 0)", "translate(0,0)")+ ,("translate(10px, 3em)", "translate(10px,3em)")+ ,("translateX(0%)", "translatex(0%)")+ ,("translateX(/* 3q */ 4q)", "translatex(4q)")+ ]++spec :: Spec+spec = do numberParserTests+ valueParserTest++main :: IO ()+main = hspec spec
+ tests/Hasmin/SelectorSpec.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}++module Hasmin.SelectorSpec where++import Test.Hspec+import Hasmin.Parser.Internal+import Hasmin.TestUtils++import Control.Monad.Reader (runReader)+import Data.Text (Text)+import Hasmin.Types.Class+import Hasmin.Config++anplusbMinificationTests :: Spec+anplusbMinificationTests =+ describe "<an+b> minification tests" $+ mapM_ (matchSpec (f <$> selector)) anplusbMinificationTestsInfo+ where f x = runReader (minifyWith x) defaultConfig++anplusbMinificationTestsInfo :: [(Text, Text)]+anplusbMinificationTestsInfo = + [(":nth-child(-1n)", ":nth-child(-n)")+ ,(":nth-child(-n)", ":nth-child(-n)")+ ,(":nth-child(+n)", ":nth-child(n)")+ ,(":nth-child(+1n)", ":nth-child(n)")+ ,(":nth-child( even )", ":nth-child(2n)")+ ,(":nth-child( 2n - 2 )", ":nth-child(2n)")+ ,(":nth-child( 2n - 4 )", ":nth-child(2n)")+ ,(":nth-child( 2n + 1 )", ":nth-child(odd)")+ ,(":nth-child( 2n - 1 )", ":nth-child(odd)")+ ,(":nth-child( 2n - 3 )", ":nth-child(odd)")+ ,(":nth-child(0n)", ":nth-child(0)")+ ,(":nth-child(0n+0)", ":nth-child(0)")+ ,(":nth-child(0n-0)", ":nth-child(0)")+ ,(":nth-child(0n-1)", ":nth-child(-1)")+ ,(":nth-child(1n+0)", ":nth-child(n)")+ ,(":nth-child(1n-0)", ":nth-child(n)")+ ]++attributeQuoteRemovalTest :: Spec+attributeQuoteRemovalTest =+ describe "attribute quote removal tests" $+ mapM_ (matchSpec (f <$> selector)) attributeQuoteRemovalTestInfo+ where f x = runReader (minifyWith x) defaultConfig++attributeQuoteRemovalTestInfo :: [(Text, Text)]+attributeQuoteRemovalTestInfo =+ [("[type=\"remove-double-quotes\"]", "[type=remove-double-quotes]")+ ,("[type='remove-single-quotes']", "[type=remove-single-quotes]")+ ,("[a^='\"']", "[a^='\"']")+ ]++spec :: Spec+spec = do anplusbMinificationTests+ attributeQuoteRemovalTest++main :: IO ()+main = hspec spec
+ tests/Hasmin/TestUtils.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}++module Hasmin.TestUtils where++import Test.Hspec++import Data.Text (Text, unpack, singleton)+import Test.Hspec.Attoparsec (parseSatisfies, (~>))+import Data.Attoparsec.Text (Parser)+import Hasmin.Types.Class+import Hasmin.Types.Declaration+import Hasmin.Utils++-- Given a parser and a 3-tuple, prints a test description,+-- applies the parser, and compares its result with the expected result+matchSpecWithDesc :: ToText a => Parser a -> (String, Text, Text) -> Spec+matchSpecWithDesc parser (description, textToParse, expectedResult) = + it description $+ (toText <$> (textToParse ~> parser)) `parseSatisfies` (== expectedResult)++matchSpec :: ToText a => Parser a -> (Text, Text) -> Spec+matchSpec parser (textToParse, expectedResult) =+ it (unpack textToParse) $ (toText <$> (textToParse ~> parser)) `parseSatisfies` (== expectedResult)++data Declarations = Declarations [Declaration]+instance ToText Declarations where+ toText (Declarations ds) = mconcatIntersperse toText (singleton ';') ds+
+ tests/Hasmin/Types/ColorSpec.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE OverloadedStrings #-}++module Hasmin.Types.ColorSpec where++import Test.Hspec+import Test.QuickCheck+import Hasmin.Parser.Value+import Hasmin.TestUtils++import Test.Hspec.Attoparsec (parseSatisfies, (~>))+import Data.Text (Text)+import Data.Foldable+import Data.Maybe (fromJust)+import Control.Monad+import Hasmin.Types.Color+import Hasmin.Types.Class+import Hasmin.Types.Numeric++instance Arbitrary Color where+ arbitrary = oneof [ fmap (fromJust . mkNamed) colorKeyword+ , liftM3 mkHex3 hexChar hexChar hexChar+ , liftM3 mkHex6 hexString hexString hexString+ , liftM4 mkHex4 hexChar hexChar hexChar hexChar+ , liftM4 mkHex8 hexString hexString hexString hexString+ , liftM3 mkRGBInt intRange intRange intRange+ , liftM3 mkRGBPer ratRange ratRange ratRange + , liftM4 mkRGBAInt intRange intRange intRange alphaRange+ , liftM4 mkRGBAPer ratRange ratRange ratRange alphaRange + , liftM3 mkHSL hueRange ratRange ratRange+ , liftM4 mkHSLA hueRange ratRange ratRange alphaRange + ]+ where intRange = choose (0, 255)+ ratRange = toPercentage <$> (choose (0, 100) :: Gen Float)+ alphaRange = toAlphavalue <$> (choose (0, 1) :: Gen Float)+ hueRange = choose (0, 360)++-- | Generates color keywords uniformly distributed +colorKeyword :: Gen Text+colorKeyword = do+ index <- choose (0, len)+ pure $ keywords !! index+ where len = length keywordColors - 1+ keywords = fmap fst keywordColors++-- | Generates a hexadecimal character uniformly distributed +hexChar :: Gen Char+hexChar = (hexadecimals !!) <$> choose (0, length hexadecimals - 1)++hexString :: Gen String+hexString = (\x y -> [x,y]) <$> hexChar <*> hexChar++-- | Check that a color is equivalent to their minified representation form+prop_minificationEq :: Color -> Bool+prop_minificationEq c = c == minifyColor c++colorTests :: Spec+colorTests =+ describe "Color datatype tests" $+ it "color minify semantically equivalent" $+ quickCheck prop_minificationEq++colorParserTests :: Spec+colorParserTests =+ describe "Color Parser tests" $+ it "succeeds in parsing and minifying different red color representations" $+ traverse_ ((`parseSatisfies` (==(fromJust $ mkNamed "red"))) . (~> (minifyColor <$> color))) redColor++colorParserSpacesAndCommentsTests :: Spec+colorParserSpacesAndCommentsTests =+ describe "Color Parser test" $+ it "succeeds in parsing different yellow color representations with spaces and comments in-between" $+ traverse_ ((`parseSatisfies` (==(fromJust $ mkNamed "yellow"))) . (~> color)) commentsAndSpacesInColors++-- | Multiple equivalent red color representations+redColor :: [Text]+redColor = + [ "red" + , "#f00", "#F00", "#ff0000", "#fF0000", "#Ff0000", "#FF0000"+ , "rgb(255,0,0)" , "rgb(100%,0%,0%)"+ , "rgba(255,0,0,1)", "rgba(255,0,0,1.0)"+ , "rgba(100%,0%,0%,1)", "rgba(100%,0%,0%,1.0)"+ , "hsl(0,100%,50%)", "hsl(360,100%,50%)"+ , "hsla(0,100%,50%,1)", "hsla(0,100%,50%,1.0)"+ , "hsla(360,100%,50%,1)", "hsla(360,100%,50%,1.0)"+ ]++-- | All 4096 (16^3) possible 3 char shorthands+allHex3 :: [String]+allHex3 = replicateM 3 hexadecimals++hexadecimals :: String+hexadecimals = "0123456789abcdef" ++-- Every color is yellow+commentsAndSpacesInColors :: [Text]+commentsAndSpacesInColors = + [ "rgb(/**/255,255,0)"+ , "rgb(255,/**/255,0)"+ , "rgb(255,255,/**/0)"+ , "rgb(255/**/,255,0)"+ , "rgb(255,255/**/,0)"+ , "rgb(255,255,0/**/)"+ , "rgb(/* */255/* */,/* */255/* */,/* */0/* */)"+ , "rgb( /* */ 255 /* */ , /* */ 255 /* */ , /* */ 0 /* */ )"+ , "rgba(/**/255,255,0,1)"+ , "rgba(255,/**/255,0,1)"+ , "rgba(255,255,/**/0,1)"+ , "rgba(255,255,0,/**/1)"+ , "rgba(255/**/,255,0,1)"+ , "rgba(255,255/**/,0,1)"+ , "rgba(255,255,0/**/,1)"+ , "rgba(255,255,0,1/**/)"+ , "rgba(/* */255/* */,/* */255/* */,/* */0/* */,/* */1/* */)"+ , "rgba( /* */ 255 /* */ , /* */ 255 /* */ , /* */ 0 /* */ , /* */ 1 /* */)"+ , "hsl(/**/60,100%,50%)"+ , "hsl(60,/**/100%,50%)"+ , "hsl(60,100%,/**/50%)"+ , "hsl(60/**/,100%,50%)"+ , "hsl(60,100%/**/,50%)"+ , "hsl(60,100%,50%/**/)"+ , "hsl(/* */60/* */,/* */100%/* */,/* */50%/* */)"+ , "hsl( /* */ 60 /* */ , /* */ 100% /* */ , /* */ 50% /* */ )"+ , "hsla(/**/60,100%,50%,1)"+ , "hsla(60,/**/100%,50%,1)"+ , "hsla(60,100%,/**/50%,1)"+ , "hsla(60,100%,50%,/**/1)"+ , "hsla(60/**/,100%,50%,1)"+ , "hsla(60,100%/**/,50%,1)"+ , "hsla(60,100%,50%/**/,1)"+ , "hsla(60,100%,50%,1/**/)"+ , "hsla(/* */60/* */,/* */100%/* */,/* */50%/* */,/* */1/* */)"+ , "hsla( /* */ 60 /* */ , /* */ 100% /* */ , /* */ 50% /* */ , /* */ 1 /* */)"+ ]++colorMinificationTests :: Spec+colorMinificationTests = + describe "color minification" $+ mapM_ (matchSpec f) colorMinificationTestsInfo+ where f = minify <$> color++colorMinificationTestsInfo :: [(Text, Text)]+colorMinificationTestsInfo =+ [ ("rgba(0,0,0,.4)", "#0006")+ , ("hsla(0,0%,0%,.4)", "#0006")+ , ("#00000066", "#0006")+ ]++spec :: Spec+spec = do colorTests + colorParserTests+ colorMinificationTests+ colorParserSpacesAndCommentsTests++main :: IO ()+main = hspec spec
+ tests/Hasmin/Types/DeclarationSpec.hs view
@@ -0,0 +1,446 @@+{-# LANGUAGE OverloadedStrings #-} + +module Hasmin.Types.DeclarationSpec where + +import Test.Hspec +import Hasmin.Parser.Internal +import Hasmin.TestUtils + +import Data.Text (Text) +import Data.Monoid ((<>)) +import Data.Foldable (traverse_) +import Hasmin.Types.Class +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 = minify <$> 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 = do + describe "minifyDec function" $ + mapM_ (matchSpec f) minifyDecTestsInfo + where f = minify <$> declaration + +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 a i = describe a $ mapM_ (matchSpecWithDesc (minify <$> declaration)) i + +backgroundTestsInfo :: [(String, Text, Text)] +backgroundTestsInfo = + [("Does not remove <position> from background when the <bg-size> cannot be removed", + "background: 0 0 / 3px", "background:0 0/3px") + ,("Removes <position> when it is the default and no <bg-size> is present", + "background: #fff 0 0", "background:#fff") + ,("Removes both <position> and <bg-size> 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 = do + describe "Shorthands that accept values in any order (mostly: medium none currentColor)" $ + traverse_ (mapM_ (matchSpec (minify <$> 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:1in") + ,("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 1in") + ,("background-size: 96px auto", "background-size:1in") + ] + +spec :: Spec +spec = do cleaningTests + minifyDecTests + shorthandInitialValuesTests + declarationTests + propertySpecificTests + +main :: IO () +main = hspec spec
+ tests/Hasmin/Types/DimensionSpec.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings #-}++module Hasmin.Types.DimensionSpec where++import Test.Hspec+--import Test.QuickCheck+--import Hasmin.Parser.Internal hiding (property)++--import Test.Hspec.Attoparsec (shouldParse, parseSatisfies, (~>))+import Hasmin.Types.Dimension++spec :: Spec+spec = + describe "<length> units equivalences" $ do+ describe "inches conversions" $ do+ it "1in == 2.54cm" $+ (Distance 1 IN) `shouldBe` Distance 2.54 CM+ it "1in == 25.4cm" $+ (Distance 1 IN) `shouldBe` Distance 25.4 MM+ it "1in == 101.6q" $+ (Distance 1 IN) `shouldBe` Distance 101.6 Q+ it "1in == 72pt" $+ (Distance 1 IN) `shouldBe` Distance 72 PT+ it "1in == 6pc" $+ (Distance 1 IN) `shouldBe` Distance 6 PC+ it "1in == 96px" $+ (Distance 1 IN) `shouldBe` Distance 96 PX+ describe "pixel conversions" $ do+ it "48px == .5in" $+ (Distance 48 PX) `shouldBe` Distance 0.5 IN+ it "72px == 1.905cm" $+ (Distance 72 PX) `shouldBe` Distance 1.905 CM+ it "72px == 19.05mm" $+ (Distance 72 PX) `shouldBe` Distance 19.05 MM + it "60px == 63.5q" $+ (Distance 60 PX) `shouldBe` Distance 63.5 Q+ it "12px == 9pt" $+ (Distance 12 PX) `shouldBe` Distance 9 PT+ it "16px == 1pc" $+ (Distance 16 PX) `shouldBe` Distance 1 PC+ describe "centimeter conversions" $ do+ it "5.08cm == 2in" $+ (Distance 5.08 CM) `shouldBe` Distance 2 IN+ it "1cm == 10mm" $+ (Distance 1 CM) `shouldBe` Distance 10 MM + it "2cm == 80q" $+ (Distance 2 CM) `shouldBe` Distance 80 Q+ it "1.27cm == 36pt" $+ (Distance 1.27 CM) `shouldBe` Distance 36 PT+ it "1.27cm == 3pc" $+ (Distance 1.27 CM) `shouldBe` Distance 3 PC+ it "1.27cm == 48px" $+ (Distance 1.27 CM) `shouldBe` Distance 48 PX++main :: IO ()+main = hspec spec
+ tests/Hasmin/Types/FilterFunctionSpec.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings #-}++module Hasmin.Types.FilterFunctionSpec where++import Test.Hspec++import Data.Text (Text)+import Hasmin.Parser.Value+import Hasmin.Types.Class+import Hasmin.TestUtils++filterTests :: Spec+filterTests = + describe "<filter-function> minification tests" $+ mapM_ (matchSpecWithDesc f) filterTestsInfo+ where f = minify <$> value+ +filterTestsInfo :: [(String, Text, Text)]+filterTestsInfo =+ [("Minifies the <color> value in drop-shadow()"+ ,"drop-shadow(1px 1px 1px #ff0000)"+ ,"drop-shadow(1px 1px 1px red)")+ ,("Minifies the <length> values in drop-shadow()"+ ,"drop-shadow(12px 12px 12px red)"+ ,"drop-shadow(9pt 9pt 9pt red)")+ ,("Removes 3rd value in drop-shadow() when it is 0"+ ,"drop-shadow(1px 1px 0 red)"+ ,"drop-shadow(1px 1px red)")+ ,("Minifies <angle> in hue-rotate()"+ ,"hue-rotate(100grad)"+ ,"hue-rotate(90deg)")+ ,("Minifies <length> in blur()"+ ,"blur(12px)"+ ,"blur(9pt)")+ ,("Minifies 100% in contrast()"+ ,"contrast(100%)"+ ,"contrast(1)")+ ,("Minifies 0% in contrast()"+ ,"contrast(0%)"+ ,"contrast(0)")+ ,("Minifies <percentage> multiple of 10 in brightness()"+ ,"brightness(50%)"+ ,"brightness(.5)")+ ,("Normalizes <percentage> to <number> when > 10 in contrast()"+ ,"contrast(11%)"+ ,"contrast(.11)")+ ,("Does not minify <percentage> when > 0 and < 10 in contrast()"+ ,"contrast(8%)"+ ,"contrast(8%)")+ ]++spec :: Spec+spec = filterTests++main :: IO ()+main = hspec spec
+ tests/Hasmin/Types/GradientSpec.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE OverloadedStrings #-}++module Hasmin.Types.GradientSpec where++import Test.Hspec+-- import Test.QuickCheck+-- import Hasmin.Parser.Internal++-- import Test.Hspec.Attoparsec (shouldParse, parseSatisfies, (~>))+import Control.Monad.Reader (runReader)+import Data.Text (Text)+-- import Data.Attoparsec.Text (Parser)+import Hasmin.Parser.Value+import Hasmin.Types.Class+import Hasmin.Config+import Hasmin.TestUtils++gradientTests :: Spec+gradientTests = + describe "<gradient> minification tests" $+ mapM_ (matchSpecWithDesc f) gradientTestsInfo+ where f = (\x -> runReader (minifyWith x) defaultConfig) <$> value+ +gradientTestsInfo :: [(String, Text, Text)]+gradientTestsInfo =+ [("Converts \"to top\" to 0 (unitless 0 <angle>)"+ ,"linear-gradient(to top, red, blue)"+ ,"linear-gradient(0,red,blue)")+ ,("Converts \"to right\" to 90deg"+ ,"linear-gradient(to right, green, violet)"+ ,"linear-gradient(90deg,green,violet)")+ ,("Converts \"to left\" to 270deg"+ ,"linear-gradient(to left, pink, peru)"+ ,"linear-gradient(270deg,pink,peru)")+ ,("Removes \"to bottom\", since that's the default <side-or-corner> value"+ ,"linear-gradient(to bottom, green, violet)"+ ,"linear-gradient(green,violet)")+ ,("Removes \"180deg\", since that equals \"to bottom\", which is the default value"+ ,"linear-gradient(180deg, green, violet)"+ ,"linear-gradient(green,violet)")+ ,("Should not convert \"to top right\""+ ,"linear-gradient(to top right, pink, peru)"+ ,"linear-gradient(to top right,pink,peru)")+ ,("Should not convert \"to bottom left\""+ ,"linear-gradient(to bottom left, pink, peru)"+ ,"linear-gradient(to bottom left,pink,peru)")+ ,("Reduces a <percentage> value to 0 when it is the same as the previous"+ ,"linear-gradient(72deg, pink 25%, peru 25%)"+ ,"linear-gradient(72deg,pink 25%,peru 0)")+ ,("Reduces a <percentage> value to 0 when it is less than the greatest previous one"+ ,"linear-gradient(72deg, pink 50%, peru 40%)"+ ,"linear-gradient(72deg,pink 50%,peru 0)")+ ,("Reduces a <length> value to 0 when it is the same as the previous"+ ,"linear-gradient(72deg, pink 3em, peru 3em)"+ ,"linear-gradient(72deg,pink 3em,peru 0)")+ ,("Reduces a <length> value to 0 when it is less than the greatest previous one"+ ,"linear-gradient(72deg, pink 1in, peru 90px)" -- 1in == 96px+ ,"linear-gradient(72deg,pink 1in,peru 0)")+ ,("Removes default start and end <percentage> values"+ ,"linear-gradient(pink 0%, peru 100%)"+ ,"linear-gradient(pink,peru)")+ ,("Should not remove trailing zero when it is the last stop"+ ,"linear-gradient(pink,peru 0)"+ ,"linear-gradient(pink,peru 0)")+ ,("Reduce complex combination of linear and non linear color hints"+ ,"linear-gradient(pink 1%, peru 10%, green 20%, red 30%, violet 50%, purple 55%, cyan 60%, #ccc 80%, #000 100%)"+ ,"linear-gradient(pink 1%,peru 10%,green,red 30%,violet 50%,purple,cyan 60%,#ccc,#000)")+ ,("Removes circle in radial-gradient() when using a single <length>"+ ,"radial-gradient(circle 1px, pink, peru)"+ ,"radial-gradient(1px,pink,peru)")+ ,("Removes ellipse in radial-gradient() when using two <length-percentage>"+ ,"radial-gradient(ellipse 1px 1px, pink, peru)"+ ,"radial-gradient(1px 1px,pink,peru)")+ ,("Removes ellipse in radial-gradient() when using an <extent-keyword> in second place"+ ,"radial-gradient(ellipse closest-side, pink, peru)"+ ,"radial-gradient(closest-side,pink,peru)")+ ,("Removes ellipse in radial-gradient() when using an <extent-keyword> first"+ ,"radial-gradient(farthest-side ellipse, pink, peru)"+ ,"radial-gradient(farthest-side,pink,peru)")+ ,("Removes 'ellipse farthest-corner' in radial-gradient()"+ ,"radial-gradient(ellipse farthest-corner, pink, peru)"+ ,"radial-gradient(pink,peru)")+ ]++spec :: Spec+spec = gradientTests++main :: IO ()+main = hspec spec
+ tests/Hasmin/Types/PositionSpec.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE OverloadedStrings #-}++module Hasmin.Types.PositionSpec where++import Test.Hspec+import Hasmin.Parser.Value+import Hasmin.TestUtils++import Data.Text (Text)+import Hasmin.Types.Class++positionMinificationTests :: Spec+positionMinificationTests =+ describe "position minification" $+ mapM_ (matchSpec f) positionMinificationTestsInfo+ where f = minify <$> position++positionMinificationTestsInfo :: [(Text, Text)]+positionMinificationTestsInfo =+ [("50%", "50%")+ ,("50% 50%", "50%")+ ,("center", "50%")+ ,("center top 50%", "50%")+ ,("top 50% center", "50%")+ ,("center left 50%", "50%")+ ,("top 50% left 50%", "50%")+ ,("left 50% top 50%", "50%")+ ,("left 50% center", "50%")+ ,("center center", "50%")++ ,("0% 50%", "0")+ ,("left", "0")+ ,("left center", "0")+ ,("left top 50%", "0")+ ,("left 0% center", "0")+ ,("left 0% top 50%", "0")+ ,("top 50% left 0%", "0")+ ,("center left 0%", "0")+ ,("top 50% left", "0")+ ,("center left", "0")++ ,("0% 0%", "0 0")+ ,("left 0%", "0 0")+ ,("0% top", "0 0")+ ,("left top", "0 0")+ ,("left top 0%", "0 0")+ ,("left 0% top", "0 0")+ ,("left 0% top 0%", "0 0")+ ,("top 0% left 0%", "0 0")+ ,("top left 0%", "0 0")+ ,("top 0% left", "0 0")+ ,("top left", "0 0")++ ,("50% 0%", "top")+ ,("top", "top")+ ,("top center", "top")+ ,("top left 50%", "top")+ ,("top 0% left 50%", "top")+ ,("left 50% top 0%", "top")+ ,("left 50% top", "top")+ ,("center top", "top")++ ,("100% 0%", "100% 0")+ ,("right top", "100% 0")+ ,("right 0% top", "100% 0")+ ,("right top 0%", "100% 0")+ ,("right 0% top 0%", "100% 0")+ ,("top 0% right 0%", "100% 0")+ ,("top 0% right", "100% 0")+ ,("top right 0%", "100% 0")+ ,("top right", "100% 0")++ ,("100%", "100%")+ ,("100% 50%", "100%")+ ,("right", "100%")+ ,("right center", "100%")+ ,("right top 50%", "100%")+ ,("right 0% center", "100%")+ ,("right 0% top 50%", "100%")+ ,("top 50% right 0%", "100%")+ ,("center right 0%", "100%")+ ,("top 50% right", "100%")+ ,("center right", "100%")++ ,("0% 100%", "0 100%")+ ,("left bottom", "0 100%")+ ,("left 0 bottom", "0 100%")+ ,("left bottom 0", "0 100%")+ ,("left 0 bottom 0", "0 100%")+ ,("bottom 0 left 0", "0 100%")+ ,("bottom left 0", "0 100%")+ ,("bottom 0 left", "0 100%")+ ,("bottom left", "0 100%")++ ,("50% 100%", "bottom")+ ,("bottom", "bottom")+ ,("center bottom", "bottom")+ ,("center bottom 0%", "bottom")+ ,("left 50% bottom", "bottom")+ ,("left 50% bottom 0%", "bottom")+ ,("bottom 0% left 50%", "bottom")+ ,("bottom left 50%", "bottom")+ ,("bottom 0% center", "bottom")+ ,("bottom center", "bottom")++ ,("100% 100%", "100% 100%")+ ,("100% bottom", "100% 100%")+ ,("right bottom", "100% 100%")+ ,("right 0% bottom", "100% 100%")+ ,("right bottom 0%", "100% 100%")+ ,("right 0% bottom 0%", "100% 100%")+ ,("bottom 0% right 0%", "100% 100%")+ ,("bottom 0% right", "100% 100%")+ ,("bottom right 0%", "100% 100%")+ ,("bottom right", "100% 100%")++ -- Other random tests+ ,("10px 15px", "10px 15px")+ ,("30% 0", "30% 0")+ ,("27% 50%", "27%")+ ,("left 0 top 30px", "0 30px")+ ,("left 10px top 15px", "10px 15px")+ ,("left 15px", "0 15px")+ ,("10px top", "10px 0")+ ,("left top 15px", "0 15px")+ ,("left 10px top", "10px 0")++ ,("right 0 top 30px", "100% 30px")+ ,("20px bottom", "20px 100%")+ ,("right 20px", "100% 20px")+ ,("top 30px right 0", "100% 30px")+ ]++spec :: Spec+spec = do positionMinificationTests ++main :: IO ()+main = hspec spec
+ tests/Hasmin/Types/RepeatStyleSpec.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}++module Hasmin.Types.RepeatStyleSpec where++import Test.Hspec++import Data.Text (Text)+import Hasmin.Parser.Value+import Hasmin.Types.Class+import Hasmin.TestUtils++repeatStyleTests :: Spec+repeatStyleTests = + describe "<repeat-style> minification tests" $+ mapM_ (matchSpec f) repeatStyleTestsInfo+ where f = minify <$> repeatStyle+ +repeatStyleTestsInfo :: [(Text, Text)]+repeatStyleTestsInfo =+ [("repeat no-repeat", "repeat-x")+ ,("no-repeat repeat", "repeat-y")+ ,("no-repeat no-repeat", "no-repeat")+ ,("repeat repeat", "repeat")+ ,("space space", "space")+ ,("round round", "round")+ ]++spec :: Spec+spec = repeatStyleTests++main :: IO ()+main = hspec spec
+ tests/Hasmin/Types/ShadowSpec.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}++module Hasmin.Types.ShadowSpec where++import Test.Hspec++import Data.Text (Text)+import Hasmin.Parser.Value+import Hasmin.Types.Class+import Hasmin.TestUtils++shadowTests :: Spec+shadowTests = + describe "<shadow> minification tests" $+ mapM_ (matchSpecWithDesc f) shadowTestsInfo+ where f = minify <$> shadowList+ +shadowTestsInfo :: [(String, Text, Text)]+shadowTestsInfo =+ [("Removes 4th <length> value when it is null"+ ,"1px 1px 1px 0px red"+ ,"1px 1px 1px red")+ ,("Removes 3rd <length> value when there is no 4th, and it is zero"+ ,"1px 1px 0px red"+ ,"1px 1px red")+ ,("Minifies permuted value"+ ,"red 1px 1px 0px 0px inset"+ ,"inset 1px 1px red")+ ,("Minifies the <color> value"+ ,"inset 1px 1px #ff0000"+ ,"inset 1px 1px red")+ ,("Minifies the <length> values"+ ,"inset 12px 12px 12px 12px blue"+ ,"inset 9pt 9pt 9pt 9pt blue")+ ,("Minifies list of <shadow> values"+ ,"inset 12px 12px 0 0 blue, 12px 12px 3px 0 red"+ ,"inset 9pt 9pt blue,9pt 9pt 3px red")+ ]++spec :: Spec+spec = shadowTests++main :: IO ()+main = hspec spec+
+ tests/Hasmin/Types/StringSpec.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}++module Hasmin.Types.StringSpec where++import Test.Hspec+import Hasmin.Parser.Value+import Hasmin.TestUtils++import Data.Text (Text)+import Hasmin.Types.Class+++quotesNormalizationTests :: Spec+quotesNormalizationTests = do+ describe "Quotes Normalization" $ do+ describe "normalizes <string>s quotes in general" $+ mapM_ (matchSpecWithDesc f) quotesNormalizationTestsInfo+ describe "normalizes <strings>s quotes inside format()" $+ mapM_ (matchSpec g) unquotingFormatTestsInfo+ describe "unquotes url() <string>s" $+ mapM_ (matchSpec g) unquotingUrlsTestsInfo+ where f = minify <$> stringvalue+ g = minify <$> textualvalue++quotesNormalizationTestsInfo :: [(String, Text, Text)]+quotesNormalizationTestsInfo =+ [("Convert single quotes into double quotes",+ "'x'", "\"x\"")+ ,("Do not convert single quotes when they enclose a double quote",+ "'\"'", "'\"'")+ ,("Convert escaped double quotes into double quotes, but don't convert the enclosing single quotes into double",+ "'\\22'", "'\"'")+ ,("Don't convert escaped double quotes when enclosed in double quotes",+ "\"\\22\"", "\"\\22\"")+ ]++unquotingUrlsTestsInfo :: [(Text, Text)] +unquotingUrlsTestsInfo = + [("url(\"validUrl\")", "url(validUrl)")+ ,("url('validUrl')", "url(validUrl)")+ ,("url('a b')", "url('a b')")+ ,("url(\"a'b\")", "url(\"a'b\")")+ ,("url('a\"b')", "url('a\"b')")+ ]++-- TODO rename this, maybe combine it with some of the other tests+unquotingFormatTestsInfo :: [(Text, Text)]+unquotingFormatTestsInfo =+ [("format('woff')", "format(\"woff\")")]++spec :: Spec+spec = quotesNormalizationTests++main :: IO ()+main = hspec spec
+ tests/Hasmin/Types/StylesheetSpec.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}++module Hasmin.Types.StylesheetSpec where++import Test.Hspec+import Hasmin.Parser.Internal+import Hasmin.TestUtils++import Data.Text (Text)++atRuleTests :: Spec+atRuleTests =+ describe "at rules parsing and printing" $+ mapM_ (matchSpec atRule) atRuleTestsInfo++atRuleTestsInfo :: [(Text, Text)]+atRuleTestsInfo =+ [("@charset \"UTF-8\";",+ "@charset \"UTF-8\";")+ ,("@import/**/ 'custom.css' ;",+ "@import 'custom.css';")+ ,("@import \"common.css\" screen , projection;",+ "@import \"common.css\" screen,projection;")+ ,("@import url(\'landscape.css\') screen and (orientation: landscape);",+ "@import url(\'landscape.css\') screen and (orientation:landscape);")+ ,("@namespace /**/ prefix url(XML-namespace-URL);",+ "@namespace prefix url(XML-namespace-URL);")+ ,("@namespace prefix /**/ \"XML-namespace-URL\";",+ "@namespace prefix \"XML-namespace-URL\";")+ ,("@media screen {s{a:a}}",+ "@media screen{s{a:a}}")+ ,("@media screen and (min-width: 768px){s{a:a}}",+ "@media screen and (min-width:768px){s{a:a}}")+ ,("@keyframes p { from { background-position: 40px 0 } to { background-position: 0 0 } }",+ "@keyframes p{from{background-position:40px 0}to{background-position:0 0}}")+ ,("@font-face /**/ {a:a;}",+ "@font-face{a:a}")+ -- ,("@supports (--foo: green) { body { color: green; } }",+ -- "@supports (--foo:green){body{color:green}}")+ -- ,("@supports ( transform-style: preserve ) or ( -moz-transform-style: preserve )",+ -- "@supports (transform-style:preserve) or (-moz-transform-style:preserve)")+ -- ,("@supports ( display : table-cell ) and ( not ( display : list-item ) )",+ -- "@supports (display:table-cell) and (not (display:list-item))")+ -- ,("@document url(http://www.w3.org/) , url-prefix(http://www.w3.org/Style/),\+ -- \ domain(mozilla.org), regexp(\"https:.*\")"+ -- ,("@document url(http://www.w3.org/),url-prefix(http://www.w3.org/Style/),\+ -- \domain(mozilla.org),regexp(\"https:.*\")"+ -- ,("@page { margin: 1in }",+ -- "@page{margin:1in}")+ -- ,("@page :left { font-size: 20pt; }",+ -- "@page:left{font-size:20pt}")+ -- ,("@page toc, index { size:8.5in 11in; }",+ -- "@page toc,index{size:8.5in 11in}")+ -- ,("@viewport { min-width: 640px; max-width: 800px; }",+ -- "@viewport{min-width:640px;max-width:800px}")+ -- ,("@counter-style circled-alpha { system: fixed; symbols: Ⓐ Ⓑ Ⓒ; suffix: " "; }",+ -- "@counter-style circled-alpha{system:fixed;symbols:Ⓐ Ⓑ Ⓒ;suffix:" "}")+ -- ,("@font-feature-values Jupiter Sans { @swash { delicate: 1; flowing: 2; } }",+ -- "@font-feature-values Jupiter Sans{@swash{delicate:1;flowing:2}}",+ ] ++spec :: Spec+spec = atRuleTests++main :: IO ()+main = hspec spec
+ tests/Hasmin/Types/TransformFunctionSpec.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings #-}++module Hasmin.Types.TransformFunctionSpec where++import Test.Hspec+import Hasmin.Parser.Value+import Hasmin.TestUtils++import Control.Monad.Reader (runReader)+import Data.Text (Text)+import Hasmin.Types.Class+import Hasmin.Types.TransformFunction+import Hasmin.Types.Value+import Hasmin.Config++transformTests :: Spec+transformTests =+ describe "transform function conversion" $+ mapM_ (matchSpec (f <$> textualvalue)) transformTestsInfo+ where f x = runReader (minifyWith x) defaultConfig++combinationTests :: Spec+combinationTests = + describe "transform function combination" $+ mapM_ (matchSpecWithDesc (g <$> values "transform")) functionCombinationTestsInfo+ where g = mkValues . fmap TransformV . f . fmap (\(TransformV t) -> t) . valuesToList+ f x = runReader (combine x) defaultConfig++transformTestsInfo :: [(Text, Text)]+transformTestsInfo = + [("translate(0)", "skew(0)")+ ,("translateX(0)", "skew(0)")+ ,("translateY(0)", "skew(0)")+ ,("translate3d(0,0,0)", "skew(0)")+ ,("translate3d(0%,0,0)", "skew(0)")+ ,("translate3d(-100%,0,0)", "translate(-100%)")+ ,("translate3d(0,-100%,0)", "translatey(-100%)")+ ,("translate3d(0%,0%,5px)", "translatez(5px)")+ ,("translate3d(2em,0,0)", "translate(2em)")+ ,("translate3d(0,3em,0)", "translatey(3em)")+ ,("translate3d(0,0,4em)", "translatez(4em)")+ ,("scale3d(4, 1, 1)", "scale(4)")+ ,("scale3d(1, 5, 1)", "scaley(5)")+ ,("scale3d(1, 1, 6)", "scalez(6)")+ ,("matrix(1,0,0,0,0,/**/ 0)", "scaley(0)")+ ,("matrix(7,0,0,8,0, 0)", "scale(7,8)")+ ]++functionCombinationTestsInfo :: [(String, Text, Text)]+functionCombinationTestsInfo = + [("Combines consecutive absolute value translate() functions into one",+ "translate(10px) translate(0) translate(10px)", "translate(20px)")+ ,("Don't combine an skew(90deg), since tan(90deg) = ∞",+ "skew(90deg) translate(1px)", "skew(90deg) translate(1px)")+ ,("Remove identity matrices from lists (e.g. translate(0))",+ "skew(90deg) translate(0px)", "skew(90deg)")+ -- ,("Remove identity matrices at the end of a list"+ -- "skew(90deg) translate(100%) skew(0)", "skew(90deg) translate(100%)")+ -- ,("Remove identity matrices at the beginning of a list"+ -- "skew(0) translate(100%) skew(90deg)", "translate(100%) skew(90deg)")+ ]+++spec :: Spec+spec = do transformTests + combinationTests++main :: IO ()+main = hspec spec
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}