Combinators.hs

{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# OPTIONS_HADDOCK hide #-}
module Text.HTML.Scalpel.Internal.Select.Combinators (
    (//)
,   (@:)
,   (@=)
,   (@=~)
,   hasClass
,   notP
,   match
) where

import Text.HTML.Scalpel.Internal.Select.Types

import qualified Data.Text as T
import qualified Text.Regex.Base.RegexLike as RE
import qualified Text.StringLike as TagSoup


-- | The '@:' operator creates a 'Selector' by combining a 'TagName' with a list
-- of 'AttributePredicate's.
(@:) :: TagName -> [AttributePredicate] -> Selector
(@:) tag attrs = MkSelector [toSelectNode tag attrs]
infixl 9 @:

-- | The '@=' operator creates an 'AttributePredicate' that will match
-- attributes with the given name and value.
--
-- If you are attempting to match a specific class of a tag with potentially
-- multiple classes, you should use the 'hasClass' utility function.
(@=) :: AttributeName -> String -> AttributePredicate
(@=) key value = anyAttrPredicate $ \(attrKey, attrValue) ->
                                      matchKey key attrKey
                                      && TagSoup.fromString value == attrValue
infixl 6 @=

-- | The '@=~' operator creates an 'AttributePredicate' that will match
-- attributes with the given name and whose value matches the given regular
-- expression.
(@=~) :: RE.RegexLike re String
      => AttributeName -> re -> AttributePredicate
(@=~) key re = anyAttrPredicate $ \(attrKey, attrValue) ->
       matchKey key attrKey
    && RE.matchTest re (TagSoup.toString attrValue)
infixl 6 @=~

-- | The '//' operator creates an 'Selector' by nesting one 'Selector' in
-- another. For example, @"div" // "a"@ will create a 'Selector' that matches
-- anchor tags that are nested arbitrarily deep within a div tag.
(//) :: Selector -> Selector -> Selector
(//) a b = MkSelector (as ++ bs)
    where (MkSelector as) = a
          (MkSelector bs) = b
infixl 5 //

-- | The classes of a tag are defined in HTML as a space separated list given by
-- the @class@ attribute. The 'hasClass' function will match a @class@ attribute
-- if the given class appears anywhere in the space separated list of classes.
hasClass :: String -> AttributePredicate
hasClass clazz = anyAttrPredicate hasClass'
    where
        hasClass' (attrName, classes)
            | "class" == TagSoup.toString attrName = textClass `elem` classList
            | otherwise                            = False
            where textClass   = TagSoup.castString clazz
                  textClasses = TagSoup.castString classes
                  classList   = T.split (== ' ') textClasses

-- | Negates an 'AttributePredicate'. 
notP :: AttributePredicate -> AttributePredicate
notP (MkAttributePredicate p) = MkAttributePredicate $ not . p

-- | The 'match' function allows for the creation of arbitrary
-- 'AttributePredicate's. The argument is a function that takes the attribute
-- key followed by the attribute value and returns a boolean indicating if the
-- attribute satisfies the predicate.
match :: (String -> String -> Bool) -> AttributePredicate
match f = anyAttrPredicate $ \(attrKey, attrValue) ->
              f (TagSoup.toString attrKey) (TagSoup.toString attrValue)