scalpel 0.3.1 → 0.4.0

raw patch · 11 files changed

+586/−228 lines, 11 filesdep +faildep +vectordep ~tagsoupPVP ok

version bump matches the API change (PVP)

Dependencies added: fail, vector

Dependency ranges changed: tagsoup

API changes (from Hackage documentation)

Files

• CHANGELOG.md +14/−0
• README.md +122/−0
• benchmarks/Main.hs +25/−9
• scalpel.cabal +9/−6
• src/Text/HTML/Scalpel.hs +5/−4
• src/Text/HTML/Scalpel/Internal/Scrape.hs +100/−41
• src/Text/HTML/Scalpel/Internal/Scrape/StringLike.hs +2/−1
• src/Text/HTML/Scalpel/Internal/Select.hs +195/−103
• src/Text/HTML/Scalpel/Internal/Select/Combinators.hs +7/−7
• src/Text/HTML/Scalpel/Internal/Select/Types.hs +32/−44
• tests/TestMain.hs +75/−13

@@ -2,6 +2,20 @@  ## HEAD +## 0.4.0++- Add the `chroot` tricks (#23 and #25) to README.md and added examples.+- Fix backtracking that occurs when using `guard` and `chroot`.+- Fix bug where the same tag may appear in the result set multiple times.+- Performance optimizations when using the (//) operator.+- Make Scraper an instance of MonadFail. Practically this means that failed+  pattern matches in `<-` expressions within a do block will evaluate to mzero+  instead of throwing an error and bringing down the entire script.+- Pluralized scrapers will now return the empty list instead mzero when there+  are no matches.+- Add the `position` scraper which provides the index of the current sub-tree+  within the context of a `chroots`'s do-block.+ ## 0.3.1  - Added the `innerHTML` and `innerHTMLs` scraper.

@@ -109,3 +109,125 @@            imageURL <- attr "src" $ "img"  @: [hasClass "image"]            return $ ImageComment author imageURL ```++Tips & Tricks+-------------++The primitives provided by scalpel are intentionally minimalistic with the+assumption being that users will be able to build up complex functionality by+combining them with functions that work on existing type classes (Monad,+Applicative, Alternative, etc.).++This section gives examples of common tricks for building up more complex+behavior from the simple primitives provided by this library.++### OverloadedStrings++`Selector`, `TagName` and `AttributeName` are all `IsString` instances, and+thus it is convenient to use scalpel with `OverloadedStrings` enabled. If not+using `OverloadedStrings`, all tag names must be wrapped with `tagSelector`.++### Matching Wildcards++Scalpel has 3 different wildcard values each corresponding to a distinct use case.++- `anySelector` is used to match all tags:++    `textOfAllTags = texts anySelector`++- `AnyTag` is used when matching all tags with some attribute constraint. For+  example, to match all tags with the attribute `class` equal to `"button"`:++    `textOfTagsWithClassButton = texts $ AnyTag @: [hasClass "button"]`++- `AnyAttribute` is used when matching tags with some arbitrary attribute equal+   to a particular value. For example, to match all tags with some attribute+   equal to `"button"`:++    `textOfTagsWithAnAttributeWhoseValueIsButton = texts $ AnyTag @: [AnyAttribute @= "button"]`++### Complex Predicates++It is possible to run into scenarios where the name and attributes of a tag are+not sufficient to isolate interesting tags and properties of child tags need to+be considered.++In these cases the `guard` function of the `Alternative` type class can be+combined with `chroot` and `anySelector` to implement predicates of arbitrary+complexity.++Building off the above example, consider a use case where we would like find the+html contents of a comment that mentions the word "cat".++The strategy will be the following:++1. Isolate the comment div using `chroot`.++2. Then within the context of that div the textual contents can be retrieved+   with `text anySelector`. This works because the first tag within the current context+   is the div tag selected by chroot, and the `anySelector` selector will match the+   first tag within the current context.++3. Then the predicate that `"cat"` appear in the text of the comment will be+   enforced using `guard`. If the predicate fails, scalpel will backtrack and+   continue the search for divs until one is found that matches the predicate.++4. Return the desired HTML content of the comment div.++```haskell+catComment :: Scraper String String+catComment =+    -- 1. First narrow the current context to the div containing the comment's+    --    textual content.+    chroot ("div" @: [hasClass "comment", hasClass "text"]) $ do+        -- 2. anySelector can be used to access the root tag of the current context.+        contents <- text anySelector+        -- 3. Skip comment divs that do not contain "cat".+        guard ("cat" `isInfixOf` contents)+        -- 4. Generate the desired value.+        html anySelector+```++For the full source of this example, see+[complex-predicates](https://github.com/fimad/scalpel/tree/master/examples/complex-predicates/)+in the examples directory.++### Generalized Repetition++The pluralized versions of the primitive scrapers (`texts`, `attrs`, `htmls`)+allow the user to extract content from all of the tags matching a given+selector. For more complex scraping tasks it will at times be desirable to be+able to extract multiple values from the same tag.++Like the previous example, the trick here is to use a combination of the+`chroots` function and the `anySelector` selector.++Consider an extension to the original example where image comments may contain+some alt text and the desire is to return a tuple of the alt text and the URLs+of the images.++The strategy will be the following:++1. to isolate each img tag using `chroots`.++2. Then within the context of each img tag, use the `anySelector` selector to extract+   the alt and src attributes from the current tag.++3. Create and return a tuple of the extracted attributes.++```haskell+altTextAndImages :: Scraper String [(String, URL)]+altTextAndImages =+    -- 1. First narrow the current context to each img tag.+    chroots "img" $ do+        -- 2. Use anySelector to access all the relevant content from the the currently+        -- selected img tag.+        altText <- attr "alt" anySelector+        srcUrl  <- attr "src" anySelector+        -- 3. Combine the retrieved content into the desired final result.+        return (altText, srcUrl)+```++For the full source of this example, see+[generalized-repetition](https://github.com/fimad/scalpel/tree/master/examples/generalized-repetition/)+in the examples directory.

