scalpel-core 0.5.1 → 0.6.0

raw patch · 10 files changed

+825/−84 lines, 10 filesdep +pointedlistPVP ok

version bump matches the API change (PVP)

Dependencies added: pointedlist

API changes (from Hackage documentation)

Files

• CHANGELOG.md +27/−0
• scalpel-core.cabal +4/−2
• src/Text/HTML/Scalpel/Core.hs +15/−0
• src/Text/HTML/Scalpel/Internal/Scrape.hs +40/−19
• src/Text/HTML/Scalpel/Internal/Scrape/StringLike.hs +1/−1
• src/Text/HTML/Scalpel/Internal/Select.hs +141/−48
• src/Text/HTML/Scalpel/Internal/Select/Combinators.hs +18/−3
• src/Text/HTML/Scalpel/Internal/Select/Types.hs +29/−4
• src/Text/HTML/Scalpel/Internal/Serial.hs +241/−0
• tests/TestMain.hs +309/−7

@@ -2,6 +2,33 @@  ## HEAD +## 0.6.0++### Breaking Changes++- `anySelector` now captures text nodes. This causes different results when used+  with a plural scraper (e.g. `chroots`). Usage with a singular scraper (e.g.+  `chroot`) should be unaffected.+- The dependency on `curl` has been replaced with `http-client` and+  `http-client-tls`. This has the following observable changes.+  - `scrapeURLWithOpts` is removed.+  - The `Config` type used with `scrapeURLWithConfig` no longer contains a list+    of curl options. Instead it now takes a `Maybe Manager` from `http-client`.+  - The `Decoder` function type now takes in a `Response` type from+    `http-client`.+  - `scrapeURL` will now throw an exception if there is a problem connecting to+     a URL.++### Other Changes++- Remove `Ord` constraint from public APIs.+- Add `atDepth` operator which allows for selecting nodes at a specified depth+  in relation to another node (#21).+- Fix issue selecting malformed HTML where `"a" // "c"` would not match+  `<a><b><c></c></a></b>`.+- Add `textSelector` for selecting text nodes.+- Add `SerialScraper` type and associated primitives (#48).+ ## 0.5.1  - Fix bug (#59, #54) in DFS traversal order.

@@ -1,5 +1,5 @@ name:                scalpel-core-version:             0.5.1+version:             0.6.0 synopsis:            A high level web scraping library for Haskell. description:     Scalpel core provides a subset of the scalpel web scraping library that is@@ -24,7 +24,7 @@ source-repository this   type:     git   location: https://github.com/fimad/scalpel.git-  tag:      v0.5.1+  tag:      v0.6.0  library   other-extensions:@@ -36,6 +36,7 @@       ,   Text.HTML.Scalpel.Internal.Select       ,   Text.HTML.Scalpel.Internal.Select.Combinators       ,   Text.HTML.Scalpel.Internal.Select.Types+      ,   Text.HTML.Scalpel.Internal.Serial   exposed-modules:       Text.HTML.Scalpel.Core   hs-source-dirs:   src/@@ -46,6 +47,7 @@       ,   containers       ,   data-default       ,   fail+      ,   pointedlist       ,   regex-base       ,   regex-tdfa       ,   tagsoup       >= 0.12.2

