diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# `css-selectors` Changelog + +For a full list of changes, see the history on [GitHub](https://github.com/hapytex/css-selectors). + +## Version 0.2.0.0 + +The first version that is deployed on Hackage. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Willem Van Onsem (c) 2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Willem Van Onsem nor the names of other + 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 +OWNER 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,158 @@ +# css-selectors + +[![Build Status of the package by Travis](https://travis-ci.com/hapytex/css-selectors.svg?branch=master)](https://travis-ci.com/hapytex/css-selectors) + +A library for parsing, manipulating, and rendering css selectors (not css files, +just the selectors). + +It has a *quasiquoter* to enable Haskell to validate the css selector at compile +time. + +Currently the css grammar is implemented *without* the pseudo-classes, +pseudo-elements and negations. One can furthermore calculate the specificity of +a css-selector, and thus perform an analysis over what css-selector will take +precedence. + +The package documentation can be found on the [GitHub pages](https://hapytex.github.io/css-selectors/). + +## Selector structure + +A css selector has the following structure: + + 1. a `SelectorGroup` is a group of one or more `Selector`s, these are + *comma-separated*; + 2. A `Selector` is a custom linked list implementation where the "cons" (the + `Combined` data constructor) contains a besides a reference to a + `SelectorSequence` (head) and a `Selector` (tail), it specifies what + `SelectorCombinator` is used. A `Selector` has at least one + `SelectorSequence`, this is constructoed with the `Selector` data + constructor; + 3. A `SelectorSequence` contains a `TypeSelector` (in case the `TypeSelector` + is `Universal`, this does not need to be part of the css-selector + expression); and a set of zero or more `SelectorFilter`s; + 4. A `SelectorFilter` is a `Hash`, a `Class`, or an `Attrib`; + 5. Both a `TypeSelector` and an `AttributeName` have a namespace. A namespace + can be any (`*`), empty, or a namespace (which should be a valid + identifier); + 6. A `Hash` is a valid identifier prepended with a number sign (`#`); + 7. A `Class` is a valid identifier prepended with a dot (`.`); + 8. An `Attribute` can be an `Exist` object that imposes a constraint that the + attribute should exist for the given tag, or an `Attrib` that specifies + that the attribute exists, and that the value for this attribute satisfies + a given constraint. This constraint is determined by the + `AttributeCombinator` and the value of the `Attrib` object. + +## Quasiquoter + +The main use of this package is a *quasiquoter*, that can be used both for +*expressions* and *patterns*. We thus can construct a `SelectorGroup` in an +expression with: + +```haskell +myCssSelector :: SelectorGroup +myCssSelector = [csssel|* html .pun .inbox, * html .pun #bdrdmain, * html .pun .infldset|] +``` + +A less common use case is using the quasiquoter in a pattern to check if a given +`SelectorGroup` matches *exactly* with a given css selector. For example: + +```haskell +isMyCssSelector :: SelectorGroup -> Bool +isMyCssSelector [csssel|* html .pun .unbox|] = True +isMyCssSelector _ = False +``` + +The quasiquoter can be used in a type signature as well, but will always, +regardless of the content, return the type for `SelectorGroup`. If you use the +quasiquoter as a declaration, it will simply not generate any declarations. It +will raise a warning (not an error) about this. + +Perhaps in the (far) future, we will make more sensical implementations for the +type and declaration part of the quasiquoter. + +Note that you need to enable the `-XQuasiQuotes` pragma when you compile. + +## Selector normalization + +One can turn equivalent css selectors in a "normalized" form. This is done by +sorting the `Selector`s in a `Selector` group, and sorting the `SelectorFilter`s +of a certain `SelectorSequence`. + +The order is determined by the default instances of `Ord` of the sequences. This +is thus not an "inherent" ordering of the css selector, but just an order that +the program constructed to convert multiple css selectors that are equivalent +same to a normal form in which these are equal. + +We here do *not* optimize the css selector, for example by removing duplicate +filters, since that can have impact on the specificity of the selector. + +## Selector specificity + +The specificity of a selector is defined by three numbers *a*, *b* and *c*. +Later, one calculates the specificity level with *100 a + 10 b + c*. The higher +the specificity level, the more it takes precedence. If there are thus two +selectors and the former selector has *14* as specificity level, and the latter +has *42* as specificity level, then rules defined in the latter, will "overrule" +the rules defined in the former, given these rules "clash". + +One can calculate the specificity of a item with as type a member of the `ToCssSelector` +class with: + +```haskell +specificity :: ToCssSelector a => a -> Int +``` + +or you can obtain a more detailed result with: + +```haskell +specificity' :: ToCssSelector a => a -> SelectorSpecificity +``` + +## `ToMarkup`, `ToJSON`, and `ToJavascript` instances + +The types that are members of the `ToCssSelector` are members of the `ToMarkup`, +`ToJSON`, and `ToJavascript` type classes as well, such that we can conveniently +use these in blaze HTML and for example in *Hamlet*. + +The `ToMarkup` instance will render the css selector as raw content. So if you +add this as an attribute, the css selector will appear, unescaped, in the +rendered page. Note that it will be escaped, so `foo > bar` will be generated as +`foo > bar`. + +The `ToJSON` instance will convert the given object in a JSON string that +contains the css selector. + +The `ToJavascript` will render the content to a javascript *string*. So if you +use this in hamlet, you generate a string that contains the css-selector. This +is often useful, since javascript itself has no syntax for css selectors, and +often strings are used to represent these. + +## `Arbitrary` css selectors + +One can generate arbitrary CSS selectors (and their subcomponents). It is +however not advisable to use this for anything other than for validation +purposes (like with `QuickCheck`). + +## `css-selectors` is not *safe* Haskell + +There are not extensions that are used that make the library *itself* +unsafe, but it makes use of `aeson`, `blaze-markup`, etc. and the packages are +not safe. Hence this package is not *safe Haskell*. + +## Future plans + +We want to implement an extra quasiquoter with the ability to specify variables, +that can then be used in expressions, or in patterns. + +## Contribute + +You can contribute by making a pull request on the [*GitHub +repository*](https://github.com/hapytex/css-selectors). + +You can contact the package maintainer by sending a mail to +[`hapytexeu+gh@gmail.com`](mailto:hapytexeu+gh@gmail.com). + +--- + +This package is dedicated in loving memory to my mother, *Veerle Dumon* +(1958-2019), in the hope that eventually it will be as stylish as she was. 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/css-selectors.cabal b/css-selectors.cabal new file mode 100644 --- /dev/null +++ b/css-selectors.cabal @@ -0,0 +1,70 @@ +name: css-selectors +version: 0.2.0.0 +synopsis: Parsing, rendering and manipulating css selectors in Haskell. +description: + A library for parsing, manipulating, and rendering css selectors (not css files, + just the selectors). + . + It has a /quasiquoter/ to enable Haskell to validate the css selector at compile + time. + . + Currently the css grammar is implemented /without/ the pseudo-classes, + pseudo-elements and negations. One can furthermore calculate the specificity of + a css-selector, and thus perform an analysis over what css-selector will take + precedence. +homepage: https://github.com/hapytex/css-selectors#readme +license: BSD3 +license-file: LICENSE +author: Willem Van Onsem +maintainer: hapytexeu+gh@gmail.com +copyright: 2019 Willem Van Onsem +category: web +build-type: Simple +extra-source-files: + README.md + , CHANGELOG.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: + Css.Selector + , Css.Selector.Core + , Css.Selector.QuasiQuoters + , Css.Selector.Utils + other-modules: + Css.Selector.Lexer + , Css.Selector.Parser + build-depends: + base >=4.7 && <5 + , aeson >=1.0 && <2 + , array >=0.5.3.0 && <0.5.4.0 + , blaze-markup >=0.8 && <0.9 + , data-default >=0.7 && <0.8 + , Decimal >=0.5.1 && <0.5.2 + , QuickCheck >=2.13 && <2.14 + , shakespeare >=2.0 && <3.0 + , template-haskell >=2.12.0 && <2.16.0 + , text >=1.1 && <1.3 + build-tools: + alex + , happy + default-language: Haskell2010 + +test-suite css-selectors-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: + base + , css-selectors + , text + , test-framework + , test-framework-quickcheck2 + , QuickCheck + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/hapytex/css-selectors diff --git a/src/Css/Selector.hs b/src/Css/Selector.hs new file mode 100644 --- /dev/null +++ b/src/Css/Selector.hs @@ -0,0 +1,18 @@ +{-| +Module : Css.Selector +Description : Css selectors in Haskell. +Maintainer : hapytexeu+gh@gmail.com +Stability : experimental +Portability : POSIX + +A module to define css selectors by making use of a quasiquoter, and manipulating these css selectors. +-} +module Css.Selector ( + module Css.Selector.Core, + module Css.Selector.QuasiQuoters, + module Css.Selector.Utils + ) where + +import Css.Selector.Core +import Css.Selector.QuasiQuoters +import Css.Selector.Utils diff --git a/src/Css/Selector/Core.hs b/src/Css/Selector/Core.hs new file mode 100644 --- /dev/null +++ b/src/Css/Selector/Core.hs @@ -0,0 +1,686 @@ +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, PatternSynonyms, TemplateHaskellQuotes, TypeFamilies #-} + +{-| +Module : Css.Selector.Core +Description : A module where we define the tree of types to represent and maniplate a css selector. +Maintainer : hapytexeu+gh@gmail.com +Stability : experimental +Portability : POSIX + +A module that defines the tree of types to represent and manipulate a css selector. These data types are members of several typeclasses to make these more useful. +-} +module Css.Selector.Core ( + -- * ToCssSelector typeclass + ToCssSelector(..) + -- * Selectors and combinators + , Selector(..) + , SelectorCombinator(..), SelectorGroup(..) + , SelectorSequence(..) + , combinatorText, combine + , (.>), (.+), (.~) + -- * Filters + , SelectorFilter(..), filters, filters', addFilters, (.:) + -- * Namespaces + , Namespace(..), pattern NEmpty + -- * Type selectors + , ElementName(..), TypeSelector(..), pattern Universal, (.|) + -- * Attributes + , Attrib(..), AttributeCombinator(..), AttributeName(..), AttributeValue + , (.=), (.~=), (.|=), (.^=), (.$=), (.*=) + , attrib, attributeCombinatorText + -- * Classes + , Class(..), (...) + -- * Hashes + , Hash(..), (.#) + -- * Specificity + , SelectorSpecificity(..), specificity, specificityValue + ) where + +-- based on https://www.w3.org/TR/2018/REC-selectors-3-20181106/#w3cselgrammar + +import Css.Selector.Utils(encodeIdentifier, encodeText, toIdentifier) + +import Data.Aeson(Value(String), ToJSON(toJSON)) +import Data.Data(Data) +import Data.Default(Default(def)) +import Data.Function(on) +import Data.List(sort, unfoldr) +import Data.List.NonEmpty(NonEmpty((:|))) +import qualified Data.List.NonEmpty +import Data.Ord(comparing) +import Data.String(IsString(fromString)) +import Data.Text(Text, cons, intercalate, pack, unpack) + +import GHC.Exts(IsList(Item, fromList, toList)) + +import Language.Haskell.TH.Lib(appE, conE) +import Language.Haskell.TH.Syntax(Lift(lift), Exp(AppE, ConE, LitE), Lit(StringL), Name, Pat(ConP, ListP, ViewP), Q) + +import Test.QuickCheck.Arbitrary(Arbitrary(arbitrary), arbitraryBoundedEnum) +import Test.QuickCheck.Gen(Gen, frequency, listOf, listOf1, oneof) + +import Text.Blaze(ToMarkup(toMarkup), text) +import Text.Blaze.Internal(Markup) +import Text.Julius(Javascript, ToJavascript(toJavascript)) + +-- | A datastructure that specifies the selectivity of a css selector. The +-- specificity is calculated based on three integers: @a@, @b@ and @c@. +-- +-- The specificity is calculated with @100*a+10*b+c@ where @a@, @b@ and @c@ +-- count certain elements of the css selector. +data SelectorSpecificity = + SelectorSpecificity Int Int Int -- ^ Create a 'SelectorSpecificity' object with a given value for @a@, @b@, and @c@. + deriving (Data, Show) + +-- | Calculate the specificity value of the 'SelectorSpecificity' +specificityValue :: SelectorSpecificity -- ^ The 'SelectorSpecificity' to calculate the specificity value from. + -> Int -- ^ The specificity level of the 'SelectorSpecificity'. If the value is higher, the rules in the css selector take precedence. +specificityValue (SelectorSpecificity a b c) = 100*a + 10*b + c + +-- | A class that defines that the given type can be converted to a css selector +-- value, and has a certain specificity. +class ToCssSelector a where + -- | Convert the given element to a 'Text' object that contains the css + -- selector. + toCssSelector :: a -- ^ The given object for which we calculate the css selector. + -> Text -- ^ The css selector text for the given object. + + -- | Lift the given 'ToCssSelector' type object to a 'SelectorGroup', which + -- is the "root type" of the css selector hierarchy. + toSelectorGroup :: a -- ^ The item to lift to a 'SelectorGroup' + -> SelectorGroup -- ^ The value of a 'SelectorGroup' of which the object is the selective part. + + -- | Calculate the specificity of the css selector by returing a + -- 'SelectorSpecificity' object. + specificity' :: a -- ^ The item for which we calculate the specificity level. + -> SelectorSpecificity -- ^ The specificity level of the given item. + -- Convert the given 'ToCssSelector' item to a 'Pat' pattern, such that we + -- can use it in functions. + toPattern :: a -- ^ The item to convert to a 'Pat'. + -> Pat -- ^ The pattern that is generated that will match only items equal to the given object. + -- Convert the given 'ToCssSelector' item to an item in a more normalized + -- form. A normalization is /idempotent/: applying this multiple times will + -- have the same effect as applying it once. + normalize :: a -- ^ The item to normalize. + -> a -- ^ A normalized variant of the given item. This will filter the same objects, and have the same specificity. + normalize = id + {-# MINIMAL toCssSelector, toSelectorGroup, specificity', toPattern #-} + +-- | Calculate the specificity of a 'ToCssSelector' type object. This is done by +-- calculating the 'SelectorSpecificity' object, and then calculating the value +-- of that object. +specificity :: ToCssSelector a => a -- ^ The object for which we evaluate the specificity. + -> Int -- ^ The specificity level as an 'Int' value. +specificity = specificityValue . specificity' + +-- | The root type of a css selector. This is a comma-separated list of +-- selectors. +newtype SelectorGroup = SelectorGroup { + unSelectorGroup :: NonEmpty Selector -- ^ Unwrap the given 'NonEmpty' list of 'Selector's from the 'SelectorGroup' object. + } deriving (Data, Eq, Ord, Show) + +-- | The type of a single selector. This is a sequence of 'SelectorSequence's that +-- are combined with a 'SelectorCombinator'. +data Selector = + Selector SelectorSequence -- ^ Convert a given 'SelectorSequence' to a 'Selector'. + | Combined SelectorSequence SelectorCombinator Selector -- ^ Create a combined selector where we have a 'SelectorSequence' that is combined with a given 'SelectorCombinator' to a 'Selector'. + deriving (Data, Eq, Ord, Show) + + +-- | A type that contains the possible ways to combine 'SelectorSequence's. +data SelectorCombinator = + Descendant -- ^ The second tag is a descendant of the first one, denoted in css with a space. + | Child -- ^ The second tag is the (direct) child of the first one, denoted with a @>@ in css. + | DirectlyPreceded -- ^ The second tag is directly preceded by the first one, denoted with a @+@ in css. + | Preceded -- ^ The second tag is preceded by the first one, denoted with a @~@ in css. + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show) + +-- | Convert the 'SelectorCombinator' to the equivalent css selector text. A +-- space for 'Descendant', a @>@ for 'Child', a @+@ for 'DirectlyPreceded', and +-- a @~@ for 'Preceded' +combinatorText :: SelectorCombinator -- ^ The given 'SelectorCombinator' to retrieve the css token for. + -> Text -- ^ The css selector token that is used for the given 'SelectorCombinator'. +combinatorText Descendant = " " +combinatorText Child = " > " +combinatorText DirectlyPreceded = " + " +combinatorText Preceded = " ~ " + +-- | Combines two 'Selector's with the given 'SelectorCombinator'. +combine :: SelectorCombinator -- ^ The 'SelectorCombinator' that is applied between the two 'Selector's. + -> Selector -- ^ The left 'Selector'. + -> Selector -- ^ The right 'Selector'. + -> Selector -- ^ A 'Selector' that is a combination of the left 'Selector' and the right 'Selector' with the given 'SelectorCombinator'. +combine c0 x0 ys = go x0 + where go (Selector x) = Combined x c0 ys + go (Combined s1 c s2) = Combined s1 c (go s2) + +-- | Combines two 'Selector's with the 'Child' combinator. +(.>) :: Selector -- ^ The left 'Selector'. + -> Selector -- ^ The right 'Selector'. + -> Selector -- ^ A selector that is the combination of the left 'Selector' and the right 'Selector' through 'Child'. +(.>) = combine Child + +-- | Combines two 'Selector's with the 'DirectlyPreceded' combinator. +(.+) :: Selector -- ^ The left 'Selector'. + -> Selector -- ^ The right 'Selector'. + -> Selector -- ^ A selector that is the combination of the left 'Selector' and the right 'Selector' through 'DirectlyPreceded'. +(.+) = combine DirectlyPreceded + +-- | Combines two 'Selector's with the 'Preceded' combinator. +(.~) :: Selector -- ^ The left 'Selector'. + -> Selector -- ^ The right 'Selector'. + -> Selector -- ^ A selector that is the combination of the left 'Selector' and the right 'Selector' through 'Preceded'. +(.~) = combine Preceded + +-- | A 'SelectorSequence' is a 'TypeSelector' (that can be 'Universal') followed +-- by zero, one or more 'SelectorFilter's these filter the selector further, for +-- example with a 'Hash', a 'Class', or an 'Attrib'. +data SelectorSequence = + SimpleSelector TypeSelector -- ^ Convert a 'TypeSelector' into a 'SimpleSelector'. + | Filter SelectorSequence SelectorFilter -- ^ Apply an additional 'SelectorFilter' to the 'SelectorSequence'. + deriving (Data, Eq, Ord, Show) + +-- | Add a given list of 'SelectorFilter's to the given 'SelectorSequence'. The +-- filters are applied left-to-right. +addFilters :: SelectorSequence -- ^ The 'SelectorSequence' to apply the filter on. + -> [SelectorFilter] -- ^ The list of 'SelectorFilter's to apply on the 'SelectorSequence'. + -> SelectorSequence -- ^ A modified 'SelectorSequence' where we applied the list of 'SelectorFilter's. +addFilters = foldl Filter + +-- | An infix variant of the 'addFilters' function. +(.:) :: SelectorSequence -- ^ The 'SelectorSequence' to apply the filter on. + -> [SelectorFilter] -- ^ The list of 'SelectorFilter's to apply on the 'SelectorSequence'. + -> SelectorSequence -- ^ A modified 'SelectorSequence' where we applied the list of 'SelectorFilter's. +(.:) = addFilters + +-- | Obtain the list of filters that are applied in the given 'SelectorSequence' +-- in /reversed/ order. +filters' :: SelectorSequence -- ^ The given 'SelectorSequence' to analyze. + -> [SelectorFilter] -- ^ The given list of 'SelectorFilter's applied in /reversed/ order, this can be empty. +filters' = unfoldr go + where go (Filter s f) = Just (f, s) + go (SimpleSelector _) = Nothing + +-- | Obtain the list of filters that are applied in the given +-- 'SelectorSequence'. +filters :: SelectorSequence -- ^ The given 'SelectorSequence' to analyze. + -> [SelectorFilter] -- ^ The given list of 'SelectorFilter's applied, this can be empty. +filters = reverse . filters' + +-- | A type that sums up the different ways to filter a type selector: with an +-- id (hash), a class, and an attribute. +data SelectorFilter = + SHash Hash -- ^ A 'Hash' object as filter. + | SClass Class -- ^ A 'Class' object as filter. + | SAttrib Attrib -- ^ An 'Attrib' object as filter. + deriving (Data, Eq, Ord, Show) + +-- | A css attribute can come in two flavors: either a constraint that the +-- attribute should exists, or a constraint that a certain attribute should have +-- a certain value (prefix, suffix, etc.). +data Attrib = + Exist AttributeName -- ^ A constraint that the given 'AttributeName' should exist. + | Attrib AttributeName AttributeCombinator AttributeValue -- ^ A constraint about the value associated with the given 'AttributeName'. + deriving (Data, Eq, Ord, Show) + +-- | A flipped version of the 'Attrib' data constructor, where one first +-- specifies the conbinator, then the 'AttributeName' and finally the value. +attrib :: AttributeCombinator -- ^ The 'AttributeCombinator' that specifies the required relation between the attribute and a value. + -> AttributeName -- ^ The name of an attribute to filter. + -> AttributeValue -- ^ The value of the attribute to filter. + -> Attrib -- ^ The result is an 'Attrib' object that will filter the given 'AttributeName' with the given 'AttributeCombinator'. +attrib = flip Attrib + +-- | Create an 'Attrib' where the given 'AttributeName' is constrainted to be +-- exactly the given value. +(.=) :: AttributeName -- ^ The name of the attribute to constraint. + -> AttributeValue -- ^ The value that constraints the attribute. + -> Attrib -- ^ The 'Attrib' object we construct with the given name and value. +(.=) = attrib Exact + +-- | Create an 'Attrib' where the given 'AttributeName' is constrainted such +-- that the attribute is a whitespace seperated list of items, and the value is +-- one of these items. +(.~=) :: AttributeName -- ^ The name of the attribute to constraint. + -> AttributeValue -- ^ The value that constraints the attribute. + -> Attrib -- ^ The 'Attrib' object we construct with the given name and value. +(.~=) = attrib Include + +-- | Create an 'Attrib' where the given 'AttributeName' is constrainted such +-- that the attribute is a dash seperated list of items, and the value is +-- the first of these items. +(.|=) :: AttributeName -- ^ The name of the attribute to constraint. + -> AttributeValue -- ^ The value that constraints the attribute. + -> Attrib -- ^ The 'Attrib' object we construct with the given name and value. +(.|=) = attrib DashMatch + +-- | Create an 'Attrib' where the given 'AttributeName' is constrainted such +-- that the attribute has as prefix the given 'AttributeValue'. +(.^=) :: AttributeName -- ^ The name of the attribute to constraint. + -> AttributeValue -- ^ The value that constraints the attribute. + -> Attrib -- ^ The 'Attrib' object we construct with the given name and value. +(.^=) = attrib PrefixMatch + +-- | Create an 'Attrib' where the given 'AttributeName' is constrainted such +-- that the attribute has as suffix the given 'AttributeValue'. +(.$=) :: AttributeName -- ^ The name of the attribute to constraint. + -> AttributeValue -- ^ The value that constraints the attribute. + -> Attrib -- ^ The 'Attrib' object we construct with the given name and value. +(.$=) = attrib SuffixMatch + +-- | Create an 'Attrib' where the given 'AttributeName' is constrainted such +-- that the attribute has as substring the given 'AttributeValue'. +(.*=) :: AttributeName -- ^ The name of the attribute to constraint. + -> AttributeValue -- ^ The value that constraints the attribute. + -> Attrib -- ^ The 'Attrib' object we construct with the given name and value. +(.*=) = attrib SubstringMatch + +-- | Filter a given 'SelectorSequence' with a given 'Hash'. +(.#) :: SelectorSequence -- ^ The given 'SelectorSequence' to filter. + -> Hash -- ^ The given 'Hash' to filter the 'SelectorSequence' further. + -> SelectorSequence -- ^ A 'SelectorSequence' that is filtered additionally with the given 'Hash'. +(.#) = (. SHash) . Filter + +-- | Filter a given 'SelectorSequence' with a given 'Class'. +(...) :: SelectorSequence -- ^ The given 'SelectorSequence to filter. + -> Class -- ^ The given 'Class' to filter the 'SelectorSequence' further. + -> SelectorSequence -- ^ A 'SelectorSequence' that is filtered additionally with the given 'Class'. +(...) = (. SClass) . Filter + +-- | Construct a 'TypeSelector' with a given 'Namespace' and 'ElementName'. +(.|) :: Namespace -- ^ The 'Namespace' for the 'TypeSelector'. + -> ElementName -- ^ The 'ElementName' for the 'TypeSelector'. + -> TypeSelector -- ^ A 'TypeSelector' object constructed with the 'Namespace' and 'ElementName'. +(.|) = TypeSelector + +-- | The namespace of a css selector tag. The namespace can be 'NAny' (all +-- possible namespaces), or a namespace with a given text (this text can be +-- empty). +data Namespace = + NAny -- ^ A typeselector part that specifies that we accept all namespaces, in css denoted with @*@. + | Namespace Text -- ^ A typselector part that specifies that we accept a certain namespace name. + deriving (Data, Eq, Ord, Show) + +-- | The empty namespace. This is /not/ the wildcard namespace (@*@). This is a +-- bidirectional namespace and can thus be used in expressions as well. +pattern NEmpty :: Namespace +pattern NEmpty = Namespace "" + +-- | The element name of a css selector tag. The element name can be 'EAny' (all +-- possible tag names), or an element name with a given text. +data ElementName = + EAny -- ^ A typeselector part that specifies that we accept all element names, in css denoted with @*@. + | ElementName Text -- ^ A typeselector part that specifies that we accept a certain element name. + deriving (Data, Eq, Ord, Show) + +-- | A typeselector is a combination of a selector for a namespace, and a +-- selector for an element name. One, or both can be a wildcard. +data TypeSelector = TypeSelector { + selectorNamespace :: Namespace, -- ^ The selector for the namespace. + elementName :: ElementName -- ^ The selector for the element name. + } deriving (Data, Eq, Ord, Show) + +-- | An attribute name is a name that optionally has a namespace, and the name +-- of the attribute. +data AttributeName = AttributeName { + attributeNamespace :: Namespace, -- ^ The namespace to which the attribute name belongs. This can be 'NAny' as well. + attributeName :: Text -- ^ The name of the attribute over which we make a claim. + } deriving (Data, Eq, Ord, Show) + +-- | We use 'Text' as the type to store an attribute value. +type AttributeValue = Text + +-- | The possible ways to match an attribute with a given value in a css +-- selector. +data AttributeCombinator = + Exact -- ^ The attribute has exactly the value of the value, denoted with @=@ in css. + | Include -- ^ The attribute has a whitespace separated list of items, one of these items is the value, denoted with @~=@ in css. + | DashMatch -- ^ The attribute has a hyphen separated list of items, the first item is the value, denoted with @|=@ in css. + | PrefixMatch -- ^ The value is a prefix of the value in the attribute, denoted with @^=@ in css. + | SuffixMatch -- ^ The value is a suffix of the value in the attribute, denoted with @$=@ in css. + | SubstringMatch -- ^The value is a substring of the value in the attribute, denoted with @*=@ in css. + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show) + +-- | A css class, this is wrapped in a data type. The type only wraps the class +-- name, not the dot prefix. +newtype Class = Class { + unClass :: Text -- ^ Obtain the name from the class. + } deriving (Data, Eq, Ord, Show) + +-- | A css hash (used to match an element with a given id). The type only wraps +-- the hash name, not the hash (@#@) prefix. +newtype Hash = Hash { + unHash :: Text -- ^ Obtain the name from the hash. + } deriving (Data, Eq, Ord, Show) + +-- | Convert the given 'AttributeCombinator' to its css selector counterpart. +attributeCombinatorText :: AttributeCombinator -- ^ The 'AttributeCombinator' for which we obtain the corresponding css selector text. + -> AttributeValue -- ^ The css selector text for the given 'AttributeCombinator'. +attributeCombinatorText Exact = "=" +attributeCombinatorText Include = "~=" +attributeCombinatorText DashMatch = "|=" +attributeCombinatorText PrefixMatch = "^=" +attributeCombinatorText SuffixMatch = "$=" +attributeCombinatorText SubstringMatch = "*=" + +-- | The universal type selector: a selector that matches all types in all +-- namespaces (including the empty namespace). This pattern is bidirectional +-- and thus can be used in expressions as well. +pattern Universal :: TypeSelector +pattern Universal = TypeSelector NAny EAny + +-- Semigroup and Monoid instances +instance Semigroup SelectorSpecificity where + SelectorSpecificity a1 b1 c1 <> SelectorSpecificity a2 b2 c2 = SelectorSpecificity (a1+a2) (b1+b2) (c1+c2) + +instance Semigroup SelectorGroup where + SelectorGroup g1 <> SelectorGroup g2 = SelectorGroup (g1 <> g2) + +instance Semigroup Selector where + (<>) = combine def + +instance Semigroup Namespace where + (<>) NAny = id + (<>) x = const x + +instance Semigroup ElementName where + (<>) EAny = id + (<>) x = const x + +instance Monoid SelectorSpecificity where + mempty = SelectorSpecificity 0 0 0 + +instance Monoid Namespace where + mempty = NAny + +instance Monoid ElementName where + mempty = EAny + +-- IsString instances +instance IsString Class where + fromString = toIdentifier Class + +instance IsString Hash where + fromString = toIdentifier Hash + +instance IsString Namespace where + fromString = toIdentifier Namespace + +instance IsString ElementName where + fromString = toIdentifier ElementName + +instance IsString AttributeName where + fromString = toIdentifier (AttributeName NAny) + +instance IsString Attrib where + fromString = Exist . fromString + +-- IsList instances +instance IsList SelectorGroup where + type Item SelectorGroup = Selector + fromList = SelectorGroup . fromList + toList (SelectorGroup ss) = toList ss + +-- ToCssSelector instances +_textToPattern :: Text -> Pat +_textToPattern t = ViewP (AppE (ConE '(==)) (AppE (ConE 'pack) (LitE (StringL (unpack t))))) (_constantP 'True) + +_constantP :: Name -> Pat +_constantP = flip ConP [] + +instance ToCssSelector SelectorGroup where + toCssSelector (SelectorGroup g) = intercalate " , " (map toCssSelector (toList g)) + toSelectorGroup = id + specificity' (SelectorGroup g) = foldMap specificity' g + toPattern (SelectorGroup g) = ConP 'SelectorGroup [go g] + where go (x :| xs) = ConP '(:|) [toPattern x, ListP (map toPattern xs)] + normalize (SelectorGroup g) = SelectorGroup (Data.List.NonEmpty.sort (normalize <$> g)) + +instance ToCssSelector Class where + toCssSelector = cons '.' . encodeIdentifier . unClass + toSelectorGroup = toSelectorGroup . SClass + specificity' = const (SelectorSpecificity 0 1 0) + toPattern (Class c) = ConP 'Class [_textToPattern c] + +instance ToCssSelector Attrib where + toCssSelector (Exist name) = "[" <> toCssSelector name <> "]" + toCssSelector (Attrib name op val) = "[" <> toCssSelector name <> attributeCombinatorText op <> encodeText '"' val <> "]" + toSelectorGroup = toSelectorGroup . SAttrib + specificity' = const (SelectorSpecificity 0 1 0) + toPattern (Exist name) = ConP 'Exist [toPattern name] + toPattern (Attrib name op val) = ConP 'Attrib [toPattern name, _constantP (go op), _textToPattern val] + where go Exact = 'Exact + go Include = 'Include + go DashMatch = 'DashMatch + go PrefixMatch = 'PrefixMatch + go SuffixMatch = 'SuffixMatch + go SubstringMatch = 'SubstringMatch + +instance ToCssSelector AttributeName where + toCssSelector (AttributeName NAny e) = encodeIdentifier e + toCssSelector (AttributeName n e) = toCssSelector n <> "|" <> encodeIdentifier e + toSelectorGroup = toSelectorGroup . Exist + specificity' = mempty + toPattern (AttributeName n a) = ConP 'AttributeName [toPattern n, _textToPattern a] + +instance ToCssSelector Hash where + toCssSelector = cons '#' . encodeIdentifier . unHash + toSelectorGroup = toSelectorGroup . SHash + specificity' = const (SelectorSpecificity 1 0 0) + toPattern (Hash h) = ConP 'Hash [_textToPattern h] + +instance ToCssSelector Namespace where + toCssSelector NAny = "*" + toCssSelector (Namespace t) = encodeIdentifier t + toSelectorGroup = toSelectorGroup . flip TypeSelector EAny + specificity' = mempty + toPattern NAny = _constantP 'NAny + -- used to make patterns more readable + toPattern NEmpty = _constantP 'NEmpty + toPattern (Namespace t) = ConP 'Namespace [_textToPattern t] + +instance ToCssSelector SelectorSequence where + toCssSelector (SimpleSelector s) = toCssSelector s + toCssSelector (Filter s f) = toCssSelector s <> toCssSelector f + toSelectorGroup = toSelectorGroup . Selector + specificity' (SimpleSelector s) = specificity' s + specificity' (Filter s f) = specificity' s <> specificity' f + toPattern (SimpleSelector s) = ConP 'SimpleSelector [toPattern s] + toPattern (Filter s f) = ConP 'Filter [toPattern s, toPattern f] + normalize = flip go [] + where go (Filter s f) = go s . (normalize f:) + go (SimpleSelector s) = addFilters (SimpleSelector (normalize s)) . sort + +instance ToCssSelector TypeSelector where + toCssSelector (TypeSelector NAny e) = toCssSelector e + toCssSelector (TypeSelector n e) = toCssSelector n <> "|" <> toCssSelector e + toSelectorGroup = toSelectorGroup . SimpleSelector + specificity' (TypeSelector _ e) = specificity' e + -- we use Universal, to make the generated pattern more convenient to read. + toPattern Universal = _constantP 'Universal + toPattern (TypeSelector n t) = ConP 'TypeSelector [toPattern n, toPattern t] + +instance ToCssSelector ElementName where + toCssSelector EAny = "*" + toCssSelector (ElementName e) = encodeIdentifier e + toSelectorGroup = toSelectorGroup . TypeSelector NAny + specificity' EAny = mempty + specificity' (ElementName _) = SelectorSpecificity 0 0 1 + toPattern EAny = _constantP 'EAny + toPattern (ElementName e) = ConP 'ElementName [_textToPattern e] + +instance ToCssSelector SelectorFilter where + toCssSelector (SHash h) = toCssSelector h + toCssSelector (SClass c) = toCssSelector c + toCssSelector (SAttrib a) = toCssSelector a + toSelectorGroup = toSelectorGroup . Filter (SimpleSelector Universal) + specificity' (SHash h) = specificity' h + specificity' (SClass c) = specificity' c + specificity' (SAttrib a) = specificity' a + toPattern (SHash h) = ConP 'SHash [toPattern h] + toPattern (SClass c) = ConP 'SClass [toPattern c] + toPattern (SAttrib a) = ConP 'SAttrib [toPattern a] + +instance ToCssSelector Selector where + toCssSelector (Selector s) = toCssSelector s + toCssSelector (Combined s1 c s2) = toCssSelector s1 <> combinatorText c <> toCssSelector s2 + toSelectorGroup = toSelectorGroup . SelectorGroup . pure + specificity' (Selector s) = specificity' s + specificity' (Combined s1 _ s2) = specificity' s1 <> specificity' s2 + toPattern (Selector s) = ConP 'Selector [toPattern s] + toPattern (Combined s1 c s2) = ConP 'Combined [toPattern s1, _constantP (go c), toPattern s2] + where go Descendant = 'Descendant + go Child = 'Child + go DirectlyPreceded = 'DirectlyPreceded + go Preceded = 'Preceded + normalize (Selector s) = Selector (normalize s) + normalize (Combined s1 c s2) = Combined (normalize s1) c (normalize s2) + +-- Custom Eq and Ord instances +instance Eq SelectorSpecificity where + (==) = on (==) specificityValue + +instance Ord SelectorSpecificity where + compare = comparing specificityValue + +-- Default instances +instance Default SelectorGroup where + def = SelectorGroup (pure def) + +instance Default Selector where + def = Selector def + +instance Default SelectorSequence where + def = SimpleSelector def + +instance Default TypeSelector where + def = Universal + +instance Default SelectorSpecificity where + def = mempty + +instance Default Namespace where + def = NAny + +instance Default ElementName where + def = EAny + +instance Default SelectorCombinator where + def = Descendant + +instance Default AttributeCombinator where + def = Exact + +-- Lift instances +_apply :: Name -> [Q Exp] -> Q Exp +_apply = foldl appE . conE + +instance Lift SelectorGroup where + lift (SelectorGroup sg) = _apply 'SelectorGroup [liftNe sg] + where liftNe (a :| as) = _apply '(:|) [lift a, lift as] + +instance Lift Selector +instance Lift SelectorCombinator +instance Lift SelectorSequence +instance Lift SelectorFilter +instance Lift Attrib + +-- ToMarkup instances +_cssToMarkup :: ToCssSelector a => a -> Markup +_cssToMarkup = text . toCssSelector + +instance ToMarkup SelectorGroup where + toMarkup = _cssToMarkup + +instance ToMarkup Selector where + toMarkup = _cssToMarkup + +instance ToMarkup SelectorSequence where + toMarkup = _cssToMarkup + +instance ToMarkup SelectorFilter where + toMarkup = _cssToMarkup + +instance ToMarkup Attrib where + toMarkup = _cssToMarkup + +-- ToJavaScript and ToJson instances +_cssToJavascript :: ToCssSelector a => a -> Javascript +_cssToJavascript = toJavascript . toCssSelector + +_cssToJson :: ToCssSelector a => a -> Value +_cssToJson = String . toCssSelector + +instance ToJavascript SelectorGroup where + toJavascript = _cssToJavascript + +instance ToJavascript Selector where + toJavascript = _cssToJavascript + +instance ToJavascript SelectorSequence where + toJavascript = _cssToJavascript + +instance ToJavascript SelectorFilter where + toJavascript = _cssToJavascript + +instance ToJavascript Attrib where + toJavascript = _cssToJavascript + +instance ToJSON SelectorGroup where + toJSON = _cssToJson + +instance ToJSON Selector where + toJSON = _cssToJson + +instance ToJSON SelectorSequence where + toJSON = _cssToJson + +instance ToJSON SelectorFilter where + toJSON = _cssToJson + +instance ToJSON Attrib where + toJSON = _cssToJson + + +-- Arbitrary instances +_arbitraryIdent :: Gen Text +_arbitraryIdent = pack <$> listOf1 arbitrary + +instance Arbitrary Hash where + arbitrary = Hash <$> _arbitraryIdent + +instance Arbitrary Class where + arbitrary = Class <$> _arbitraryIdent + +instance Arbitrary Namespace where + arbitrary = frequency [(3, return NAny), (1, Namespace <$> _arbitraryIdent)] + +instance Arbitrary ElementName where + arbitrary = frequency [(1, return EAny), (3, ElementName <$> _arbitraryIdent)] + +instance Arbitrary TypeSelector where + arbitrary = TypeSelector <$> arbitrary <*> arbitrary + +instance Arbitrary SelectorSequence where + arbitrary = addFilters . SimpleSelector <$> arbitrary <*> listOf arbitrary + +instance Arbitrary SelectorCombinator where + arbitrary = arbitraryBoundedEnum + +instance Arbitrary AttributeCombinator where + arbitrary = arbitraryBoundedEnum + +instance Arbitrary SelectorFilter where + arbitrary = oneof [SHash <$> arbitrary, SClass <$> arbitrary, SAttrib <$> arbitrary] + +instance Arbitrary AttributeName where + arbitrary = AttributeName <$> arbitrary <*> _arbitraryIdent + +instance Arbitrary Attrib where + arbitrary = oneof [Exist <$> arbitrary, Attrib <$> arbitrary <*> arbitrary <*> (pack <$> listOf arbitrary)] + +instance Arbitrary SelectorGroup where + arbitrary = SelectorGroup <$> ((:|) <$> arbitrary <*> arbitrary) + +instance Arbitrary Selector where + arbitrary = frequency [(3, Selector <$> arbitrary), (1, Combined <$> arbitrary <*> arbitrary <*> arbitrary) ] diff --git a/src/Css/Selector/Lexer.x b/src/Css/Selector/Lexer.x new file mode 100644 --- /dev/null +++ b/src/Css/Selector/Lexer.x @@ -0,0 +1,100 @@ +--vim:ft=haskell +{ +module Css.Selector.Lexer(AlexPosn(..), Token(..), TokenLoc(..), alexScanTokens) where + +import Data.Decimal(Decimal) +import Css.Selector.Utils(readCssString, readIdentifier) +} + +%wrapper "posn" + +$nonascii = [^\0-\xff] +$w = [\ \t\r\n\f] +$nostar = [^\*] +$nostars = [^\/\*] +$tl = [\~] + +@nl = \r|\n|\r\n|\f +@unicode = \\[0-9a-fA-F]{1,6}(\r\n|[ \n\r\t\f])? +@escape = @unicode | \\[^\n\r\f0-9a-fA-F] + +@wo = $w* +@nonaesc = $nonascii | @escape +@nmstart = [_a-zA-Z] | @nonaesc +@nmchar = [_\-a-zA-Z0-9] | @nonaesc +@ident = [\-]? @nmstart @nmchar* +@name = @nmchar+ +@int = [0-9]+ +@float = [0-9]*[.][0-9]+ +@string1 = \'([^\n\r\f\\\'] | \\@nl | @nonaesc )*\' -- strings with single quote +@string2 = \"([^\n\r\f\\\"] | \\@nl | @nonaesc )*\" -- strings with double quotes +@string = @string1 | @string2 + +@d = d|D|\\0{0,4}(44|64)(\r\n|[ \t\r\n\f])? +@e = e|E|\\0{0,4}(45|65)(\r\n|[ \t\r\n\f])? +@n = n|N|\\0{0,4}(4e|6e)(\r\n|[ \t\r\n\f])?|\\n +@o = o|O|\\0{0,4}(4f|6f)(\r\n|[ \t\r\n\f])?|\\o +@t = t|T|\\0{0,4}(54|74)(\r\n|[ \t\r\n\f])?|\\t +@v = v|V|\\0{0,4}(58|78)(\r\n|[ \t\r\n\f])?|\\v +@cmo = \/\* +@cmc = \*\/ + + +tokens :- + @wo "=" @wo { constoken TEqual } + @wo "~=" @wo { constoken TIncludes } + @wo "|=" @wo { constoken TDashMatch } + @wo "^=" @wo { constoken TPrefixMatch } + @wo "$=" @wo { constoken TSuffixMatch } + @wo "*=" @wo { constoken TSubstringMatch } + @wo "," @wo { constoken Comma } + "." { constoken Dot } + "|" { constoken Pipe } + "*" { constoken Asterisk } + @ident { tokenize (Ident . readIdentifier) } + @string { tokenize (String . readCssString) } + "#" @name { tokenize (THash . readIdentifier . drop 1) } + @float { tokenize (Decimal . read) } + @int { tokenize (Integer . read) } + @wo "+" @wo { constoken Plus } + @wo ">" @wo { constoken Greater } + @wo $tl @wo { constoken Tilde } + "[" @wo { constoken BOpen } + @wo "]" { constoken BClose } + $w @wo { constoken Space } + @cmo $nostar* \*+ ($nostars $nostar* \*+)* @cmc ; + +{ +data TokenLoc = TokenLoc { token :: Token, original :: String, location :: AlexPosn } + +tokenize :: (String -> Token) -> AlexPosn -> String -> TokenLoc +tokenize = flip . (>>= TokenLoc) + +constoken :: Token -> AlexPosn -> String -> TokenLoc +constoken = tokenize . const + +-- The token type: +data Token = + TIncludes + | TEqual + | TDashMatch + | TPrefixMatch + | TSuffixMatch + | TSubstringMatch + | Ident String + | String String + | THash String + | Decimal Decimal + | Integer Integer + | Comma + | Plus + | Greater + | Tilde + | Dot + | Pipe + | Asterisk + | Space + | BOpen + | BClose + deriving (Eq,Show) +} diff --git a/src/Css/Selector/Parser.y b/src/Css/Selector/Parser.y new file mode 100644 --- /dev/null +++ b/src/Css/Selector/Parser.y @@ -0,0 +1,131 @@ +-- vim:ft=haskell +{ +module Css.Selector.Parser where + +import Css.Selector.Core +import Css.Selector.Lexer(AlexPosn(..), Token(..), TokenLoc(..)) + +import Data.List.NonEmpty(NonEmpty((:|)), (<|)) +import Data.Text(pack) +} + +%name cssselector +%tokentype { TokenLoc } +%error { happyError } + +%token + ',' { TokenLoc Comma _ _ } + '>' { TokenLoc Greater _ _ } + '+' { TokenLoc Plus _ _ } + '~' { TokenLoc Tilde _ _ } + '.' { TokenLoc Dot _ _ } + ' ' { TokenLoc Space _ _ } + '|' { TokenLoc Pipe _ _ } + '*' { TokenLoc Asterisk _ _ } + '[' { TokenLoc BOpen _ _ } + ']' { TokenLoc BClose _ _ } + '=' { TokenLoc TEqual _ _ } + '^=' { TokenLoc TPrefixMatch _ _ } + '$=' { TokenLoc TSuffixMatch _ _ } + '*=' { TokenLoc TSubstringMatch _ _ } + '|=' { TokenLoc TDashMatch _ _ } + '~=' { TokenLoc TIncludes _ _ } + ident { TokenLoc (Ident $$) _ _ } + string { TokenLoc (String $$) _ _ } + hash { TokenLoc (THash $$) _ _ } + +%% + +SelectorsGroup + : SelectorGroupList { SelectorGroup $1 } + ; + +SelectorGroupList + : Selector { $1 :| [] } + | Selector ',' SelectorGroupList { $1 <| $3 } + ; + +Selector + : SimpleSelectorSequence { Selector $1 } + | SimpleSelectorSequence Combinator Selector { Combined $1 $2 $3 } + ; + +Combinator + : '+' { DirectlyPreceded } + | '>' { Child } + | '~' { Preceded } + | ' ' { Descendant } + ; + +SimpleSelectorSequence + : Type FilterList { addFilters (SimpleSelector $1) $2 } + | SelectorAddition FilterList { addFilters (SimpleSelector Universal) ($1:$2) } + ; + +FilterList + : { [] } + | SelectorAddition FilterList { $1 : $2 } + ; + +SelectorAddition + : hash { SHash (Hash (pack $1)) } + | Class { SClass $1 } + | AttribBox { SAttrib $1 } + ; + +AttribBox + : '[' Attrib ']' { $2 } + ; + +Attrib + : AttribName { Exist $1 } + | AttribName AttribOp Ident { Attrib $1 $2 $3 } + | AttribName AttribOp string { Attrib $1 $2 (pack $3) } + ; + +AttribName + : NamespacePrefix '|' Ident { AttributeName $1 $3 } + | '|' Ident { AttributeName NEmpty $2 } + | Ident { AttributeName NAny $1 } + ; + +AttribOp + : '=' { Exact } + | '~=' { Include } + | '|=' { DashMatch } + | '^=' { PrefixMatch } + | '$=' { SuffixMatch } + | '*=' { SubstringMatch } + ; + +Type + : ElementName { NAny .| $1 } + | '|' ElementName { NEmpty .| $2 } + | NamespacePrefix '|' ElementName { $1 .| $3 } + ; + +ElementName + : Ident { ElementName $1 } + | '*' { EAny } + ; + +Class + : '.' Ident { Class $2 } + ; + +NamespacePrefix + : Ident { Namespace $1 } + | '*' { NAny } + ; + +Ident + : ident { pack $1 } + ; + +{ + +happyError :: [TokenLoc] -> a +happyError [] = error "Unexpected end of string when parsing a css selector." +happyError (~(TokenLoc _ s ~(AlexPn _ l c)):_) = error ("Can not parse the CSS selector: unpexected token \"" <> s <> "\" at location (" <> show l <> ", " <> show c <> ")") + +} diff --git a/src/Css/Selector/QuasiQuoters.hs b/src/Css/Selector/QuasiQuoters.hs new file mode 100644 --- /dev/null +++ b/src/Css/Selector/QuasiQuoters.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +{-| +Module : Css.Selector.QuasiQuoters +Description : A module that defines a quasiquoter to parse a string to a css selector. +Maintainer : hapytexeu+gh@gmail.com +Stability : experimental +Portability : POSIX + +A module that defines a quasiquoter to parse a string to a css selector. +-} +module Css.Selector.QuasiQuoters ( + csssel, cssselFile, parseCss + ) where + +import Css.Selector.Core(SelectorGroup, toPattern) +import Css.Selector.Lexer(alexScanTokens) +import Css.Selector.Parser(cssselector) + +import Data.Data(Data, cast) +import Data.Text(pack, unpack) + +import Language.Haskell.TH.Quote(QuasiQuoter(QuasiQuoter, quoteExp, quotePat, quoteType, quoteDec), quoteFile) +import Language.Haskell.TH.Syntax(Exp(AppE, VarE), Q, Type(ConT), dataToExpQ, lift, reportWarning) + +-- | Parse the string to a 'SelectorGroup'. +parseCss :: String -- ^ The string to be parsed to a 'SelectorGroup' + -> SelectorGroup -- ^ The selectorgroup that is the equivalent of the given 'String'. +parseCss = cssselector . alexScanTokens . filter ('\r' /=) + +liftDataWithText :: Data a => a -> Q Exp +liftDataWithText = dataToExpQ ((((AppE (VarE 'pack) <$>) . lift . unpack) <$>) . cast) + +-- | A quasiquoter that can be used to construct a 'SelectorGroup' for the given +-- css selector. In case the css selector is invalid. A compiler error will be +-- thrown (at compile time). +csssel :: QuasiQuoter +csssel = QuasiQuoter { + quoteExp = liftDataWithText . parseCss, + quotePat = pure . toPattern . parseCss, + quoteType = const (reportWarning "The type of the quasiquoter will always use the SelectorGroup type." >> pure (ConT ''SelectorGroup)), + quoteDec = const (reportWarning "The use of this quasiquoter will not make any declarations." >> pure []) + } + +-- | A quasiquoter that takes the content from the file, and then runs the +-- content of that file as a 'csssel' quasiquote. +cssselFile :: QuasiQuoter +cssselFile = quoteFile csssel diff --git a/src/Css/Selector/Utils.hs b/src/Css/Selector/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Css/Selector/Utils.hs @@ -0,0 +1,117 @@ +{-| +Module : Css.Selector.Utils +Description : A set of utility methods to encode and decode strings. +Maintainer : hapytexeu+gh@gmail.com +Stability : experimental +Portability : POSIX + +A module to encode and decode css selector strings. These are used in the parser and renderer to parse and render css selector strings. +-} +module Css.Selector.Utils ( + -- * Identifiers + readIdentifier, encodeIdentifier + , isValidIdentifier, toIdentifier + -- * Css strings + , readCssString, encodeString, encodeText + ) where + +import Control.Arrow(first) + +import Data.Char(chr, digitToInt, intToDigit, isAsciiLower, isAsciiUpper, isHexDigit, ord) +import Data.Text(Text, cons, pack, singleton, snoc) +import qualified Data.Text as T + +_initLast :: [a] -> Maybe ([a], a) +_initLast [] = Nothing +_initLast (a:as) = Just (go as a) + where go [] x = ([], x) + go (y:ys) x = first (x:) (go ys y) + +_isQuote :: Char -> Bool +_isQuote '"' = True +_isQuote '\'' = True +_isQuote _ = False + +-- | Parses a css string literal to a string that ontains the content of that +-- string literal. +readCssString :: String -- ^ The string that contains the string literal in the css selector. + -> String -- ^ A string that contains the content of the string literal. +readCssString (c:xs) | _isQuote c = f + where f | Just (vs, c') <- _initLast xs = g c' vs + | otherwise = "The string literal should contain at least two quotation marks." + where g c' vs | c == c' = _readCssString c vs + | otherwise = "The start and end quotation mark should be the same." +readCssString _ = error "The string should start with an \" or ' and end with the same quotation." + +_readCssString :: Char -> String -> String +_readCssString c' = go + where go [] = [] + go ('\\':'\n':xs) = go xs + go ('\\':ca@(c:xs)) | c == c' = c : go xs + | otherwise = let ~(y,ys) = _parseEscape ca in y : go ys + go (x:xs) | x == c' = error "The string can not contain a " ++ show x ++ ", you should escape it." + | otherwise = x : go xs + +-- | Parse a given css identifier to the content of the identifier. +readIdentifier :: String -- ^ The given css identifier to parse. + -> String -- ^ The result of the parsing: the content of the identifier. +readIdentifier = _readCssString '\\' + +_notEncode :: Char -> Bool +_notEncode x = isAsciiLower x || isAsciiUpper x + +-- | Convert a string to a css selector string literal. This is done by putting +-- quotes around the content, and escaping certain characters. +encodeString :: Char -- ^ The type of quotes that should be put around the content (should be @'@ or @"@). + -> String -- ^ The string that should be converted to a css selector string literal. + -> String -- ^ The corresponding css selector string literal. +encodeString c' = (c' :) . go + where go [] = [c'] + go (c:cs) | _notEncode c = c : go cs + | otherwise = '\\' : _showHex (ord c) (go cs) + +-- | Convert a string to a css selector string literal. This is done by putting +-- quotes around the content, and escaping certain characters. +encodeText :: Char -- ^ The type of quotes that should be put around the content (should be @'@ or @"@). + -> Text -- ^ The string that should be converted to a css selector string literal. + -> Text -- ^ The corresponding css selector string literal. +encodeText c' t = cons c' (snoc (T.concatMap _encodeCharacter t) c') + +_encodeCharacter :: Char -> Text +_encodeCharacter c + | _notEncode c = singleton c + | otherwise = cons '\\' (pack (_showHex (ord c) "")) + +-- | Encode a given identifier to its css selector equivalent by escaping +-- certain characters. +encodeIdentifier :: Text -- ^ The identifier to encode. + -> Text -- ^ The encoded identifier. +encodeIdentifier = T.concatMap _encodeCharacter + +_showHex :: Int -> ShowS +_showHex = go (6 :: Int) + where go 0 _ s = s + go k n rs = go (k-1) q (intToDigit r : rs) + where ~(q, r) = quotRem n 16 + +_parseEscape :: String -> (Char, String) +_parseEscape = go (6 :: Int) 0 + where go 0 n cs = yield n cs + go _ n "" = yield n "" + go i n ca@(c:cs) | isHexDigit c = go (i-1) (16*n+digitToInt c) cs + | otherwise = yield n ca + yield n s = (chr n, s) + +-- | Check if the given identifier is a valid css selector identifier. +isValidIdentifier :: String -- ^ The given identifier to check. + -> Bool -- ^ 'True' if the given identifier is valid, 'False' otherwise. +isValidIdentifier = not . null + +-- | Convert the given string to a given object by first checking if it is a +-- valid identifier, and if not raising an error. If it is a valid identifier, +-- the string is packed, and wrapped in the given function. +toIdentifier :: (Text -> a) -- ^ The given function to wrap the 'Text' identifier to an object. + -> String -- ^ The string to validate, and wrap into the given function. + -> a -- ^ The identifier object to return if the identifier is valid. +toIdentifier f ident | isValidIdentifier ident = f (pack ident) + | otherwise = error ("The identifier " <> show ident <> " is not a valid identifier.") diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,73 @@ +import Css.Selector +import Css.Selector.Utils(encodeString, readCssString) + +import Data.Text(pack, unpack) + +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck + +main :: IO () +main = defaultMain tests + +tests = [ + testGroup "Encode-decode strings" [ + testProperty "Encode-decode identity 1" (encodeDecode '"'), + testProperty "Encode-decode identity 2" (encodeDecode '\''), + testProperty "Encode-decode identifier" encodeDecodeId + ], + testGroup "Arbitrary css parsing" [ + testProperty "Encode-decode css identity" encodeDecodeCss, + testProperty "Encode-decode css identity: selector group" (encodeDecodeCss' :: SelectorGroup -> Bool), + testProperty "Encode-decode css identity: selector" (encodeDecodeCss' :: Selector -> Bool), + testProperty "Encode-decode css identity: selector sequence" (encodeDecodeCss' :: SelectorSequence -> Bool), + testProperty "Encode-decode css identity: selector filter" (encodeDecodeCss' :: SelectorFilter -> Bool), + testProperty "Encode-decode css identity: namespace" (encodeDecodeCss' :: Namespace -> Bool), + testProperty "Encode-decode css identity: element name" (encodeDecodeCss' :: ElementName -> Bool), + testProperty "Encode-decode css identity: type selector" (encodeDecodeCss' :: TypeSelector -> Bool), + testProperty "Encode-decode css identity: attribute" (encodeDecodeCss' :: Attrib -> Bool), + testProperty "Encode-decode css identity: attribute name" (encodeDecodeCss' :: AttributeName -> Bool), + testProperty "Encode-decode css identity: class" (encodeDecodeCss' :: Class -> Bool), + testProperty "Encode-decode css identity: hash" (encodeDecodeCss' :: Hash -> Bool) + ], + testGroup "SelectorSequences" [ + testProperty "Adding and removing filters" addRemFilters + ], + testGroup "Normalization" [ + testProperty "Normalized variant has the same specificity" normSpec, + testProperty "Normalization is idempotent" normIdem + ], + testGroup "Build an expression or pattern" [ + testProperty "Check build of pattern 1" buildPattern1, + testProperty "Check build of pattern 2" buildPattern2 + ] + ] + +encodeDecode :: Char -> String -> Bool +encodeDecode c b = readCssString (encodeString c b) == b + +encodeDecodeId :: String -> Bool +encodeDecodeId b = readIdentifier (unpack (encodeIdentifier (pack b))) == b + +encodeDecodeCss :: SelectorGroup -> Bool +encodeDecodeCss sg = sg == (parseCss . unpack . toCssSelector) sg + +encodeDecodeCss' :: ToCssSelector a => a -> Bool +encodeDecodeCss' sg = (parseCss . unpack . toCssSelector . toSelectorGroup) sg == toSelectorGroup sg + +buildPattern1 :: SelectorGroup -> Bool +buildPattern1 x = toPattern x == toPattern x -- we use equality checks to force evaluation + +buildPattern2 :: SelectorGroup -> SelectorGroup -> Bool +buildPattern2 x y = (x == y) == (toPattern x == toPattern y) + +addRemFilters :: TypeSelector -> [SelectorFilter] -> Bool +addRemFilters x fs = filters (addFilters (SimpleSelector x) fs) == fs + +normSpec :: SelectorGroup -> Bool +normSpec x = specificity' x == specificity' nx + where nx = normalize x + +normIdem :: SelectorGroup -> Bool +normIdem x = normalize nx == nx + where nx = normalize x