scalpel-core 0.5.1 → 0.6.2.2
raw patch · 10 files changed
Files
- CHANGELOG.md +43/−0
- scalpel-core.cabal +6/−2
- src/Text/HTML/Scalpel/Core.hs +19/−0
- src/Text/HTML/Scalpel/Internal/Scrape.hs +117/−78
- src/Text/HTML/Scalpel/Internal/Scrape/StringLike.hs +12/−4
- 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 +247/−0
- tests/TestMain.hs +309/−7
CHANGELOG.md view
@@ -2,6 +2,49 @@ ## HEAD +## 0.6.2.2++- Fix build breakage on GHC 9.8 / mtl 2.3++## 0.6.2.1++- Match Content-Type case-insensitively.++## 0.6.2++- Add the monad transformer `ScraperT`.++## 0.6.1++- Support GHC 8.8.++## 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.
scalpel-core.cabal view
@@ -1,5 +1,5 @@ name: scalpel-core-version: 0.5.1+version: 0.6.2.2 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.2.2 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,11 +47,14 @@ , containers , data-default , fail+ , pointedlist , regex-base , regex-tdfa , tagsoup >= 0.12.2 , text , vector+ , transformers+ , mtl default-extensions: ParallelListComp , PatternGuards
src/Text/HTML/Scalpel/Core.hs view
@@ -18,10 +18,12 @@ , AttributeName (..) , TagName (..) , tagSelector+, textSelector -- ** Wildcards , anySelector -- ** Tag combinators , (//)+, atDepth -- ** Attribute predicates , (@:) , (@=)@@ -32,6 +34,7 @@ -- * Scrapers , Scraper+, ScraperT -- ** Primitives , attr , attrs@@ -44,12 +47,28 @@ , chroot , chroots , position+, matches -- ** Executing scrapers , scrape+, scrapeT , scrapeStringLike+, scrapeStringLikeT++-- * Serial Scraping+, SerialScraper+, SerialScraperT+, 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
src/Text/HTML/Scalpel/Internal/Scrape.hs view
@@ -1,7 +1,16 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} module Text.HTML.Scalpel.Internal.Scrape ( Scraper+, ScraperT (..) , scrape+, scrapeT , attr , attrs , html@@ -12,6 +21,7 @@ , texts , chroot , chroots+, matches , position ) where @@ -20,6 +30,14 @@ import Control.Applicative import Control.Monad+import Control.Monad.Except (MonadError)+import Control.Monad.Cont (MonadCont)+import Control.Monad.Reader+import Control.Monad.State (MonadState)+import Control.Monad.Trans.Maybe+import Control.Monad.Writer (MonadWriter)+import Control.Monad.Fix+import Data.Functor.Identity import Data.Maybe import qualified Control.Monad.Fail as Fail@@ -28,47 +46,44 @@ import qualified Text.StringLike as TagSoup --- | 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 {- scrapeTagSpec :: TagSpec str -> Maybe a- }+-- | A 'ScraperT' operates like 'Scraper' but also acts as a monad transformer.+newtype ScraperT str m a = MkScraper (ReaderT (TagSpec str) (MaybeT m) a)+ deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadFix,+ MonadIO, MonadCont, MonadError e, MonadState s, MonadWriter w) -instance Functor (Scraper str) where- fmap f (MkScraper a) = MkScraper $ fmap (fmap f) a+#if MIN_VERSION_base(4,9,0)+deriving instance Monad m => Fail.MonadFail (ScraperT str m)+#else+instance Fail.MonadFail m => Fail.MonadFail (ScraperT str m) where+ fail = lift . Fail.fail+#endif -instance Applicative (Scraper str) where- pure = MkScraper . const . Just- (MkScraper f) <*> (MkScraper a) = MkScraper applied- where applied tags | (Just aVal) <- a tags = ($ aVal) <$> f tags- | otherwise = Nothing+instance MonadTrans (ScraperT str) where+ lift op = MkScraper . lift . lift $ op -instance Alternative (Scraper str) where- empty = MkScraper $ const Nothing- (MkScraper a) <|> (MkScraper b) = MkScraper choice- where choice tags | (Just aVal) <- a tags = Just aVal- | otherwise = b tags+instance MonadReader s m => MonadReader s (ScraperT str m) where+ ask = MkScraper (lift . lift $ ask)+ local f (MkScraper op) = (fmap MkScraper . mapReaderT . local) f op -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- in b tags- | otherwise = Nothing+-- | 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@.+type Scraper str = ScraperT str Identity -instance MonadPlus (Scraper str) where- mzero = empty- mplus = (<|>)+scrapeTagSpec :: ScraperT str m a -> TagSpec str -> m (Maybe a)+scrapeTagSpec (MkScraper r) = runMaybeT . runReaderT r -instance Fail.MonadFail (Scraper str) where- fail _ = mzero+-- | The 'scrapeT' function executes a 'ScraperT' on a list of 'TagSoup.Tag's+-- and produces an optional value. Since 'ScraperT' is a monad transformer, the+-- result is monadic.+scrapeT :: (TagSoup.StringLike str)+ => ScraperT str m a -> [TagSoup.Tag str] -> m (Maybe a)+scrapeT s = scrapeTagSpec s . tagsToSpec . TagSoup.canonicalizeTags --- | The 'scrape' function executes a 'Scraper' on a list of--- 'TagSoup.Tag's and produces an optional value.-scrape :: (Ord str, TagSoup.StringLike str)+-- | The 'scrape' function executes a 'Scraper' on a list of 'TagSoup.Tag's and+-- produces an optional value.+scrape :: (TagSoup.StringLike str) => Scraper str a -> [TagSoup.Tag str] -> Maybe a-scrape s = scrapeTagSpec s . tagsToSpec . TagSoup.canonicalizeTags+scrape = fmap runIdentity . scrapeT -- | 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@@ -76,8 +91,8 @@ -- -- 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)- => Selector -> Scraper str a -> Scraper str a+chroot :: (TagSoup.StringLike str, Monad m)+ => Selector -> ScraperT str m a -> ScraperT str m a chroot selector inner = do maybeResult <- listToMaybe <$> chroots selector inner guard (isJust maybeResult)@@ -86,39 +101,55 @@ -- | 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)- => Selector -> Scraper str a -> Scraper str [a]-chroots selector (MkScraper inner) = MkScraper- $ return . mapMaybe inner . select selector+-- 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, Monad m)+ => Selector -> ScraperT str m a -> ScraperT str m [a]+chroots selector (MkScraper (ReaderT inner)) =+ MkScraper $ ReaderT $ \tags -> MaybeT $ do+ mvalues <- forM (select selector tags) (runMaybeT . inner)+ return $ Just $ catMaybes mvalues +-- | The 'matches' function takes a selector and returns `()` if the selector+-- matches any node in the DOM.+matches :: (TagSoup.StringLike str, Monad m) => Selector -> ScraperT str m ()+matches s = MkScraper $ (guard . not . null) =<< reader (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 s = MkScraper $ withHead tagsToText . select s+text :: (TagSoup.StringLike str, Monad m) => Selector -> ScraperT str m str+text s = MkScraper $ withHead tagsToText =<< reader (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)- => Selector -> Scraper str [str]-texts s = MkScraper $ withAll tagsToText . select s+-- 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, Monad m)+ => Selector -> ScraperT str m [str]+texts s = MkScraper $ withAll tagsToText =<< reader (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) => Selector -> Scraper str str-html s = MkScraper $ withHead tagsToHTML . select s+html :: (TagSoup.StringLike str, Monad m) => Selector -> ScraperT str m str+html s = MkScraper $ withHead tagsToHTML =<< reader (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)- => Selector -> Scraper str [str]-htmls s = MkScraper $ withAll tagsToHTML . select s+-- 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, Monad m)+ => Selector -> ScraperT str m [str]+htmls s = MkScraper $ withAll tagsToHTML =<< reader (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@@ -126,15 +157,18 @@ -- -- 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)- => Selector -> Scraper str str-innerHTML s = MkScraper $ withHead tagsToInnerHTML . select s+innerHTML :: (TagSoup.StringLike str, Monad m)+ => Selector -> ScraperT str m str+innerHTML s = MkScraper $ withHead tagsToInnerHTML =<< reader (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)- => Selector -> Scraper str [str]-innerHTMLs s = MkScraper $ withAll tagsToInnerHTML . select s+-- 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, Monad m)+ => Selector -> ScraperT str m [str]+innerHTMLs s = MkScraper $ withAll tagsToInnerHTML =<< reader (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@@ -142,18 +176,23 @@ -- -- 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)- => String -> Selector -> Scraper str str-attr name s = MkScraper- $ join . withHead (tagsToAttr $ TagSoup.castString name) . select s+attr :: (Show str, TagSoup.StringLike str, Monad m)+ => String -> Selector -> ScraperT str m str+attr name s = MkScraper $ ReaderT $ MaybeT+ . return . listToMaybe . catMaybes+ . fmap (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)- => String -> Selector -> Scraper str [str]-attrs name s = MkScraper- $ fmap catMaybes . withAll (tagsToAttr nameStr) . select s+-- 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, Monad m)+ => String -> Selector -> ScraperT str m [str]+attrs name s = MkScraper $ ReaderT $ MaybeT+ . return . Just . catMaybes+ . fmap (tagsToAttr nameStr) . select s where nameStr = TagSoup.castString name -- | The 'position' function is intended to be used within the do-block of a@@ -190,15 +229,15 @@ -- , (2, "Third paragraph.") -- ] -- @-position :: (Ord str, TagSoup.StringLike str) => Scraper str Int-position = MkScraper $ Just . tagsToPosition+position :: (TagSoup.StringLike str, Monad m) => ScraperT str m Int+position = MkScraper $ reader tagsToPosition -withHead :: (a -> b) -> [a] -> Maybe b-withHead _ [] = Nothing-withHead f (x:_) = Just $ f x+withHead :: Monad m => (a -> b) -> [a] -> ReaderT (TagSpec str) (MaybeT m) b+withHead _ [] = empty+withHead f (x:_) = return $ f x -withAll :: (a -> b) -> [a] -> Maybe [b]-withAll f xs = Just $ map f xs+withAll :: Monad m => (a -> b) -> [a] -> ReaderT (TagSpec str) (MaybeT m) [b]+withAll f xs = return $ map f xs foldSpec :: TagSoup.StringLike str => (TagSoup.Tag str -> str -> str) -> TagSpec str -> str@@ -222,11 +261,11 @@ tagsToAttr :: (Show str, TagSoup.StringLike str) => str -> TagSpec str -> Maybe str-tagsToAttr attr (tags, _, _) = do+tagsToAttr tagName (tags, _, _) = do guard $ 0 < Vector.length tags let tag = infoTag $ tags Vector.! 0 guard $ TagSoup.isTagOpen tag- return $ TagSoup.fromAttrib attr tag+ return $ TagSoup.fromAttrib tagName tag tagsToPosition :: TagSpec str -> Int tagsToPosition (_, _, ctx) = ctxPosition ctx
src/Text/HTML/Scalpel/Internal/Scrape/StringLike.hs view
@@ -1,17 +1,25 @@ {-# OPTIONS_HADDOCK hide #-} module Text.HTML.Scalpel.Internal.Scrape.StringLike ( scrapeStringLike+, scrapeStringLikeT ) where +import Data.Functor.Identity import Text.HTML.Scalpel.Internal.Scrape import qualified Text.HTML.TagSoup as TagSoup import qualified Text.StringLike as TagSoup - -- | 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)+scrapeStringLike = fmap runIdentity . scrapeStringLikeT++-- | The 'scrapeStringLikeT' function parses a 'StringLike' value into a list of+-- tags and executes a 'ScraperT' on it. Since 'ScraperT' is a monad+-- transformer, the result is monadic.+scrapeStringLikeT :: (TagSoup.StringLike str, Monad m)+ => str -> ScraperT str m a -> m (Maybe a)+scrapeStringLikeT tags scraper = scrapeT scraper+ (TagSoup.parseTagsOptions TagSoup.parseOptionsFast tags)
src/Text/HTML/Scalpel/Internal/Select.hs view
@@ -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
src/Text/HTML/Scalpel/Internal/Select/Combinators.hs view
@@ -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
src/Text/HTML/Scalpel/Internal/Select/Types.hs view
@@ -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.
+ src/Text/HTML/Scalpel/Internal/Serial.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK hide #-}+module Text.HTML.Scalpel.Internal.Serial (+ SerialScraper+, SerialScraperT+, 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 Control.Monad.Trans+import Control.Monad.Except (MonadError)+import Control.Monad.Cont (MonadCont)+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Trans.Maybe+import Control.Monad.Writer (MonadWriter)+import Control.Monad.Fix+import Data.Bifunctor+import Data.Functor.Identity+import Data.List.PointedList (PointedList)+import Data.Maybe+import Prelude hiding (until)++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"]),+-- ])+-- @+type SerialScraper str a = SerialScraperT str Identity a++-- | Run a serial scraper transforming over a monad 'm'.+newtype SerialScraperT str m a =+ MkSerialScraper (StateT (SpecZipper str) (MaybeT m) a)+ deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadFix,+ MonadIO, MonadCont, MonadError e, MonadReader r, MonadWriter w)++#if MIN_VERSION_base(4,9,0)+deriving instance Monad m => Fail.MonadFail (SerialScraperT str m)+#else+instance Fail.MonadFail m => Fail.MonadFail (SerialScraperT str m) where+ fail = lift . Fail.fail+#endif++instance MonadTrans (SerialScraperT str) where+ lift op = MkSerialScraper . lift . lift $ op++instance MonadState s m => MonadState s (SerialScraperT str m) where+ get = MkSerialScraper (lift . lift $ get)+ put = MkSerialScraper . lift . lift . put++-- | Executes a 'SerialScraper' in the context of a 'Scraper'. The immediate+-- children of the currently focused node are visited serially.+inSerial :: (TagSoup.StringLike str, Monad m)+ => SerialScraperT str m a -> ScraperT str m a+inSerial (MkSerialScraper serialScraper) = MkScraper $ ReaderT $ scraper+ where+ scraper spec@(vec, root : _, ctx)+ | ctxInChroot ctx = evalStateT serialScraper+ (toZipper (vec, Tree.subForest root, ctx))+ | otherwise = evalStateT serialScraper (toZipper spec)+ scraper _ = empty++ -- 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, Monad m)+ => (SpecZipper str -> Maybe (SpecZipper str))+ -> ScraperT str m b+ -> SerialScraperT str m b+stepWith moveList (MkScraper (ReaderT scraper)) = MkSerialScraper . StateT $+ \zipper -> do+ zipper' <- maybeT $ moveList zipper+ focus <- maybeT $ 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, Monad m) => ScraperT str m a -> SerialScraperT str m 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, Monad m)+ => ScraperT str m a -> SerialScraperT str m a+stepNext = stepWith PointedList.next++seekWith :: (TagSoup.StringLike str, Monad m)+ => (SpecZipper str -> Maybe (SpecZipper str))+ -> ScraperT str m b+ -> SerialScraperT str m b+seekWith moveList (MkScraper (ReaderT scraper)) = MkSerialScraper (StateT go)+ where+ go zipper = do zipper' <- maybeT $ moveList zipper+ runScraper zipper' <|> go zipper'+ runScraper zipper = do+ focus <- maybeT $ 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, Monad m)+ => ScraperT str m a -> SerialScraperT str m 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, Monad m)+ => ScraperT str m a -> SerialScraperT str m a+seekNext = seekWith PointedList.next++untilWith :: (TagSoup.StringLike str, Monad m)+ => (SpecZipper str -> Maybe (SpecZipper str))+ -> (Maybe (TagSpec str) -> SpecZipper str -> SpecZipper str)+ -> ScraperT str m a+ -> SerialScraperT str m b+ -> SerialScraperT str m b+untilWith moveList appendNode (MkScraper (ReaderT until)) (MkSerialScraper scraper) =+ MkSerialScraper $ do+ inner <- StateT split+ lift (evalStateT scraper (appendNode Nothing inner))+ where+ split zipper =+ do zipper' <- maybeT $ moveList zipper+ spec <- maybeT $ PointedList._focus zipper'+ do until spec+ return (PointedList.singleton Nothing, zipper)+ <|> (first (appendNode (Just spec)) `liftM` split zipper')+ <|> return (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, Monad m)+ => ScraperT str m a -> SerialScraperT str m b -> SerialScraperT str m 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, Monad m)+ => ScraperT str m a -> SerialScraperT str m b -> SerialScraperT str m b+untilNext = untilWith PointedList.next PointedList.insertLeft++maybeT :: Monad m => Maybe a -> MaybeT m a+maybeT = MaybeT . return
tests/TestMain.hs view
@@ -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)