packages feed

css-selectors 0.2.0.0 → 0.2.1.0

raw patch · 15 files changed

+1162/−1065 lines, 15 files

Files

CHANGELOG.md view
@@ -2,6 +2,10 @@  For a full list of changes, see the history on [GitHub](https://github.com/hapytex/css-selectors). +## Version 0.2.1.0++Move from modules from `Css.*` to `Css3.*`, and implementations of `shrink` for the css selectors data types.+ ## Version 0.2.0.0  The first version that is deployed on Hackage.
README.md view
@@ -1,6 +1,8 @@ # 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)+[![Build Status of the package by GitHub actions](https://github.com/hapytex/css-selectors/actions/workflows/build-ci.yml/badge.svg)](https://github.com/hapytex/css-selectors/actions/workflows/build-ci.yml)+[![Build Status of the package by Hackage](https://matrix.hackage.haskell.org/api/v2/packages/css-selectors/badge)](https://matrix.hackage.haskell.org/#/package/css-selectors)+[![Hackage version badge](https://img.shields.io/hackage/v/css-selectors.svg)](https://hackage.haskell.org/package/css-selectors)  A library for parsing, manipulating, and rendering css selectors (not css files, just the selectors).
css-selectors.cabal view
@@ -1,5 +1,5 @@ name:                css-selectors-version:             0.2.0.0+version:             0.2.1.0 synopsis:            Parsing, rendering and manipulating css selectors in Haskell. description:   A library for parsing, manipulating, and rendering css selectors (not css files,@@ -32,9 +32,13 @@     , Css.Selector.Core     , Css.Selector.QuasiQuoters     , Css.Selector.Utils+    , Css3.Selector+    , Css3.Selector.Core+    , Css3.Selector.QuasiQuoters+    , Css3.Selector.Utils   other-modules:-       Css.Selector.Lexer-     , Css.Selector.Parser+       Css3.Selector.Lexer+     , Css3.Selector.Parser   build-depends:       base >=4.7 && <5     , aeson >=1.0 && <2
src/Css/Selector.hs view
@@ -1,18 +1,14 @@ {-| Module      : Css.Selector-Description : Css selectors in Haskell.+Description : Css 3 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.+A module for backwards compatibility that re-exports 'Css3.Selector'. This module is deprecated and eventually will be removed. -}-module Css.Selector (-    module Css.Selector.Core,-    module Css.Selector.QuasiQuoters,-    module Css.Selector.Utils+module Css.Selector {-# DEPRECATED "Use Css3.Selector instead" #-} (+    module Css3.Selector,   ) where -import Css.Selector.Core-import Css.Selector.QuasiQuoters-import Css.Selector.Utils+import Css3.Selector
src/Css/Selector/Core.hs view
@@ -1,5 +1,3 @@-{-# 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.@@ -7,680 +5,10 @@ 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.+A module for backwards compatibility that re-exports 'Css3.Selector.Core'. This module is deprecated and eventually will be removed. -}-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+module Css.Selector.Core {-# DEPRECATED "Use Css3.Selector.Core instead" #-} (+    module Css3.Selector.Core   ) 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) ]+import Css3.Selector.Core
− src/Css/Selector/Lexer.x 
@@ -1,100 +0,0 @@---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 
@@ -1,131 +0,0 @@--- 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
@@ -1,5 +1,3 @@-{-# LANGUAGE TemplateHaskellQuotes #-}- {-| Module      : Css.Selector.QuasiQuoters Description : A module that defines a quasiquoter to parse a string to a css selector.@@ -7,42 +5,10 @@ Stability   : experimental Portability : POSIX -A module that defines a quasiquoter to parse a string to a css selector.+A module for backwards compatibility that re-exports 'Css3.Selector.QuasiQuoters'. This module is deprecated and eventually will be removed. -}-module Css.Selector.QuasiQuoters (-    csssel, cssselFile, parseCss+module Css.Selector.QuasiQuoters {-# DEPRECATED "Use Css3.Selector.QuasiQuoters instead" #-} (+    module Css3.Selector.QuasiQuoters   ) 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+import Css3.Selector.QuasiQuoters
src/Css/Selector/Utils.hs view
@@ -5,113 +5,10 @@ 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.+A module for backwards compatibility that re-exports 'Css3.Selector.Utils'. This module is deprecated and eventually will be removed. -}-module Css.Selector.Utils (-    -- * Identifiers-      readIdentifier, encodeIdentifier-    , isValidIdentifier, toIdentifier-    -- * Css strings-    , readCssString, encodeString, encodeText+module Css.Selector.Utils {-# DEPRECATED "Use Css3.Selector.Utils instead" #-} (+  module Css3.Selector.Utils   ) 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.")+import Css3.Selector.Utils
+ src/Css3/Selector.hs view
@@ -0,0 +1,18 @@+{-|+Module      : Css3.Selector+Description : Css 3 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 Css3.Selector (+    module Css3.Selector.Core,+    module Css3.Selector.QuasiQuoters,+    module Css3.Selector.Utils+  ) where++import Css3.Selector.Core+import Css3.Selector.QuasiQuoters+import Css3.Selector.Utils
+ src/Css3/Selector/Core.hs view
@@ -0,0 +1,717 @@+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, PatternSynonyms, TemplateHaskellQuotes, TypeFamilies #-}++{-|+Module      : Css3.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 Css3.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 Control.Applicative(liftA2)++import Css3.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 qualified Data.Text as T+import Data.Text(Text, cons, inits, intercalate, pack, tails, 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, shrink), 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++_shrinkText :: Text -> [Text]+_shrinkText = liftA2 (zipWith (<>)) inits (tails . T.drop 1)++_shrinkIdent :: Text -> [Text]+_shrinkIdent t+    | T.length t < 2 = []+    | otherwise = _shrinkText t++instance Arbitrary Hash where+    arbitrary = Hash <$> _arbitraryIdent+    shrink (Hash a) = Hash <$> _shrinkIdent a++instance Arbitrary Class where+    arbitrary = Class <$> _arbitraryIdent+    shrink (Class a) = Class <$> _shrinkIdent a++instance Arbitrary Namespace where+    arbitrary = frequency [(3, pure NAny), (1, Namespace <$> _arbitraryIdent)]+    shrink NAny = []+    shrink (Namespace a) = Namespace <$> _shrinkIdent a++instance Arbitrary ElementName where+    arbitrary = frequency [(1, pure EAny), (3, ElementName <$> _arbitraryIdent)]+    shrink EAny = []+    shrink (ElementName a) = ElementName <$> _shrinkIdent a++instance Arbitrary TypeSelector where+    arbitrary = TypeSelector <$> arbitrary <*> arbitrary+    shrink (TypeSelector x y) = (TypeSelector x <$> shrink y) ++ ((`TypeSelector` y) <$> shrink x)++instance Arbitrary SelectorSequence where+    arbitrary = addFilters . SimpleSelector <$> arbitrary <*> listOf arbitrary+    shrink (SimpleSelector _) = []+    shrink (Filter ss sf) = ss : (Filter ss <$> shrink sf)++instance Arbitrary SelectorCombinator where+    arbitrary = arbitraryBoundedEnum++instance Arbitrary AttributeCombinator where+    arbitrary = arbitraryBoundedEnum++instance Arbitrary SelectorFilter where+    arbitrary = oneof [SHash <$> arbitrary, SClass <$> arbitrary, SAttrib <$> arbitrary]+    shrink (SHash x) = SHash <$> shrink x+    shrink (SClass x) = SClass <$> shrink x+    shrink (SAttrib x) = SAttrib <$> shrink x++instance Arbitrary AttributeName where+    arbitrary = AttributeName <$> arbitrary <*> _arbitraryIdent+    shrink (AttributeName x y) = (AttributeName x <$> _shrinkIdent y) ++ ((`AttributeName` y) <$> shrink x)++instance Arbitrary Attrib where+    arbitrary = oneof [Exist <$> arbitrary, Attrib <$> arbitrary <*> arbitrary <*> (pack <$> listOf arbitrary)]+    shrink (Exist x) = Exist <$> shrink x+    shrink (Attrib x y z) = (Attrib x y <$> _shrinkText z) ++ ((\sx -> Attrib sx y z) <$> shrink x)++instance Arbitrary SelectorGroup where+    arbitrary = SelectorGroup <$> ((:|) <$> arbitrary <*> arbitrary)+    shrink (SelectorGroup (x :| xs)) = go xs (SelectorGroup . (x :|) <$> shrink xs)+      where go [] = id+            go (y:ys) = (SelectorGroup (y :| ys) :)++instance Arbitrary Selector where+    arbitrary = frequency [(3, Selector <$> arbitrary), (1, Combined <$> arbitrary <*> arbitrary <*> arbitrary) ]+    shrink (Selector x) = Selector <$> shrink x+    shrink (Combined x y z) = z : (Combined x y <$> shrink z) ++ ((\sx -> Combined sx y z) <$> shrink x)
+ src/Css3/Selector/Lexer.x view
@@ -0,0 +1,100 @@+--vim:ft=haskell+{+module Css3.Selector.Lexer(AlexPosn(..), Token(..), TokenLoc(..), alexScanTokens) where++import Data.Decimal(Decimal)+import Css3.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/Css3/Selector/Parser.y view
@@ -0,0 +1,131 @@+-- vim:ft=haskell+{+module Css3.Selector.Parser where++import Css3.Selector.Core+import Css3.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/Css3/Selector/QuasiQuoters.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE TemplateHaskellQuotes #-}++{-|+Module      : Css3.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 Css3.Selector.QuasiQuoters (+    csssel, cssselFile, parseCss+  ) where++import Css3.Selector.Core(SelectorGroup, toPattern)+import Css3.Selector.Lexer(alexScanTokens)+import Css3.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/Css3/Selector/Utils.hs view
@@ -0,0 +1,117 @@+{-|+Module      : Css3.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 Css3.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.")