diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright 2017 Cristian Adrián Ontivero + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE TemplateHaskell #-} +----------------------------------------------------------------------------- +-- | +-- Module : Main +-- Copyright : (c) 2017 Cristian Adrián Ontivero +-- License : BSD3 +-- Stability : experimental +-- Portability : non-portable +-- +----------------------------------------------------------------------------- +module Main where + +import Codec.Compression.Hopfli +import Control.Monad.Reader +import Data.Monoid ((<>)) +import Data.Attoparsec.Text (parseOnly) +import Data.Text.Lazy.Builder (toLazyText) +import Options.Applicative hiding (command) +import Data.Version (showVersion) +import Development.GitRev (gitHash) +import Paths_hasmin (version) +import qualified Data.ByteString as B +import qualified Data.Text.Encoding as TE +import qualified Data.Text.IO as TIO +import qualified Data.Text.Lazy as TL +import System.Exit (die) +import Text.PrettyPrint.Mainland (line, punctuate, putDoc, ppr) +import Hasmin.Config +import Hasmin.Parser.Internal +import Hasmin.Types.Class +import Hasmin.Types.Stylesheet + +command :: Parser Commands +command = Commands <$> switch (long "beautify" + <> short 'b' <> help "Beautify output") + <*> switch (long "zopfli" + <> short 'z' <> help "Compress result using zopfli") + <*> argument str (metavar "FILE") + +config :: Parser Config +config = Config + <$> flag ColorMinOn ColorMinOff (long "no-color-min" + <> short 'c' + <> help "Disable minification") + <*> flag DimMinOff DimMinOn (long "dimension-min" + <> short 'd' + <> help "Enable normalization of absolute dimensions") + <*> flag GradientMinOn GradientMinOff (long "-no-gradient-min" + <> short 'g' + <> help "Disable minification") + <*> flag True False (long "no-property-traits" + <> short 't' + <> help "Disable use of property traits for declaration minification") + <*> flag True False (long "no-rule-cleaning" + <> short 'a' + <> help "Disable deletion of overwritten properties") + <*> flag True False (long "no-timing-function-min" + <> help "Disable minifications") + <*> flag True False (long "no-filter-function-min" + <> help "Disable minifications") + <*> flag True False (long "no-quotes-removal" + <> short 'q' + <> help "Disable removing quotes whenever possible") + <*> flag FontWeightMinOn FontWeightMinOff (long "no-font-weight-minification" + <> help "Disable converting normal to 400 and bold to 700 in font-weight") + <*> flag True False (long "no-transform-origin-minification" + <> help "Disable converting left and top to 0%, bottom and right to 100%, and center to 50%") + <*> flag True False (long "no-microsyntax-min" + <> short 'm' + <> help "Disable minification of An+B microsyntax") + <*> flag True False (long "no-@kfsel-min" + <> short 'k' + <> help "Disable transform function minification") + <*> flag True False (long "no-transform-function-min" + <> help "Disable @keyframe selectors minification") + <*> switch (long "convert-escaped-characters" + <> help "Convert escaped characters to their UTF-8 equivalent") + <*> flag True False (long "no-null-percentage-conversion" + <> help "Disable converting 0% to 0 when possible") + <*> flag True False (long "no-empty-block-removal" + <> short 'e' + <> help "Disable empty block removal") + <*> flag True False (long "no-duplicate-selector-removal" + <> help "Disable removal of duplicate selectors") + <*> flag True False (long "no-quote-normalization" + <> help "Disable trying to convert all quotation marks to either \" or \'") + <*> flag Lowercase Original (long "no-lowercasing" + <> short 'l' + <> help "Disable lowercasing everything possible") + <*> flag Lexicographical NoSorting (long "no-selector-sorting" + <> help "Disable sorting selectors lexicographically") + <*> flag Lexicographical NoSorting (long "no-property-sorting" + <> help "Disable sorting properties lexicographically") + +instructions :: ParserInfo Instructions +instructions = info (helper <*> versionOption <*> ((,) <$> command <*> config)) + (fullDesc <> header "Hasmin - A Haskell CSS Minifier") + where versionOption = infoOption (showVersion version <> " " <> $(gitHash)) + (long "version" <> help "Show version and commit hash") + +main :: IO () +main = do + (comm, conf) <- execParser instructions + text <- TIO.readFile (file comm) + case parseOnly stylesheet text of + Right r -> process r comm conf + Left e -> die e + +process :: [Rule] -> Commands -> Config -> IO () +process r comm conf + | shouldBeautify comm = printBeautified $ fmap ppr sheet + | shouldCompress comm = B.writeFile "output.gz" . compressWith defaultCompressOptions GZIP . TE.encodeUtf8 $ output + | otherwise = TIO.putStr output + where sheet = let ruleList = fmap (\x -> runReader (minifyWith x) conf) r + in if shouldRemoveEmptyBlocks conf + then filter (not . isEmpty) ruleList + else ruleList + output = TL.toStrict . toLazyText $ mconcat (fmap toBuilder sheet) + printBeautified = putDoc . mconcat . punctuate (line <> line) diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,50 @@ +Hasmin - A Haskell CSS Minifier +==== +[![Build Status](https://travis-ci.org/contivero/hasmin.svg?branch=master)](https://travis-ci.org/contivero/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. + +Aside from the usual techniques (e.g. whitespace removal, color minification, +etc.), the idea was to explore new possibilities, by implementing things +other minifiers weren't doing, or they were, but not taking full advantage of. + +Also, the minifier implements some techniques that do nothing for minified +sizes, but attempt to improve post-compression sizes (at least when using +DEFLATE, i.e. gzip). + +For a list of techniques, see [Minification Techniques](https://github.com/contivero/hasmin/wiki/Minification-Techniques). + +## Building +To compile, just run `stack build`. + +## Minifier Usage +Hasmin expects a path to the CSS file, and outputs the minified result to +stdout. + +Every technique is enabled by default, except for: + 1. Escaped character conversions (e.g. converting `\2714` to `✔`, which can be enabled with `--convert-escaped-characters`) + 2. Dimension minifications (e.g. converting `12px` to `9pt`, which can be enabled with `--dimension-min`, or just `-d`) + +These two are disabled mainly because they are—on average, not +always—detrimental for DEFLATE compression. When something needs to be +disabled, use the appropriate flag. Not every technique can be toggled yet, but +a good amount of them allow it. + +Note: there is a problem in Windows when using the +`--convert-escaped-characters` flag to enable the conversion of escaped +characters. A workaround is changing the code page, which can be done by running +`chcp 65001` in the terminal (whether cmd, or cygwin). + +## Zopfli Integration +Hasmin uses bindings to Google's +[Zopfli library](https://en.wikipedia.org/wiki/Zopfli), allowing the +possibility to compress the result. + +Since the output is a gzip file, it can be used for the web. It tipically +produces files 3~8% smaller than zlib, at the cost of being around 80 times +slower, so it is only a good idea if you don't need compression on the fly. + + +Zopfli is released under the Apache License, Version 2.0. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hasmin.cabal b/hasmin.cabal new file mode 100644 --- /dev/null +++ b/hasmin.cabal @@ -0,0 +1,132 @@ +name: hasmin +version: 0.3.0.1 +license: BSD3 +license-file: LICENSE +author: (c) 2017 Cristian Adrián Ontivero +maintainer: Cristian Adrián Ontivero +synopsis: "A CSS Minifier" +homepage: https://github.com/contivero/hasmin/ +bug-reports: https://github.com/contivero/hasmin/issues +category: Text +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 +description: + A CSS minifier which not only aims at reducing the amount of bytes of the + output, but also at improving gzip compression. By default, the output is the + minified CSS file, but hasmin allows also its compression into gzip using + Google's Zopfli library. + . + To use it: ./hasmin input.css > output.css + . + By default, most minification techniques are enabled. For a list of + available flags, do: ./hasmin --help + +source-repository head + type: git + location: https://github.com/contivero/hasmin.git + +executable hasmin + default-language: Haskell2010 + ghc-options: -O2 -Wall -fwarn-tabs -fwarn-unused-do-bind + main-is: Main.hs + other-modules: Paths_hasmin + build-depends: base >=4.8 && <5.1 + , attoparsec >=0.12 && <0.14 + , containers >=0.5 && <0.6 + , optparse-applicative >=0.11 && <0.14 + , parsers >=0.12.3 && <0.13 + , mainland-pretty >=0.4.1 && <0.5 + , text >=1.2 && <1.3 + , hopfli >=0.2 && <0.3 + , bytestring >=0.10.2.0 && <0.11 + , gitrev >=1.0.0 && <=1.2.0 + , matrix >=0.3.4 && <0.4 + , mtl >=2.2.1 && <2.3 + , numbers >=3000.2.0.0 && <3000.3 + , hasmin + +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -O2 -Wall -fwarn-tabs -fwarn-unused-do-bind + exposed-modules: Hasmin + , Hasmin.Config + , Hasmin.Types.Class + , Hasmin.Types.Stylesheet + -- exposed because it is needed by tests: + , Hasmin.Parser.Internal + , Hasmin.Parser.Value + , Hasmin.Types.Color + , Hasmin.Types.Declaration + , Hasmin.Types.Dimension + , Hasmin.Types.Numeric + , Hasmin.Types.TransformFunction + , Hasmin.Types.Value + , Hasmin.Utils + other-modules: Hasmin.Parser.Utils + , Hasmin.Properties + , Hasmin.Selector + , Hasmin.Types.BgSize + , Hasmin.Types.FilterFunction + , Hasmin.Types.Gradient + , Hasmin.Types.PercentageLength + , Hasmin.Types.Position + , Hasmin.Types.RepeatStyle + , Hasmin.Types.Shadow + , Hasmin.Types.String + , Hasmin.Types.TimingFunction + build-depends: base >=4.8 && <5.1 + , attoparsec >=0.12 && <0.14 + , bytestring >=0.10.2.0 && <0.11 + , containers >=0.5 && <0.6 + , mainland-pretty >=0.4.1 && <0.5 + , matrix >=0.3.4 && <0.4 + , mtl >=2.2.1 && <2.3 + , numbers >=3000.2.0.0 && <3000.3 + , parsers >=0.12.3 && <0.13 + , semigroups >=0.16 && <0.19 + , text >=1.2 && <1.3 + +test-suite spec + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Spec.hs + ghc-options: -Wall -fno-warn-orphans + default-extensions: OverloadedStrings + other-modules: Hasmin.Parser.InternalSpec + , Hasmin.Parser.ValueSpec + , Hasmin.SelectorSpec + , Hasmin.TestUtils + , Hasmin.Types.ColorSpec + , Hasmin.Types.DeclarationSpec + , Hasmin.Types.DimensionSpec + , Hasmin.Types.FilterFunctionSpec + , Hasmin.Types.GradientSpec + , Hasmin.Types.PositionSpec + , Hasmin.Types.RepeatStyleSpec + , Hasmin.Types.ShadowSpec + , Hasmin.Types.StringSpec + , Hasmin.Types.StylesheetSpec + , Hasmin.Types.TransformFunctionSpec + build-depends: base >=4.7 && <5.1 + , attoparsec >=0.12 && <0.14 + , hspec >=2.2 && <3.0 + , hspec-attoparsec >=0.1.0.0 && <0.2 + , mtl >=2.2.1 && <2.3 + , QuickCheck >=2.8 && <3.0 + , text >=1.2 && <1.3 + , hasmin + +test-suite doctest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: DocTest.hs + ghc-options: -threaded -Wall -fno-warn-orphans + build-depends: base >=4.8 && <5.1 + , doctest >=0.11 && <0.12 + , doctest-discover >=0.1.0.0 && <0.2 + , doctest >=0.10 + , hasmin diff --git a/src/Hasmin.hs b/src/Hasmin.hs new file mode 100644 --- /dev/null +++ b/src/Hasmin.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Hasmin +-- Copyright : (c) 2017 Cristian Adrián Ontivero +-- License : BSD3 +-- Stability : experimental +-- Portability : unknown +-- +-- Recommended module to use the library. +-- +----------------------------------------------------------------------------- +module Hasmin ( + -- * Using the library + -- $use + minifyCSS + , minifyCSSWith + , module Hasmin.Config + ) where + +import Control.Monad.Reader (runReader) +import Data.Attoparsec.Text (parseOnly) +import Data.Text.Lazy.Builder (toLazyText) +import Data.Text (Text) +import qualified Data.Text.Lazy as TL + +import Hasmin.Parser.Internal +import Hasmin.Types.Class +import Hasmin.Config + +-- | Minify Text, based on a 'Config'. To just use a default set of +-- configurations (i.e. 'defaultConfig'), use 'minifyCSS'. +minifyCSSWith :: Config -> Text -> Either String Text +minifyCSSWith cfg t = do + sheet <- parseOnly stylesheet t + pure . TL.toStrict . toLazyText . mconcat $ map f sheet + where f x = toBuilder $ runReader (minifyWith x) cfg + +-- | Minify Text CSS, using a default set of configurations (with most +-- minification techniques enabled). +minifyCSS :: Text -> Either String Text +minifyCSS = minifyCSSWith defaultConfig + +-- $use +-- +-- This section shows a basic library use case. +-- +-- Given a style sheet, say: +-- +-- > sampleSheet :: Text +-- > sampleSheet = "body { color: #ff0000 } div { margin: 0 0 0 0 }" +-- +-- Minify it with 'minifyCSS'. In ghci: +-- +-- > > minifyCSS sampleSheet +-- > Just "body{color:red}div{margin:0}" +-- +-- To modify the minification settings, just use another 'Config', e.g.: +-- +-- > cfg :: Config +-- > cfg = defaultConfig { colorSettings = ColorMinOff } +-- +-- Once more in ghci, this time using 'minifyCSSWith': +-- +-- > > minifyStylesheet cfg sampleSheet +-- > Just "body{color:#ff0000}div{margin:0}" +-- +-- The output is once more minified, but this time leaving colors as they were +-- originally. +-- +-- For the complete list of possible options, refer to 'Config'. diff --git a/src/Hasmin/Config.hs b/src/Hasmin/Config.hs new file mode 100644 --- /dev/null +++ b/src/Hasmin/Config.hs @@ -0,0 +1,95 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hasmin.Config +-- Copyright : (c) 2017 Cristian Adrián Ontivero +-- License : BSD3 +-- Stability : experimental +-- Portability : non-portable +-- +----------------------------------------------------------------------------- +module Hasmin.Config ( + Config(..) + , ColorSettings(..) + , DimensionSettings(..) + , GradientSettings(..) + , FontWeightSettings(..) + , LetterCase(..) + , SortingMethod(..) + , defaultConfig + , Instructions + , Commands(..) + ) where + +type Instructions = (Commands, Config) + +data Commands = Commands { shouldBeautify :: Bool + , shouldCompress :: Bool + , file :: FilePath + } deriving (Show) + +data ColorSettings = ColorMinOff | ColorMinOn + deriving (Show, Eq) +data DimensionSettings = DimMinOff | DimMinOn + deriving (Show, Eq) +data GradientSettings = GradientMinOff | GradientMinOn + deriving (Show, Eq) +data LetterCase = Original -- ^ Leave letter casing as is. + | Lowercase -- ^ Lowercase whatever possible to improve gzip compression. + deriving (Show, Eq) +data SortingMethod = NoSorting | Lexicographical + deriving (Show, Eq) +data FontWeightSettings = FontWeightMinOff | FontWeightMinOn + deriving (Show, Eq) + +-- TODO: * avoid boolean blindness +-- * Use a more declarative style for the names, e.g. shouldLowercase vs. +-- preferredCasing, shouldSortSelectors vs. selectorSorting, etc. +-- | The configuration used for minifying. +data Config = Config { colorSettings :: ColorSettings + , dimensionSettings :: DimensionSettings + , gradientSettings :: GradientSettings + , shouldUsePropertyTraits :: Bool + , shouldCleanRules :: Bool + , shouldMinifyTimingFunctions :: Bool + , shouldMinifyFilterFunctions :: Bool + , shouldRemoveQuotes :: Bool + , fontweightSettings :: FontWeightSettings + , shouldMinifyTransformOrigin :: Bool + , shouldMinifyMicrosyntax :: Bool + , shouldMinifyKeyframeSelectors :: Bool + , shouldMinifyTransformFunction :: Bool + , shouldConvertEscaped :: Bool + , shouldConvertNullPercentages :: Bool + , shouldRemoveEmptyBlocks :: Bool + , shouldRemoveDuplicateSelectors :: Bool + , shouldNormalizeQuotes :: Bool + , letterCase :: LetterCase + , selectorSorting :: SortingMethod + , declarationSorting :: SortingMethod + } deriving (Show) + +-- | A default config with most settings enabled. Used by the minify function, +-- mainly for testing purposes. +defaultConfig :: Config +defaultConfig = Config { colorSettings = ColorMinOn + , dimensionSettings = DimMinOn + , gradientSettings = GradientMinOn + , shouldUsePropertyTraits = True + , shouldCleanRules = True + , shouldMinifyTimingFunctions = True + , shouldMinifyFilterFunctions = True + , shouldRemoveQuotes = True + , fontweightSettings = FontWeightMinOn + , shouldMinifyTransformOrigin = True + , shouldMinifyMicrosyntax = True + , shouldMinifyKeyframeSelectors = True + , shouldMinifyTransformFunction = True + , shouldConvertEscaped = True + , shouldConvertNullPercentages = True + , shouldRemoveEmptyBlocks = True + , shouldRemoveDuplicateSelectors = True + , shouldNormalizeQuotes = True + , letterCase = Lowercase + , selectorSorting = NoSorting + , declarationSorting = NoSorting + } diff --git a/src/Hasmin/Parser/Internal.hs b/src/Hasmin/Parser/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Hasmin/Parser/Internal.hs @@ -0,0 +1,499 @@ +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Hasmin.Parser.Internal +-- Copyright : (c) 2017 Cristian Adrián Ontivero +-- License : BSD3 +-- Stability : experimental +-- Portability : unknown +-- +----------------------------------------------------------------------------- +module Hasmin.Parser.Internal ( + stylesheet + , atRule + , declaration + , declarations + , selector + ) where + +import Control.Arrow (first) +import Control.Applicative ((<|>), many) +import Control.Monad (mzero) +import Data.Functor (($>)) +import Data.Attoparsec.Combinator (lookAhead, sepBy, endOfInput) +import Data.Attoparsec.Text (asciiCI, char, many1, manyTill, + option, Parser, satisfy, string) +import Data.List.NonEmpty (NonEmpty( (:|) )) +import Data.Monoid ((<>)) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text.Lazy.Builder as LB +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Attoparsec.Text as A +import qualified Data.Char as C +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +import Hasmin.Parser.Utils +import Hasmin.Parser.Value +import Hasmin.Selector +import Hasmin.Types.Stylesheet +import Hasmin.Types.Declaration + +selector :: Parser Selector +selector = Selector <$> compoundSelector + <*> many ((,) <$> (combinator <* skipComments) <*> compoundSelector) + +-- First tries with '>>' (descendant), '>' (child), '+' (adjacent sibling), and +-- '~' (general sibling) combinators. If those fail, it tries with the +-- descendant (whitespace) combinator. This is done to allow comments in-between. +-- +-- | Parser for selector combinators, i.e. ">>" (descendant), '>' (child), '+' +-- (adjacent sibling), '~' (general sibling), and ' ' (descendant) combinators. +combinator :: Parser Combinator +combinator = (skipComments *> ((string ">>" $> Descendant) + <|> (char '>' $> Child) + <|> (char '+' $> AdjacentSibling) + <|> (char '~' $> GeneralSibling))) + <|> (satisfy ws $> Descendant) + where ws c = c == ' ' || c == '\t' || c == '\n' || c == '\r' || c == '\f' + +compoundSelector :: Parser CompoundSelector +compoundSelector = + (:|) <$> (typeSelector <|> universal) + <*> many p + <|> ((Universal mempty :|) <$> many1 p) + where p = idSel <|> classSel <|> attributeSel <|> pseudo + +idSel :: Parser SimpleSelector +idSel = do + _ <- char '#' + name <- mconcat <$> many1 nmchar + pure $ IdSel (TL.toStrict (toLazyText name)) + +-- class: '.' IDENT +classSel :: Parser SimpleSelector +classSel = char '.' *> (ClassSel <$> ident) + +{- +attrib + : '[' S* [ namespace_prefix ]? IDENT S* + [ [ PREFIXMATCH | + SUFFIXMATCH | + SUBSTRINGMATCH | + '=' | + INCLUDES | + DASHMATCH ] S* [ IDENT | STRING ] S* + ]? ']' + ; +-} +-- FIXME namespace prefixes aren't allowed inside attribute selectors, +-- but they should be. +attributeSel :: Parser SimpleSelector +attributeSel = do + _ <- char '[' *> skipComments + attId <- ident <* skipComments + g <- option Attribute attValue + _ <- char ']' + pure $ AttributeSel (g attId) + where attValue = do + f <- ((string "^=" $> (:^=:)) <|> + (string "$=" $> (:$=:)) <|> + (string "*=" $> (:*=:)) <|> + (string "=" $> (:=:)) <|> + (string "~=" $> (:~=:)) <|> + (string "|=" $> (:|=:))) <* skipComments + attval <- ((Left <$> ident) <|> (Right <$> stringtype)) <* skipComments + pure (`f` attval) + +{- +-- string1: \"([^\n\r\f\\"]|\\{nl}|{escape})*\" +string1 = char '\"' *> many (o1 <|> o2 <|> escape) + where o1 = satisfy (c -> c /= '\"' && c /= '\\' && c /= '\n') + o2 = char '\\' *> newline $> mempty +-} + +-- type_selector: [namespace_prefix]? element_name +typeSelector :: Parser SimpleSelector +typeSelector = Type <$> opt namespacePrefix <*> ident + +-- universal: [ namespace_prefix ]? '*' +universal :: Parser SimpleSelector +universal = Universal <$> opt namespacePrefix <* char '*' + +-- namespace_prefix: [ IDENT | '*' ]? '|' +namespacePrefix :: Parser Text +namespacePrefix = opt (ident <|> string "*") <* char '|' + +{- '::' starts a pseudo-element, ':' a pseudo-class + Exceptions: :first-line, :first-letter, :before and :after. + Note that pseudo-elements are restricted to one per selector and + occur only in the last simple_selector_sequence. + + = ':' | + ':' ')' + = ':' +-} +-- pseudo: ':' ':'? [ IDENT | functional_pseudo ] +pseudo :: Parser SimpleSelector +pseudo = char ':' *> (pseudoElementSelector <|> pseudoClassSelector) + where pseudoClassSelector = do + i <- ident + c <- A.peekChar + case c of + Just '(' -> char '(' *> case Map.lookup (T.toCaseFold i) fpcMap of + Just p -> functionParser p + Nothing -> functionParser (FunctionalPseudoClass i <$> A.takeWhile (/= ')')) + _ -> pure $ PseudoClass i + pseudoElementSelector = do + parsedColon <- option False (char ':' $> True) + if parsedColon + then PseudoElem <$> ident + else ident >>= handleSpecialCase + where handleSpecialCase :: Text -> Parser SimpleSelector + handleSpecialCase t = if T.toCaseFold t `elem` specialPseudoElements + then pure $ PseudoElem t + else mzero + +-- \ microsyntax parser. +anplusb :: Parser AnPlusB +anplusb = (asciiCI "even" $> Even) + <|> (asciiCI "odd" $> Odd) + <|> do + s <- option Nothing (Just <$> parseSign) + x <- option mempty digits + case x of + [] -> ciN *> (AB (Nwith s Nothing) <$> (skipComments *> option Nothing (Just <$> bValue))) + _ -> do n <- option False (ciN $> True) + let a = read x :: Int + if n + then AB (Nwith s (Just a)) <$> (skipComments *> option Nothing (Just <$> bValue)) + else pure $ AB NoValue (Just $ getSign s * a) + where ciN = satisfy (\c -> c == 'N' || c == 'n') + parseSign = (char '-' $> Minus) <|> (char '+' $> Plus) + getSign (Just Minus) = -1 + getSign _ = 1 + bValue = do + readPlus <- (char '-' $> False) <|> (char '+' $> True) + d <- skipComments *> digits + if readPlus + then pure $ read d + else pure $ read ('-':d) + +-- Functional pseudo classes parsers map +fpcMap :: Map Text (Parser SimpleSelector) +fpcMap = Map.fromList $ fmap (first T.toCaseFold) + [buildTuple "nth-of-type" (\x -> FunctionalPseudoClass2 x <$> anplusb) + ,buildTuple "nth-last-of-type" (\x -> FunctionalPseudoClass2 x <$> anplusb) + ,buildTuple "nth-column" (\x -> FunctionalPseudoClass2 x <$> anplusb) + ,buildTuple "nth-last-column" (\x -> FunctionalPseudoClass2 x <$> anplusb) + ,buildTuple "not" (\x -> FunctionalPseudoClass1 x <$> compoundSelectorList) + ,buildTuple "matches" (\x -> FunctionalPseudoClass1 x <$> compoundSelectorList) + ,buildTuple "nth-child" (anbAndSelectors . FunctionalPseudoClass3) + ,buildTuple "nth-last-child" (anbAndSelectors . FunctionalPseudoClass3) + -- + -- :drop( [ active || valid || invalid ]? ) + -- The :drop() functional pseudo-class is identical to :drop + -- ,("drop", anplusb) + -- + -- It accepts a comma-separated list of one or more language ranges as its + -- argument. Each language range in :lang() must be a valid CSS or + -- . + -- ,("lang", anplusb) + -- + -- ,("dir", text) + -- ,("has", relative selectors) + ] + where buildTuple t c = (t, c t) + compoundSelectorList = (:) <$> compoundSelector <*> many (comma *> compoundSelector) + anbAndSelectors constructor = do + a <- anplusb <* skipComments + o <- option [] (asciiCI "of" *> skipComments *> compoundSelectorList) + pure $ constructor a o + +-- | Parse a list of comma-separated selectors, ignoring whitespace and +-- comments. +selectors :: Parser [Selector] +selectors = lexeme selector `sepBy` char ',' + +declaration :: Parser Declaration +declaration = do + p <- property <* colon + v <- values p <|> valuesFallback + i <- important <* skipComments + ie <- iehack <* skipComments + pure $ Declaration p v i ie + +-- | Parser for property names. Usually, 'ident' would be enough, but this +-- parser adds support for IE hacks (e.g. *width), which deviate from the CSS +-- grammar. +property :: Parser Text +property = mappend <$> opt ie7orLessHack <*> ident + where ie7orLessHack = T.singleton <$> satisfy (`Set.member` ie7orLessHacks) + ie7orLessHacks = Set.fromList ("!$&*()=%+@,./`[]#~?:<>|" :: String) + +-- | Used to parse the "!important" at the end of declarations, ignoring spaces +-- and comments after the '!'. +important :: Parser Bool +important = option False (char '!' *> skipComments *> asciiCI "important" $> True) + +iehack :: Parser Bool +iehack = option False (string "\\9" $> True) + +-- | Parses a list of declarations, ignoring spaces, comments, and empty +-- declarations (e.g. ; ;) +declarations :: Parser [Declaration] +declarations = many (declaration <* handleSemicolons) + where handleSemicolons = many (string ";" *> skipComments) + +-- | Parser for CSS at-rules (e.g. \@keyframes, \@media) +atRule :: Parser Rule +atRule = do + _ <- char '@' + ruleType <- ident + fromMaybe (atBlock ruleType) (Map.lookup ruleType m) + where m = Map.fromList [("charset", atCharset) + ,("import", atImport) + ,("namespace", atNamespace) + ,("media", atMedia) + -- ,("supports", atSupports) + -- ,("document", atDocument) + -- ,("page", atPage) + ,("font-face", skipComments *> atBlock "font-face") + ,("keyframes", atKeyframe mempty ) + ,("-webkit-keyframes", atKeyframe "-webkit-") + ,("-moz-keyframes", atKeyframe "-moz-") + ,("-o-keyframes", atKeyframe "-o-") + -- ,("viewport", atViewport) + -- ,("counter-style", atCounterStyle) + -- ,("font-feature-value", atFontFeatureValue) + ] +-- @import [ | ] []?; +atImport :: Parser Rule +atImport = do + esu <- skipComments *> stringOrUrl + mql <- option [] mediaQueryList + _ <- skipComments <* char ';' + pure $ AtImport esu mql + +atCharset :: Parser Rule +atCharset = do + st <- skipComments *> stringtype <* skipComments <* char ';' + pure $ AtCharset st + +-- @namespace ? [ | ]; +-- where +-- = IDENT +atNamespace :: Parser Rule +atNamespace = do + i <- skipComments *> option mempty ident + ret <- if T.null i + then (AtNamespace i . Left) <$> stringtype + else decideBasedOn i + _ <- skipComments <* char ';' + pure ret + where decideBasedOn x = + let urltext = T.toCaseFold "url" + in if T.toCaseFold x == urltext + then do c <- A.peekChar + case c of + Just '(' -> AtNamespace mempty <$> (char '(' *> (Right <$> url)) + _ -> AtNamespace x <$> (skipComments *> stringOrUrl) + else AtNamespace x <$> (skipComments *> stringOrUrl) + +atKeyframe :: Text -> Parser Rule +atKeyframe t = do + _ <- skipComments + name <- ident <* skipComments <* char '{' + bs <- many (keyframeBlock <* skipComments) + _ <- char '}' + pure $ AtKeyframes t name bs + +keyframeBlock :: Parser KeyframeBlock +keyframeBlock = do + sel <- skipComments *> kfsList <* skipComments + ds <- char '{' *> skipComments *> declarations <* char '}' + pure $ KeyframeBlock sel ds + where from = asciiCI "from" $> From + to = asciiCI "to" $> To + keyframeSelector = from <|> to <|> (KFPercentage <$> percentage) + kfsList = (:) <$> keyframeSelector <*> many (comma *> keyframeSelector) + +atMedia :: Parser Rule +atMedia = do + m <- satisfy C.isSpace *> mediaQueryList + _ <- char '{' <* skipComments + r <- manyTill (rule <* skipComments) (lookAhead (char '}')) + _ <- char '}' + pure $ AtMedia m r + +-- TODO clean code +-- the "manyTill .. lookAhead" was added because if we only used "rules", it +-- doesn't know when to stop, and breaks the parser +atBlock :: Text -> Parser Rule +atBlock i = do + t <- mappend i <$> A.takeWhile (/= '{') <* char '{' + r <- skipComments *> ((AtBlockWithDec t <$> declarations) <|> (AtBlockWithRules t <$> manyTill (rule <* skipComments) (lookAhead (char '}')))) + _ <- char '}' + pure r + +-- | Parses a CSS style rule, e.g. @body { padding: 0; }@ +styleRule :: Parser Rule +styleRule = do + sels <- selectors <* char '{' <* skipComments + decs <- declarations <* char '}' + pure $ StyleRule sels decs + +-- | Parser for a CSS rule, which can be either an at-rule (e.g. \@charset), or a style +-- rule. +rule :: Parser Rule +rule = atRule <|> styleRule + +-- | Parser for CSS rules (both style rules, and at-rules), which can be +-- separated by whitespace or comments. +rules :: Parser [Rule] +rules = manyTill (rule <* skipComments) endOfInput + +stylesheet :: Parser [Rule] +stylesheet = do + charset <- option [] ((:[]) <$> atCharset <* skipComments) + imports <- many (atImport <* skipComments) + namespaces <- many (atNamespace <* skipComments) + _ <- skipComments -- if there is no charset, import, or namespace at rule we need this here. + rest <- rules + pure $ charset <> imports <> namespaces <> rest + +-- data AtRule = AtMedia (Maybe [MediaQuery]) + +-- | Media Feature values. Per the +-- , +-- \ only accepts dpi and dpcm units, dppx was added later. +-- However, the w3c validator considers it valid, so we make no exceptions. +{- +data MediaFeatureValue = MFV_Length Length + | MFV_Ratio Ratio + | MFV_Number Number + | MFV_Resolution Resolution + | MFV_Other Text +-} + +-- | Specs: +-- +-- https://drafts.csswg.org/mediaqueries-3/#syntax +-- https://www.w3.org/TR/css3-mediaqueries/ +-- https://www.w3.org/TR/CSS21/grammar.html +-- +-- Implementation based on mozilla's pseudo BNF: +-- https://developer.mozilla.org/en-US/docs/Web/CSS/Media_Queries/Using_media_queries +mediaQueryList :: Parser [MediaQuery] +mediaQueryList = lexeme ((:) <$> mediaQuery <*> many (char ',' *> skipComments *> mediaQuery)) + +mediaQuery :: Parser MediaQuery +mediaQuery = mediaQuery1 <|> mediaQuery2 + where mediaQuery1 = MediaQuery1 <$> optionalNotOrOnly <*> mediaType <*> andExpressions + mediaQuery2 = MediaQuery2 <$> ((:) <$> expression <*> andExpressions) + mediaType = lexeme ident + andExpressions = many (h *> expression) + h = skipComments *> asciiCI "and" *> satisfy C.isSpace *> skipComments + optionalNotOrOnly = option mempty (asciiCI "not" <|> asciiCI "only") + +expression :: Parser Expression +expression = char '(' *> skipComments *> (expr <|> expFallback) + where expr = do + e <- ident <* skipComments + v <- option Nothing (char ':' *> lexeme (Just <$> value)) + _ <- char ')' + pure $ Expression e v + expFallback = InvalidExpression <$> A.takeWhile (/= ')') <* char ')' + + + +-- Note: The code below pertains to CSS Media Queries Level 4. +-- Since it is still too new and nobody implements it (afaik), +-- I leave it here for future reference, when the need to cater for it +-- arrives. +{- +mediaCondition = asciiCI "not" + <|> asciiCI "and" + <|> asciiCI "or" + <|> mediaInParens + +mediaInParens = char '(' *> skipComments *> mediaCondition <* skipComments <* char ')' + +mediaFeature :: Parser MediaFeature +mediaFeature = mfPlain <|> mfRange <|> mfBoolean + where mfBoolean = ident + +mfRange = ident + +data MediaFeature = MFPlain Text Value + | MFBoolean Text + | MFRange Range + +data Range = Range1 Text RangeOp Value + | Range2 Value RangeOp Text + | Range3 Value RangeOp Text RangeOp Value + +data RangeOp = LTOP | GTOP | EQOP | GEQOP | LEQOP + +-- = [ '<' | '>' ]? '='? +-- | [ '<' | '>' ]? '='? +-- | '<' '='? '<' '='? +-- | '>' '='? '>' '='? + +mfPlain = ident *> skipComments *> char ':' *> skipComments *> mfValue + +mfValue :: Parser Value +mfValue = number <|> dimension <|> ident <|> ratio + +-- TODO check if both integers are positive (required by the spec) +ratio :: Parser Value +ratio = do + n <- digits + _ <- skipComments *> char '/' <* skipComments + m <- digits + pure $ Other (mconcat [n, "/", m]) + + + +-- expr +-- : term [ operator? term ]* +-- ; +-- +--term +-- : unary_operator? +-- [ NUMBER S* | PERCENTAGE S* | LENGTH S* | EMS S* | EXS S* | ANGLE S* | +-- TIME S* | FREQ S* ] +-- | STRING S* | IDENT S* | URI S* | hexcolor | function +-- ; +-- + +data MediaFeatureType = Range | Discrete + +t = + [("width", Range) + ,("height", Range) + ,("aspect-ratio", Range) + ,("orientation", Discrete) + ,("resolution", Range) + ,("scan", Discrete) + ,("grid", Discrete) + ,("update", Discrete) + ,("overflow-block", Discrete) + ,("overflow-inline", Discrete) + ,("color", Range) + ,("color-index", Range) + ,("monochrome", Range) + ,("color-gamut", Discrete) + ,("pointer", Discrete) + ,("hover", Discrete) + ,("any-pointer", Discrete) + ,("any-hover", Discrete) + ,("scripting", Discrete) + ,("device-width", Range) + ,("device-height", Range) + ,("device-aspect-ratio", Range) + ] +-} diff --git a/src/Hasmin/Parser/Utils.hs b/src/Hasmin/Parser/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Hasmin/Parser/Utils.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Hasmin.Parser.Internal +-- Copyright : (c) 2017 Cristian Adrián Ontivero +-- License : BSD3 +-- Stability : experimental +-- Portability : unknown +-- +----------------------------------------------------------------------------- +module Hasmin.Parser.Utils ( + ident + , fontfamilyname + , nonquotedurl + , skipComments + , lexeme + , functionParser + , comma + , colon + , opt + , nmchar + ) where + +import Control.Applicative ((<|>), many) +import Control.Monad (void, mzero) +import Data.Attoparsec.Text (char, + option, Parser, satisfy, skipSpace, string, takeWhile1, ()) +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Text.Lazy.Builder as LB +import qualified Data.Attoparsec.Text as A +import qualified Data.Char as C +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +-- | Skip whatever comments and whitespaces are found. +skipComments :: Parser () +skipComments = void $ many (skipSpace *> comment) <* skipSpace + +comment :: Parser Text +comment = mappend <$> string "/*" <*> (string "*/" <|> untilAsterisk) + where untilAsterisk = mappend <$> A.takeWhile (/= '*') <*> checkAsterisk + checkAsterisk = mappend <$> string "*" <*> (string "/" <|> untilAsterisk) + +comma :: Parser Char +comma = lexeme $ char ',' + +colon :: Parser Char +colon = lexeme $ char ':' + +lexeme :: Parser a -> Parser a +lexeme p = skipComments *> p <* skipComments + +opt :: Monoid m => Parser m -> Parser m +opt = option mempty + +nonquotedurl :: Parser Text +nonquotedurl = do + t <- many (escape <|> (LB.singleton <$> satisfy validChar)) + pure $ TL.toStrict (toLazyText (mconcat t)) + where validChar x = x /= '\"' && x /= '\'' && x /= '(' && x /= ')' + && x /= '\\' && notWhitespace x && notNonprintable x + notWhitespace x = x /= '\n' && x /= '\t' && x /= ' ' + notNonprintable x = not (C.chr 0 <= x && x <= C.chr 8) + && x /= '\t' + && not ('\SO' <= x && x <= C.chr 31) + && x /= '\DEL' + +fontfamilyname :: Parser Text +fontfamilyname = do + i <- ident + is <- many (skipComments *> ident) + if T.toLower i `elem` invalidNames + then mzero + else pure $ i <> mconcat (map (" "<>) is) + where invalidNames = ["serif", "sans-serif", "monospace", "cursive", + "fantasy", "inherit", "initial", "unset", "default"] + +-- ident: -?{nmstart}{nmchar}* +ident :: Parser Text +ident = do + dash <- option mempty (LB.singleton <$> char '-') + ns <- nmstart + nc <- mconcat <$> many nmchar + pure $ TL.toStrict (toLazyText (dash <> ns <> nc)) + +-- nmstart: [_a-z]|{nonascii}|{escape} +nmstart :: Parser Builder +nmstart = LB.singleton <$> satisfy (\c -> C.isAlpha c || (not . C.isAscii) c || c == '_') + <|> escape + "not an nmstart token: [_a-z]|{nonascii}|{escape}" + +-- nmchar: [_a-z0-9-]|{nonascii}|{escape} +nmchar :: Parser Builder +nmchar = LB.singleton <$> satisfy cond <|> escape + where cond x = C.isAlphaNum x || x == '_' || x == '-' + || (not . C.isAscii) x + +-- TODO combine with unicode to make it more efficient +-- escape: {unicode}|\\[^\n\r\f0-9a-f] +escape :: Parser Builder +escape = unicode + <|> (mappend <$> (LB.singleton <$> char '\\') <*> (LB.singleton <$> satisfy cond)) + "not an escape token: {unicode}|\\\\[^\\n\\r\\f0-9a-f]" + where cond c = c /= '\n' + && c /= '\r' + && c /= '\f' + && (not . C.isHexDigit) c + +-- unicode \\[0-9a-f]{1,6}(\r\n|[ \n\r\t\f])? +unicode :: Parser Builder +unicode = do + backslash <- char '\\' + hexChars <- takeWhile1 C.isHexDigit + _ <- opt (string "\r\n" <|> (T.singleton <$> satisfy ws)) + if T.length hexChars <= 6 + then pure $ LB.singleton backslash <> LB.fromText hexChars + else fail "unicode escaped character with length greater than 6" + where ws x = x == ' ' || x == '\n' || x == '\r' || x == '\t' || x == '\f' + +-- | Assumes the identifier and the left parenthesis have been parsed +-- Parses p, ignoring comments before and after it, and consumes the final +-- right parenthesis +functionParser :: Parser a -> Parser a +functionParser p = lexeme p <* char ')' diff --git a/src/Hasmin/Parser/Value.hs b/src/Hasmin/Parser/Value.hs new file mode 100644 --- /dev/null +++ b/src/Hasmin/Parser/Value.hs @@ -0,0 +1,1184 @@ +{-# LANGUAGE OverloadedStrings, TupleSections #-} +----------------------------------------------------------------------------- +-- | +-- Module : Hasmin.Parser.Internal +-- Copyright : (c) 2017 Cristian Adrián Ontivero +-- License : BSD3 +-- Stability : experimental +-- Portability : unknown +-- +-- Parsers for CSS values. +-- +----------------------------------------------------------------------------- +module Hasmin.Parser.Value ( + values + , percentage + , value + , valuesFallback + , stringOrUrl + , url + , stringtype + , digits + , textualvalue + , stringvalue + , shadowList + , repeatStyle + , position + , color + , number + , fontStyle + ) where + +import Control.Applicative ((<|>), many, liftA2, liftA3) +import Control.Arrow (first, (&&&)) +import Control.Monad (mzero) +import Data.Functor (($>)) +import Data.Attoparsec.Text (asciiCI, char, choice, count, many1, + option, Parser, satisfy, skipSpace, string, digit) +import Data.Map.Strict (Map) +import Data.Monoid ((<>)) +import Data.Maybe (fromMaybe, isNothing) +import Data.Text (Text) +import Data.Word (Word8) +import Data.Char (isAscii) +import Text.Parser.Permutation ((<|?>), (<$$>), (<$?>), (<||>), permute) +import qualified Data.Set as Set +import Numeric (readSigned, readFloat) +import qualified Data.Attoparsec.Text as A +import qualified Data.Char as C +import qualified Data.Map.Strict as Map +import qualified Data.Text as T + +import Hasmin.Parser.Utils +import Hasmin.Types.BgSize +import Hasmin.Types.Class +import Hasmin.Types.Color +import Hasmin.Types.Dimension +import Hasmin.Types.FilterFunction +import Hasmin.Types.Gradient +import Hasmin.Types.Numeric +import Hasmin.Types.PercentageLength +import Hasmin.Types.Position +import Hasmin.Types.RepeatStyle +import Hasmin.Types.Shadow +import Hasmin.Types.String +import Hasmin.Types.TimingFunction +import Hasmin.Types.TransformFunction +import Hasmin.Types.Value + +values :: Text -> Parser Values +values p = case Map.lookup (T.toLower p) propertyValueParsersMap of + Just x -> x <* skipComments -- mappend <$> (x <|> ((:[]) <$> csswideKeyword)) + Nothing -> valuesFallback + +number :: Parser Number +number = Number <$> rational + +-- --------------------------------------------------------------------------- +-- Color Parsers +-- --------------------------------------------------------------------------- + +-- Assumes "rgb(" has already been read +rgb :: Parser Color +rgb = functionParser (rgbInt <|> rgbPer) + where rgbInt = mkRGBInt <$> word8 <* comma <*> word8 <* comma <*> word8 + rgbPer = mkRGBPer <$> percentage <* comma + <*> percentage <* comma <*> percentage + +-- Assumes "rgba(" has already been read +rgba :: Parser Color +rgba = functionParser (rgbaInt <|> rgbaPer) + where rgbaInt = mkRGBAInt <$> word8 <* comma <*> word8 <* comma + <*> word8 <* comma <*> alphavalue + rgbaPer = mkRGBAPer <$> percentage <* comma <*> percentage <* comma + <*> percentage <* comma <*> alphavalue + +-- Assumes "hsl(" has already been read +hsl :: Parser Color +hsl = functionParser p + where p = mkHSL <$> int <* comma <*> percentage <* comma <*> percentage + +-- Assumes "hsla(" has already been read +hsla :: Parser Color +hsla = functionParser p + where p = mkHSLA <$> int <* comma <*> percentage <* comma + <*> percentage <* comma <*> alphavalue + +alphavalue :: Parser Alphavalue +alphavalue = mkAlphavalue <$> rational + +hexvalue :: Parser Value +hexvalue = ColorV <$> hex + +-- TODO improve this parser +hex :: Parser Color +hex = char '#' *> (constructHex <$> choice ps) + where hexadecimal = satisfy C.isHexDigit + ps = [count 8 hexadecimal, count 6 hexadecimal, + count 4 hexadecimal, count 3 hexadecimal] + constructHex [r,g,b] = mkHex3 r g b + constructHex [r,g,b,a] = mkHex4 r g b a + constructHex [r1,r2,g1,g2,b1,b2] = mkHex6 [r1,r2] [g1,g2] [b1,b2] + constructHex [r1,r2,g1,g2,b1,b2,a1,a2] = mkHex8 [r1,r2] [g1,g2] [b1,b2] [a1,a2] + constructHex _ = error "invalid list size for a hex color" + +-- --------------------------------------------------------------------------- +-- Dimensions Parsers +-- --------------------------------------------------------------------------- + +-- A map relating dimension units and the percentage symbol, +-- to functions that construct that value. Meant to unify all the numerical +-- parsing in a single parse for generality without losing much efficiency. +-- See numericalvalue. +numericalConstructorsMap :: Map Text (Number -> Value) +numericalConstructorsMap = Map.fromList $ fmap (first T.toCaseFold) l + where durationFunc u v = DurationV (Duration v u) + frequencyFunc u v = FrequencyV (Frequency v u) + resolutionFunc u v = ResolutionV (Resolution v u) + l = [("s", durationFunc S) + ,("ms", durationFunc Ms) + ,("hz", frequencyFunc Hz) + ,("khz", frequencyFunc Khz) + ,("dpi", resolutionFunc Dpi) + ,("dpcm", resolutionFunc Dpcm) + ,("dppx", resolutionFunc Dppx) + ,("%", \x -> PercentageV (Percentage $ toRational x)) + ] ++ (fmap . fmap) (DistanceV .) distanceConstructorsList + ++ (fmap . fmap) (AngleV .) angleConstructorsList + +-- Unified numerical parser. +-- Parses , dimensions (i.e. , , ...), and +numericalvalue :: Parser Value +numericalvalue = do + n <- number + rest <- opt (string "%" <|> A.takeWhile1 C.isAlpha) + if T.null rest -- if true, then it was just a value + then pure $ NumberV n + else case Map.lookup (T.toCaseFold rest) numericalConstructorsMap of + Just f -> pure $ f n + Nothing -> mzero -- TODO see if we should return an "Other" value + +-- Create a numerical parser based on a Map. +-- See for instance, the "angle" parser +dimensionParser :: Map Text (Number -> a) -> a -> Parser a +dimensionParser m unitlessValue = do + n <- number + u <- opt (A.takeWhile1 C.isAlpha) + if T.null u + then if n == 0 + then pure unitlessValue -- 0, without units + else mzero -- Non-zero , fail + else case Map.lookup (T.toCaseFold u) m of + Just f -> pure $ f n + Nothing -> mzero -- parsed units aren't angle units, fail + +distance :: Parser Distance +distance = dimensionParser distanceConstructorsMap (Distance 0 Q) + where distanceConstructorsMap = Map.fromList distanceConstructorsList + +angle :: Parser Angle +angle = dimensionParser angleConstructorsMap (Angle 0 Deg) + where angleConstructorsMap = Map.fromList angleConstructorsList + +duration :: Parser Duration +duration = do + n <- number + u <- opt (A.takeWhile1 C.isAlpha) + if T.null u + then mzero + else case Map.lookup (T.toCaseFold u) durationConstructorsMap of + Just f -> pure $ f n + Nothing -> mzero -- parsed units aren't angle units, fail + where durationConstructorsMap = Map.fromList $ + fmap (toText &&& flip Duration) [S, Ms] + +angleConstructorsList :: [(Text, Number -> Angle)] +angleConstructorsList = fmap (toText &&& flip Angle) + [Deg, Grad, Rad, Turn] + +distanceConstructorsList :: [(Text, Number -> Distance)] +distanceConstructorsList = fmap (toText &&& flip Distance) + [EM, EX, CH, VH, VW, VMIN, VMAX, REM, Q, CM, MM, IN, PC, PT, PX] + +percentage :: Parser Percentage +percentage = Percentage <$> rational <* char '%' + +-- --------------------------------------------------------------------------- +-- Primitives +-- --------------------------------------------------------------------------- + +-- | \ data type parser, but into a String instead of an Int, for other +-- parsers to use (e.g.: see the parsers int, or rational) +int' :: Parser String +int' = do + sign <- option '+' (char '-' <|> char '+') + d <- digits + case sign of + '+' -> pure d + '-' -> pure (sign:d) + _ -> error "int': parsed a number starting with other than [+|-]" + +-- | Parser for \: [+|-][0-9]+ +int :: Parser Int +int = read <$> int' + +digits :: Parser String +digits = many1 digit + +word8 :: Parser Word8 +word8 = read <$> digits + +-- Note that many properties that allow an integer or real number as a value +-- actually restrict the value to some range, often to a non-negative value. +-- +-- | Real numbers parser. \: <'int' integer> | [0-9]*.[0-9]+ +rational :: Parser Rational +rational = do + sign <- option [] (wrapMinus <$> (char '-' <|> char '+')) + dgts <- ((++) <$> digits <*> option "" fractionalPart) + <|> ("0"++) <$> fractionalPart -- append a zero for read not to fail + e <- option [] expo + pure $ fst . head $ readSigned readFloat (sign ++ dgts ++ e) + where fractionalPart = (:) <$> char '.' <*> digits + expo = (:) <$> satisfy (\c -> c == 'e' || c == 'E') <*> int' + wrapMinus x = if x == '-' -- we use this since read fails with leading '+' + then [x] + else [] + +fontStyle :: Parser Value +fontStyle = do + k <- ident + if Set.member k keywords + then pure $ mkOther k + else mzero + where keywords = Set.fromList ["normal", "italic", "oblique"] + +{- +fontWeight :: Parser Value +fontWeight = do + k <- ident + if Set.member k keywords + then pure $ mkOther k + else mzero + where keywords = Set.fromList ["normal", "bold", "lighter", "bolder"] + validNumbers = Set.fromList [100, 200, 300, 400, 500, 600, 700, 800, 900] +-} + +fontSize :: Parser Value +fontSize = fontSizeKeyword + <|> (DistanceV <$> distance) + <|> (PercentageV <$> percentage) + where fontSizeKeyword = do + v1 <- ident + if Set.member v1 keywords + then pure $ mkOther v1 + else mzero + keywords = Set.fromList ["medium", "xx-small", "x-small", "small" + ,"large", "x-large", "xx-large", "smaller" + ,"larger"] + +{- [ [ <‘font-style’> || || <‘font-weight’> || + - <‘font-stretch’> ]? <‘font-size’> [ / <‘line-height’> ]? <‘font-family’> ] | + - caption | icon | menu | message-box | small-caption | status-bar +where = [normal | small-caps] + +-} + +-- TODO clean this parser!! +positionvalue :: Parser Value +positionvalue = PositionV <$> position + +position :: Parser Position +position = pos4 <|> pos2 <|> pos1 + +pos1 :: Parser Position +pos1 = (asciiCI "left" $> (f $ Just PosLeft)) + <|> (asciiCI "center" $> (f $ Just PosCenter)) + <|> (asciiCI "right" $> (f $ Just PosRight)) + <|> (asciiCI "top" $> (f $ Just PosTop)) + <|> (asciiCI "bottom" $> (f $ Just PosBottom)) + <|> ((\a -> Position Nothing a Nothing Nothing) <$> (Just <$> percentageLength)) + where f x = Position x Nothing Nothing Nothing + +pos2 :: Parser Position +pos2 = firstx <|> firsty + where firstx = do + a <- (asciiCI "left" $> (Position (Just PosLeft) Nothing)) + <|> (asciiCI "center" $> (Position (Just PosCenter) Nothing)) + <|> (asciiCI "right" $> (Position (Just PosRight) Nothing)) + <|> ((Position Nothing . Just) <$> percentageLength) + skipComments *> ((asciiCI "top" $> (a (Just PosTop) Nothing)) + <|> (asciiCI "center" $> (a (Just PosCenter) Nothing)) + <|> (asciiCI "bottom" $> (a (Just PosBottom) Nothing)) + <|> ((a Nothing . Just) <$> percentageLength)) + firsty = do + a <- (asciiCI "top" $> (Position (Just PosTop) Nothing)) + <|> (asciiCI "center" $> (Position (Just PosCenter) Nothing)) + <|> (asciiCI "bottom" $> (Position (Just PosBottom) Nothing)) + <|> ((Position Nothing . Just) <$> percentageLength) + skipComments *> ((asciiCI "left" $> (a (Just PosLeft) Nothing)) + <|> (asciiCI "center" $> (a (Just PosCenter) Nothing)) + <|> (asciiCI "right" $> (a (Just PosRight) Nothing)) + <|> ((a Nothing . Just) <$> percentageLength)) + +pos4 :: Parser Position +pos4 = firstx <|> firsty + where posTop = asciiCI "top" $> (Position (Just PosTop)) + posRight = asciiCI "right" $> (Position (Just PosRight)) + posBottom = asciiCI "bottom" $> (Position (Just PosBottom)) + posLeft = asciiCI "left" $> (Position (Just PosLeft)) + firstx = do + x <- (asciiCI "center" $> (Position (Just PosCenter) Nothing)) + <|> ((posLeft <|> posRight) <*> (skipComments *> option Nothing (Just <$> percentageLength))) + _ <- skipComments + (asciiCI "center" $> (x (Just PosCenter) Nothing)) + <|> (((asciiCI "top" $> (x $ Just PosTop)) <|> (asciiCI "bottom" $> (x (Just PosBottom)))) + <*> (skipComments *> option Nothing (Just <$> percentageLength))) + firsty = do + x <- (asciiCI "center" $> (Position (Just PosCenter) Nothing)) + <|> ((posTop <|> posBottom) <*> (skipComments *> option Nothing (Just <$> percentageLength))) + _ <- skipComments + (asciiCI "center" $> (x (Just PosCenter) Nothing)) + <|> (((asciiCI "left" $> (x $ Just PosLeft)) <|> (asciiCI "right" $> (x (Just PosRight)))) + <*> (skipComments *> option Nothing (Just <$> percentageLength))) + +{- +transformOrigin :: Parser Values +transformOrigin = twoVal <|> oneVal + where oneVal = (singleValue numericalvalue) <|> offsetKeyword + offsetKeyword = do + v1 <- ident + if v1 == "top" || v1 == "right" || v1 == "bottom" || v1 == "left" || v1 == "center" + then pure $ mkValues [mkOther v1] + else mzero + twoVal = do + (v1, v2) <- ((,) <$> yAxis <*> (skipComments *> (xAxis <|> numericalvalue))) + <|> ((,) <$> xAxis <*> (skipComments *> (yAxis <|> numericalvalue))) + <|> ((,) <$> numericalvalue <*> (skipComments *> (yAxis <|> xAxis))) + option (mkValues [v1,v2]) ((\x -> mkValues [v1,v2, DistanceV x]) <$> distance) + yAxis = do + v1 <- ident + if v1 == "top" || v1 == "bottom" || v1 == "center" + then pure $ mkOther v1 + else mzero + xAxis = do + v1 <- ident + if v1 == "right" || v1 == "left" || v1 == "center" + then pure $ mkOther v1 + else mzero +-} + +bgSize :: Parser BgSize +bgSize = twovaluesyntax <|> contain <|> cover + where cover = asciiCI "cover" $> Cover + contain = asciiCI "contain" $> Contain + twovaluesyntax = do + v1 <- (Left <$> percentageLength) <|> (Right <$> auto) + _ <- skipComments + v2 <- option Nothing (Just <$> ((Left <$> percentageLength) <|> (Right <$> auto))) + pure $ BgSize v1 v2 + +bgAttachment :: Parser TextV +bgAttachment = matchKeywords ["scroll", "fixed", "local"] + +box :: Parser TextV +box = matchKeywords ["border-box", "padding-box", "content-box"] + +-- [ , ]* +background :: Parser Values +background = do + xs <- many (bgLayer <* char ',' <* skipComments) + x <- finalBgLayer + pure $ if null xs + then Values x [] + else Values (head xs) (fmap (Comma,) $ tail xs ++ [x]) + +-- = || [ / ]? || || || || || <'background-color'> +finalBgLayer :: Parser Value +finalBgLayer = do + layer <- permute (mkFinalBgLayer <$?> (Nothing, Just <$> image <* skipComments) + <|?> (Nothing, Just <$> positionAndBgSize <* skipComments) + <|?> (Nothing, Just <$> repeatStyle <* skipComments) + <|?> (Nothing, Just <$> bgAttachment <* skipComments) + <|?> (Nothing, Just <$> box <* skipComments) + <|?> (Nothing, Just <$> box <* skipComments) + <|?> (Nothing, Just <$> color <* skipComments)) + if finalBgLayerIsEmpty layer + then mzero + else pure layer + where finalBgLayerIsEmpty (FinalBgLayer Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing) = True + finalBgLayerIsEmpty _ = False + -- parameters e and f are being swapped to deal with the permutation + -- changing the original order of the parsed values. + mkFinalBgLayer a Nothing c d e f g = FinalBgLayer a Nothing Nothing c d f e g + mkFinalBgLayer a (Just (p,s)) c d e f g = FinalBgLayer a (Just p) s c d f e g + +-- = || [ / ]? || || || {1,2} +bgLayer :: Parser Value +bgLayer = do + layer <- permute (mkBgLayer <$?> (Nothing, Just <$> image <* skipComments) + <|?> (Nothing, Just <$> positionAndBgSize <* skipComments) + <|?> (Nothing, Just <$> repeatStyle <* skipComments) + <|?> (Nothing, Just <$> bgAttachment <* skipComments) + <|?> (Nothing, Just <$> box2 <* skipComments)) + if bgLayerIsEmpty layer + then mzero + else pure layer + where bgLayerIsEmpty (BgLayer Nothing Nothing Nothing Nothing Nothing Nothing Nothing) = True + bgLayerIsEmpty _ = False + mkBgLayer a Nothing c d Nothing = BgLayer a Nothing Nothing c d Nothing Nothing + mkBgLayer a (Just (p,s)) c d Nothing = BgLayer a (Just p) s c d Nothing Nothing + mkBgLayer a Nothing c d (Just (i,j)) = BgLayer a Nothing Nothing c d (Just i) j + mkBgLayer a (Just (p,s)) c d (Just (i,j)) = BgLayer a (Just p) s c d (Just i) j + box2 :: Parser (TextV, Maybe TextV) + box2 = do + x <- box <* skipComments + y <- option Nothing (Just <$> box) + pure (x,y) + +-- used for the background property, which takes among other things: +-- [ / ]? +positionAndBgSize :: Parser (Position, Maybe BgSize) +positionAndBgSize = do + x <- position <* skipComments + y <- option Nothing (Just <$> (char '/' *> skipComments *> bgSize)) + pure (x,y) + +matchKeywords :: [Text] -> Parser TextV +matchKeywords listOfKeywords = do + i <- ident + if T.toCaseFold i `elem` Set.fromList listOfKeywords + then pure $ TextV i + else mzero + +-- = | | | | | +image :: Parser Value +image = do + i <- ident + let lowercased = T.toLower i + if lowercased == "none" + then pure $ mkOther "none" + else do _ <- char '(' + if Set.member lowercased possibilities + then fromMaybe mzero (Map.lookup lowercased functionsMap) + else mzero + where possibilities = Set.fromList $ map T.toCaseFold + ["url", "element", "linear-gradient", "radial-gradient"] + +transition :: Parser Values +transition = parseCommaSeparated singleTransition + +-- [ none | ] ||