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