packages feed

css-selectors (empty) → 0.2.0.0

raw patch · 12 files changed

+1440/−0 lines, 12 filesdep +Decimaldep +QuickCheckdep +aesonsetup-changed

Dependencies added: Decimal, QuickCheck, aeson, array, base, blaze-markup, css-selectors, data-default, shakespeare, template-haskell, test-framework, test-framework-quickcheck2, text

Files

+ CHANGELOG.md view
@@ -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.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ css-selectors.cabal view
@@ -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
+ src/Css/Selector.hs view
@@ -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
+ src/Css/Selector/Core.hs view
@@ -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) ]
+ src/Css/Selector/Lexer.x view
@@ -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)+}
+ src/Css/Selector/Parser.y view
@@ -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 <> ")")++}
+ src/Css/Selector/QuasiQuoters.hs view
@@ -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
+ src/Css/Selector/Utils.hs view
@@ -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.")
+ test/Spec.hs view
@@ -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