@@ -1,9 +1,13 @@+{-# LANGUAGE OverloadedStrings #-}+ import Text.HTML.Scalpel  import Control.Applicative ((<$>)) import Control.Monad (replicateM_) import Criterion.Main (bgroup, bench, defaultMain, nf)+import Data.Foldable (foldr') import qualified Data.Text as T+import qualified Text.HTML.TagSoup as TagSoup   main :: IO ()@@ -18,24 +22,36 @@             ,   bench "10000" $ nf sumListTags nested10000             ]         ,   bgroup "many-selects" [-                bench "10"  $ nf (manySelects 10) nested1000+                bench "10" $ nf (manySelects 10) nested1000             ,   bench "100" $ nf (manySelects 100) nested1000             ,   bench "1000" $ nf (manySelects 1000) nested1000             ]+        ,   bgroup "many-//" [+                bench "10" $ nf (manySelectNodes 10) nested1000+            ,   bench "100" $ nf (manySelectNodes 100) nested1000+            ,   bench "1000" $ nf (manySelectNodes 1000) nested1000+            ]         ] -makeNested :: Int -> T.Text-makeNested i = T.concat [T.replicate i open, one, T.replicate i close]+makeNested :: Int -> [TagSoup.Tag T.Text]+makeNested i = TagSoup.parseTags+             $ T.concat [T.replicate i open, one, T.replicate i close]     where         open  = T.pack "<tag>"         close = T.pack "</tag>"         one   = T.pack "1" -sumListTags :: T.Text -> Maybe Integer-sumListTags testData = scrapeStringLike testData-                     $ (sum . map (const 1)) <$> texts "tag"+sumListTags :: [TagSoup.Tag T.Text] -> Maybe Integer+sumListTags testData = flip scrape testData+                     $ sum <$> chroots "tag" (return 1) -manySelects :: Int -> T.Text -> Maybe ()-manySelects i testData = scrapeStringLike testData+manySelects :: Int -> [TagSoup.Tag T.Text] -> Maybe ()+manySelects i testData = flip scrape testData                        $ replicateM_ i-                       $ texts "tag"+                       $ sum <$> chroots "tag" (return 1)++manySelectNodes :: Int -> [TagSoup.Tag T.Text] -> Maybe T.Text+manySelectNodes i testData = flip scrape testData+                           $ text+                           $ foldr' (//) (tagSelector "tag")+                           $ replicate (i - 1) (tagSelector "tag")

@@ -1,5 +1,5 @@ name:                scalpel-version:             0.3.1+version:             0.4.0 synopsis:            A high level web scraping library for Haskell. description:     Scalpel is a web scraping library inspired by libraries like Parsec and@@ -24,7 +24,7 @@ source-repository this   type:     git   location: https://github.com/fimad/scalpel.git-  tag:      v0.3.1+  tag:      v0.4.0  library   other-extensions:@@ -47,10 +47,12 @@       ,   containers       ,   curl          >= 1.3.4       ,   data-default+      ,   fail       ,   regex-base       ,   regex-tdfa       ,   tagsoup       >= 0.12.2       ,   text+      ,   vector   default-extensions:           ParallelListComp       ,   PatternGuards@@ -79,8 +81,9 @@   hs-source-dirs:   benchmarks   main-is:          Main.hs   build-depends:-      base               >=4.7 && <5-    , criterion          >=1.1-    , scalpel-    , text+         base           >=4.7 && <5+      ,  criterion      >=1.1+      ,  scalpel+      ,  tagsoup+      ,  text   ghc-options: -Wall

@@ -100,12 +100,12 @@ module Text.HTML.Scalpel ( -- * Selectors     Selector-,   Selectable (..) ,   AttributePredicate-,   AttributeName-,   TagName+,   AttributeName (..)+,   TagName (..)+,   tagSelector -- ** Wildcards-,   Any (..)+,   anySelector -- ** Tag combinators ,   (//) -- ** Attribute predicates@@ -128,6 +128,7 @@ ,   texts ,   chroot ,   chroots+,   position -- ** Executing scrapers ,   scrape ,   scrapeStringLike

@@ -12,6 +12,7 @@ ,   texts ,   chroot ,   chroots+,   position ) where  import Text.HTML.Scalpel.Internal.Select@@ -21,6 +22,8 @@ import Control.Monad import Data.Maybe +import qualified Control.Monad.Fail as Fail+import qualified Data.Vector as Vector import qualified Text.HTML.TagSoup as TagSoup import qualified Text.StringLike as TagSoup @@ -28,7 +31,7 @@ -- | A value of 'Scraper' @a@ defines a web scraper that is capable of consuming -- a list of 'TagSoup.Tag's and optionally producing a value of type @a@. newtype Scraper str a = MkScraper {-        scrapeOffsets :: [(TagSoup.Tag str, CloseOffset)] -> Maybe a+        scrapeTagSpec :: TagSpec str -> Maybe a     }  instance Functor (Scraper str) where@@ -47,6 +50,7 @@                           | otherwise             = b tags  instance Monad (Scraper str) where+    fail = Fail.fail     return = pure     (MkScraper a) >>= f = MkScraper combined         where combined tags | (Just aVal) <- a tags = let (MkScraper b) = f aVal@@ -57,11 +61,14 @@     mzero = empty     mplus = (<|>) +instance Fail.MonadFail (Scraper str) where+    fail _ = mzero+ -- | The 'scrape' function executes a 'Scraper' on a list of -- 'TagSoup.Tag's and produces an optional value. scrape :: (Ord str, TagSoup.StringLike str)        => Scraper str a -> [TagSoup.Tag str] -> Maybe a-scrape s = scrapeOffsets s . tagWithOffset . TagSoup.canonicalizeTags+scrape s = scrapeTagSpec s . tagsToSpec . TagSoup.canonicalizeTags  -- | The 'chroot' function takes a selector and an inner scraper and executes -- the inner scraper as if it were scraping a document that consists solely of@@ -69,18 +76,19 @@ -- -- This function will match only the first set of tags matching the selector, to -- match every set of tags, use 'chroots'.-chroot :: (Ord str, TagSoup.StringLike str, Selectable s)-       => s -> Scraper str a -> Scraper str a-chroot selector (MkScraper inner) = MkScraper-                                  $ join . (inner <$>)-                                  . listToMaybe . select selector+chroot :: (Ord str, TagSoup.StringLike str)+       => Selector -> Scraper str a -> Scraper str a+chroot selector inner = do+    maybeResult <- listToMaybe <$> chroots selector inner+    guard (isJust maybeResult)+    return $ fromJust maybeResult  -- | The 'chroots' function takes a selector and an inner scraper and executes -- the inner scraper as if it were scraping a document that consists solely of -- the tags corresponding to the selector. The inner scraper is executed for -- each set of tags matching the given selector.-chroots :: (Ord str, TagSoup.StringLike str, Selectable s)-        => s -> Scraper str a -> Scraper str [a]+chroots :: (Ord str, TagSoup.StringLike str)+        => Selector -> Scraper str a -> Scraper str [a] chroots selector (MkScraper inner) = MkScraper                                    $ return . mapMaybe inner . select selector @@ -89,28 +97,28 @@ -- -- This function will match only the first set of tags matching the selector, to -- match every set of tags, use 'texts'.-text :: (Ord str, TagSoup.StringLike str, Selectable s) => s -> Scraper str str-text s = MkScraper $ withHead tagsToText . select_ s+text :: (Ord str, TagSoup.StringLike str) => Selector -> Scraper str str+text s = MkScraper $ withHead tagsToText . select s  -- | The 'texts' function takes a selector and returns the inner text from every -- set of tags matching the given selector.-texts :: (Ord str, TagSoup.StringLike str, Selectable s)-      => s -> Scraper str [str]-texts s = MkScraper $ withAll tagsToText . select_ s+texts :: (Ord str, TagSoup.StringLike str)+      => Selector -> Scraper str [str]+texts s = MkScraper $ withAll tagsToText . select s  -- | The 'html' function takes a selector and returns the html string from the -- set of tags described by the given selector. -- -- This function will match only the first set of tags matching the selector, to -- match every set of tags, use 'htmls'.-html :: (Ord str, TagSoup.StringLike str, Selectable s) => s -> Scraper str str-html s = MkScraper $ withHead tagsToHTML . select_ s+html :: (Ord str, TagSoup.StringLike str) => Selector -> Scraper str str+html s = MkScraper $ withHead tagsToHTML . select s  -- | The 'htmls' function takes a selector and returns the html string from -- every set of tags matching the given selector.-htmls :: (Ord str, TagSoup.StringLike str, Selectable s)-      => s -> Scraper str [str]-htmls s = MkScraper $ withAll tagsToHTML . select_ s+htmls :: (Ord str, TagSoup.StringLike str)+      => Selector -> Scraper str [str]+htmls s = MkScraper $ withAll tagsToHTML . select s  -- | The 'innerHTML' function takes a selector and returns the inner html string -- from the set of tags described by the given selector. Inner html here meaning@@ -118,15 +126,15 @@ -- -- This function will match only the first set of tags matching the selector, to -- match every set of tags, use 'innerHTMLs'.-innerHTML :: (Ord str, TagSoup.StringLike str, Selectable s)-          => s -> Scraper str str-innerHTML s = MkScraper $ withHead tagsToInnerHTML . select_ s+innerHTML :: (Ord str, TagSoup.StringLike str)+          => Selector -> Scraper str str+innerHTML s = MkScraper $ withHead tagsToInnerHTML . select s  -- | The 'innerHTMLs' function takes a selector and returns the inner html -- string from every set of tags matching the given selector.-innerHTMLs :: (Ord str, TagSoup.StringLike str, Selectable s)-           => s -> Scraper str [str]-innerHTMLs s = MkScraper $ withAll tagsToInnerHTML . select_ s+innerHTMLs :: (Ord str, TagSoup.StringLike str)+           => Selector -> Scraper str [str]+innerHTMLs s = MkScraper $ withAll tagsToInnerHTML . select s  -- | The 'attr' function takes an attribute name and a selector and returns the -- value of the attribute of the given name for the first opening tag that@@ -134,40 +142,91 @@ -- -- This function will match only the opening tag matching the selector, to match -- every tag, use 'attrs'.-attr :: (Ord str, Show str, TagSoup.StringLike str, Selectable s)-     => String -> s -> Scraper str str+attr :: (Ord str, Show str, TagSoup.StringLike str)+     => String -> Selector -> Scraper str str attr name s = MkScraper-            $ join . withHead (tagsToAttr $ TagSoup.castString name) . select_ s+            $ join . withHead (tagsToAttr $ TagSoup.castString name) . select s  -- | The 'attrs' function takes an attribute name and a selector and returns the -- value of the attribute of the given name for every opening tag that matches -- the given selector.-attrs :: (Ord str, Show str, TagSoup.StringLike str, Selectable s)-     => String -> s -> Scraper str [str]+attrs :: (Ord str, Show str, TagSoup.StringLike str)+     => String -> Selector -> Scraper str [str] attrs name s = MkScraper-             $ fmap catMaybes . withAll (tagsToAttr nameStr) . select_ s+             $ fmap catMaybes . withAll (tagsToAttr nameStr) . select s     where nameStr = TagSoup.castString name +-- | The 'position' function is intended to be used within the do-block of a+-- `chroots` call. Within the do-block position will return the index of the+-- current sub-tree within the list of all sub-trees matched by the selector+-- passed to `chroots`.+--+-- For example, consider the following HTML:+--+-- @+-- \<article\>+--  \<p\> First paragraph. \</p\>+--  \<p\> Second paragraph. \</p\>+--  \<p\> Third paragraph. \</p\>+-- \</article\>+-- @+--+-- The `position` function can be used to determine the index of each @\<p\>@ tag+-- within the @article@ tag by doing the following.+--+-- @+-- chroots "article" // "p" $ do+--   index   <- position+--   content <- text "p"+--   return (index, content)+-- @+--+-- Which will evaluate to the list:+--+-- @+-- [+--   (0, "First paragraph.")+-- , (1, "Second paragraph.")+-- , (2, "Third paragraph.")+-- ]+-- @+position :: (Ord str, TagSoup.StringLike str) => Scraper str Int+position = MkScraper $ Just . tagsToPosition+ withHead :: (a -> b) -> [a] -> Maybe b withHead _ []    = Nothing withHead f (x:_) = Just $ f x  withAll :: (a -> b) -> [a] -> Maybe [b]-withAll _ [] = Nothing withAll f xs = Just $ map f xs -tagsToText :: TagSoup.StringLike str => [TagSoup.Tag str] -> str-tagsToText = TagSoup.innerText+foldSpec :: TagSoup.StringLike str+         => (TagSoup.Tag str -> str -> str) -> TagSpec str -> str+foldSpec f = Vector.foldr' (f . infoTag) TagSoup.empty . (\(a, _, _) -> a) -tagsToHTML :: TagSoup.StringLike str => [TagSoup.Tag str] -> str-tagsToHTML = TagSoup.renderTags -tagsToInnerHTML :: TagSoup.StringLike str => [TagSoup.Tag str] -> str-tagsToInnerHTML = tagsToHTML . reverse . drop 1 . reverse . drop 1+tagsToText :: TagSoup.StringLike str => TagSpec str -> str+tagsToText = foldSpec f+    where+        f (TagSoup.TagText str) s = str `TagSoup.append` s+        f _                     s = s +tagsToHTML :: TagSoup.StringLike str => TagSpec str -> str+tagsToHTML = foldSpec (\tag s -> TagSoup.renderTags [tag] `TagSoup.append` s)++tagsToInnerHTML :: TagSoup.StringLike str => TagSpec str -> str+tagsToInnerHTML (tags, tree, ctx)+    | len < 2   = TagSoup.empty+    | otherwise = tagsToHTML (Vector.slice 1 (len - 2) tags, tree, ctx)+    where len = Vector.length tags+ tagsToAttr :: (Show str, TagSoup.StringLike str)-           => str -> [TagSoup.Tag str] -> Maybe str-tagsToAttr attr tags = do-    tag <- listToMaybe tags+           => str -> TagSpec str -> Maybe str+tagsToAttr attr (tags, _, _) = do+    guard $ 0 < Vector.length tags+    let tag = infoTag $ tags Vector.! 0     guard $ TagSoup.isTagOpen tag     return $ TagSoup.fromAttrib attr tag++tagsToPosition :: TagSpec str -> Int+tagsToPosition (_, _, ctx) = ctxPosition ctx

@@ -13,4 +13,5 @@ -- tags and executes a 'Scraper' on it. scrapeStringLike :: (Ord str, TagSoup.StringLike str)                  => str -> Scraper str a -> Maybe a-scrapeStringLike html scraper = scrape scraper (TagSoup.parseTags html)+scrapeStringLike html scraper+    = scrape scraper (TagSoup.parseTagsOptions TagSoup.parseOptionsFast html)

@@ -1,45 +1,91 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE BangPatterns #-} {-# OPTIONS_HADDOCK hide #-} module Text.HTML.Scalpel.Internal.Select (-    CloseOffset+    SelectContext (..)+,   TagSpec+,   TagInfo (..)  ,   select-,   select_-,   tagWithOffset+,   tagsToSpec ) where  import Text.HTML.Scalpel.Internal.Select.Types  import Control.Applicative ((<$>), (<|>))-import Control.Arrow (first)-import Data.List (tails)-import Data.Maybe (catMaybes)-import GHC.Exts (sortWith)+import Data.Maybe (catMaybes, isJust, fromJust, fromMaybe)  import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import qualified Data.Tree as Tree+import qualified Data.Vector as Vector import qualified Text.HTML.TagSoup as TagSoup import qualified Text.StringLike as TagSoup  -type CloseOffset = Maybe Int+type Index = Int+type Name = Maybe T.Text+type CloseOffset = Maybe Index +-- | The span of a tag in terms of the index of the opening tag and the index of+-- the closing tag. If there is no closing tag the closing tag is equal to the+-- opening tag.+data Span = Span !Int !Int++-- | A representation of the hierarchal structure of a document. Nodes of the+-- tree are spans which mark the start and end of a tag. The tree is organized+-- such that tags that appear earlier in the parsed string appear earlier in the+-- list of nodes, and that a given node is completely within the span of its+-- parent.+type TagForest = Tree.Forest Span++-- | A tag and associated precomputed meta data that is accessed in tight inner+-- loops during scraping.+data TagInfo str = TagInfo {+                   infoTag    :: !(TagSoup.Tag str)+                 , infoName   :: !Name+                 , infoIndex  :: !Index+                 , infoOffset :: !CloseOffset+                 }++-- | A vector of tags and precomputed meta data. A vector is used because it+-- allows for constant time slicing and sharing memory between the slices.+type TagVector str = Vector.Vector (TagInfo str)++-- | Ephemeral meta-data that each TagSpec is tagged with. This type contains+-- information that is not intrinsic in the sub-tree that corresponds to a given+-- TagSpec.+data SelectContext = SelectContext {+                     -- | `select` generates a list of `TagSpec`s that match a+                     -- selector. This indicates the index in the result list+                     -- that this TagSpec corresponds to.+                     ctxPosition :: !Index+                   }++-- | A structured representation of the parsed tags that provides fast element+-- look up via a vector of tags, and fast traversal via a rose tree of tags.+type TagSpec str = (TagVector str, TagForest, SelectContext)+ -- | The 'select' function takes a 'Selectable' value and a list of -- 'TagSoup.Tag's and returns a list of every subsequence of the given list of -- Tags that matches the given selector.-select :: (Ord str, TagSoup.StringLike str, Selectable s)-       => s-       -> [(TagSoup.Tag str, CloseOffset)]-       -> [[(TagSoup.Tag str, CloseOffset)]]-select s = selectNodes nodes-    where (MkSelector nodes) = toSelector s+select :: (Ord str, TagSoup.StringLike str)+       => Selector -> TagSpec str -> [TagSpec str]+select s tagSpec = newSpecs+    where+        (MkSelector nodes) = s+        newSpecs = zipWith applyPosition [0..] (selectNodes nodes tagSpec [])+        applyPosition p (tags, f, ctx) = (tags, f, SelectContext p) --- | Like 'select' but strips the 'CloseOffset' from the result.-select_ :: (Ord str, TagSoup.StringLike str, Selectable s)-       => s-       -> [(TagSoup.Tag str, CloseOffset)]-       -> [[TagSoup.Tag str]]-select_ s = map (map fst) . select s+-- | Creates a TagSpec from a list of tags parsed by TagSoup.+tagsToSpec :: forall str. (Ord str, TagSoup.StringLike str)+           => [TagSoup.Tag str] -> TagSpec str+tagsToSpec tags = (vector, tree, ctx)+    where+        vector = tagsToVector tags+        tree   = vectorToTree vector+        ctx    = SelectContext 0  -- | Annotate each tag with the offset to the corresponding closing tag. This -- annotating is done in O(n * log(n)).@@ -62,114 +108,160 @@ --          unclosed tags from the state are added to the result set without a --          closing offset. -----      (5) The result set is then sorted and the indices are stripped from the---          tags.-tagWithOffset :: forall str. (Ord str, TagSoup.StringLike str)-              => [TagSoup.Tag str] -> [(TagSoup.Tag str, CloseOffset)]-tagWithOffset tags = let indexed  = zip tags [0..]-                         unsorted = go indexed Map.empty-                         sorted   = sortWith snd unsorted-                      in map fst sorted+--      (5) The result set is then sorted by their indices.+tagsToVector :: forall str. (Ord str, TagSoup.StringLike str)+             => [TagSoup.Tag str] -> TagVector str+tagsToVector tags = let indexed  = zip tags [0..]+                        total    = length indexed+                        unsorted = go indexed Map.empty+                        emptyVec = Vector.replicate total undefined+                     in emptyVec Vector.// unsorted     where-        go :: [(TagSoup.Tag str, Int)]-           -> Map.Map str [(TagSoup.Tag str, Int)]-           -> [((TagSoup.Tag str, CloseOffset), Int)]-        go [] state = map (first (, Nothing)) $ concat $ Map.elems state+        go :: [(TagSoup.Tag str, Index)]+           -> Map.Map T.Text [(TagSoup.Tag str, Index)]+           -> [(Index, TagInfo str)]+        go [] state = map (\(t, i) -> (i, TagInfo t (maybeName t) i Nothing))+                                    $ concat+                                    $ Map.elems state+            where+                maybeName t | TagSoup.isTagOpen t  = Just $ getTagName t+                            | TagSoup.isTagClose t = Just $ getTagName t+                            | otherwise            = Nothing         go (x@(tag, index) : xs) state             | TagSoup.isTagClose tag =                 let maybeOpen = head <$> Map.lookup tagName state                     state'    = Map.alter popTag tagName state+                    info      = TagInfo tag (Just tagName) index Nothing                     res       = catMaybes [-                                        Just ((tag, Nothing), index)-                                    ,   calcOffset <$> maybeOpen-                                    ]+                                  Just (index, info)+                              ,   calcOffset <$> maybeOpen+                              ]                  in res ++ go xs state'             | TagSoup.isTagOpen tag  = go xs (Map.alter appendTag tagName state)-            | otherwise              = ((tag, Nothing), index) : go xs state+            | otherwise              =+                let info = TagInfo tag Nothing index Nothing+                in (index, info) : go xs state             where                 tagName = getTagName tag -                appendTag :: Maybe [(TagSoup.Tag str, Int)]-                          -> Maybe [(TagSoup.Tag str, Int)]+                appendTag :: Maybe [(TagSoup.Tag str, Index)]+                          -> Maybe [(TagSoup.Tag str, Index)]                 appendTag m = (x :) <$> (m <|> Just []) -                calcOffset :: (t, Int) -> ((t, Maybe Int), Int)+                calcOffset :: (TagSoup.Tag str, Int) -> (Index, TagInfo str)                 calcOffset (t, i) =                     let offset = index - i-                     in offset `seq` ((t, Just offset), i)+                        info   = TagInfo t (Just tagName) i (Just offset)+                     in offset `seq` (i, info)                  popTag :: Maybe [a] -> Maybe [a]                 popTag (Just (_ : y : xs)) = let s = y : xs in s `seq` Just s                 popTag _                   = Nothing +getTagName :: TagSoup.StringLike str => TagSoup.Tag str -> T.Text+getTagName (TagSoup.TagOpen name _) = TagSoup.castString name+getTagName (TagSoup.TagClose name)  = TagSoup.castString name+getTagName _                        = undefined++-- | Builds a forest describing the structure of the tags within a given vector.+-- The nodes of the forest are tag spans which mark the indices within the+-- vector of an open and close pair. The tree is organized such for any node n+-- the parent of node n is the smallest span that completely encapsulates the+-- span of node n.+vectorToTree :: TagSoup.StringLike str => TagVector str -> TagForest+vectorToTree tags = fixup $ forestWithin 0 (Vector.length tags)+    where+        forestWithin :: Int -> Int -> TagForest+        forestWithin !lo !hi+            | hi <= lo   = []+            | not isOpen = forestWithin (lo + 1) hi+            | otherwise  = Tree.Node (Span lo closeIndex) subForest+                         : forestWithin (closeIndex + 1) hi+            where+                info       = tags Vector.! lo+                isOpen     = TagSoup.isTagOpen $ infoTag info+                closeIndex = lo + fromMaybe 0 (infoOffset info)+                subForest  = forestWithin (lo + 1) closeIndex++        -- Lifts nodes whose closing tags lay outside their parent tags up to+        -- within a parent node that encompasses the node's entire span.+        fixup :: TagForest -> TagForest+        fixup [] = []+        fixup (Tree.Node (Span lo hi) subForest : siblings)+            = Tree.Node (Span lo hi) ok : bad+            where+                (ok, bad) = malformed (fixup siblings) $ fixup subForest++                malformed :: TagForest -- Forest to prepend bad trees on.+                          -> TagForest  -- Remaining trees to examine.+                          -> (TagForest, TagForest)+                malformed preBad [] = ([], preBad)+                malformed preBad (n@(Tree.Node (Span _ nHi) _) : ns)+                    | hi < nHi  = (ok, n : bad)+                    | otherwise = (n : ok, bad)+                    where (ok, bad) = malformed preBad ns++-- | Generates a list of 'TagSpec's that match the given list of 'SelectNode's.+-- This is is done in linear time with respect to the number of tags.+--+-- The algorithm is a simple DFS traversal of the tag forest. While traversing+-- the forest if the current SelectNode is satisfied by the current node in the+-- tree the SelectNode is popped and the current node's sub-forest is traversed+-- with the remaining SelectNodes. If there is only a single SelectNode then any+-- node encountered that satisfies the SelectNode is returned as an answer. selectNodes :: TagSoup.StringLike str-            => [SelectNode]-            -> [(TagSoup.Tag str, CloseOffset)]-            -> [[(TagSoup.Tag str, CloseOffset)]]-selectNodes nodes tags = head' $ reverse results-    where results = [concatMap (selectNode s) ts | s  <- nodes-                                                 | ts <- [tags] : results]-          head' []    = []-          head' (x:_) = x+            => [SelectNode] -> TagSpec str -> [TagSpec str] -> [TagSpec str]+selectNodes []  _          acc = acc+selectNodes [_] (_, [], _) acc = acc+-- Now that there is only a single SelectNode to satisfy, search the remaining+-- forests and generates a TagSpec for each node that satisfies the condition.+selectNodes [n] (tags, f : fs, ctx) acc+    | nodeMatches n info = (shrunkSpec :)+                         $ selectNodes [n] (tags, fs, ctx)+                         $ selectNodes [n] (tags, Tree.subForest f, ctx) acc+    | otherwise          = selectNodes [n] (tags, fs, ctx)+                         $ selectNodes [n] (tags, Tree.subForest f, ctx) acc+    where+        Span lo hi = Tree.rootLabel f+        shrunkSpec = (+                       Vector.slice lo (hi - lo + 1) tags+                     , [fmap recenter f]+                     , ctx+                     )+        recenter (Span nLo nHi) = Span (nLo - lo) (nHi - lo)+        info = tags Vector.! lo+-- There are multiple SelectNodes that need to be satisfied. If the current node+-- satisfies the condition, then the current nodes sub-forest is searched for+-- matches of the remaining SelectNodes.+selectNodes (_ : _) (_, [], _) acc = acc+selectNodes (n : ns) (tags, f : fs, ctx) acc+    | nodeMatches n info = selectNodes ns       (tags, Tree.subForest f, ctx)+                         $ selectNodes (n : ns) (tags, fs, ctx) acc+    | otherwise          = selectNodes (n : ns) (tags, Tree.subForest f, ctx)+                         $ selectNodes (n : ns) (tags, fs, ctx) acc+    where+        Span lo _ = Tree.rootLabel f+        info = tags Vector.! lo -selectNode :: TagSoup.StringLike str-           => SelectNode-           -> [(TagSoup.Tag str, CloseOffset)]-           -> [[(TagSoup.Tag str, CloseOffset)]]-selectNode (SelectNode node attributes) tags = concatMap extractTagBlock nodes-    where nodes = filter (checkTag node attributes) $ tails tags-selectNode (SelectAny attributes) tags = concatMap extractTagBlock nodes-    where nodes = filter (checkPreds attributes) $ tails tags+-- | Returns True if a tag satisfies a given SelectNode's condition.+nodeMatches :: TagSoup.StringLike str => SelectNode -> TagInfo str -> Bool+nodeMatches (SelectNode node preds) info = checkTag node preds info+nodeMatches (SelectAny preds)       info = checkPreds preds (infoTag info)  -- | Given a tag name and a list of attribute predicates return a function that -- returns true if a given tag matches the supplied name and predicates. checkTag :: TagSoup.StringLike str-          => String-          -> [AttributePredicate]-          -> [(TagSoup.Tag str, CloseOffset)]-          -> Bool-checkTag name preds tags@((TagSoup.TagOpen str _, _) : _)-    = TagSoup.fromString name == str && checkPreds preds tags-checkTag _ _ _ = False+         => T.Text -> [AttributePredicate] -> TagInfo str -> Bool+checkTag name preds (TagInfo tag tagName _ _)+      =  TagSoup.isTagOpen tag+      && isJust tagName+      && name == fromJust tagName+      && checkPreds preds tag +-- | Returns True if a tag satisfies a list of attribute predicates. checkPreds :: TagSoup.StringLike str-            => [AttributePredicate] -> [(TagSoup.Tag str, CloseOffset)] -> Bool-checkPreds preds ((TagSoup.TagOpen _ attrs, _) : _)-    = and [or [checkPred p attr | attr <- attrs] | p <- preds]-checkPreds _ _ = False---- | Given a list of tags, return the prefix of the tags up to the closing tag--- that corresponds to the initial tag.-extractTagBlock :: TagSoup.StringLike str-                => [(TagSoup.Tag str, CloseOffset)]-                -> [[(TagSoup.Tag str, CloseOffset)]]-extractTagBlock (ctag@(tag, maybeOffset) : tags)-    | not $ TagSoup.isTagOpen tag = []-    | Just offset <- maybeOffset  = [takeOrClose ctag offset tags]-    -- To handle tags that do not have a closing tag, fake an empty block by-    -- adding a closing tag. This function assumes that the tag is an open-    -- tag.-    | otherwise                   = [[ctag, (closeForOpen tag, Nothing)]]-extractTagBlock _                 = []---- | Take offset number of elements from tags if available. If there are not--- that many available, then fake a closing tag for the open tag. This happens--- with malformed HTML that looks like `<a><b></a></b>`.-takeOrClose :: TagSoup.StringLike str-            => (TagSoup.Tag str, CloseOffset)-            -> Int-            -> [(TagSoup.Tag str, CloseOffset)]-            -> [(TagSoup.Tag str, CloseOffset)]-takeOrClose open@(tag, _) offset tags = go offset tags (open :)-    where-        go 0 _        f = f []-        go _ []       _ = [open, (closeForOpen tag, Nothing)]-        go i (x : xs) f = go (i - 1) xs (f . (x :))--closeForOpen :: TagSoup.StringLike str => TagSoup.Tag str -> TagSoup.Tag str-closeForOpen = TagSoup.TagClose . getTagName--getTagName :: TagSoup.StringLike str => TagSoup.Tag str -> str-getTagName (TagSoup.TagOpen name _) = name-getTagName (TagSoup.TagClose name)  = name-getTagName _                        = undefined+           => [AttributePredicate] -> TagSoup.Tag str -> Bool+checkPreds preds tag+    =  TagSoup.isTagOpen tag+    && and [or [checkPred p attr | attr <- attrs] | p <- preds]+    where (TagSoup.TagOpen _ attrs) = tag

@@ -20,7 +20,7 @@  -- | The '@:' operator creates a 'Selector' by combining a 'TagName' with a list -- of 'AttributePredicate's.-(@:) :: TagName tag => tag -> [AttributePredicate] -> Selector+(@:) :: TagName -> [AttributePredicate] -> Selector (@:) tag attrs = MkSelector [toSelectNode tag attrs] infixl 9 @: @@ -29,7 +29,7 @@ -- -- If you are attempting to match a specific class of a tag with potentially -- multiple classes, you should use the 'hasClass' utility function.-(@=) :: AttributeName key => key -> String -> AttributePredicate+(@=) :: AttributeName -> String -> AttributePredicate (@=) key value = MkAttributePredicate $ \(attrKey, attrValue) ->                                          matchKey key attrKey                                       && TagSoup.fromString value == attrValue@@ -38,8 +38,8 @@ -- | The '@=~' operator creates an 'AttributePredicate' that will match -- attributes with the given name and whose value matches the given regular -- expression.-(@=~) :: (AttributeName key, RE.RegexLike re String)-      => key -> re -> AttributePredicate+(@=~) :: RE.RegexLike re String+      => AttributeName -> re -> AttributePredicate (@=~) key re = MkAttributePredicate $ \(attrKey, attrValue) ->        matchKey key attrKey     && RE.matchTest re (TagSoup.toString attrValue)@@ -48,10 +48,10 @@ -- | 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.-(//) :: (Selectable a, Selectable b) => a -> b -> Selector+(//) :: Selector -> Selector -> Selector (//) a b = MkSelector (as ++ bs)-    where (MkSelector as) = toSelector a-          (MkSelector bs) = toSelector b+    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

@@ -2,43 +2,38 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ImpredicativeTypes #-} {-# OPTIONS_HADDOCK hide #-}+ module Text.HTML.Scalpel.Internal.Select.Types (     Selector (..)-,   Selectable (..) ,   AttributePredicate (..) ,   checkPred-,   Any (..) ,   AttributeName (..)+,   matchKey ,   TagName (..)- ,   SelectNode (..)+,   tagSelector+,   anySelector+,   toSelectNode ) where  import Data.Char (toLower)+import Data.String (IsString, fromString)  import qualified Text.HTML.TagSoup as TagSoup import qualified Text.StringLike as TagSoup+import qualified Data.Text as T  --- | The 'Selectable' class defines a class of types that are capable of being--- cast into a 'Selector' which in turns describes a section of an HTML DOM--- tree.-class Selectable s where-    toSelector :: s -> Selector+-- | The 'AttributeName' type can be used when creating 'Selector's to specify+-- the name of an attribute of a tag.+data AttributeName = AnyAttribute | AttributeString String --- | The 'AttributeName' class defines a class of types that can be used when--- creating 'Selector's to specify the name of an attribute of a tag.  Currently--- the only types of this class are 'String' for matching attributes exactly,--- and 'Any' for matching attributes with any name.-class AttributeName k where-    matchKey :: TagSoup.StringLike str => k -> str -> Bool+matchKey :: TagSoup.StringLike str => AttributeName -> str -> Bool+matchKey (AttributeString s) = ((TagSoup.fromString $ map toLower s) ==)+matchKey AnyAttribute = const True --- | The 'TagName' class defines a class of types that can be used when creating--- 'Selector's to specify the name of a tag. Currently the only types of this--- class are 'String' for matching tags exactly, and 'Any' for matching tags--- with any name.-class TagName t where-    toSelectNode :: t -> [AttributePredicate] -> SelectNode+instance IsString AttributeName where+    fromString = AttributeString  -- | An 'AttributePredicate' is a method that takes a 'TagSoup.Attribute' and -- returns a 'Bool' indicating if the given attribute matches a predicate.@@ -51,38 +46,31 @@           => AttributePredicate -> TagSoup.Attribute str -> Bool checkPred (MkAttributePredicate p) = p --- | 'Any' can be used as a wildcard when constructing selectors to match tags--- and attributes with any name.------ For example, the selector @Any \@: [Any \@= \"foo\"]@ matches all tags that--- have any attribute where the value is @\"foo\"@.-data Any = Any- -- | 'Selector' defines a selection of an HTML DOM tree to be operated on by -- a web scraper. The selection includes the opening tag that matches the -- selection, all of the inner tags, and the corresponding closing tag. newtype Selector = MkSelector [SelectNode] -data SelectNode = SelectNode String [AttributePredicate]-                | SelectAny [AttributePredicate]--instance Selectable Selector where-    toSelector = id+tagSelector :: String -> Selector+tagSelector tag = MkSelector [toSelectNode (TagString tag) []] -instance Selectable String where-    toSelector node = MkSelector [SelectNode (map toLower node) []]+-- | A selector which will match all tags+anySelector :: Selector+anySelector = MkSelector [SelectAny []] -instance Selectable Any where-    toSelector = const (MkSelector [SelectAny []])+instance IsString Selector where+  fromString = tagSelector -instance AttributeName Any where-    matchKey = const . const True+data SelectNode = SelectNode !T.Text [AttributePredicate]+                | SelectAny [AttributePredicate] -instance AttributeName String where-    matchKey = (==) . TagSoup.fromString . map toLower+-- | The 'TagName' type is used when creating a 'Selector' to specify the name+-- of a tag.+data TagName = AnyTag | TagString String -instance TagName Any where-    toSelectNode = const SelectAny+instance IsString TagName where+    fromString = TagString -instance TagName String where-    toSelectNode = SelectNode . TagSoup.fromString . map toLower+toSelectNode :: TagName -> [AttributePredicate] -> SelectNode+toSelectNode AnyTag = SelectAny+toSelectNode (TagString str) = SelectNode . TagSoup.fromString $ map toLower str

@@ -1,9 +1,13 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+ module Main (main) where  import Text.HTML.Scalpel  import Control.Applicative+import Control.Monad (guard)+import Data.List (isInfixOf) import System.Exit import Test.HUnit @@ -43,12 +47,12 @@      ,   scrapeTest             "<a>foo</a>"-            Nothing+            (Just [])             (htmls ("b" @: []))      ,   scrapeTest             "<a>foo"-            (Just ["<a></a>"])+            (Just ["<a>"])             (htmls ("a" @: []))      ,   scrapeTest@@ -73,7 +77,7 @@      ,   scrapeTest             "<a class=\"a b\">foo</a>"-            Nothing+            (Just [])             (htmls ("a" @: [hasClass "c"]))      ,   scrapeTest@@ -84,27 +88,27 @@     ,   scrapeTest             "<a foo=\"value\">foo</a><a bar=\"value\">bar</a>"             (Just ["<a foo=\"value\">foo</a>", "<a bar=\"value\">bar</a>"])-            (htmls ("a" @: [Any @= "value"]))+            (htmls ("a" @: [AnyAttribute @= "value"]))      ,   scrapeTest             "<a foo=\"other\">foo</a><a bar=\"value\">bar</a>"             (Just ["<a bar=\"value\">bar</a>"])-            (htmls ("a" @: [Any @= "value"]))+            (htmls ("a" @: [AnyAttribute @= "value"]))      ,   scrapeTest             "<a foo=\"value\">foo</a><b bar=\"value\">bar</b>"             (Just ["<a foo=\"value\">foo</a>", "<b bar=\"value\">bar</b>"])-            (htmls (Any @: [Any @= "value"]))+            (htmls (AnyTag @: [AnyAttribute @= "value"]))      ,   scrapeTest             "<a foo=\"other\">foo</a><b bar=\"value\">bar</b>"             (Just ["<b bar=\"value\">bar</b>"])-            (htmls (Any @: [Any @= "value"]))+            (htmls (AnyTag @: [AnyAttribute @= "value"]))      ,   scrapeTest             "<a foo=\"bar\">1</a><a foo=\"foo\">2</a><a bar=\"bar\">3</a>"             (Just ["<a foo=\"foo\">2</a>", "<a bar=\"bar\">3</a>"])-            (htmls (Any @: [match (==)]))+            (htmls (AnyTag @: [match (==)]))      ,   scrapeTest             "<a>foo</a>"@@ -156,9 +160,15 @@             (Just "bar")             (text ("a" // "d") <|> text ("a" // "c")) -    ,   scrapeTest "<img src='foobar'>" (Just "foobar") (attr "src" "img")+    ,   scrapeTest+            "<img src='foobar'>"+            (Just "foobar")+            (attr "src" "img") -    ,   scrapeTest "<img src='foobar' />" (Just "foobar") (attr "src" "img")+    ,   scrapeTest+            "<img src='foobar' />"+            (Just "foobar")+            (attr "src" "img")      ,   scrapeTest             "<a>foo</a><A>bar</A>"@@ -177,7 +187,7 @@      ,   scrapeTest             "<a B=C>foo</a>"-            Nothing+            (Just [])             (texts $ "A" @: ["b" @= "c"])      ,   scrapeTest@@ -213,17 +223,69 @@     ,   scrapeTest             "<a>1<b>2</b>3</a>"             (Just "1<b>2</b>3")-            (innerHTML Any)+            (innerHTML anySelector)      ,   scrapeTest             "<a>"             (Just "")-            (innerHTML Any)+            (innerHTML anySelector)      ,   scrapeTest             "<a>foo</a><a>bar</a>"             (Just ["foo","bar"])             (innerHTMLs "a")++    ,   scrapeTest+            "<a>foo</a><a>bar</a><a>baz</a>"+            (Just "<a>bar</a>")+            (chroot "a" $ do+                t <- text anySelector+                guard ("b" `isInfixOf` t)+                html anySelector)++    ,   scrapeTest+            "<div id=\"outer\"><div id=\"inner\">inner text</div></div>"+            (Just ["inner"])+            (attrs "id" ("div" // "div"))++    ,   scrapeTest+            "<div id=\"a\"><div id=\"b\"><div id=\"c\"></div></div></div>"+            (Just ["b", "c"])+            (attrs "id" ("div" // "div"))++    ,   scrapeTest+            "<a>1<b>2<c>3</c>4</b>5</a>"+            (Just "12345")+            (text anySelector)++    ,   scrapeTest+            "<a>1</a>"+            Nothing+            $ do+                "Bad pattern" <- text "a"+                return "OK"++    ,   scrapeTest+            "<a>1</a>"+            (Just "OK")+            $ do+                "1" <- text "a"+                return "OK"+    ,   scrapeTest+            "<article><p>A</p><p>B</p><p>C</p></article>"+            (Just [(0, "A"), (1, "B"), (2, "C")])+            (chroots ("article" // "p") $ do+                index   <- position+                content <- text anySelector+                return (index, content))++    ,   scrapeTest+            "<article><p>A</p></article><article><p>B</p><p>C</p></article>"+            (Just [[(0, "A")], [(0, "B"), (1, "C")]])+            (chroots "article" $ chroots "p" $ do+                index   <- position+                content <- text anySelector+                return (index, content))     ]  scrapeTest :: (Eq a, Show a) => String -> Maybe a -> Scraper String a -> Test