diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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). diff --git a/css-selectors.cabal b/css-selectors.cabal --- a/css-selectors.cabal +++ b/css-selectors.cabal @@ -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 diff --git a/src/Css/Selector.hs b/src/Css/Selector.hs --- a/src/Css/Selector.hs +++ b/src/Css/Selector.hs @@ -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 diff --git a/src/Css/Selector/Core.hs b/src/Css/Selector/Core.hs --- a/src/Css/Selector/Core.hs +++ b/src/Css/Selector/Core.hs @@ -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 diff --git a/src/Css/Selector/Lexer.x b/src/Css/Selector/Lexer.x deleted file mode 100644 --- a/src/Css/Selector/Lexer.x +++ /dev/null @@ -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) -} diff --git a/src/Css/Selector/Parser.y b/src/Css/Selector/Parser.y deleted file mode 100644 --- a/src/Css/Selector/Parser.y +++ /dev/null @@ -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 <> ")") - -} diff --git a/src/Css/Selector/QuasiQuoters.hs b/src/Css/Selector/QuasiQuoters.hs --- a/src/Css/Selector/QuasiQuoters.hs +++ b/src/Css/Selector/QuasiQuoters.hs @@ -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 diff --git a/src/Css/Selector/Utils.hs b/src/Css/Selector/Utils.hs --- a/src/Css/Selector/Utils.hs +++ b/src/Css/Selector/Utils.hs @@ -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 diff --git a/src/Css3/Selector.hs b/src/Css3/Selector.hs new file mode 100644 --- /dev/null +++ b/src/Css3/Selector.hs @@ -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 diff --git a/src/Css3/Selector/Core.hs b/src/Css3/Selector/Core.hs new file mode 100644 --- /dev/null +++ b/src/Css3/Selector/Core.hs @@ -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) diff --git a/src/Css3/Selector/Lexer.x b/src/Css3/Selector/Lexer.x new file mode 100644 --- /dev/null +++ b/src/Css3/Selector/Lexer.x @@ -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) +} diff --git a/src/Css3/Selector/Parser.y b/src/Css3/Selector/Parser.y new file mode 100644 --- /dev/null +++ b/src/Css3/Selector/Parser.y @@ -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 <> ")") + +} diff --git a/src/Css3/Selector/QuasiQuoters.hs b/src/Css3/Selector/QuasiQuoters.hs new file mode 100644 --- /dev/null +++ b/src/Css3/Selector/QuasiQuoters.hs @@ -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 diff --git a/src/Css3/Selector/Utils.hs b/src/Css3/Selector/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Css3/Selector/Utils.hs @@ -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.")