@@ -18,10 +18,12 @@ ,   AttributeName (..) ,   TagName (..) ,   tagSelector+,   textSelector -- ** Wildcards ,   anySelector -- ** Tag combinators ,   (//)+,   atDepth -- ** Attribute predicates ,   (@:) ,   (@=)@@ -44,12 +46,25 @@ ,   chroot ,   chroots ,   position+,   matches -- ** Executing scrapers ,   scrape ,   scrapeStringLike++-- * Serial Scraping+,   SerialScraper+,   inSerial+-- ** Primitives+,   stepNext+,   stepBack+,   seekNext+,   seekBack+,   untilNext+,   untilBack ) where  import Text.HTML.Scalpel.Internal.Scrape import Text.HTML.Scalpel.Internal.Scrape.StringLike import Text.HTML.Scalpel.Internal.Select.Combinators import Text.HTML.Scalpel.Internal.Select.Types+import Text.HTML.Scalpel.Internal.Serial

@@ -1,6 +1,6 @@ {-# OPTIONS_HADDOCK hide #-} module Text.HTML.Scalpel.Internal.Scrape (-    Scraper+    Scraper (..) ,   scrape ,   attr ,   attrs@@ -12,6 +12,7 @@ ,   texts ,   chroot ,   chroots+,   matches ,   position ) where @@ -66,7 +67,7 @@  -- | The 'scrape' function executes a 'Scraper' on a list of -- 'TagSoup.Tag's and produces an optional value.-scrape :: (Ord str, TagSoup.StringLike str)+scrape :: (TagSoup.StringLike str)        => Scraper str a -> [TagSoup.Tag str] -> Maybe a scrape s = scrapeTagSpec s . tagsToSpec . TagSoup.canonicalizeTags @@ -76,7 +77,7 @@ -- -- 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)+chroot :: (TagSoup.StringLike str)        => Selector -> Scraper str a -> Scraper str a chroot selector inner = do     maybeResult <- listToMaybe <$> chroots selector inner@@ -86,23 +87,34 @@ -- | 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)+-- each set of tags (possibly nested) matching the given selector.+--+-- > s = "<div><div>A</div></div>"+-- > scrapeStringLike s (chroots "div" (pure 0)) == Just [0, 0]+chroots :: (TagSoup.StringLike str)         => Selector -> Scraper str a -> Scraper str [a] chroots selector (MkScraper inner) = MkScraper                                    $ return . mapMaybe inner . select selector +-- | The 'matches' function takes a selector and returns `()` if the selector+-- matches any node in the DOM.+matches :: (TagSoup.StringLike str) => Selector -> Scraper str ()+matches s = MkScraper $ withHead (pure ()) . select s+ -- | The 'text' function takes a selector and returns the inner text 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 'texts'.-text :: (Ord str, TagSoup.StringLike str) => Selector -> Scraper str str+text :: (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)+-- set of tags (possibly nested) matching the given selector.+--+-- > s = "<div>Hello <div>World</div></div>"+-- > scrapeStringLike s (texts "div") == Just ["Hello World", "World"]+texts :: (TagSoup.StringLike str)       => Selector -> Scraper str [str] texts s = MkScraper $ withAll tagsToText . select s @@ -111,12 +123,15 @@ -- -- 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) => Selector -> Scraper str str+html :: (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)+-- every set of tags (possibly nested) matching the given selector.+--+-- > s = "<div><div>A</div></div>"+-- > scrapeStringLike s (htmls "div") == Just ["<div><div>A</div></div>", "<div>A</div>"]+htmls :: (TagSoup.StringLike str)       => Selector -> Scraper str [str] htmls s = MkScraper $ withAll tagsToHTML . select s @@ -126,13 +141,16 @@ -- -- 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)+innerHTML :: (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)+-- string from every set of tags (possibly nested) matching the given selector.+--+-- > s = "<div><div>A</div></div>"+-- > scrapeStringLike s (innerHTMLs "div") == Just ["<div>A</div>", "A"]+innerHTMLs :: (TagSoup.StringLike str)            => Selector -> Scraper str [str] innerHTMLs s = MkScraper $ withAll tagsToInnerHTML . select s @@ -142,15 +160,18 @@ -- -- 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)+attr :: (Show str, TagSoup.StringLike str)      => String -> Selector -> Scraper str str attr name s = MkScraper             $ 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)+-- value of the attribute of the given name for every opening tag+-- (possibly nested) that matches the given selector.+--+-- > s = "<div id=\"out\"><div id=\"in\"></div></div>"+-- > scrapeStringLike s (attrs "id" "div") == Just ["out", "in"]+attrs :: (Show str, TagSoup.StringLike str)      => String -> Selector -> Scraper str [str] attrs name s = MkScraper              $ fmap catMaybes . withAll (tagsToAttr nameStr) . select s@@ -190,7 +211,7 @@ -- , (2, "Third paragraph.") -- ] -- @-position :: (Ord str, TagSoup.StringLike str) => Scraper str Int+position :: (TagSoup.StringLike str) => Scraper str Int position = MkScraper $ Just . tagsToPosition  withHead :: (a -> b) -> [a] -> Maybe b

@@ -11,7 +11,7 @@  -- | The 'scrapeStringLike' function parses a 'StringLike' value into a list of -- tags and executes a 'Scraper' on it.-scrapeStringLike :: (Ord str, TagSoup.StringLike str)+scrapeStringLike :: (TagSoup.StringLike str)                  => str -> Scraper str a -> Maybe a scrapeStringLike html scraper     = scrape scraper (TagSoup.parseTagsOptions TagSoup.parseOptionsFast html)

@@ -45,7 +45,6 @@ data TagInfo str = TagInfo {                    infoTag    :: !(TagSoup.Tag str)                  , infoName   :: !Name-                 , infoIndex  :: !Index                  , infoOffset :: !CloseOffset                  } @@ -61,6 +60,10 @@                      -- selector. This indicates the index in the result list                      -- that this TagSpec corresponds to.                      ctxPosition :: !Index+                     -- | True if the current context is the result of chrooting+                     -- to a sub-tree. This is used by serial scrapers to+                     -- determine how to generate zippered sibling nodes.+                   , ctxInChroot :: !Bool                    }  -- | A structured representation of the parsed tags that provides fast element@@ -70,22 +73,23 @@ -- | 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)+select :: (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)+        newSpecs =+            zipWith applyPosition [0..] (selectNodes nodes tagSpec tagSpec [])+        applyPosition p (tags, f, _) = (tags, f, SelectContext p True)  -- | Creates a TagSpec from a list of tags parsed by TagSoup.-tagsToSpec :: forall str. (Ord str, TagSoup.StringLike str)+tagsToSpec :: forall str. (TagSoup.StringLike str)            => [TagSoup.Tag str] -> TagSpec str tagsToSpec tags = (vector, tree, ctx)     where         vector = tagsToVector tags         tree   = vectorToTree vector-        ctx    = SelectContext 0+        ctx    = SelectContext 0 False  -- | Annotate each tag with the offset to the corresponding closing tag. This -- annotating is done in O(n * log(n)).@@ -109,7 +113,7 @@ --          closing offset. -- --      (5) The result set is then sorted by their indices.-tagsToVector :: forall str. (Ord str, TagSoup.StringLike str)+tagsToVector :: forall str. (TagSoup.StringLike str)              => [TagSoup.Tag str] -> TagVector str tagsToVector tags = let indexed  = zip tags [0..]                         total    = length indexed@@ -120,38 +124,40 @@         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+        go [] state =+                map (\(t, i) -> (i, TagInfo t (maybeName t) 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+        go ((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+                    info      = TagInfo tag (Just tagName) Nothing                     res       = catMaybes [                                   Just (index, info)                               ,   calcOffset <$> maybeOpen                               ]                  in res ++ go xs state'-            | TagSoup.isTagOpen tag  = go xs (Map.alter appendTag tagName state)-            | otherwise              =-                let info = TagInfo tag Nothing index Nothing+            | TagSoup.isTagOpen tag =+                go xs (Map.alter appendTag tagName state)+            | otherwise =+                let info = TagInfo tag Nothing Nothing                 in (index, info) : go xs state             where                 tagName = getTagName tag                  appendTag :: Maybe [(TagSoup.Tag str, Index)]                           -> Maybe [(TagSoup.Tag str, Index)]-                appendTag m = (x :) <$> (m <|> Just [])+                appendTag m = ((tag, index) :) <$> (m <|> Just []) -                calcOffset :: (TagSoup.Tag str, Int) -> (Index, TagInfo str)+                calcOffset :: (TagSoup.Tag str, Index) -> (Index, TagInfo str)                 calcOffset (t, i) =                     let offset = index - i-                        info   = TagInfo t (Just tagName) i (Just offset)+                        info   = TagInfo t (Just tagName) (Just offset)                      in offset `seq` (i, info)                  popTag :: Maybe [a] -> Maybe [a]@@ -174,12 +180,14 @@         forestWithin :: Int -> Int -> TagForest         forestWithin !lo !hi             | hi <= lo   = []-            | not isOpen = forestWithin (lo + 1) hi+            | shouldSkip = 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+                isText     = TagSoup.isTagText $ infoTag info+                shouldSkip = not isOpen && not isText                 closeIndex = lo + fromMaybe 0 (infoOffset info)                 subForest  = forestWithin (lo + 1) closeIndex @@ -210,17 +218,25 @@ -- 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] -> TagSpec str -> [TagSpec str] -> [TagSpec str]-selectNodes []  _          acc = acc-selectNodes [_] (_, [], _) acc = acc+            => [(SelectNode, SelectSettings)]+            -> TagSpec str+            -> 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, Tree.subForest f, ctx)-                         $ selectNodes [n] (tags, fs, ctx) acc+selectNodes [n] cur@(tags, f : fs, ctx) root acc+    | MatchOk == matchResult+        = (shrunkSpec :)+        $ selectNodes [n] (tags, fs, ctx) root+        $ selectNodes [n] (tags, Tree.subForest f, ctx) root acc+    | MatchCull == matchResult+        = selectNodes [n] (tags, fs, ctx) root acc+    | otherwise+        = selectNodes [n] (tags, Tree.subForest f, ctx) root+        $ selectNodes [n] (tags, fs, ctx) root acc     where         Span lo hi = Tree.rootLabel f         shrunkSpec = (@@ -230,38 +246,115 @@                      )         recenter (Span nLo nHi) = Span (nLo - lo) (nHi - lo)         info = tags Vector.! lo+        matchResult = nodeMatches n info cur root -- 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+selectNodes (_ : _) (_, [], _) _ acc = acc+selectNodes (n : ns) cur@(tags, f : fs, ctx) root acc+    | MatchOk == matchResult+        = selectNodes ns       (tags, Tree.subForest f ++ siblings, ctx)+                               -- The new root node is the just matched node+                               -- plus the lifted siblings.+                               (tags, f : siblings, ctx)+        $ selectNodes (n : ns) (tags, fs, ctx) root acc+    | MatchCull == matchResult+        = selectNodes (n : ns) (tags, fs, ctx) root acc+    | otherwise+        = selectNodes (n : ns) (tags, Tree.subForest f, ctx) root+        $ selectNodes (n : ns) (tags, fs, ctx) root acc     where-        Span lo _ = Tree.rootLabel f+        Span lo hi = Tree.rootLabel f         info = tags Vector.! lo+        matchResult = nodeMatches n info cur root +        -- In the case of a match, it is possible that there are children nested+        -- within the sibling forests that are potentially valid matches for the+        -- current node despite not being direct children. This can happen with+        -- malformed HTML, for example <a><b><c></c><a></b>. In this case <c>+        -- would be a child of <b> which would be a sibling of <a>.+        --+        -- In order to match <c> it must be lifted out of <b>'s sub forest when+        -- matching <a>.+        treeLo tree | (Span lo _) <- Tree.rootLabel tree = lo+        treeHi tree | (Span _ hi) <- Tree.rootLabel tree = hi++        liftSiblings []       acc = acc+        liftSiblings (t : ts) acc+          | lo < treeLo t && treeHi t < hi = t : liftSiblings ts acc+          | hi < treeLo t || treeHi t < lo = liftSiblings ts acc+          | otherwise                      = liftSiblings (Tree.subForest t)+                                           $ liftSiblings ts acc+        siblings = liftSiblings fs []++-- | The result of nodeMatches, can either be a match, a failure, or a failure+-- that culls all children of the current node.+data MatchResult = MatchOk | MatchFail | MatchCull+  deriving (Eq)++-- | Ands together two MatchResult values.+andMatch :: MatchResult -> MatchResult -> MatchResult+andMatch MatchOk MatchOk = MatchOk+andMatch MatchCull _     = MatchCull+andMatch _ MatchCull     = MatchCull+andMatch _ _             = MatchFail++-- | Turns a boolean value into a MatchResult.+boolMatch :: Bool -> MatchResult+boolMatch True  = MatchOk+boolMatch False = MatchFail+ -- | 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)+nodeMatches :: TagSoup.StringLike str+            => (SelectNode, SelectSettings)+            -> TagInfo str+            -> TagSpec str+            -> TagSpec str+            -> MatchResult+nodeMatches (SelectNode node preds, settings) info cur root =+    checkSettings settings cur root `andMatch` checkTag node preds info+nodeMatches (SelectAny preds      , settings) info cur root =+    checkSettings settings cur root `andMatch` checkPreds preds (infoTag info)+nodeMatches (SelectText           , settings) info cur root =+    checkSettings settings cur root `andMatch`+    boolMatch (TagSoup.isTagText $ infoTag info) +-- | Given a SelectSettings, the current node under consideration, and the last+-- matched node, returns true IFF the current node satisfies all of the+-- selection settings.+checkSettings :: TagSoup.StringLike str+              => SelectSettings -> TagSpec str -> TagSpec str -> MatchResult+checkSettings (SelectSettings (Just depth))+              (_, curRoot : _, _)+              (_, root, _)+  | depthOfCur < depth = MatchFail+  | depthOfCur > depth = MatchCull+  | otherwise          = MatchOk+  where+      Span curLo curHi = Tree.rootLabel curRoot+      mapTree f = map f . concatMap Tree.flatten+      depthOfCur = sum $ mapTree oneIfContainsCur root+      oneIfContainsCur (Span lo hi)+          | lo < curLo && curHi < hi = 1+          | otherwise = 0+checkSettings (SelectSettings _) _ _ = MatchOk+ -- | 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-         => T.Text -> [AttributePredicate] -> TagInfo str -> Bool-checkTag name preds (TagInfo tag tagName _ _)-      =  TagSoup.isTagOpen tag-      && isJust tagName-      && name == fromJust tagName-      && checkPreds preds tag+         => T.Text -> [AttributePredicate] -> TagInfo str -> MatchResult+checkTag name preds (TagInfo tag tagName _)+      =  boolMatch (+          TagSoup.isTagOpen tag+        && isJust tagName+        && name == fromJust tagName+      ) `andMatch` checkPreds preds tag  -- | Returns True if a tag satisfies a list of attribute predicates. checkPreds :: TagSoup.StringLike str-           => [AttributePredicate] -> TagSoup.Tag str -> Bool-checkPreds preds tag-    =  TagSoup.isTagOpen tag-    && all (flip checkPred attrs) preds+           => [AttributePredicate] -> TagSoup.Tag str -> MatchResult+checkPreds []    tag = boolMatch+                     $ TagSoup.isTagOpen tag || TagSoup.isTagText tag+checkPreds preds tag = boolMatch+                     $ TagSoup.isTagOpen tag && all (`checkPred` attrs) preds     where (TagSoup.TagOpen _ attrs) = tag

@@ -7,9 +7,10 @@ ,   (@:) ,   (@=) ,   (@=~)+,   atDepth ,   hasClass-,   notP ,   match+,   notP ) where  import Text.HTML.Scalpel.Internal.Select.Types@@ -22,7 +23,7 @@ -- | The '@:' operator creates a 'Selector' by combining a 'TagName' with a list -- of 'AttributePredicate's. (@:) :: TagName -> [AttributePredicate] -> Selector-(@:) tag attrs = MkSelector [toSelectNode tag attrs]+(@:) tag attrs = MkSelector [(toSelectNode tag attrs, defaultSelectSettings)] infixl 9 @:  -- | The '@=' operator creates an 'AttributePredicate' that will match@@ -46,6 +47,20 @@     && RE.matchTest re (TagSoup.toString attrValue) infixl 6 @=~ +-- | The 'atDepth' operator constrains a 'Selector' to only match when it is at+-- @depth@ below the previous selector.+--+-- For example, @"div" // "a" `atDepth` 1@ creates a 'Selector' that matches+-- anchor tags that are direct children of a div tag.+atDepth :: Selector -> Int -> Selector+atDepth (MkSelector xs) depth = MkSelector (addDepth xs)+  where addDepth []                 = []+        addDepth [(node, settings)] = [+            (node, settings { selectSettingsDepth = Just depth })+          ]+        addDepth (x : xs)           = x : addDepth xs+infixl 6 `atDepth`+ -- | 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.@@ -68,7 +83,7 @@                   textClasses = TagSoup.castString classes                   classList   = T.split (== ' ') textClasses --- | Negates an 'AttributePredicate'. +-- | Negates an 'AttributePredicate'. notP :: AttributePredicate -> AttributePredicate notP (MkAttributePredicate p) = MkAttributePredicate $ not . p 

@@ -14,7 +14,10 @@ ,   SelectNode (..) ,   tagSelector ,   anySelector+,   textSelector ,   toSelectNode+,   SelectSettings (..)+,   defaultSelectSettings ) where  import Data.Char (toLower)@@ -56,20 +59,42 @@ -- | '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]+newtype Selector = MkSelector [(SelectNode, SelectSettings)] +-- | 'SelectSettings' defines additional criteria for a Selector that must be+-- satisfied in addition to the SelectNode. This includes criteria that are+-- dependent on the context of the current node, for example the depth in+-- relation to the previously matched SelectNode.+data SelectSettings = SelectSettings {+  -- | The required depth of the current select node in relation to the+  -- previously matched SelectNode.+  selectSettingsDepth :: Maybe Int+}++defaultSelectSettings :: SelectSettings+defaultSelectSettings = SelectSettings {+  selectSettingsDepth = Nothing+}+ tagSelector :: String -> Selector-tagSelector tag = MkSelector [toSelectNode (TagString tag) []]+tagSelector tag = MkSelector [+    (toSelectNode (TagString tag) [], defaultSelectSettings)+  ] --- | A selector which will match all tags+-- | A selector which will match any node (including tags and bare text). anySelector :: Selector-anySelector = MkSelector [SelectAny []]+anySelector = MkSelector [(SelectAny [], defaultSelectSettings)] +-- | A selector which will match all text nodes.+textSelector :: Selector+textSelector = MkSelector [(SelectText, defaultSelectSettings)]+ instance IsString Selector where   fromString = tagSelector  data SelectNode = SelectNode !T.Text [AttributePredicate]                 | SelectAny [AttributePredicate]+                | SelectText  -- | The 'TagName' type is used when creating a 'Selector' to specify the name -- of a tag.

@@ -0,0 +1,241 @@+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_HADDOCK hide #-}+module Text.HTML.Scalpel.Internal.Serial (+    SerialScraper+,   inSerial+,   stepBack+,   stepNext+,   seekBack+,   seekNext+,   untilBack+,   untilNext+) where++import Text.HTML.Scalpel.Internal.Scrape+import Text.HTML.Scalpel.Internal.Select++import Control.Applicative+import Control.Monad+import Data.List.PointedList (PointedList)++import qualified Control.Monad.Fail as Fail+import qualified Data.List.PointedList as PointedList+import qualified Data.Tree as Tree+import qualified Text.StringLike as TagSoup+++-- | Serial scrapers operate on a zipper of tag specs that correspond to the+-- root nodes / siblings in a document.+--+-- Access to the zipper is always performed in a move-then-read manner. For this+-- reason it is valid for the current focus of the zipper to be just off either+-- end of list such that moving forward or backward would result in reading the+-- first or last node.+--+-- These valid focuses are expressed as Nothing values at either end of the+-- zipper since they are valid positions for the focus to pass over, but not+-- valid positions to read.+type SpecZipper str = PointedList (Maybe (TagSpec str))++-- | A 'SerialScraper' allows for the application of 'Scraper's on a sequence of+-- sibling nodes. This allows for use cases like targeting the sibling of a+-- node, or extracting a sequence of sibling nodes (e.g. paragraphs (\<p\>)+-- under a header (\<h2\>)).+--+-- Conceptually serial scrapers operate on a sequence of tags that correspond to+-- the immediate children of the currently focused node. For example, given the+-- following HTML:+--+-- @+--  \<article\>+--    \<h1\>title\</h1\>+--    \<h2\>Section 1\</h2\>+--    \<p\>Paragraph 1.1\</p\>+--    \<p\>Paragraph 1.2\</p\>+--    \<h2\>Section 2\</h2\>+--    \<p\>Paragraph 2.1\</p\>+--    \<p\>Paragraph 2.2\</p\>+--  \</article\>+-- @+--+-- A serial scraper that visits the header and paragraph nodes can be executed+-- with the following:+--+-- @+-- 'chroot' "article" $ 'inSerial' $ do ...+-- @+--+-- Each 'SerialScraper' primitive follows the pattern of first moving the focus+-- backward or forward and then extracting content from the new focus.+-- Attempting to extract content from beyond the end of the sequence causes the+-- scraper to fail.+--+-- To complete the above example, the article's structure and content can be+-- extracted with the following code:+--+-- @+-- 'chroot' "article" $ 'inSerial' $ do+--     title <- 'seekNext' $ 'text' "h1"+--     sections <- many $ do+--        section <- 'seekNext' $ text "h2"+--        ps <- 'untilNext' ('matches' "h2") (many $ 'seekNext' $ 'text' "p")+--        return (section, ps)+--     return (title, sections)+-- @+--+-- Which will evaluate to:+--+-- @+--  ("title", [+--    ("Section 1", ["Paragraph 1.1", "Paragraph 1.2"]),+--    ("Section 2", ["Paragraph 2.1", "Paragraph 2.2"]),+--  ])+-- @+newtype SerialScraper str a =+    MkSerialScraper (SpecZipper str -> Maybe (a, SpecZipper str))++instance Functor (SerialScraper str) where+    fmap f (MkSerialScraper a) = MkSerialScraper applied+      where applied zipper+                | Just (aVal, zipper') <- a zipper = Just (f aVal, zipper')+                | otherwise                        = Nothing++instance Applicative (SerialScraper str) where+    pure a = MkSerialScraper $ \zipper -> Just (a, zipper)+    (MkSerialScraper f) <*> (MkSerialScraper a) = MkSerialScraper applied+        where+          applied zipper = do+              (f', zipper')  <- f zipper+              (a', zipper'') <- a zipper'+              return (f' a', zipper'')++instance Alternative (SerialScraper str) where+    empty = MkSerialScraper $ const Nothing+    (MkSerialScraper a) <|> (MkSerialScraper b) = MkSerialScraper choice+        where choice zipper | (Just aVal) <- a zipper = Just aVal+                            | otherwise               = b zipper++instance Monad (SerialScraper str) where+    fail = Fail.fail+    return = pure+    (MkSerialScraper a) >>= f = MkSerialScraper combined+        where+          combined zipper = do+              (aVal, zipper') <- a zipper+              let (MkSerialScraper b) = f aVal+              b zipper'++instance MonadPlus (SerialScraper str) where+    mzero = empty+    mplus = (<|>)++instance Fail.MonadFail (SerialScraper str) where+    fail _ = mzero++-- | Executes a 'SerialScraper' in the context of a 'Scraper'. The immediate+-- children of the currently focused node are visited serially.+inSerial :: TagSoup.StringLike str => SerialScraper str a -> Scraper str a+inSerial (MkSerialScraper serialScraper) = MkScraper scraper+  where+    scraper spec@(vec, root : _, ctx)+      | ctxInChroot ctx = fst <$> serialScraper+                                  (toZipper (vec, Tree.subForest root, ctx))+      | otherwise       = fst <$> serialScraper (toZipper spec)+    scraper _           = Nothing++    -- Create a zipper from the current tag spec by generating a new tag spec+    -- that just contains each root node in the forest.+    toZipper (vector, forest, context) =+        zipperFromList $ map ((vector, , context) . return) forest++-- | Creates a SpecZipper from a list of tag specs. This requires bookending the+-- zipper with Nothing values to denote valid focuses that are just off either+-- end of the list.+zipperFromList :: TagSoup.StringLike str => [TagSpec str] -> SpecZipper str+zipperFromList = PointedList.insertLeft Nothing+               . foldr (PointedList.insertLeft . Just)+                       (PointedList.singleton Nothing)++stepWith :: TagSoup.StringLike str+         => (SpecZipper str -> Maybe (SpecZipper str))+         -> Scraper str b+         -> SerialScraper str b+stepWith moveList (MkScraper scraper) = MkSerialScraper $ \zipper -> do+    zipper' <- moveList zipper+    focus <- PointedList._focus zipper'+    value <- scraper focus+    return (value, zipper')++-- | Move the cursor back one node and execute the given scraper on the new+-- focused node.+stepBack :: TagSoup.StringLike str => Scraper str a -> SerialScraper str a+stepBack = stepWith PointedList.previous++-- | Move the cursor forward one node and execute the given scraper on the new+-- focused node.+stepNext :: TagSoup.StringLike str => Scraper str a -> SerialScraper str a+stepNext = stepWith PointedList.next++seekWith :: TagSoup.StringLike str+         => (SpecZipper str -> Maybe (SpecZipper str))+         -> Scraper str b+         -> SerialScraper str b+seekWith moveList (MkScraper scraper) = MkSerialScraper go+    where+      go zipper = do+        zipper' <- moveList zipper+        runScraper zipper' <|> go zipper'+      runScraper zipper = do+        focus <- PointedList._focus zipper+        value <- scraper focus+        return (value, zipper)++-- | Move the cursor backward until the given scraper is successfully able to+-- execute on the focused node. If the scraper is never successful then the+-- serial scraper will fail.+seekBack :: TagSoup.StringLike str => Scraper str a -> SerialScraper str a+seekBack = seekWith PointedList.previous++-- | Move the cursor forward until the given scraper is successfully able to+-- execute on the focused node. If the scraper is never successful then the+-- serial scraper will fail.+seekNext :: TagSoup.StringLike str => Scraper str a -> SerialScraper str a+seekNext = seekWith PointedList.next++untilWith :: TagSoup.StringLike str+         => (SpecZipper str -> Maybe (SpecZipper str))+         -> (Maybe (TagSpec str) -> SpecZipper str -> SpecZipper str)+         -> Scraper str a+         -> SerialScraper str b+         -> SerialScraper str b+untilWith moveList appendNode+          (MkScraper untilScraper) (MkSerialScraper scraper) =+  MkSerialScraper $ \zipper -> do+      let (innerZipper, zipper') = split zipper+      (value, _)  <- scraper $ appendNode Nothing innerZipper+      return (value, zipper')+  where+    split zipper+        | Just zipper' <- moveList zipper+        , Just spec    <- PointedList._focus zipper'+        , Nothing <- untilScraper spec =+            let (specs, zipper'') = split zipper'+            in  (appendNode (Just spec) specs, zipper'')+        | otherwise                   = (PointedList.singleton Nothing, zipper)++-- | Create a new serial context by moving the focus backward and collecting+-- nodes until the scraper matches the focused node. The serial scraper is then+-- executed on the collected nodes.+untilBack :: TagSoup.StringLike str+          => Scraper str a -> SerialScraper str b -> SerialScraper str b+untilBack = untilWith PointedList.previous PointedList.insertRight++-- | Create a new serial context by moving the focus forward and collecting+-- nodes until the scraper matches the focused node. The serial scraper is then+-- executed on the collected nodes.+--+-- The provided serial scraper is unable to see nodes outside the new restricted+-- context.+untilNext :: TagSoup.StringLike str+          => Scraper str a -> SerialScraper str b -> SerialScraper str b+untilNext = untilWith PointedList.next PointedList.insertLeft

@@ -8,14 +8,16 @@ import Control.Applicative import Control.Monad (guard) import Data.List (isInfixOf)-import System.Exit-import Test.HUnit+import System.Exit (ExitCode(..), exitSuccess, exitWith)+import Test.HUnit (Test(..), (@=?), (~:), runTestTT, failures)  import qualified Text.HTML.TagSoup as TagSoup import qualified Text.Regex.TDFA --main = exit . failures =<< runTestTT (TestList [scrapeTests])+main :: IO ()+main = do+  n <- runTestTT (TestList [scrapeTests])+  exit $ failures n  exit :: Int -> IO () exit 0 = exitSuccess@@ -26,226 +28,271 @@  scrapeTests = "scrapeTests" ~: TestList [         scrapeTest+            "htmls should extract matching tag"             "<a>foo</a>"             (Just ["<a>foo</a>"])             (htmls ("a" @: []))      ,   scrapeTest+            "htmls should ignore non-matching tag"             "<a>foo</a><a>bar</a>"             (Just ["<a>foo</a>", "<a>bar</a>"])             (htmls ("a" @: []))      ,   scrapeTest+            "htmls should extract matching tag when it is nested"             "<b><a>foo</a></b>"             (Just ["<a>foo</a>"])             (htmls ("a" @: []))      ,   scrapeTest+            "htmls should extract each matching tag even if it is nested"             "<a><a>foo</a></a>"             (Just ["<a><a>foo</a></a>", "<a>foo</a>"])             (htmls ("a" @: []))      ,   scrapeTest+            "htmls with no matching nodes should result in an empty list"             "<a>foo</a>"             (Just [])             (htmls ("b" @: []))      ,   scrapeTest+            "unclosed tags should be treated as immediately closed"             "<a>foo"             (Just ["<a>"])             (htmls ("a" @: []))      ,   scrapeTest+            "scraping should obey attribute predicates"             "<a>foo</a><a key=\"value\">bar</a>"             (Just ["<a key=\"value\">bar</a>"])             (htmls ("a" @: ["key" @= "value"]))      ,   scrapeTest+            "selectors using // should match the deepest node"             "<a><b><c>foo</c></b></a>"             (Just ["<c>foo</c>"])             (htmls ("a" // "b" @: [] // "c"))      ,   scrapeTest+            "selectors using // should skip over irrelevant nodes"             "<c><a><b>foo</b></a></c><c><a><d><b>bar</b></d></a></c><b>baz</b>"             (Just ["<b>foo</b>", "<b>bar</b>"])             (htmls ("a" // "b"))      ,   scrapeTest+            "hasClass should match tags with multiple classes"             "<a class=\"a b\">foo</a>"             (Just ["<a class=\"a b\">foo</a>"])             (htmls ("a" @: [hasClass "a"]))      ,   scrapeTest+            "hasClass should not match tags without the specified class"             "<a class=\"a b\">foo</a>"             (Just [])             (htmls ("a" @: [hasClass "c"]))      , scrapeTest+            "notP should negate attribute predicates"             "<a>foo</a><a class=\"a b\">bar</a><a class=\"b\">baz</a>"             (Just ["foo", "baz"])             (texts ("a" @: [notP $ hasClass "a"]))      ,   scrapeTest+            "@=~ should match via regular expressions"             "<a key=\"value\">foo</a>"             (Just ["<a key=\"value\">foo</a>"])             (htmls ("a" @: ["key" @=~ re "va(foo|bar|lu)e"]))      ,   scrapeTest+            "AnyAttribute should match any attribute key"             "<a foo=\"value\">foo</a><a bar=\"value\">bar</a>"             (Just ["<a foo=\"value\">foo</a>", "<a bar=\"value\">bar</a>"])             (htmls ("a" @: [AnyAttribute @= "value"]))      ,   scrapeTest+            "AnyAttribute should not match any attribute value"             "<a foo=\"other\">foo</a><a bar=\"value\">bar</a>"             (Just ["<a bar=\"value\">bar</a>"])             (htmls ("a" @: [AnyAttribute @= "value"]))      ,   scrapeTest+            "AnyTag should match any tag with the corresponding attributes"             "<a foo=\"value\">foo</a><b bar=\"value\">bar</b>"             (Just ["<a foo=\"value\">foo</a>", "<b bar=\"value\">bar</b>"])             (htmls (AnyTag @: [AnyAttribute @= "value"]))      ,   scrapeTest+            "AnyTag should not match tags without the corresponding attributes"             "<a foo=\"other\">foo</a><b bar=\"value\">bar</b>"             (Just ["<b bar=\"value\">bar</b>"])             (htmls (AnyTag @: [AnyAttribute @= "value"]))      ,   scrapeTest+            "Custom predicates"             "<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 (AnyTag @: [match (==)]))      ,   scrapeTest+            "text should extract inner text from the first matching tag"             "<a>foo</a>"             (Just "foo")             (text "a")      ,   scrapeTest+            "text should extract inner text from only the first matching tag"             "<a>foo</a><a>bar</a>"             (Just "foo")             (text "a")      ,   scrapeTest+            "texts should extract inner text from all matching tags"             "<a>foo</a><a>bar</a>"             (Just ["foo", "bar"])             (texts "a")      ,   scrapeTest+            "fmap should work as expected"             "<a>foo</a><a>bar</a>"             (Just [True, False])             (map (== "foo") <$> texts "a")      ,   scrapeTest+            "attr extract matching attribute value"             "<a key=foo />"             (Just "foo")             (attr "key" "a")      ,   scrapeTest+            "attr extract matching attribute value with complex predicates"             "<a key1=foo/><b key1=bar key2=foo /><a key1=bar key2=baz />"             (Just "baz")             (attr "key2" $ "a" @: ["key1" @= "bar"])      ,   scrapeTest+            "chroot should limit context to just selected node"             "<a><b>foo</b></a><b>bar</b>"             (Just ["foo"])             (chroot "a" $ texts "b")      ,   scrapeTest+            "chroots should work for all matching nodes"             "<a><b>foo</b></a><a><b>bar</b></a>"             (Just ["foo", "bar"])             (chroots "a" $ text "b")      ,   scrapeTest+            "<|> should return first match if valid"             "<a><b>foo</b></a><a><c>bar</c></a>"             (Just "foo")             (text ("a" // "b") <|> text ("a" // "c"))      ,   scrapeTest+            "<|> should return second match if valid"             "<a><b>foo</b></a><a><c>bar</c></a>"             (Just "bar")             (text ("a" // "d") <|> text ("a" // "c"))      ,   scrapeTest+            "Unclosed tags should be treated as immediately closed"             "<img src='foobar'>"             (Just "foobar")             (attr "src" "img")      ,   scrapeTest+            "scraping should work for self-closing tags"             "<img src='foobar' />"             (Just "foobar")             (attr "src" "img")      ,   scrapeTest+            "lower case selectors should match any case tag"             "<a>foo</a><A>bar</A>"             (Just ["foo", "bar"])             (texts "a")      ,   scrapeTest+            "upper case selectors should match any case tag"             "<a>foo</a><A>bar</A>"             (Just ["foo", "bar"])             (texts "A")      ,   scrapeTest+            "attribute key matching should be case-insensitive"             "<a B=C>foo</a>"             (Just ["foo"])             (texts $ "A" @: ["b" @= "C"])      ,   scrapeTest+            "attribute value matching should be case-sensitive"             "<a B=C>foo</a>"             (Just [])             (texts $ "A" @: ["b" @= "c"])      , scrapeTest+            "notP should invert attribute value matching"             "<a>foo</a><a B=C>bar</a><a B=D>baz</a>"             (Just ["foo", "baz"])             (texts ("a" @: [notP $ "b" @= "C"]))      ,   scrapeTest+            "html should work when matching the root node"             "<a>foo</a>"             (Just "<a>foo</a>")             (html "a")      ,   scrapeTest+            "html should work when matching a nested node"             "<body><div><ul><li>1</li><li>2</li></ul></div></body>"             (Just "<li>1</li>")             (html "li")      ,   scrapeTest+            "html should work when matching a node with no inner text"             "<body><div></div></body>"             (Just "<div></div>")             (html "div")      ,   scrapeTest+            "htmls should return html matching root nodes"             "<a>foo</a><a>bar</a>"             (Just ["<a>foo</a>","<a>bar</a>"])             (htmls "a")      ,   scrapeTest+            "htmls should return html matching nested nodes"             "<body><div><ul><li>1</li><li>2</li></ul></div></body>"             (Just ["<li>1</li>", "<li>2</li>"])             (htmls "li")      ,   scrapeTest+            "htmls should return html matching empty nested nodes"             "<body><div></div></body>"             (Just ["<div></div>"])             (htmls "div")      ,   scrapeTest+            "innerHTML should exclude root tags"             "<a>1<b>2</b>3</a>"             (Just "1<b>2</b>3")             (innerHTML anySelector)      ,   scrapeTest+            "innerHTML of a self closed tag should be the empty string"             "<a>"             (Just "")             (innerHTML anySelector)      ,   scrapeTest+            "innerHTML should match root nodes"             "<a>foo</a><a>bar</a>"             (Just ["foo","bar"])             (innerHTMLs "a")      ,   scrapeTest+            "guard should stop matches"             "<a>foo</a><a>bar</a><a>baz</a>"             (Just "<a>bar</a>")             (chroot "a" $ do@@ -254,21 +301,25 @@                 html anySelector)      ,   scrapeTest+            "// should force a decent before matching"             "<div id=\"outer\"><div id=\"inner\">inner text</div></div>"             (Just ["inner"])             (attrs "id" ("div" // "div"))      ,   scrapeTest+            "div // div should match div/div/div twice"             "<div id=\"a\"><div id=\"b\"><div id=\"c\"></div></div></div>"             (Just ["b", "c"])             (attrs "id" ("div" // "div"))      ,   scrapeTest+            "anySelector should match the root node"             "<a>1<b>2<c>3</c>4</b>5</a>"             (Just "12345")             (text anySelector)      ,   scrapeTest+            "failing a pattern match should stop a scraper"             "<a>1</a>"             Nothing             $ do@@ -276,12 +327,14 @@                 return "OK"      ,   scrapeTest+            "passing a pattern match should not stop a scraper"             "<a>1</a>"             (Just "OK")             $ do                 "1" <- text "a"                 return "OK"     ,   scrapeTest+            "position should return the index of the match"             "<article><p>A</p><p>B</p><p>C</p></article>"             (Just [(0, "A"), (1, "B"), (2, "C")])             (chroots ("article" // "p") $ do@@ -290,6 +343,7 @@                 return (index, content))      ,   scrapeTest+            "position should return the index of most recent match"             "<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@@ -298,28 +352,276 @@                 return (index, content))      ,   scrapeTest+            "DFS regression test for #59 (1)"             "<div><p>p1</p><p>p2</p><blockquote><p>p3</p></blockquote><p>p4</p>"             (Just ["p1", "p2", "p3", "p4"])             (texts "p")      ,   scrapeTest+            "DFS regression test for #59 (2)"             "<a><b>1</b></a><a><b>2</b></a><a><b>3</b></a>"             (Just ["1","2","3"])             (texts "a")      ,   scrapeTest+            "DFS regression test for #59 (3)"             "<a><b>1</b></a><a><b>2</b></a><a><b>3</b></a>"             (Just ["1","2","3"])             (texts $ "a" // "b")      ,   scrapeTest+            "DFS regression test for #59 (4)"             "<a><b>1</b></a><a><b>2</b></a><a><b>3</b></a>"             (Just ["1","2","3"])             (texts "b")++    ,   scrapeTest+            "atDepth 1 should select immediate children"+            "<a><b>1</b><c><b>2</b></c></a>"+            (Just ["1"])+            (texts $ "a" // "b" `atDepth` 1)++    ,   scrapeTest+            "atDepth 2 should select children children"+            "<a><b>1</b><c><b>2</b></c></a>"+            (Just ["2"])+            (texts $ "a" // "b" `atDepth` 2)++    ,   scrapeTest+            "atDepth should compose with attribute predicates"+            "<a><b class='foo'>1</b><c><b class='foo'>2</b></c></a>"+            (Just ["1"])+            (texts $ "a" // "b" @: [hasClass "foo"] `atDepth` 1)++    -- Depth should handle malformed HTML correctly. Below <b> and <c> are not+    -- closed in the proper order, but since <d> is nested within both in the+    -- context of <a>, <d> is still at depth 3.+    ,   scrapeTest+            "atDepth should handle tags closed out of order (full context)"+            "<a><b><c><d>1</d></b></c></a>"+            (Just ["1"])+            (texts $ "a" // "d" `atDepth` 3)++    -- However, from the context of <b>, <d> is only at depth 1 because there is+    -- no closing <c> tag within the <b> tag so the <c> tag is assumed to be+    -- self-closing.+    ,   scrapeTest+            "atDepth should handle tags closed out of order (partial context)"+            "<a><b><c><d>2</d></b></c></a>"+            (Just ["2"])+            (texts $ "b" // "d" `atDepth` 1)++    ,   scrapeTest+            "// should handle tags closed out of order"+            "<a><b><c><d>2</d></b></c></a>"+            (Just ["2"])+            (texts $ "b" // "d")++    ,   scrapeTest+            "// should handle tags closed out of order for the root (1)"+            "<b><c><d>2</d></b></c>"+            (Just ["2"])+            (texts $ "b" // "d")++    ,   scrapeTest+            "// should handle tags closed out of order for the root (2)"+            "<b><c><d>2</d></b></c>"+            (Just ["2"])+            (texts $ "c" // "d")++    ,   scrapeTest+            "textSelector should select each text node"+            "1<a>2</a>3<b>4<c>5</c>6</b>7"+            (Just $ map show [1..7])+            (texts textSelector)++    ,   scrapeTest+            "anySelector should select text nodes"+            "1<a>2</a>3<b>4<c>5</c>6</b>7"+            (Just ["1", "2", "3", "456", "7"])+            (texts $ anySelector `atDepth` 0)++    ,   scrapeTest+            "atDepth should treat out of focus close tags as immediately closed"+            "<a><b><c><d>2</d></c></a></b>"+            (Just ["2"])+            (texts $ "a" // "d" `atDepth` 2)++    ,   scrapeTest+            "Applicative sanity checks for SerialScraper"+            "<a>1</a><b>2</b><a>3</a>"+            (Just ("1", "2"))+            (inSerial $ (,) <$> stepNext (text "a")+                            <*> stepNext (text "b"))++    ,   scrapeTest+            "Monad sanity checks for SerialScraper"+            "<a>1</a><b>2</b><a>3</a>"+            (Just ("1", "2"))+            (inSerial $ do+              a <- stepNext (text "a")+              b <- stepNext (text "b")+              return (a, b))++    ,   scrapeTest+            "stepping off the end of the list without reading should be allowed"+            "<a>1</a><b>2</b><a>3</a>"+            (Just ["1", "2", "3", "2" , "1"])+            (inSerial $ do+              a <- stepNext $ text anySelector+              b <- stepNext $ text anySelector+              c <- stepNext $ text anySelector+              d <- stepBack $ text anySelector+              e <- stepBack $ text anySelector+              return [a, b, c, d, e])++    ,   scrapeTest+            "stepping off the end of the list and reading should fail"+            "<a>1</a><b>2</b><a>3</a>"+            Nothing+            (inSerial $ (,,,) <$> stepNext (text anySelector)+                              <*> stepNext (text anySelector)+                              <*> stepNext (text anySelector)+                              <*> stepNext (text anySelector))++    ,   scrapeTest+            "seeking should skip over nodes"+            "<a>1</a><b>2</b><a>3</a>"+            (Just ("2", "3"))+            (inSerial $ (,) <$> seekNext (text "b")+                            <*> seekNext (text "a"))++    ,   scrapeTest+            "seeking should fail if there is not matching node"+            "<a>1</a><b>2</b><a>3</a>"+            Nothing+            (inSerial $ seekNext $ text "c")++    ,   scrapeTest+            "seeking off the end the zipper should be allowed without reading"+            "<a>1</a><b>2</b><c>3</c>"+            (Just ("3", "1"))+            (inSerial $ (,) <$> seekNext (text "c")+                            <*> seekBack (text "a"))++    ,   scrapeTest+            "Alternative sanity check for SerialScraper"+            "1<a foo=bar>2</a>3"+            (Just ["1", "bar", "3"])+            (inSerial $   many+                      $   stepNext (text $ textSelector `atDepth` 0)+                      <|> stepNext (attr "foo" $ "a" `atDepth` 0))++    ,   scrapeTest+            "MonadFail sanity check for SerialScraper (passing check)"+            "1"+            (Just "OK")+            (inSerial $ do+              "1" <- stepNext $ text textSelector+              return "OK")++    ,   scrapeTest+            "MonadFail sanity check for SerialScraper (failing check)"+            "1"+            Nothing+            (inSerial $ do+              "mismatch" <- stepNext $ text textSelector+              return "OK")++    ,   scrapeTest+            "untilNext should stop at first match"+            "1<a>2</a><b>3</b>"+            (Just ["1", "2"])+            (inSerial $ untilNext (matches "b")+                      $ many $ stepNext $ text anySelector)++    ,   scrapeTest+            "untilNext should go till end of the zipper on no match"+            "1<a>2</a><b>3</b>"+            (Just ["1", "2", "3"])+            (inSerial $ untilNext (matches "c")+                      $ many $ stepNext $ text anySelector)++    ,   scrapeTest+            "untilNext should leave the focus at the match"+            "1<a>2</a><b>3</b>"+            (Just "3")+            (inSerial $ do+              untilNext (matches "b") $ many $ stepNext $ text anySelector+              stepNext $ text "b")++    ,   scrapeTest+            "untilNext should create valid a empty context"+            "<a>1</a><a>2</a>"+            (Just "1")+            (inSerial $ do+              untilNext (matches "a") $ return ()+              stepNext $ text "a")++    ,   scrapeTest+            "scraping within an empty context should fail"+            "<a>1</a><a>2</a>"+            Nothing+            (inSerial $ do+              untilNext (matches "a") $ stepNext $ text anySelector+              stepNext $ text "a")++    ,   scrapeTest+            "untilBack should leave the focus of the new context at the end"+            "<b foo=bar /><a>1</a><a>2</a><a>3</a>"+            (Just ("bar", ["1", "2", "3"], ["2", "1"]))+            (inSerial $ do+              as <- many $ seekNext $ text "a"+              as' <- untilBack (matches "b") $ many $ stepBack $ text "a"+              b <- stepBack $ attr "foo" "b"+              return (b, as, as'))++    ,   scrapeTest+            "inSerial in a chroot should visit immediate children"+            "<parent><a>1</a><b>2</b></parent>"+            (Just ["1", "2"])+            (chroot "parent" $ inSerial $+              many $ stepNext $ text anySelector)++    ,   scrapeTest+            "Issue #41 regression test"+            "<p class='something'>Here</p><p>Other stuff that matters</p>"+            (Just "Other stuff that matters")+            (inSerial $ do+              seekNext $ matches $ "p" @: [hasClass "something"]+              stepNext $ text "p")++    ,   scrapeTest+            "Issue #45 regression test"+            (unlines [+              "<body>"+            , "  <h1>title1</h1>"+            , "  <h2>title2 1</h2>"+            , "  <p>text 1</p>"+            , "  <p>text 2</p>"+            , "  <h2>title2 2</h2>"+            , "  <p>text 3</p>"+            , "  <h2>title2 3</h2>"+            , "</body>"+            ])+            (Just [+              ("title2 1", ["text 1", "text 2"])+            , ("title2 2", ["text 3"])+            , ("title2 3", [])+            ])+            (chroot "body" $ inSerial $ many $ do+                title <- seekNext $ text "h2"+                ps <- untilNext (matches "h2") (many $ do+                  -- New lines between tags count as text nodes, skip over+                  -- these.+                  optional $ stepNext $ matches textSelector+                  stepNext $ text "p")+                return (title, ps))     ] -scrapeTest :: (Eq a, Show a) => String -> Maybe a -> Scraper String a -> Test-scrapeTest html expected scraper = label ~: expected @=? actual+scrapeTest :: (Eq a, Show a)+           => String -> String -> Maybe a -> Scraper String a -> Test+scrapeTest label html expected scraper = label' ~: expected @=? actual     where-        label  = "scrape (" ++ show html ++ ")"+        label' = label ++ ": scrape (" ++ html ++ ")"         actual = scrape scraper (TagSoup.parseTags html)