scrappy-core (empty) → 0.1.0.0
raw patch · 16 files changed
+4835/−0 lines, 16 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, containers, directory, filepath, lens, modern-uri, network-uri, parsec, parser-combinators, text, transformers
Files
- LICENSE +30/−0
- README.MD +150/−0
- Setup.hs +2/−0
- scrappy-core.cabal +88/−0
- src/Scrappy/Elem.hs +12/−0
- src/Scrappy/Elem/ChainHTML.hs +154/−0
- src/Scrappy/Elem/ElemHeadParse.hs +411/−0
- src/Scrappy/Elem/ITextElemParser.hs +641/−0
- src/Scrappy/Elem/SimpleElemParser.hs +548/−0
- src/Scrappy/Elem/TreeElemParser.hs +1029/−0
- src/Scrappy/Elem/Types.hs +762/−0
- src/Scrappy/Files.hs +65/−0
- src/Scrappy/Find.hs +267/−0
- src/Scrappy/Links.hs +419/−0
- src/Scrappy/Scrape.hs +193/−0
- src/Scrappy/Types.hs +64/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2021, Galen++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Galen nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.MD view
@@ -0,0 +1,150 @@+# Scrappy #++# <img src="./scrappy-logo.png.png" width="200">+++provides a number of functions that allow for easily scraping certain patterns from websites as well control functions that allow you to rotate between multiple sites and rotate proxies in order to deal with common bot detection problems faced by scrapers. ++## Scraping ## ++Scraping is parsing, where we don't care about the placement of our match in a chunk of data. ScraperT is really just ParsecT (ParsecT String () Identity a)++## How to depend on this project ## ++Scrappy is currently not on Hackage because I honestly don't have time to perfect version bounds however through [Nix](https://nixos.org/download) you can get the package the following way:++OR!! Just clone scrappy-tutorial and rename it ++OR if you really want to learn (hey good for you!) ++```bash +# assuming you've done nix-setup... I'd show you how but it depends what setup you prefer and its super simple+nix-env -f https://github.com/obsidiansystems/nix-thunk/archive/master.tar.gz -iA command+nix-shell -p cabal2nix+cd yourProjectDirectory+cabal init +# follow prompts+mkdir deps +git clone https://github.com/Ace-Interview-Prep/scrappy.git deps/scrappy # or SSH url +nix-thunk pack deps/scrappy # this is technically optional but recommended+# add scrappy to your cabal file under build-depends+cabal2nix . --shell > shell.nix -- this will create an easy to use shell.nix file with all of your build depends+nix-shell #you could also do nix-shell shell.nix+cabal run my-project-name-in-cabal-file +```+++## Tutorials ## ++- https://medium.com/p/135283dc2af+- https://github.com/Ace-Interview-Prep/scrappy-tutorial++## Main functions, Types, and Classes ## ++```haskell++class ElementRep (a :: * -> *) where+--type InnerHTMLRep a = something + elTag :: a b -> Elem+ attrs :: a b -> Attrs+ innerText' :: a b -> String + matches' :: a b -> [b]++instance ElementRep (Elem') where+ elTag = _el+ attrs = _attrs+ innerText' = innerHtmlFull+ matches' = innerMatches++data Elem' a = Elem' { _el :: Elem + , _attrs :: Map String String + , innerMatches :: [a] + , innerHtmlFull :: String+ } deriving Show++-- | Manager returned may be a new manager, if the given manager failed +getHtml :: Manager -> Url -> IO (Manager, Html) +getHtml' :: Url -> IO Html++scrape :: ScraperT a -> Html -> Maybe [a]++-- | For more advanced control over inner structure see Elem.TreeElemParser+elemParser :: Elem -> [(String, Maybe String)] + -> Maybe (ParsecT s u m a) -- Optionally scraped pattern inside this el, if specified, return element must have at least 1 + -> ScraperT (Elem' a)++el :: Elem -> [(String, String)] -> ScraperT (Elem' String)++-- | Find any expressive pattern as long as it is inside of some HTML context +contains :: ScraperT (Elem' a) -> ScraperT a -> ScraperT a +++:t fmap snd getHtml' "https://google.com" >>= return . (runScraperOnHtml (el "a" []) +>>> IO (Maybe [Elem' a])++-- Will get all <a id="link"> 's on the url that are inside+-- divs with a class of xyz+example :: IO (Maybe [Elem' a])+example = runScraperOnUrl url $ el "div" [("class", "xyz")] `contains`+ el "a" [("id", "link")]+++```++Currently with this library you can request HTML and run a multitude of scraper-patterns on it, for example:+- Scrape an element+- Scrape an element with a specific inner pattern+- Scrape an element with an attribute that fits a specific parser-pattern +- Scrape an element with a specific inner DOM-tree +- Scrape a group of elements that *kinda* repeats + - For example, if you want a complex group that varies from page to page but to the user's eye looks the exact same (think of search results on a nice website) or even largely the same, then use the `htmlGroup` function from Scrappy.Elem.TreeElemParser +- Scrape any **arbitrary** parser from the [parsec library](https://hackage.haskell.org/package/parsec)++You can also deeply chain! +- Inside any instance of the ElementRep class (Elem', TreeHTML) through contains and contains'! + - For example use: think of getting all prices +- In a sequence!+ - skipToBody: to avoid matches in the <head>+ - (</>>=) and (</>>) which are sequencers that take two parsers like Monadic actions (hence the characters chosen) but unlike running two parsers one after the other, there may be whatever random stuff in between! +++## TODO ## ++As this is an Open Source ambitious project, there is much that is left to do which follows from the potential of this library as a result of it's inner workings++- Upload to Hackage+- Be included in the haskellPackages attribute of nixpkgs+- grep/regex replacement (and streamEdit across multiple files, see below) + - I hate ReGeX with a burning passion. No way will I ever come back to an expression and say "Oh that must match on emails!". + - It would be neat to have a way to write haskell at the command line like "grepScrappy -sR "char 'a' >> some digit >> char 'b'" but this string would quickly get massive so I wonder if there's a happy medium that exists such as shortforms for the most common parsers (char, many, some, digit, string, etc) that while we would still allow for any haskell string (which typifies to a ParsecT) there would be ways to shorten expressions+- Improve `contains` and similar functions to be able to somehow apply the 'contained' parser to inside the start and end tags+- More Generic typing and Monads for a SiteT, HistoryT, and WebT (an accumulator of new undiscovered sites)+ - I have a number of complicated Monads all with their own varied implementations that could be greatly reduced to a SiteT which keeps state of what branches of the Site tree have been visited or seen.+ - With a SiteT it would easily allow for logic to gather all new links (see Scrappy.Links) upon getting a new HTML via getHTML or sibling functions, and perhaps a new sibling function like getNextHTML which gets the next untouched HTML page + - SiteT extension would mean that we could create functions like `scrapeSite` which might look for all pattern matches across the site-tree. By extension this could apply to HistoryT and WebT via an incredibly simple interface. + - The concept of a SiteT implies there may be use in a HistoryT (ie all Sites visited with their respective site-trees) and a WebT which is meant to represent the entire web in the sense that it continues to extend and is not constrained to past history.+ - Hopefully this gives intriguing ideas to why scrappy-nlp might be so powerful+- Concurrency with streamEdits + - This functionality will help both for making it easier+quicker to perform concurrency when scraping (which is actually quite easy for different pages due to forkIO and standard library functions) but also makes a scrappy-DOM (see below) much easier to imagine as a robust web framework (imagine how long 10+ prerender-like scrapers would take or rather 10 passthroughs). I see this as the biggest blocker to a 1st version of scrappy-DOM (which wouldn't yet have FRP or GHCJS functionality.. you could still write raw JavaScript in V1 though) + - Extending this idea, lazy-js (see below) is effectively a streamEdit performer and so this logic would also provide incredible speed to this 'category' of the DOM as well. +- Break up into scrappy-core and scrappy-requests+ - This is so that scrappy-core can be used in frontend apps that are built using GHCJS. GHCJS purposely doesn't build networking packages. +- Fork a streamEdit package+ - A lot of streamEdit packages are exceptionally complex while library functions like Data.Text leave much to be desired. scrappy-streamEdit would be a perfect medium+- Fork a scrappy-staleLink (or better name) package + - For use with [Obelisk](https://github.com/obsidiansystems/obelisk) the static directory which will provide a list of static assets which are no longer in use and might be good to delete+- Fork a scrappy-templates package+ - This is in the works currently for templating files/strings with variables such as large prompts for GPT-*, for example you could template a prompt for resumes that is job dependent in an ergonomic/easy-to-use way+ - See Scrappy.Templates+ - To reduce runtime errors from performing IO, it would be nice to have a staticFile finder like with staticWhich: a package that ensures an executable's existence *at compile time* +- scrappy + nlp+ - It would be advantageous to use certain functions like a recursive scraper from pageN -> page(N+M), where M is based on a stop condition and/or the arrow a successful pattern match (see Scrappy.Run). While this can be easily done with HTML patterns, this extends and lends well to NLP analysis for the text that is contained in the structural HTML+- scrappy-DOM+ - I currently have a bone to pick with the `prerender` function from [reflex-dom](https://github.com/reflex-frp/reflex-dom) as it can easily fail. For example, if the browser insists on inserting a <tbody> inside a <table> tag then reflex-dom panics because the DOM is not as expected, even if the DOM area is on a completely different branch and way earlier than it. Intuitively, using streamEdit on an element with an attribute like prerenderID="some unique string" would be an incredibly dependable solution. + - The blockers to this are of course that it's only worth doing if it will be an improvement to reflex-dom as a whole (or maybe we integrate with reflex-dom) and reflex-dom is truly exceptional with FRP, GHCJS bindings, and mobile-readiness +- scrappy-headless+ - This is effectively a headless browser which has the ability to read and run JS in response to events. A lot of work has been done on this in the Scrappy.BuildActions module and in [lazy-js](https://github.com/augyg/lazy-js) which is a fork of this project+ - Also need to implement httpHistory in a more robust way to make a headless browser more legit +- lazy-js + - This is a foundational project for both scrappy-headless and scrappy-DOM which is a lazy reader and writer of JavaScript. An example use is virtualizing clicking a link to bypass any JavaScript bot detectors and/or just to follow JavaScript based events like a button which calls some JS to change window.location (like a fancy href)+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ scrappy-core.cabal view
@@ -0,0 +1,88 @@+cabal-version: 2.4+name: scrappy-core+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.1.0.0+synopsis: html pattern matching library and high-level interface concurrent requests lib for webscraping+description:+ Scrappy is meant to be a fully expressive library for all aspects of webscraping.+ In this sense it is meant to be as undetectable as using Selenium but with a design+ specifically for webscraping (where Selenium was never intended for webscraping nor do+ it's maintainers seek to provide features that allow for more expressive scraping if it+ would not help testing). The Elem.* modules provide a wide range of expressive pattern matching+ functions while adding no more complexity in needing to learn this library over parsing.+ .+ In addition to expressive patterns to fit your specific patterns you hope to scrape, scrappy+ provides helper functions for complex control flows such as running multiple different+ parser-scrapers on respective sites based on a rotating ConcurrentStream when users have many+ target sites that they can rotate working on to not overload a given site and thus avoid detection+ .+ For simpler control flows such as scraping a large number of pages on a single site, scrappy currently+ provides functions like getHtml, which not only is a super simple interface to http requests,+ but a persistent function that gurantees retrieval of the HTML document to be scraped+ .+ This package is labelled as uncurated, and so suggestions are very much welcome and this package is+ expected to grow based on feedback. The primary focus will be on running Javascript to allow for greater+ access to information on sites++-- URL for the project homepage or repository.+homepage: https://github.com/Ace-Interview-Prep/scrappy+license: BSD-3-Clause+license-file: LICENSE+author: Galen Sprout+maintainer: galen.sprout@gmail.com+bug-reports: https://github.com/Ace-Interview-Prep/scrappy/issues+x-curated: uncurated-seeking-adoption+stability: Experimental+category: Webscraping+build-type: Simple+extra-source-files: README.MD+source-repository head+ type: git + location: https://github.com/Ace-Interview-Prep/scrappy-core +library+ exposed-modules: Scrappy.Find+ , Scrappy.Scrape+ , Scrappy.Elem+ , Scrappy.Elem.Types+ , Scrappy.Elem.TreeElemParser+ , Scrappy.Elem.SimpleElemParser+ , Scrappy.Elem.ElemHeadParse+ , Scrappy.Elem.ITextElemParser+ , Scrappy.Elem.ChainHTML+ , Scrappy.Links+ , Scrappy.Files+ , Scrappy.Types++ build-depends: aeson >= 2.2.3 && < 2.3+ , base >= 4.20.2 && < 4.21+ , bytestring >= 0.12.2 && < 0.13+ , containers >= 0.7 && < 0.8+ , directory >= 1.3.8 && < 1.4+ , filepath >= 1.5.4 && < 1.6+ , lens >= 5.3.5 && < 5.4+ , modern-uri >= 0.3.6 && < 0.4+ , network-uri >= 2.6.4 && < 2.7+ , parsec >= 3.1.18 && < 3.2+ , parser-combinators >= 1.3.1 && < 1.4+ , text >= 2.1.3 && < 2.2+ , transformers >= 0.6.1 && < 0.7++-- base+-- , aeson+-- , bytestring+-- , containers+-- , directory+-- , filepath+-- , lens+-- , modern-uri+-- -- ^ less maintained?+-- , network-uri+-- , parsec+-- , parser-combinators+-- , text+-- , transformers+ + hs-source-dirs: src+ default-language: Haskell2010
+ src/Scrappy/Elem.hs view
@@ -0,0 +1,12 @@+module Scrappy.Elem+ ( module Scrappy.Elem.Types+ , module Scrappy.Elem.ElemHeadParse+ , module Scrappy.Elem.SimpleElemParser+ , module Scrappy.Elem.ChainHTML+ ) where+++import Scrappy.Elem.Types+import Scrappy.Elem.ElemHeadParse+import Scrappy.Elem.SimpleElemParser hiding (manyTill_)+import Scrappy.Elem.ChainHTML
+ src/Scrappy/Elem/ChainHTML.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}++module Scrappy.Elem.ChainHTML where++++import Scrappy.Find (findNaive)+import Scrappy.Links (maybeUsefulUrl)+import Scrappy.Elem.SimpleElemParser (elemParser)+import Scrappy.Elem.ElemHeadParse (parseOpeningTag, hrefParser)+import Scrappy.Elem.Types (Elem', ShowHTML, ElemHead, Elem, innerText'+ , matches')++import Control.Monad.Trans.Maybe (MaybeT)+import Text.Parsec (ParsecT, Stream, char, (<|>), many, parserFail, parse, parserZero, string, optional)+import Control.Applicative (some, liftA2)+import Data.Functor.Identity (Identity)+import Data.Maybe (catMaybes)+-- functions for chaining free-range html patterns based on the previous+-- patterns to allow for maximum flexibility ++nl :: Stream s m Char => ParsecT s u m ()+nl = optional (many $ (char '\n' <|> char ' '))++manyHtml p = many $ p <* nl++someHtml p = some $ p <* nl++manyTillHtml_ p end = manyTill_ (p <* nl) end +++htmlTag :: Stream s m Char => ParsecT s u m ElemHead+htmlTag = parseOpeningTag (Just ["html"]) [] +++++manyTill_ :: ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m ([a], end)+manyTill_ p end = go+ where+ go = (([],) <$> end) <|> liftA2 (\x (xs, y) -> (x : xs, y)) p go++++clean :: String -> String+clean = undefined -- drop if == ( \n | \" | '\\' )+++-- -- same site is guranteed+-- allLinks :: String -> ParsecT String () Identity [String] +-- allLinks baseUrl = do+-- x <- findNaive hrefParser +-- return $ case x of+-- Just (x':xs') -> catMaybes $ fmap (maybeUsefulUrl baseUrl) (x':xs')+-- Just [] -> []+-- Nothing -> [] ++++mustContain :: ParsecT s u m (Elem' a) -> Int -> ParsecT s u m b -> ParsecT s u m (Elem' a)+mustContain e count pat = do+ out <- e+ case parse (findNaive $ string "Search") "" (innerText' out) of+ Right (Just xs) -> if count > (length xs) then parserZero else return out+ _ -> parserZero+ +-- | An elem head configures the bracketing so this is all we need for+-- | crafting++type Shell = (Elem, [(String, Maybe String)]) ++-- incomplete+contains'' :: (Stream s m Char, ShowHTML a) => Shell + -> ParsecT s u m a+ -> ParsecT s u m [a]+contains'' (e,as) p = matches' <$> elemParser (Just [e]) (Just p) as++parseInShell = contains ++-- | This will be fully removed in the future+-- | 99% of the time this is gonna be desired to pair with findNaive +{-# DEPRECATED contains "this should have been called parseInShell from the start, you probably want contains' or containsFirst" #-}+contains :: ParsecT s u m (Elem' a) -> ParsecT String () Identity b -> ParsecT s u m b+contains shell b = do+ x <- shell++ let+ ridNL p = (many (char ' ' <|> char '\n')) >> p + + -- need to skip + case parse (ridNL b) "" (innerText' x) of+ Right match -> return match+ Left err -> parserFail (show err)++-- | finds multiple matches anywhere inside the passed elem+-- | This function is also quite extensible because when used with `scrape`+-- | this combo will return a list of list of elems where the hierarchy of HTML has been preserved+-- | but a great deal of information has been filtered out. An example use case would be knowing that+-- | you want <p> tags from a Set of very specific shells, this could allow you to analyze what and how many+-- | came from each shell.+-- | This also naturally extends to running this same scraper on multiple pages which would allow you to recover+-- | ample details on the number of match_A in shell_S on Page_P ~~ [[[MatchA]]] and this Match can be any+-- | arbitarily defined type. You can further imagine pairing with NLP analysis but this is a long enough point here.+containsMany, contains'+ :: ShowHTML a =>+ ParsecT s u m (Elem' a) + -> ParsecT String () Identity b+ -> ParsecT s u m [b]+containsMany = contains' -- legacy+contains' shell b = do+ x <- shell+ case parse (findNaive b) "" (innerText' x) of+ Right (Just matches) -> pure matches+ Left err -> parserFail (show err)+ Right Nothing -> parserFail "no matches in this container" ++containsFirst :: ShowHTML a =>+ ParsecT s u m (Elem' a) + -> ParsecT String () Identity b+ -> ParsecT s u m b+containsFirst shell b = head <$> contains' shell b+++sequenceHtml :: Stream s m Char => ParsecT s u m a -> ParsecT s u m b -> ParsecT s u m (a, b)+sequenceHtml p1 p2 = do+ x <- p1+ _ <- many (char ' ' <|> char '\n' <|> char '\t')+ y <- p2+ return (x, y)++sequenceHtml_ :: Stream s m Char => ParsecT s u m a -> ParsecT s u m b -> ParsecT s u m b+sequenceHtml_ p1 p2 = do+ _ <- p1+ _ <- many (char ' ' <|> char '\n' <|> char '\t')+ p2++(</>>) :: Stream s m Char => ParsecT s u m a -> ParsecT s u m b -> ParsecT s u m b +(</>>) = sequenceHtml_++(</>>=) :: Stream s m Char => ParsecT s u m a -> ParsecT s u m b -> ParsecT s u m (a, b)+(</>>=) = sequenceHtml++----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------+++-- manyHtml :: Stream s m Char => ParsecT s u m a -> ParsecT s u m [a]+-- manyHtml prsrHtml = (many (char ' ' <|> char '\n')) >> many (fmap snd $ manyTill_ (char ' ' <|> char '\n') prsrHtml)++-- someHtml :: Stream s m Char => ParsecT s u m a -> ParsecT s u m [a]+-- someHtml prsrHtml = many (char ' ' <|> char '\n') >> some prsrHtml+++
+ src/Scrappy/Elem/ElemHeadParse.hs view
@@ -0,0 +1,411 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+++module Scrappy.Elem.ElemHeadParse where++import Scrappy.Links (Link, LastUrl, CurrentUrl)+import Scrappy.Elem.Types (Elem, Elem', ElemHead, Attrs, AttrsError(IncorrectAttrs), getHrefAttrs) -- Attr)++import Control.Applicative (some)+import Text.Parsec (Stream, ParsecT, (<|>), string, try, noneOf, parserZero, char, option, space,+ alphaNum, many1, between, many, letter, parserFail, optional, manyTill)+import Data.Map as Map (Map, fromList, lookup, toList) +import Data.Maybe (fromMaybe)+--import Witherable (mapMaybe)++import Scrappy.Types++-- | needs to use many for multiple links+++href :: Stream s m Char => Bool -> LastUrl -> ParsecT s u m Link+href booly cUrl = ((getHrefAttrs booly cUrl) . snd) `mapMaybe` (parseOpeningTag (Just ["a"]) [])++href' :: Stream s m Char => Maybe CurrentUrl -> ParsecT s u m Link+href' = undefined -- bo+++++++-- | Safe because it forces parse of the entire ElemHead then pulls if there+-- | Designed for use in findSomeHtml+parseAttrSafe :: Stream s m Char => String -> ParsecT s u m String +parseAttrSafe attrName = do+ tag <- parseOpeningTag Nothing [(attrName, Nothing)] -- i could in theory pass an expression as value+ case (Map.lookup attrName . snd) tag of+ Nothing -> parserZero+ Just a -> return a++-- | Done like this so that it reliably is true link and not false positive +hrefParser :: Stream s m Char => ParsecT s u m String --Link+hrefParser = do+ tag <- parseOpeningTag Nothing [("href", Nothing)] -- i could in theory pass an expression as value+ case (Map.lookup "href" . snd) tag of+ Nothing -> parserZero+ Just a -> return a+-- snd OR fmap snd for multiple then analyze URI++parseOpeningTagF :: Stream s m Char => String -> (String -> Bool) -> ParsecT s u m ElemHead --Link+parseOpeningTagF attrib predicate = do+ (e, as) <- parseOpeningTag Nothing [(attrib, Nothing)] -- i could in theory pass an expression as value+ case Map.lookup attrib as of+ Nothing -> parserZero+ Just a -> if predicate a then return (e,as) else parserFail "couldnt find match parseOpeningTagF"++-- | TODO(galen): make this actually generic, not just for one attr+parseOpeningTagWhere :: Stream s m Char+ => Maybe [Elem]+ -> String + -> (String -> Bool)+ -> ParsecT s u m ElemHead --Link+parseOpeningTagWhere es attrib predicate = do+ (e, as) <- parseOpeningTag es [(attrib, Nothing)] -- i could in theory pass an expression as value+ case Map.lookup attrib as of+ Nothing -> parserZero+ Just a -> if predicate a then return (e,as) else parserFail "couldnt find match parseOpeningTagF"+++++-- parseOpeningTagFs :: Stream s m Char => [(String, (String -> Bool)] -> ParsecT s u m ElemHead --Link+-- parseOpeningTagFs (attrib, predicate):xs = do+ -- (e, as) <- parseOpeningTag Nothing [(attrib, Nothing)] -- i could in theory pass an expression as value+ -- case Map.lookup attrib a of+ -- Nothing -> parserZero+ -- Just a -> if predicate a then return (e,as) else parserZero +++-- | Allows parsing with high level predicate +hrefParser' :: Stream s m Char => (String -> Bool) -> ParsecT s u m String --Link+hrefParser' predicate = do+ tag <- parseOpeningTag Nothing [("href", Nothing)] -- i could in theory pass an expression as value+ case (Map.lookup "href" . snd) tag of+ Nothing -> parserZero+ Just a -> if predicate a then return a else parserZero +-- snd OR fmap snd for multiple then analyze URI++-- Does between have an answer to my problem of non-infinite parsers?+-- between' (parseOpeningTag) (endTag) innerParser ... or something+++--also could be with '' not just ""+-- | In future should add replace of apostrophe and similar issues to corresponding html representations+attrValue :: Stream s m Char => ParsecT s u m [Char]+attrValue = (between (char '"') (char '"') (many (noneOf ['"'])))+ <|> (between (char '\'') (char '\'') (many (noneOf ['\''])))++--PAST+-- attrValue :: Stream s m Char => ParsecT s u m [Char]+-- attrValue = between (char '"' <|> char '\'') (char '"' <|> char '\'') (many (noneOf ['"', '\'']))++-- ++-- -- this could be extensible to scrapePDFLink+-- attrValue' :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a+-- attrValue' parser = between (char '"') (char '"') parser++-- | Both attrValue functions mimic map functionality ++attrValuesExist :: [(String, String)] -> [(String, Maybe String)] -> Bool +attrValuesExist _ [] = True-- Either AttrsError [(String, String)]+attrValuesExist attrsOut (nextAttr:attrsIn)+ | attrValueExists attrsOut nextAttr = True && (attrValuesExist attrsOut attrsIn)+ | otherwise = False ++attrValueExists :: [(String, String)] -> (String, Maybe String) -> Bool+attrValueExists [] _ = False +attrValueExists (attrF:attrsOut) nextAttr-- (AttrPair nextAttrP:attrsIn)+ | fst attrF == fst nextAttr && snd nextAttr == Nothing = True+ | fst attrF == fst nextAttr && snd nextAttr == (Just (snd attrF)) = True+ | otherwise = attrValueExists attrsOut nextAttr+++-- -- | Doesn't check for value of attr+-- attrNamesExist :: [(String, String)] -> [AttrsP] -> Either AttrsError [(String, String)]+-- -- attrNamesExist attrsOut [AnyAttr] = Right attrsOut --relevant??+-- attrNamesExist attrsOut [] = Right attrsOut +-- attrNamesExist attrsOut (Attr nextAttr:attrsIn)+ +-- elem nextAttr (fmap fst attrsOut) = attrNamesExist attrsOut attrsIn+-- otherwise = Left IncorrectAttrs +-- -- Im not sure this will continue to the next element though++-- -- | With attrs, we must parse to a map regardless of actual value due to lack of ordering then+-- -- | should do lookup+++attrName :: Stream s m Char => ParsecT s u m String +attrName = some (alphaNum <|> char '-' <|> char '_')+-- | Need lower|UPPER case insensitivity+ --++-- SPACE, ("), ('), (>), (/), (=)++-- | for generalization sake+attrParser :: Stream s m Char => ParsecT s u m (String, String)+attrParser = do+ _ <- many (space <|> char '\n' <|> char '\t')++ --re-implement anyAttr+ --needs to include weird edge cases+ attrName' <- attrName+ content <- option "" (char '=' >> attrValue)+ return (attrName', content)+ -- [AttrsPNew]+attrsParser :: Stream s m Char =>+ [(String, Maybe String)] -- Maybe (ParsecT s u m String)+ -> ParsecT s u m (Either AttrsError (Map String String))+ --change to Either AttrsError (Map String String) +attrsParser attrs = do+ -- attrPairs <- MParsec.manyTill attrParser {- this needs to also handle -} (char '/' <|> char '>')+ attrPairs <- many $ try attrParser -- (char '>' <|> char '/')+ let+ attrPairsMap = fromList attrPairs+ case isAttrsMatch attrPairsMap attrs of+ True -> return $ Right attrPairsMap+ False -> return $ Left IncorrectAttrs+++isAttrsMatch' :: Map String String -> [(String, Maybe String)] -> Bool+isAttrsMatch' _ [] = True +isAttrsMatch' mapAttr ((name, maybeVal):desired) + | Map.lookup name mapAttr == Nothing = False + | (Map.lookup name mapAttr == maybeVal) || (maybeVal == Nothing) = isAttrsMatch mapAttr desired ++isAttrsMatch :: Map String String -> [(String, Maybe String)] -> Bool+isAttrsMatch _ [] = True+isAttrsMatch mapAttr ((name, maybeVal): desired) = case maybeVal of+ Just val ->+ case Map.lookup name mapAttr of+ Just valFromKey -> if val /= valFromKey then False else isAttrsMatch mapAttr desired+ Nothing -> False+ + Nothing ->+ case Map.lookup name mapAttr of+ Just irrValFromKey {- we only care about the name -} -> isAttrsMatch mapAttr desired+ Nothing -> False++attrsFit :: Map String String -> [(String, (String -> Bool))] -> Bool+attrsFit _ [] = True+attrsFit mapppy ((name, test): rest) =+ (fromMaybe False $ fmap test $ Map.lookup name mapppy) && attrsFit mapppy rest++ -- [AttrsPNew]++++attrsMatch' :: Map String String -> Map String String -> Bool+attrsMatch' a b = attrsMatch (toList a) b++++attrsMatch :: [(String, String)] -> Map String String -> Bool+attrsMatch [] _ = True +attrsMatch ((k,v):kvs) mappy = case Map.lookup k mappy of+ Just val ->+ if elem k ["title", "alt", "href"] then True && attrsMatch kvs mappy+ else digitEqFree v val && attrsMatch kvs mappy+ Nothing -> False ++ +attrsParserDesc :: Stream s m Char =>+ [(String, String)] -- Maybe (ParsecT s u m String)+ -> ParsecT s u m (Map String String)+ --change to Either AttrsError (Map String String) +attrsParserDesc attrs = do+ attrPairs <- many attrParser -- (char '>' <|> char '/')+ let+ attrPairsMap = fromList attrPairs + if attrsMatch attrs attrPairsMap + then return attrPairsMap+ else parserFail $ "incorrect attrs:" <> (show $ unfit attrs attrPairsMap)+ + -- let+ -- attrPairsMap = fromList attrPairs+ -- case isAttrsMatch attrPairsMap attrs of+ -- True -> return $ Right attrPairsMap+ -- False -> return $ Left IncorrectAttrs++++parseOpeningTagDesc :: Stream s m Char => Maybe [Elem] -> [(String, String)] -> ParsecT s u m (Elem, Attrs)+parseOpeningTagDesc elemOpts attrs = do+ _ <- char '<'+ elem <- mkElemtagParser elemOpts+ attrs <- attrsParserDesc attrs+ return (elem, attrs) +++-- | Allows for certain degrees of freedom such as 1 spot off eg 123 vs 1230 (or even (109|22))+-- | as well as any numerical digit must also be a numerical digit from 0 to 9 +digitEq :: String -> String -> Bool+digitEq [] [] = True -- Only time the func gives True +digitEq [] (y:ys) = False+digitEq (x:xs) [] = False+digitEq (charA:xs) (charB:ys) =+ if charA == charB+ then True && digitEq xs ys + else+ if elem charA ['0'..'9'] && elem charB ['0'..'9']+ then digitEq xs ys + else+ -- allow for one more digit + saveDigitEq (charA:xs) (charB:ys) ++-- A; 12340red+-- B; 1234red++saveDigitEq :: String -> String -> Bool+saveDigitEq as bs =+ if elem ((length as) - (length bs)) [1,-1]+ then -- allows for one more digit + if (elem (head as) ['0'..'9']) || (elem (head bs) ['0'..'9']) + then svDigEq as bs + else False+ else False++svDigEq :: String -> String -> Bool +svDigEq (charA:as) (charB:bs) = -- True+ if head as == charB+ then digitEq (tail as) bs + else+ if head bs == charA+ then digitEq as (tail bs)+ else False || saveDigitEq (charA:as) bs || saveDigitEq as (charB:bs)++++-- OR!!!+digitEqFree :: [Char] -> [Char] -> Bool+digitEqFree [] [] = True+digitEqFree as [] = if elem (head as) ['0'..'9'] then digitEqFree (tail as) [] else False+digitEqFree [] bs = if elem (head bs) ['0'..'9'] then digitEqFree [] (tail bs) else False +digitEqFree as bs =+ if elem (head as) ['0'..'9'] then digitEqFree (tail as) bs+ else+ if elem (head bs) ['0'..'9'] then digitEqFree as (tail bs)+ else+ if head as == (head bs) then digitEqFree (tail as) (tail bs)+ else False + +++unfit :: [(String, String)] -> Map String String -> [(String, String)]+unfit [] _ = [] +unfit ((n,v):ns) map = case Map.lookup n map of+ Nothing -> (n, "no attr") : unfit ns map+ Just val -> if elem n ["href", "alt", "title"] then unfit ns map+ else if digitEq v val+ then unfit ns map+ else (n<>":"<>"("<>val<>"|"<>v<>")", "failed test") : unfit ns map +++mkAttrsDesc :: [(String, String)] -> [(String, (String -> Bool))]+mkAttrsDesc atrs = (fmap . fmap) digitEqFree atrs++-- htmlGroup = do+-- (e,a) <- treeElemParser+-- treeElSpec e a+-- where +-- treeElSpec e a = do+-- parseOpeningTagDesc e (mkAttrsDesc a)+-- ...innerElem + endTag ++-- attrsFit mapAttr ((name, maybeVal): desired) = case maybeVal of+-- Just val ->+-- case Map.lookup name mapAttr of+-- Just valFromKey -> if val /= valFromKey then False else isAttrsMatch mapAttr desired+-- Nothing -> False+ +-- Nothing ->+-- case Map.lookup name mapAttr of+-- Just irrValFromKey {- we only care about the name -} -> isAttrsMatch mapAttr desired+-- Nothing -> False+++ +-- | NOTES+-- if href="#" on form -> just means scroll to top++-- | May rename parseOpeningTag to elemHeadParser+ -- | -> Case of input tag: <input ...."> DONE ie no innerhtml or end tag+ -- | then this would be more efficient or even maybe we should add an option via+ -- | a datatype: InnerTextOpts a = DoesntExist --efficient parser | AnyText | ParserText a+parseOpeningTag :: Stream s m Char => Maybe [Elem] -> [(String, Maybe String)] -> ParsecT s u m (Elem, Attrs)+parseOpeningTag elemOpts attrsSubset = do+ -- _ <- MParsec.manyTill anyToken (char '<' >> elemOpts >> attrsParser attrsSubset) -- the buildElemsOpts [Elem]+ _ <- char '<'+ elem <- mkElemtagParser elemOpts+ attrs <- attrsParser attrsSubset+ optional (many space)+ case attrs of+ Left IncorrectAttrs -> parserZero+ Right whateva -> return (elem, whateva)++-- | For elemsOpts, will either be+-- | Parser: (anyChar)+-- | Parser: (buildElemsOpts elems)++-- parseOpeningTagTutorial :: ParsecT s u m (String, [(String, String)])+-- parseOpeningTagTutorial = do+-- skipChar '<'+-- elem <- some letter+-- attrs <- manyTill attrParser ++-- attrParser :: Stream s m Char => ParsecT s u m (String, String)+-- attrParser = do+-- _ <- space+-- attrName' <- attrName+-- content <- option "" (char '=' >> attrValue)+-- return (attrName', content)+++mkElemtagParser :: Stream s m Char => Maybe [Elem] -> ParsecT s u m String+mkElemtagParser x = case x of+ -- Nothing -> MParsec.some (noneOf [' ', '>'])+ --commented out in case below is wrong+ Nothing -> some (alphaNum <|> char '-')+ Just elemsOpts -> buildElemsOpts elemsOpts+++-- | FUTURE USE CASES: buildElemsOpts :: [ParsecT s u m a] -> ParsecT s u m a -- using <|>+buildElemsOpts :: Stream s m Char => [Elem] -> ParsecT s u m String+-- buildElemsOpts [] = <----- i dont think i need this+buildElemsOpts [] = parserZero+buildElemsOpts (x:elemsAllow) = try (string x) <|> (buildElemsOpts elemsAllow)+++++++++++++++++++++++++++-- [("alt:(Link to external site, this site will open in a new window|Abstract/Details from ABI/INFORM Global and other databases)","failed test"),("class:( /abicomplete/ExternalImage/G@o662VDDpZRdYIFMpLL4twEDUtNbkgCEUrRr@NuLI2KJgLR3sPk50yOcu09+kEL|addFlashPageParameterformat_abstract )","failed test"),("href:(https://www-proquest-com.proxy1.lib.uwo.ca/results.displayresultsitem.contentitemlinks:outboundevent/https:$2f$2focul-uwo.primo.exlibrisgroup.com$2fopenurl$2f01OCUL_UWO$2f01OCUL_UWO:UWO_DEFAULT$3f$3furl_ver$3dZ39.88-2004$26rft_val_fmt$3dinfo:ofi$2ffmt:kev:mtx:journal$26genre$3darticle$26sid$3dProQ:ProQ$253Aabiglobal$26atitle$3dSALARY$2bINEQUALITY$252C$2bTEAM$2bSUCCESS$252C$2bLEAGUE$2bPOLICIES$252C$2bAND$2bTHE$2bSUPERSTAR$2bEFFECT$26title$3dContemporary$2bEconomic$2bPolicy$26issn$3d10743529$26date$3d2018-01-01$26volume$3d36$26issue$3d1$26spage$3d200$26au$3dCyrenne$252C$2bPhilippe$26isbn$3d$26jtitle$3dContemporary$2bEconomic$2bPolicy$26btitle$3d$26rft_id$3dinfo:eric$2f$26rft_id$3dinfo:doi$2f10.1111$252Fcoep.12217/1967324598/318806?site=abicomplete&t:ac=85FEBC108EAA4132PQ/1|https://www-proquest-com.proxy1.lib.uwo.ca/abicomplete/docview/2213130775/abstract/85FEBC108EAA4132PQ/1?accountid=15115)","failed test"),("id:(linkResolverLink|addFlashPageParameterformat_abstract)","failed test"),("linktitle","no attr"),("onclick","no attr"),("title:(Link to external site, this site will open in a new window|Abstract/Details from ABI/INFORM Global and other databases)","failed test")]++++++
+ src/Scrappy/Elem/ITextElemParser.hs view
@@ -0,0 +1,641 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+++-- | This will eventually be a beautiful interface between NLP and scrappy++module Scrappy.Elem.ITextElemParser where+++import Scrappy.Elem.TreeElemParser (treeElemParser, sameTreeH)+import Scrappy.Elem.SimpleElemParser (elemParser)+import Scrappy.Elem.ElemHeadParse (parseOpeningTag, buildElemsOpts, attrsParser+ , mkElemtagParser)+import Scrappy.Elem.Types (HTMLMatcher(..), Elem'(..), Elem, Attrs, ShowHTML(..)+ , TreeHTML(..), endTag+ , selfClosingTextful, noPat, innerText', _innerTree'+ , attrs, elTag, coerceAttrs+ )+++import Text.Parsec (parse, ParsecT, Stream, string, (<|>), anyChar, char+ , optional, try, manyTill, many, runParserT, ParseError+ , parserZero, alphaNum, oneOf+ , digit+ , option+ , letter+ , space+ )+import Control.Monad+import Control.Applicative (some)+import Control.Applicative.Combinators (some, eitherP)+import Data.Either (fromRight, isRight)+import Data.List (intercalate, intersperse)++-- testing writersAbstract+import Scrappy.Find +import Scrappy.Elem.ChainHTML++++-- | comment is to crash nix as reminder to move somewhere sensible+-- data OpenStruct a = OpenStruct (Parser a)+-- type CloseStruct a = OpenStruct a -> ClosePiece a+ -- could be even \_ -> f , when the Close struct is independent of Open and I dont think this+ -- would affect speed+-- data ClosePiece a = ClosePiece (Parser a) ++-- | paired with maybeUsefulNewUrls this would allow us to scrape an entire+-- | site for a singular pattern+-- | and just by virtue of basic haskell types, there's zero reason we cant+-- | have some simple type:+-- | data Scrapeable = Case1 A | Case2 B ... +-- fanExistential :: Url -> (Url -> Bool) -> MaybeT m a -> MaybeT m [a]+-- fanExistential url = do+-- html <- getHtmlST sv url +-- links <- flip successesM html $ hoistMaybe $ scrape (hrefParser' cond)+-- fanExistential links++ -- but actually this would fail due to circularity ; the site is a graph of links++-- writersAbstractSimple = do+-- abstract+-- (_, g) <- manyTill_ anyChar $ paragElemGroup+ +++-- paragElemGroup but instead use treeElemParser and ensure that+-- tree == mempty and that you try to match for a proper paragraph+++emptyTree :: (ShowHTML a, Stream s m Char) =>+ Maybe [Elem]+ -> Maybe (ParsecT s u m a)+ -> [(String, Maybe String)]+ -> ParsecT s u m (TreeHTML a)+emptyTree elemOpts match attrs = do+ e <- treeElemParser elemOpts match attrs + when (not $ null $ _innerTree' e) $ parserZero+ pure e+++preface :: Stream s m Char =>+ ParsecT s u m pre+ -> ParsecT s u m a+ -> ParsecT s u m a+preface pre p = p >> (fmap snd $ manyTill_ anyChar p)+++-- | Returns a minimum of 2 --> almost like `same` should be function ; same :: a -> [a] to be applied to some doc/String+-- | note: not sure if this exists but here's where we could handle iterating names of attributes +-- | Can generalize to ElementRep e++-- instance Show a => ShowHTML Parag where+-- showH = show+++class Zero a where+ consumeZero :: a -> b -> b + -- functions which will always work with a null value++class Singleton a where+ consumeSingleton :: a -> b+ -- functions which will always work with a singular value+ -- most functions in haskell would support this++class Multiple a where+ consumeMultiple :: a -> b + -- functions which are guranteed to work on 2 or more but not+ -- necessarily less++class (Zero a, Singleton a, Multiple a) => Existential a where+ consumeExists :: a -> b+ -- functions that will always work for any case of existentiality ++-- | Only matches if no innerTrees+-- | This doesn't behave exactly like a "group" function+-- | because it allows matching on one element+-- | but this will also never be empty +emptyTreeGroup :: (ShowHTML a, Stream s m Char) =>+ Maybe [Elem]+ -> Maybe (ParsecT s u m a)+ -> [(String, Maybe String)]+ -> ParsecT s u m [TreeHTML a]+emptyTreeGroup elemOpts match attrsSubset = do+ e <- emptyTree elemOpts match attrsSubset+ let+ same = emptyTree (Just [elTag e]) match (coerceAttrs $ attrs e)+ (:) <$> pure e <*> (many $ same <* nl)+ +++-- emptyTreeGroup :: (Stream s m Char)+-- => Maybe [Elem]+-- -> Maybe (ParsecT s u m a)+-- -> [(String, Maybe String)]+-- -> ParsecT s u m [a]+-- emptyTreeGroup elemOpts match attrsSubset = do+-- treeH <- treeElemParser elemOpts match attrsSubset+-- when (not $ null $ _innerTree' treeH) $ parserZero+ +-- let+-- sameTreeHMatches tree = do+-- t <- sameTreeH (Just paragraph) tree +-- when (not $ null $ _innerTree' t) $ parserZero+-- pure $ _matches' t+-- many_treeHMatches <- some $ try $ sameTreeHMatches treeH+-- pure $ mconcat $ (_matches' treeH) : many_treeHMatches+ +-- >>= (\treeH -> fmap (treeH :) (some (try $ sameTreeH matchh treeH))))++-- fmap (_matches) list :: mconcat $ [match] : [[match]] +++-- myEl :: Stream s m Char => ParsecT s u m (TreeHTML Paragraph)+-- myEl = emptyTree Nothing (Just paragraph) [] +++-- abstractPattern >> skipManyTIll $ htmlGroupEmptyTree `eachContain` paragraph +++-- paragElemGroup = do+-- let+-- e1 = do+-- e <- elemParser Nothing (Just paragraph) []+-- if exists anyEndTag $ innerText' e then parserZero else return e+-- innerTextIfNoEndTags e =+-- if exists anyEndTag $ innerText' e then parserZero else return e +-- eN = many $ fmap innerTextIfNoEndTags+-- $ elemParser (Just . (:[]) . elem $ e1) (Just paragraph) []+-- (:) <$> (innerText' <$> e1) <*> eN ++++-- writersAbstract :: Stream s m Char =>+-- ParsecT s u m (Maybe [Either String Paragraph]) +-- writersAbstract = do+-- elemParser Nothing (Just $ abstractWord) [] `contains`+-- findNaive (some $ elemAny paragraphOrAbstractWord)++elemAny :: Stream s m Char => ParsecT s u m (Elem' String) +elemAny = elemParser Nothing noPat [] ++-- Start Pattern+-- pattern+-- notPattern / falsePattern+++-- I might have a function in chainHTML that allows this++-- somePrevPat >> dropManyTill startPattern >> findFirst pattern++-- which I think is reasonably safe given our pattern should be:++-- some' $ elAny `contains` paragraph+-- where+-- some' = all tags determined by first tag if 'p' then might+-- be 6 'p' tags in a row ++-- so we can have multiple but it must be same tag++-- and I could still use contain just not findNaive + ++ +-- abstractWord :: Stream s m Char => ParsecT s u m String+-- abstractWord = string "Abstract" <|> string "abstract" <|> string "Nonlinear"++-- paragraphOrAbstractWord :: Stream s m Char => ParsecT s u m (Either String Paragraph)+-- paragraphOrAbstractWord = Left <$> abstractWord <|> Right <$> paragraph+++-- revalation:+-- scrape x --> [entry1, entry2, entry3 ..] so every item found is in order meaning we could add patterns that influence the consumption of this++-- for example:+-- lets say we want to scrape an abstract ~~~ so thus we want to scrape a body of text titled abstract+-- design principles make it fairly predictable that such will look like:++-- Abstract+-- blah blahblahblabla++-- so:+-- if p in scrape p html is == (Abstract <$> abstractPattern <|> Paragraph p) -- abstractPattern = string "abstract"++-- then we get something like:++-- [Paragraph txt, Paragraph txt2, Abstract "abstract", Paragraph txt3]++-- then reasonably we can infer that txt3 is a valid writers abstract Paragraph but since the first 2 would be rendered above, these 2 are not++-- further this could be a general pattern++-- scrapeWithSeparatingPattern :: ParsecT s u m a -> ParsecT s u m sep -> Maybe (Seperated sep a)+-- scrapeWithSeparatingPattern = undefined++-- type Seperated e a = [Either e a] ++++++-- i need to test if this module would work for extracting text out of research papers even though they are pdfs++--- ***** if we read a research paper backwards we can be waaaaaaay more confident about name and author, may even mix the+-- two up a lot at least its there and discernable to the user even maybe a dumb user, because names are very `discrete` in a sense++-- ---> might even make parsing citations easier++-- I need to do some investigation on the feasibility of reading papers with my parsers by determining if PDFs can just be converted from UTF8 char sequences+-- and read by scraping++-- this could also be an interface ; scrape :: Scrapeable t => ScraperT t a -> t -> Maybe [a] +++-- justPlaintext :: Int -> ParsecT s u m [String]+-- justPlaintext atLeast = +-- fmap (filter (\x -> length x > atLeast)) {--} (find $ many (letter <|> number <|> char ' ' <|> char '.'))++-- just for testing +type ResearchResult = String ++-- type Paragraph = [[String]]+-- | TODO(galen): these should build off each other+data Paragraph = Paragraph { unParagraph :: [Sentence] } ++data Sentence = Sentence { unSentence :: [WrittenWord] }++data WrittenWord = WW { unWord :: String }++instance Show Paragraph where+ show (Paragraph sentences) = intercalate " " $ show <$> sentences++instance Show Sentence where+ show (Sentence words) = (intercalate " " $ show <$> words) <> "."++instance Show WrittenWord where+ show (WW s) = s++ ++instance Semigroup WrittenWord where+ (WW w1) <> (WW w2) = WW $ w1 <> " " <> w2++-- | Technically this shouldnt exist ever +instance Monoid WrittenWord where+ mempty = WW ""++instance Semigroup Sentence where+ (Sentence s1) <> (Sentence s2) = Sentence $ s1 <> s2++instance Monoid Sentence where+ mempty = Sentence []++instance Semigroup Paragraph where+ (Paragraph p) <> (Paragraph p2) = Paragraph $ p <> p2++instance Monoid Paragraph where+ mempty = Paragraph []++instance ShowHTML Paragraph where+ showH (Paragraph s) = mconcat $ fmap showH s ++instance ShowHTML Sentence where+ showH (Sentence words) = intercalate "" (fmap unWord words) <> "."+ --where++punctuation :: Stream s m Char => ParsecT s u m Char+punctuation = oneOf [';', ':', '(', ')', '\"', '\'', '-', ','] -- dk if last one works++-- | Word also means bits but I mean written specifically+-- | This can definitely be expanded upon to increase its reach+-- | while maintaining validity+writtenWord :: Stream s m Char => ParsecT s u m WrittenWord+writtenWord = WW <$> (some $ alphaNum <|> punctuation) <* optional (char ' ')++++++++wordSeparator, comma, colon, semiColon :: Stream s m Char => ParsecT s u m String+wordSeparator = ((:[]) <$> space) <|> comma <|> colon <|> semiColon +comma = do+ c <- char ','+ s <- option "" $ (:[]) <$> space+ pure $ c : s +colon = do + c <- char ':'+ s <- option "" $ (:[]) <$> space+ pure $ c : s +semiColon = do+ c <- char ';'+ s <- option "" $ (:[]) <$> space+ pure $ c : s ++word' :: Stream s m Char => ParsecT s u m String+word' = a_ <|> else'+ where+ a_ = do+ head_ <- char 'a'+ tail_ <- many $ letter <|> (char '\'') <|> (char '-')+ pure $ head_ : tail_+ + else' = some (letter <|> (char '\'') <|> (char '-'))++capitalizedWord :: Stream s m Char => ParsecT s u m String+capitalizedWord = try ia <|> else'+ where+ ia = do+ head_ <- oneOf ['I', 'A']+ tail_ <- many $ letter <|> (char '\'') <|> (char '-')+ pure $ head_ : tail_+ else' = do+ head_ <- oneOf $ ['B'..'H'] <> ['J'..'Z']+ tail_ <- some (letter <|> (char '\'') <|> (char '-'))+ pure $ head_ : tail_ ++number :: Stream s m Char => ParsecT s u m String+number = do+ whole <- some digit+ dec <- option "" $ do+ (:) <$> char '.' <*> some digit+ pure $ whole <> dec++sentence :: Stream s m Char => ParsecT s u m Sentence+sentence = sentenceWhere (const True)+ +sentenceWhere :: Stream s m Char => ([WrittenWord] -> Bool) -> ParsecT s u m Sentence+sentenceWhere test = do+ tokens <- eitherP capitalizedWord number >>= \case+ Left word -> do+ eitherP wordSeparator (char '.') >>= \case+ Right period -> pure [WW word]+ Left separator -> (WW (word <> separator) :) <$> sentenceTail False+ Right number -> do+ eitherP wordSeparator (char '.') >>= \case+ Right period -> pure [WW number]+ Left separator -> (WW (number <> separator) :) <$> sentenceTail True++ toSentence test tokens+ where+ toSentence :: Stream s m Char => ([WrittenWord] -> Bool) -> [WrittenWord] -> ParsecT s u m Sentence+ toSentence test words = case test words of+ False -> parserZero+ True -> pure $ Sentence words -- Sentence $ intercalate "" (fmap unWord words) <> "."+ unWord (WW s) = s++sentenceTail :: Stream s m Char => Bool -> ParsecT s u m [WrittenWord]+sentenceTail previousWasNumber = do+ token <- case previousWasNumber of+ True -> Left <$> word'+ False -> eitherP word' number + eitherP wordSeparator (char '.') >>= \case + Left separator -> do+ tokens <- sentenceTail $ isRight token+ pure $ WW (either id id token <> separator) : tokens + Right period -> pure $ [WW $ either id id token]+++-- sentenceTail = \case+-- True -> do+-- -- was number+-- some (word' >> + ++ +-- a <|> b+-- where+-- a = parseMaybe (number <* optional space) >> some word' >> (number <* optional space) >> (endSentence <|> recSentence) + +++ ++-- | For the sake of chaining these parsers, this optionally consumes+-- | a space at the end. This is the key char diff between one and many+-- | sentences+-- sentence :: Stream s m Char => ParsecT s u m Sentence+-- sentence = do+-- words <- some writtenWord+-- if length words < 4 then parserZero else return () +-- period <- char '.'+-- optional (char ' ')+-- pure . mkSentence $ words + -- pure words++-- *** for research: new concept: reliable generalizations of thinking+-- --> perhaps a point on intelligence eg. math dude vs a dummy++-- | To my understanding this should not affect how we parse; it is+-- | only for sure a given that the result of our low level read is really+-- | just words and so the parsers should focus on setting up the next+-- | parser + +-- paragraph :: Stream s m Char => ParsecT s u m Paragraph+-- paragraph = fmap mkParagraph $ some $ try sentence++-- | This is built in a way that allows the idea of a sentence+-- | to be as internally valid as possible; the sentence controls+-- | the period +-- mkParagraph :: [Sentence] -> Paragraph+-- mkParagraph ss = Paragraph . mkParagraph' $ ss+-- where+-- mkParagraph' :: [Sentence] -> String+-- mkParagraph' ((Sentence s):[]) = s <> ('\n':[])+-- mkParagraph' ((Sentence s):ss) = s <> " " <> (mkParagraph' ss)++-- mkSentence :: [WrittenWord] -> Sentence+-- mkSentence words = Sentence . mkSentence' $ words+-- where +-- mkSentence' :: [WrittenWord] -> String +-- mkSentence' ((WW lastWord):[]) = lastWord <> "." +-- mkSentence' ((WW word):words) = word <> " " <> (mkSentence' words)++-- paragraph' :: Stream s m Char => ParsecT s u m String+-- paragraph' = fmap ((intercalate " ") . mconcat) $ some $ try sentence++-- | Note: will need more complex accumulator for case where an elem has two distinct text segements broken up+-- | by an element, (rare case)+++-- at a low level I would need to create a new elemHeadParser that succeeds for+-- whenever the case is not in the input set of tag and maybe attributes, ie+-- doesnt share any commonalities with the description++-- for now ill forget about attributes++-- -- | Is parseOpeningTag except elem tags are a fail if they match+-- -- | "blacklisted" so to speak+-- notElemHeadParser :: [Elem] -> ParsecT s u m ElemHead+-- notElemHeadParser = do+-- _ <- char '<'+-- elem <- mkNegElemtagParser ++styleTags :: [String]+styleTags = ["b", "strong", "i", "em", "mark", "small", "ins", "sub", "sup"] ++-- | Will only match elements not specified +negParseOpeningTag :: Stream s m Char => [Elem] -> ParsecT s u m (Elem, Attrs)+negParseOpeningTag elemOpts = do+ -- _ <- MParsec.manyTill anyToken (char '<' >> elemOpts >> attrsParser attrsSubset) -- the buildElemsOpts [Elem]+ _ <- char '<'+ tag <- some alphaNum -- mkElemtagParser $ Just elemOpts+ when (elem tag elemOpts) parserZero+ attrs <- attrsParser []+ pure $ (tag, fromRight mempty attrs) ++textChunk :: Stream s m Char => ParsecT s u m String +textChunk = fmap mconcat $ manyTill plainText (try $ openOrCloseTag)+ -- also need to trim out whitespace, \n's, and script++-- | This will match any element open or closing tag that is not a style tag+openOrCloseTag :: Stream s m Char => ParsecT s u m ()+openOrCloseTag = + void $ (try $ negParseOpeningTag styleTags >> char '>') <|> anyEndTag+ -- could also fit in script bit here ++anyEndTag :: Stream s m Char => ParsecT s u m Char +anyEndTag = do+ string "</" >> anyThingbut styleTags >> char '>'++-- | Despite the fun name, this is just for textChunk use+anyThingbut :: Stream s m Char => [String] -> ParsecT s u m String+anyThingbut es = do+ txt <- some alphaNum+ when (elem txt es) $ parserZero+ pure txt+ +textChunkIf :: Stream s m Char => (String -> Bool) -> ParsecT s u m String+textChunkIf f = do+ x <- textChunk+ when (not $ f x) $ parserZero+ pure x ++-- parse () "" "eeee<i>hey</i><a></a>"++plainText :: Stream s m Char => ParsecT s u m String+plainText = do+ unit <- innerText' <$> styleElem <|> (fmap (:[]) anyChar)+ pure unit +++-- plainText' = do+-- styleElemOpenOrClose+-- anyChar ++-- a style elem should be skiped while a normal elem should end++-- fmap elemAny ++styleElem :: Stream s m Char => ParsecT s u m (Elem' String)+styleElem = elemParser (Just $ styleTags) noPat []+-- closeOrOpenTag = try $ negParseOpeningTag ["i"]++-- manyTill anyChar (el "i" [] >> parserZero) <|> (elemParser Nothing Nothing []) ++-- prsr = openingTag >> manyTill (styleTagElem <|> anyChar) closeOrOpenTag++-- scrape prsr html +++-- check if styleTag --> Wrap InnerText (show styleTag) ;; safely unwraps into plain text +-- <|> (elemParser null >> pure Fail)+-- <|> anyChar++-- }-> inside of manyTill_ :: (end, [a]) +++type Html = String+-- getPlainText :: Html -> Either ParseError [String]+-- getPlainText html = do+ -- let+ -- expr = (fmap show $ parseOpeningTag (Just styleTags) [])+ -- <|> (string "</" >> buildElemsOpts styleTags >> string ">")+ -- styleTags = ["b", "strong", "i", "em", "mark", "small", "ins", "sub", "sup"] --"del" omitted+ + -- divied <- parse (divideUp expr) "" html + -- parse onlyPlainText "" $ (mconcat . catEithers) divied++removeStyleTags :: Html -> Html+removeStyleTags html = (mconcat . catEithers) $ fromRight [] $ parse (divideUp expr) "" html+ where expr = (fmap show $ parseOpeningTag (Just styleTags) [])+ <|> (string "</" >> buildElemsOpts styleTags >> string ">")+ ++++-- getPlainText' :: ParsecT s u m [String]+-- getPlainText' = do+ ++ -- join $ fmap ( (parse onlyPlainText "") . mconcat . catEithers) $ + -- where+ -- expr = (fmap show $ parseOpeningTag (Just styleTags) [])+ -- <|> (string "</" >> buildElemsOpts styleTags >> string ">")+ -- styleTags = ["b", "strong", "i", "em", "mark", "small", "ins", "sub", "sup"] --"del" omitted ++-- Just applies onlyPlainText to html tag+-- getDocText :: Html -> [String]+-- getDocText html = +++catEithers :: [Either e a] -> [a]+catEithers (x:xs) = case x of+ Right a -> a : catEithers xs+ Left _ -> catEithers xs+ -- in this case, our Right case are the ones we want to eliminate++divideUp :: Stream s m Char => ParsecT s u m String -> ParsecT s u m [Either String String]+divideUp parser = many ((Right <$> parser) <|> ( (Left . (:[]) ) <$> anyChar)) ++onlyPlainText :: Stream s m Char => ParsecT s u m String+onlyPlainText = fmap (\(ACT strings) -> mconcat $ reverse strings) specialElemParser + where+ specialElemParser :: Stream s m Char => ParsecT s u m (AccumITextElem String)+ specialElemParser = do+ (elem', attrs') <- parseOpeningTag (Just ["html"]) [] + (localText, inTex) <- fmap (foldr textOnlyFoldr mempty)+ $ (try (string "/>") >> return [])+ <|> (try $ innerElemParser' elem')+ <|> (selfClosingTextful Nothing) -- did not have an easily associated end tag+ return $ ACT (localText : inTex) + + where innerElemParser' eTag = --htmlGenParser with specialElemParser + char '>'+ >> manyTill (Element <$> (try specialElemParser) + <|> ((IText . (:[])) <$> anyChar) ) (endTag eTag)++ -- selfClosingTextful = manyTill (IText . (:[]) <$> anyChar) endTagg+ -- endTagg = (try (char '<'+ -- >> (optional (char '/'))+ -- >> MParsec.some anyChar+ -- >> (string " " <|> string ">")))++-- Not for getting matches +data AccumITextElem a = ACT [String]++textOnlyFoldr :: HTMLMatcher AccumITextElem String -> (String, [String]) -> (String, [String]) +textOnlyFoldr htmlM (itextAccum, fromElemAccum) = case htmlM of + IText str -> + (itextAccum <> str, fromElemAccum) + Element (ACT strList) ->+ (itextAccum, fromElemAccum <> strList)+ -- should never fire+ Match mat ->+ (itextAccum <> mat, fromElemAccum)++-- Should consider using the following data structure+++++-- textOnlyFoldr :: [HTMLMatcher e a] -> [String] +-- textOnlyFoldr htmlMs = fmap f htmlMs -- . filter (\x -> case x of { IText x -> True; _ -> False }) htmlMs+-- where+-- f htmlM = case htmlM of +-- Match str -> str+-- IText str -> str+-- Element e -> innerText' e+
+ src/Scrappy/Elem/SimpleElemParser.hs view
@@ -0,0 +1,548 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}++module Scrappy.Elem.SimpleElemParser where++import Scrappy.Elem.Types++import Scrappy.Elem.ElemHeadParse (parseOpeningTag, parseOpeningTagWhere)+import Scrappy.Links (LastUrl)++import Scrappy.Types -- for witherable instance++import Control.Monad (when) +import Control.Applicative (Alternative, liftA2, some, (<|>))+--import Witherable (mapMaybe)+--import Text.Megaparsec as MParsec (eitherP, some, manyTill)+import Text.Parsec (ParsecT, Stream, string, try, parserZero, anyChar, char, optional, anyToken, parserFail+ , many, space, manyTill)+import Text.URI (URI, render)+import Data.Text (Text, unpack)+import Data.Map (Map, toList)+import Data.Maybe (fromMaybe)++import Control.Monad.IO.Class++-- TODO(galen): antiElemParser --- inner matches must be 0 ... maybe doesnt match any parameter +++eitherP :: Alternative m => m a -> m b -> m (Either a b)+eitherP a b = (Left <$> a) <|> (Right <$> b)++manyTill_ :: ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m ([a], end)+manyTill_ p end = go+ where+ go = (([],) <$> end) <|> liftA2 (\x (xs, y) -> (x : xs, y)) p go+++-- | Try to cut out Megaparsec for now - get direct export from Control.Applicative++-- | Note: could make class HtmlP where { el :: a -> Elem, attrs :: a -> Attrs, innerText :: a -> Text } ++-- | A use-case/problem is popping up as I code:+ -- if elem 'a' contains elem 'a'+ -- then do what?+ -- 1) Restrict to identifying in parent only if not in some inner same element+ -- 2) Get all in parent element regardless+ -- 3) Consider being inside of same element a fail -> then get inner-same element+ -- like 1) but seeks to carry minimal data around it / more honed in++++-- | Simplest interface to building element patterns +el :: Stream s m Char => Elem -> [(String, String)] -> ParsecT s u m (Elem' String)+el element attrss = elemParser (Just (element:[])) Nothing ((fmap . fmap) Just attrss)++++-- | Generic interface for building Html element patterns where we do not differentiate based on whats inside+-- | for control of allowable inner html patterns, see ChainHTML and/or TreeElemParser +elemParser :: (ShowHTML a, Stream s m Char) =>+ Maybe [Elem]+ -> Maybe (ParsecT s u m a)+ -> [(String, Maybe String)]+ -> ParsecT s u m (Elem' a)+elemParser elemList innerSpec attrs = do+ -- liftIO $ print "hey"+ (elem', attrs') <- parseOpeningTag elemList attrs + -- we should now read the elem' to see if in list of self-closing tags+ -- TODO(galen): What about when the self closing tag actually doesnt?+ case elem elem' selfClosing of+ True -> do+ (try (string ">") <|> string "/>")+ case innerSpec of+ Nothing -> return $ Elem' elem' attrs' mempty mempty + Just _ -> parserZero + False -> do+ (asString, matches) <- fmap (foldr foldFuncTup mempty) -- this cant be where we do "/>" if we parse ">" in parseOpeningTag+ $ (try (string "/>") >> return [])+ <|> (try $ innerElemParser elem' innerSpec) -- need to be sure that we have exhausted looking for an end tag, then we can do the following safely+ <|> (selfClosingTextful innerSpec)+ return $ Elem' elem' attrs' matches (reverse asString)+++-- | Generic interface for building Html element patterns where we do not differentiate based on whats inside+-- | for control of allowable inner html patterns, see ChainHTML and/or TreeElemParser +elemParserWhere :: (ShowHTML a, Stream s m Char) =>+ Maybe [Elem]+ -> Maybe (ParsecT s u m a)+ -> String -> (String -> Bool) -- GOAL: -> [(String, String -> Bool)]+ -- ^ An attr and a predicate+ -> ParsecT s u m (Elem' a)+elemParserWhere elemList innerSpec attr pred = do+ (elem', attrs') <- parseOpeningTagWhere elemList attr pred+ -- we should now read the elem' to see if in list of self-closing tags+ case elem elem' selfClosing of+ True -> do+ (try (string ">") <|> string "/>")+ case innerSpec of+ Nothing -> return $ Elem' elem' attrs' mempty mempty + Just _ -> parserZero + False -> do+ (asString, matches) <- fmap (foldr foldFuncTup mempty) -- this cant be where we do "/>" if we parse ">" in parseOpeningTag+ $ (try (string "/>") >> return [])+ <|> (try $ innerElemParser elem' innerSpec) -- need to be sure that we have exhausted looking for an end tag, then we can do the following safely+ <|> (selfClosingTextful innerSpec)+ return $ Elem' elem' attrs' matches (reverse asString)++++ +clickableHref :: Stream s m Char => Bool -> LastUrl -> ParsecT s u m Clickable+clickableHref booly cUrl = do+ elA <- parseOpeningTag Nothing [("href", Nothing)]+ href <- mapMaybe (getHrefAttrs booly cUrl) (pure $ snd elA) + return $ Clickable elA href+++-- eg clickable' (string "download") +clickableHref' :: (Stream s m Char, ShowHTML a) =>+ ParsecT s u m a+ -> Bool+ -> LastUrl+ -> ParsecT s u m Clickable +clickableHref' innerPat booly cUrl = do+ e <- elemParser Nothing (Just $ innerPat) [("href", Nothing)]+ href <- mapMaybe (getHrefEl booly cUrl) (pure e)+ return $ Clickable (elTag e, attrs e) href++ +-- instance Monad Elem' where ++sameElTag :: (ShowHTML a, Stream s m Char) => Elem -> Maybe (ParsecT s u m a) -> ParsecT s u m (Elem' a)+sameElTag elem parser = elemParser (Just [elem]) parser []+ + -- innerMatches el + -- return $ (elemToStr el, Match $ innerMatches el) -- allowed to return a String or Match a++-- future concern for foldFuncMatchlist where Elem ~~ [] ; both of kind * -> *+matchesInSameElTag :: (ShowHTML a, Stream s m Char) => Elem -> Maybe (ParsecT s u m a) -> ParsecT s u m [a]+matchesInSameElTag elem parser = do+ el <- elemParser (Just [elem]) parser [] + return $ (matches' el) -- allowed to return a String or Match a++-- | Might be worth it to do again with findNextMatch func+ -- this would open up ability to return multiple matches inside of a given element+ -- would need to retain ability to handle 3Cases{ self-closing(2 { /> or > .. eof}) | match | no match+ -- in case of no match { self-closing || simply, no match } -> needs to throw parserZero ++-- | findNextMatch already handles case of Eof+ -- would be re-definition of baseParser in `let`+++-- the below class functions give rise to concept:+-- findInRecursive :: IsHTMLRep a => (Parser1, Parser2, Parser3, ...) -> Element a++-- where Element a is meant to represent anything that fits IsHTMLRep and has some number of summarized data+-- from the html++-- and is meant to work with a MessyTree ~ String in a context-enabled manner++-- this could in theory be as abstract as possible++-- | Case 1:++-- (ParserLevel1 a, ParserLevel2 b) ~ up to 2 levels specified ~ up to 2 patterns+ -- Given find functions, this can start at any arbitrary next index++-- | Case 2:++-- [ParserSomeLevel] ~ up to n levels specified, 1 possible pattern'++-- | Case 3: The most general++-- [Show a => forall a. a] ~ up to n levels specified, n possible patterns +++-- class MonoidFold a where+ -- foldMon :: [a] -> b+ -- newEmpty :: b++-- parseHtmlMatcher -> foldtoITR + opening tag -> elem +++-- | Maybe elemParser can be abstracted to be a class function++-- | Does this work with parser meant to take up whole inner?+ -- I suppose it would but this would allow other stuff+ -- that case is handled by treeElemParserSpecific++-- {-# DEPRECATED elemParser "needs logic for anyTagInner for text-ful, self-closing tags" #-}+-- elemParser :: (InnerHTMLRep Elem' InnerTextResult a, ShowHTML a, Stream s m Char) =>+-- Maybe [Elem]+-- -> Maybe (ParsecT s u m a)+-- -> [(String, Maybe String)]+-- -> ParsecT s u m (Elem' a)+-- elemParser elemList innerSpec attrs = do+-- (elem', attrs') <- parseOpeningTag elemList attrs+-- let+-- parser = char '>'+-- >> manyTill (Match <$> (fromMaybe parserZero innerSpec)+-- <|> Element <$> sameElTag elem' innerSpec+-- <|> ((IText . (:[])) <$> anyChar)) (endTag elem')+ ++-- innerH <- (try (string "/>") >> return []) <|> (try parser) <|> (selfClosingTextful innerSpec)+-- let itr = foldHtmlMatcher innerH +-- case length $ matches itr of+-- 0 ->+-- case innerSpec of+-- Nothing -> return $ Elem' elem' attrs' (matches itr) (innerText itr)+-- _ -> parserZero+-- _ -> return $ Elem' elem' attrs' (matches itr) (innerText itr)++-- if innerSpec == Nothing+ -- then return $ Elem' elem' attrs' (matches itr) (innerText itr)+ -- else parserZero+ + {- endTag is currently in TreeElemParser -}+ +-- selfClosingTextful :: ParsecT s u m a+-- selfClosingTextful = do+-- -++-- foldHtmlMatcherToTrup :: [HTMLMatcher e a] -> ([a], + +-- {-# DEPRECATED elemParser "needs logic for anyTagInner for text-ful, self-closing tags" #-}++-- elemParser :: (ShowHTML a, Stream s m Char) =>+-- Maybe [Elem]+-- -> Maybe (ParsecT s u m a)+-- -> [(String, Maybe String)]+-- -> ParsecT s u m (Elem' a)+-- elemParser elemList innerSpec attrs = do+-- let+-- parser eTag = char '>'+-- >> manyTill (Match <$> (fromMaybe parserZero innerSpec)+-- <|> Element <$> sameElTag eTag innerSpec+-- <|> ((IText . (:[])) <$> anyChar)) (endTag eTag)+-- required = case innerSpec of+-- { Nothing -> 0; _ -> 1 }+-- enoughMatches e a (asString, matches) = +-- if required > (length matches)+-- then return $ Elem' e a matches asString+-- else parserZero+ +-- (elem', attrs') <- parseOpeningTag elemList attrs+-- innerH <- fmap (foldr foldFuncTup mempty) +-- $ (try (string "/>") >> return [])+-- <|> (try $ parser elem')+-- <|> (selfClosingTextful innerSpec)+-- enoughMatches elem' attrs' innerH++selfClosing :: [String]+selfClosing = ["area", "base", "br", "col", "embed", "hr", "img", "input", "link", "meta", "param", "source", "track", "wbr"]++elSelfC :: Stream s m Char => Maybe [Elem] -> [(String, Maybe String)] -> ParsecT s u m (Elem' a)+elSelfC elemOpts attrsSubset = do+ (tag, attrs) <- parseOpeningTag elemOpts attrsSubset+ return $ Elem' tag attrs mempty mempty ++elSelfClosing :: Stream s m Char => Maybe [Elem] -> Maybe (ParsecT s u m a) -> [(String, Maybe String)] -> ParsecT s u m (Elem' a)+elSelfClosing elemOpts innerSpec attrsSubset = do+ (tag, attrs) <- parseOpeningTag elemOpts attrsSubset+ case innerSpec of+ Just _ -> parserZero+ Nothing -> return $ Elem' tag attrs mempty mempty ++elemWithBody :: (ShowHTML a, Stream s m Char) =>+ Maybe [Elem]+ -> Maybe (ParsecT s u m a)+ -> [(String, Maybe String)]+ -> ParsecT s u m (Elem' a)+elemWithBody elemList innerSpec attrs = do+ e <- elemParserInternal elemList innerSpec attrs+ when (length (matches' e) < (case innerSpec of { Nothing -> 0; _ -> 1 })) (parserFail "not enough matches")+ return e+ +elemParserInternal :: (ShowHTML a, Stream s m Char) =>+ Maybe [Elem]+ -> Maybe (ParsecT s u m a)+ -> [(String, Maybe String)]+ -> ParsecT s u m (Elem' a)+elemParserInternal elemList innerSpec attrs = do+ (elem', attrs') <- parseOpeningTag elemList attrs+ -- we should now read the elem' to see if in list of self-closing tags+ -- case elem elem' selfClosing of+ -- True -> return Elem' elem' attrs' + (asString, matches) <- fmap (foldr foldFuncTup mempty) -- this cant be where we do "/>" if we parse ">" in parseOpeningTag+ $ (try (string "/>") >> return [])+ <|> (try $ innerElemParser elem' innerSpec) -- need to be sure that we have exhausted looking for an end tag, then we can do the following safely+ <|> (selfClosingTextful innerSpec)+ return $ Elem' elem' attrs' matches (reverse asString)+++-- elemParserInternalV2 :: (ShowHTML a, Stream s m Char) =>+-- Maybe [Elem]+-- -> Maybe (ParsecT s u m a)+-- -> [(String, Maybe String)]+-- -> ParsecT s u m (Elem' a)+-- elemParserInternalV2 elemList innerSpec attrs = do+-- (elem', attrs') <- parseOpeningTag elemList attrs+-- -- we should now read the elem' to see if in list of self-closing tags+-- case elem elem' selfClosing of+-- True -> (try string ">" <|> string "/>") >> return Elem' elem' attrs' mempty mempty +-- False -> do+-- (asString, matches) <- fmap (foldr foldFuncTup mempty) -- this cant be where we do "/>" if we parse ">" in parseOpeningTag+-- $ (try (string "/>") >> return [])+-- <|> (try $ innerElemParser elem' innerSpec) -- need to be sure that we have exhausted looking for an end tag, then we can do the following safely+-- <|> (selfClosingTextful innerSpec)+-- return $ Elem' elem' attrs' matches (reverse asString)+++ +-- elemParser :: (ShowHTML a, Stream s m Char) =>+-- Maybe [Elem]+-- -> Maybe (ParsecT s u m a)+-- -> [(String, Maybe String)]+-- -> ParsecT s u m (Elem' a)+-- elemParser elemList innerSpec attrs = do+-- -- let required = case innerSpec of { Nothing -> 0; _ -> 1 }+-- (elem', attrs') <- parseOpeningTag elemList attrs+-- innerH <- fmap (foldr foldFuncTup mempty)+-- -- this cant be where we do "/>" if we parse ">" in parseOpeningTag+-- $ (try (string "/>") >> return [])+-- <|> (try $ innerElemParser elem' innerSpec)+-- -- need to be sure that we have exhausted looking for an end tag+-- -- then we can do the following safely+-- <|> (selfClosingTextful innerSpec)+-- enoughMatches 0 elem' attrs' innerH+++innerElemParser :: (ShowHTML a, Stream s m Char) =>+ String+ -> Maybe (ParsecT s u m a)+ -> ParsecT s u m [HTMLMatcher Elem' a]+innerElemParser eTag innerSpec = char '>'+ >> manyTill (try (Match <$> (fromMaybe parserZero innerSpec))+ <|> (try (IText <$> stylingElem)) -- this line is new/unstable+ <|> try (Element <$> sameElTag eTag innerSpec)+ <|> ((IText . (:[])) <$> anyChar)) (endTag eTag)+ ++-- Doesnt change the structure of the page at all just how text is styled like MS word stuff+stylingTags = ["abbr", "b", "big", "acronym", "dfn", "em", "font", "i", "mark", "q", "small", "strong"]++-- | Just gives the inners +stylingElem :: Stream s m Char => ParsecT s u m String +stylingElem = do+ (e,_) <- parseOpeningTag (Just stylingTags) []+ char '>'+ fmap (reverse. fst) $ manyTill_ anyChar (endTag e) + -- matches : Reversed >-> RW+ +-- f :: ([a], [b], [c]) -> Elem' a+-- f (x,y,z) = f' x y z++-- f' el attrs = Elem' el attrs++ ++-- case length $ matches itr of+-- 0 ->+-- case innerSpec of+-- Nothing -> return $ Elem' elem' attrs' (matches itr) (innerText itr)+-- _ -> parserZero+-- _ -> return $ Elem' elem' attrs' (matches itr) (innerText itr)++ +-- -- this should be a success but does not allow +++-- baseInnerParser :: Stream s m Char =>+-- Maybe (ParsecT s u m a)+-- -> ParsecT s u m String+-- -> ParsecT s u m (InnerTextResult a)+-- baseInnerParser innerPat endParse = do+-- _ <- char '>'++-- x :: [Inner a] <- manyTill_ (Match $ match <|> El <$> sameElTag <|> NonMatch anyChar) endParse++-- foldHtmlMatcher x+ + + -- (pre, patternFound) <- manyTill_ (try sameElTag <|> p) (fromMaybe anyChar innerPat)+ -- (post, _) <- manyTill_ (try sameElTag <|> p) endParse++ -- return $ InnerTextResult { match = patternFound+ -- , fullInner = mconcat pre <> patternFound <> mconcat post }++++-- -- | Gets own subsets (eg div if outer = div)+-- -- | Monoid may need to be implemented so that we can have mempty to help generalize+-- parseInnerHTMLAndEndTag2 :: (ToHTML a, Stream s m Char) => Elem -> Maybe (ParsecT s u m a) -> ParsecT s u m (InnerTextResult a)+-- parseInnerHTMLAndEndTag2 elem innerPattern = do+-- let+-- p :: Stream s m Char => ParsecT s u m (Inner a) +-- p = do+-- a <- anyChar+-- return (NonMatch $ a : [])+ +-- -- what does anyTagInner do?+-- -- should it instead be +-- anyTagInner :: Stream s m Char => Maybe (ParsecT s u m String) -> ParsecT s u m (InnerTextResult a)+-- anyTagInner innerP = baseParser innerP (try (char '<'+-- >> (optional (char '/'))+-- >> MParsec.some anyChar -- end tag +-- >> (string " " <|> string ">")))++-- normal :: Stream s m Char => Maybe (ParsecT s u m String) -> ParsecT s u m (InnerTextResult a)+-- normal innerP = baseParser innerP (try (string ("</" <> elem <> ">")))+ +-- x <- Match <$> normal <|> NonMatch <$> ++-- baseInnerParser+-- _ <- char '>'+-- (pre, patternFound) <- manyTill_ (try (sameElTag elem) <|> p) (fromMaybe anyChar innerPattern)+-- (post, _) <- manyTill_ (try sameElTag <|> p) endParse++-- return $ InnerTextResult { match = patternFound+-- , fullInner = mconcat pre <> patternFound <> mconcat post }++ + +-- x <- MParsec.eitherP (try (string "/>")) (normal innerPattern <|> anyTagInner innerPattern)+-- case x of+-- Left a -> -- was "/>" +-- case innerPattern of+-- Just a -> parserZero+-- Nothing ->+-- pure InnerTextResult { match = "", fullInner = "" }++-- --was not "/>"+-- -- but i believe could still be+-- -- > implicit self-closing tag+-- -- > fail + +-- Right b -> return b++-- | Does not get subsets, gets most inner (Elem <-> Match) combo+-- | Monoid may need to be implemented so that we can have mempty to help generalize+{-# DEPRECATED parseInnerHTMLAndEndTag "use new elem parser directly" #-}+parseInnerHTMLAndEndTag :: (Stream s m Char) =>+ Elem+ -> Maybe (ParsecT s u m String)+ -> ParsecT s u m (InnerTextResult String)+parseInnerHTMLAndEndTag elem innerPattern = do++ let f :: Stream s m Char => Maybe (ParsecT s u m String) -> ParsecT s u m String+ f x = case x of+ Just pat -> pat+ Nothing -> string ""++ sameElTag :: Stream s m Char => ParsecT s u m String+ sameElTag = do+ el <- elemParserOld (Just [elem]) Nothing []+ return $ showH el++ p :: Stream s m Char => ParsecT s u m String + p = do+ a <- anyToken+ return (a : [])++ baseParser :: Stream s m Char => Maybe (ParsecT s u m String) -> ParsecT s u m String -> ParsecT s u m (InnerTextResult String)+ baseParser innerPat endParse = do+ _ <- char '>'+ (pre, patternFound) <- manyTill_ (try sameElTag <|> p) (f innerPat)+ (post, _) <- manyTill_ (try sameElTag <|> p) endParse++ return $ InnerTextResult { _matchesITR = [patternFound]+ , _fullInner = mconcat pre <> patternFound <> mconcat post }+ + anyTagInner :: Stream s m Char => Maybe (ParsecT s u m String) -> ParsecT s u m (InnerTextResult String)+ anyTagInner innerP = baseParser innerP (try (char '<'+ >> (optional (char '/'))+----------------------------------------------------DOES THIS ACTUALLY WORK BELOW?--------------------+ >> some anyChar -- end tag + >> (string " " <|> string ">")))++ normal :: Stream s m Char => Maybe (ParsecT s u m String) -> ParsecT s u m (InnerTextResult String)+ normal innerP = baseParser innerP (try (string ("</" <> elem <> ">")))+ ++ x <- eitherP (try (string "/>")) (normal innerPattern <|> anyTagInner innerPattern)+ case x of+ Left a ->+ case innerPattern of+ Just a -> parserZero+ Nothing ->+ pure InnerTextResult { _matchesITR = [], _fullInner = "" }+ + Right b -> return b+ + -- Note: we can parse these better with eitherP+ -- eitherP :: Alternative m => m a -> m b -> m (Either a b)++ -- then use case statement to deal with case (A: sub-elem | B: anychar)+ --if sub-elem -> put in list --then--> + + -- (pre, patternFound) <- manyTill_ (try sameElTag <|> p) (f innerPattern)+ -- (post, _) <- manyTill_ (try sameElTag <|> p) (try (string ("</" <> elem <> ">")))++ -- return $ InnerTextResult { match = patternFound+ -- , fullInner = mconcat pre <> patternFound <> mconcat post }+++-- | Note: In case of Nothing for innerSpec, the parser should be : optional anyChar == () ++-- Note: this can be passed to findAll func in megaparsec as is+-- | attrs (Attr | AnyAttr) maybe discr elem+{-# DEPRECATED elemParserOld "use elemParser" #-}+elemParserOld :: (Stream s m Char) =>+ Maybe [Elem]+ -> Maybe (ParsecT s u m String)+ -> [(String, Maybe String)]+ -> ParsecT s u m (Elem' String)+elemParserOld elemList innerSpec attrs = do+ (elem', attrs') <- parseOpeningTag elemList attrs+ --note that at this point, there is a set elem' to match + inner <- parseInnerHTMLAndEndTag elem' innerSpec+ return $ Elem' elem' attrs' (_matchesITR inner) (_fullInner inner)+-- | Attrs should really be returned as a map++-- | note that this could even be used for mining text on page+-- | eg. search with innerSpec as "the" or other common articles ++-- either begin parsing the element or href and find that it is what youre looking for+-- OR -> skip to start of next element+ +-- | Note: how do we get a computer to recognize, Boolean-ly if some representation is x?+-- | where x is some statement?++ -- As humans we do this visually : is this object red? yes or no++ -- A computer must do the same with "local vision" that theoretically must be as parsing algorithm+ -- aka Bool `followedby` Bool2 `followedBy` Bool3 ... Bool_n+ + -- where some Bools are of set-wise funcs and some are singleton-options AKA / therfore some+ -- sequential combo of (Set 1 of Any <-> Set (totalCount) of Any)++ -- Therefore -> this logic generalizes processing to both humans and computers,; the full set of+ -- higher level processors +++++
+ src/Scrappy/Elem/TreeElemParser.hs view
@@ -0,0 +1,1029 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}++module Scrappy.Elem.TreeElemParser where++import Control.Monad.IO.Class++import Scrappy.Elem.ElemHeadParse (parseOpeningTag, hrefParser', parseOpeningTagDesc, mkAttrsDesc, attrParser)+import Scrappy.Elem.Types (Elem, Attrs, ElemHead, TreeHTML(TreeHTML), HTMLMatcher (IText, Element, Match)+ , InnerTextHTMLTree(InnerTextHTMLTree), innerTree, innerText, matches, GroupHtml+ , Elem', TreeIndex, attrs, elTag, ShowHTML, showH, _innerTree', matches'+ , ElementRep, mkGH, innerText', _innerText, _matches, foldFuncTrup+ , UrlPagination(..), enoughMatchesTree, selfClosingTextful, endTag)++import Scrappy.Elem.ChainHTML (someHtml, manyHtml, nl)+import Scrappy.Elem.SimpleElemParser (elemParser)+import Scrappy.Find (findNaive)++import Control.Monad (when)+import Control.Applicative (Alternative, liftA2, many, (<|>), some)+import Text.Parsec (Stream, ParsecT, anyChar, try, parserZero, parserFail, string, parse+ , char, noneOf, option, space, alphaNum, notFollowedBy, (<?>), optional, manyTill)+import qualified Data.Map as Map (Map, toList, fromList, adjust) +import Data.Graph (Tree (Node), Forest)+import Data.Tree (rootLabel)+import Text.URI as URI+import Data.Char (digitToInt)+import Data.Maybe (fromMaybe, fromJust)+import Data.List+import Data.Text (Text, splitOn)+++skipManyTill :: Alternative m => m a -> m end -> m end+skipManyTill p end = go+ where+ go = end <|> (p *> go)+{-# INLINE skipManyTill #-}++-- | Note for research on Parsers/Scrapers + AI research -> if a scraper does provide only+-- | a slow method for processing (Picture -> *) that we might be able to solve this issue with+-- | either Quantum (same as current AI) or with attentive methodologies to "gamble" on what to first pay+-- | attention to , which could further be based on if Video like (frame -> frame) or single picture+++manyTill_ :: ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m ([a], end)+manyTill_ p end = go+ where+ go = (([],) <$> end) <|> liftA2 (\x (xs, y) -> (x : xs, y)) p go+++data Many a = Many a | One a deriving Show++treeLookupIdx :: TreeIndex -> Forest a -> a+treeLookupIdx = undefined+++-------------------------------------------------------------------------------------------------------------------+----------------------Top Level Functions-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------++++ +-- | Like elemParser, this matches on an html element but also represents the innerHTML+-- | as a Tree ElemHead so that we can match this structure in elements further down in the DOM+-- | see groupHtml and treeElemParserSpecific +treeElemParser :: (Stream s m Char, ShowHTML a) =>+ Maybe [Elem]+ -> Maybe (ParsecT s u m a)+ -> [(String, Maybe String)]+ -> ParsecT s u m (TreeHTML a)+treeElemParser elemOpts matchh attrsSubset = do+ e <- treeElemParser' elemOpts matchh attrsSubset+ when (length (matches' e) < (case matchh of { Nothing -> 0; _ -> 1 })) (parserFail "not enough matches")+ return e+++selfClosing :: [String]+selfClosing = ["area", "base", "br", "col", "embed", "hr", "img", "input", "link", "meta", "param", "source", "track", "wbr"]+++-- | Used by treeElemParser, is not an interface, use treeElemParser+treeElemParser' :: (Stream s m Char, ShowHTML a) =>+ Maybe [Elem]+ -> Maybe (ParsecT s u m a)+ -> [(String, Maybe String)]+ -> ParsecT s u m (TreeHTML a)+treeElemParser' elemOpts matchh attrsSubset = do+ (elem', attrs') <- parseOpeningTag elemOpts attrsSubset+ case elem elem' selfClosing of+ True -> do+ (try (string ">") <|> string "/>")+ case matchh of+ Nothing -> return $ TreeHTML elem' attrs' mempty mempty mempty+ Just _ -> parserZero ++ -- ((try string ">") <|> string "/>") >> return TreeHTML elem' attrs' mempty mempty mempty+ False -> do+ -- (inText, matchBook, treees) <- inerTreeElemParser + (inText, matchBook, treees) <- fmap (foldr foldFuncTrup mempty)+ $ (try (string "/>") >> return []) + <|> (try $ innerElemParser2 elem' matchh)+ <|> (selfClosingTextful matchh)+ return $ TreeHTML elem' attrs' (reverse matchBook) (reverse inText) (reverse treees)++-------------------------------------------------------------------------------------------------------------------++-- | The real difference between (htmlGroup _ _ _) and specificRepetitiveForest is a matter of if we accept the next+-- | piece to be a new discovery to match on or if we are in that process of matching what we just found+++-- digitEq "ere3" "ere4"+innerTreeElemParser :: (ShowHTML a, Stream s m Char) =>+ Elem+ -> Maybe (ParsecT s u m a)+ -> ParsecT s u m (String, [a], [Tree ElemHead]) +innerTreeElemParser elem' matchh = do+ fmap (foldr foldFuncTrup mempty)+ $ (try (string "/>") >> return []) + <|> (try $ innerElemParser2 elem' matchh)+ <|> (selfClosingTextful matchh)+-- then i apply this to all leaves of the Map++-- !!!!!!!!!!!!!!!!!!!+-- | NOTE: In future: create function that simplifies all numbers that will be compared to their number of digits+-- 1426674 -> 1234567+-- 1834324 -> 1234567 (==) -> True +++++-- htmlGroup --calls--> treeElemParser >>= (many treeSpecific --calls--> specificRepForest) ++-- | Ideal case is that we can do (Many a) struturing even if interspersed with text which would solve issues like+-- | many search terms highlighted, we then wouldnt need to know what the search term is+-- | AND!! we have already seen that it could for exmaple be: <a><b class="hiddenText">Hockey</b></a> +++-- treeElemParserSpecific' :: -> HTMLMatcher TreeHTML String+-- treeElemParserSpecific' = do+-- x <- treeElemParserSpecific+-- case innerText' x == searchTerm of+-- True -> IText (innerText' x)+-- False -> Element x++type SubTree a = [Tree a]+-- | Note: unlike other Element parsers, it does not call itself but innerParserSpecific instead loops with+-- | +treeElemParserSpecific :: (Stream s m Char, ShowHTML a) =>+ Maybe (ParsecT s u m a)+ -> Elem+ -> [(String, String)]+ -> SubTree ElemHead+ -> ParsecT s u m (TreeHTML a)+treeElemParserSpecific match elem' attrs' subTree = do+ (tag, attrsOut) <- parseOpeningTagDesc (Just [elem']) attrs'+ char '>'+ (matchBook, inText, treees) <- innerParserSpecific match tag subTree+ return $ TreeHTML tag attrsOut matchBook inText treees++validateGPR :: [Many (Tree ElemHead)] -> ParsecT s u m [HTMLMatcher TreeHTML a]+validateGPR manyElHeads =+ if length (filter (\case {One a -> True; _ -> False}) manyElHeads) == 0 then return []+ else parserFail "promised elements not found"++-- We allow attrs to be any then check, but also avoid unnceccessarily parsing attrs+-- following needs to be inside many+-- innerParser will be from case elem tag selfClosing and on +-- Is able to repeat / execute any pattern that returns multiple elements of same type+-- (see manyTreeElemHeadParser)+++-- | Uses HTMLMatcher to collect cases of html while parsing inside of a certain element+htmlGenParserRepeat' :: (Stream s m Char, ShowHTML a) =>+ String + -> Maybe (ParsecT s u m a)+ -> [Many (Tree ElemHead)]+ -> ParsecT s u m [HTMLMatcher TreeHTML a]+htmlGenParserRepeat' elemTag match manyElHeads = {-parsesTreeHs-}+ ((endTag elemTag) >> validateGPR manyElHeads)+ <|> liftA2 (:) (fmap Match $ try (fromMaybe parserZero match)) (htmlGenParserRepeat elemTag match manyElHeads)+ <|> liftA2 (:) (fmap IText $ try stylingElem) (htmlGenParserRepeat elemTag match manyElHeads) + <|> try ((treeElemParserSpecificContinuous match manyElHeads)+ >>= (\(sM, a) -> fmap ((Element a):) (htmlGenParserRepeat elemTag match sM)))+ <|> liftA2 (:) ((IText . (:[])) <$> anyChar) (htmlGenParserRepeat elemTag match manyElHeads) ++++-- Note: even tho this is done / works (below) we could allow for any element the entire time+-- | BUT! we need to check off our list of demanded elements so that when we parse the end tag, we can see if+-- | the elements (ordered and parsed only in order) were all found before the end tag+-- for htmlGenParserRepeat it can just change the passed state of [Many (Tree ElemHead)]+++htmlGenParserRepeat :: (Stream s m Char, ShowHTML a) =>+ String + -> Maybe (ParsecT s u m a)+ -> [Many (Tree ElemHead)]+ -> ParsecT s u m [HTMLMatcher TreeHTML a]+htmlGenParserRepeat elemTag match manyElHeadss = {-parsesTreeHs-}+ case manyElHeadss of+ -- [] -> fmap ((flip (:) []) . IText . fst) (manyTill_ (htmlGenParserFlex match) (endTag elemTag))++ [] -> do+ (htMMers, _) <- manyTill_ (htmlGenParserFlex match) (endTag elemTag)+ if length (filter (\case {Element _ -> True; _ -> False}) htMMers) == 0 -- AND loose == False + then+ return htMMers+ else+ parserFail "extra elements"+ -- New idea: parse this structure up until the endTag and invalidate if number of elems exceeds 0 + + -- fmap ((flip (:) []) . IText . (:[])) specificITextParser+ -- fmap ((flip (:) []) . IText . fst) (manyTill_ anyChar (endTag elemTag))+ manyElHeads -> + -- ((endTag elemTag) >> validateGPR manyElHeads)+ liftA2 (:) (fmap Match $ try (fromMaybe parserZero match)) (htmlGenParserRepeat elemTag match manyElHeads)+ <|> liftA2 (:) (fmap IText $ try stylingElem) (htmlGenParserRepeat elemTag match manyElHeads) + <|> try ((treeElemParserSpecificContinuous match manyElHeads)+ >>= (\(sM, a) -> fmap ((Element a):) (htmlGenParserRepeat elemTag match sM)))++ -- if at this point in time with all possibilities considered:+ -- do (if openingTag then fail else Itext)+ <|> liftA2 (:) (fmap (IText . (:[])) specificChar) (htmlGenParserRepeat elemTag match manyElHeads) + -- case parseOpeningTag ++ + -- <|> liftA2 (:) ((IText . (:[])) <$> anyChar) (htmlGenParserRepeat elemTag match manyElHeads) +++-- | NEW IDEA!!++ -- Continue if first tree is present in second tree AND! allow for new branches+ -- NewBranch -> Optional (ParsecT s u m a) in data sig of (Many a)+++specificChar :: Stream s m Char => ParsecT s u m Char+specificChar = do+ notFollowedBy (parseOpeningTag Nothing [] >> char '>') <?> "error on specificChar (tag found)"+ anyChar +++ -- first <- anyChar+ -- if first == '<'+ -- then+ -- do + -- e <- option "false" (some alphaNum)+ -- attrs <- option "false" (some attrsParser)+ -- close <- option "false" (char '>')++ -- if e == "false" && e == attrs && attrs = close+ -- then return (first : []) -- no elemHead return + -- -- attrs <- many attrsParser+ -- -- char '>'+ -- -- if length x == 0+ -- -- then+ -- -- return first+ + -- -- do+ -- -- notFollowedBy $ (,) <$> many alphaNum <*> many attrParser <* char '>'+ -- -- return (first : [])+ -- else return (first : [])+ + -- manyTill anyChar (char ' ') == + -- many alphaNum+ -- many attrsParser + + -- elemTag : many attrsParser+ -- parserFail "+ -- else+ + -- parseOpeningTag >> parserFail ""+ + -- it can be any character except < if its not followedby +++-- (do { txt <- try stylingElem; return $ (IText txt):[] })++-- | treeElemParserSpecific is an interface to this (via innerParserSpecific)+-- | This inner function uses the Many datatype to differentiate between whether we should expect+-- | to parse a single element with the given specs or allow for multiple of the given element specs in a row+-- |+-- | +treeElemParserSpecificContinuous :: (Stream s m Char, ShowHTML a) => Maybe (ParsecT s u m a)+ -> [Many (Tree ElemHead)] -- The total innerHtml structure the current element must have in order to match+ -> ParsecT s u m ([Many (Tree ElemHead)], TreeHTML a)+treeElemParserSpecificContinuous match manyElHeads = do+ let+ -- If we take up until the 1st (One a) then we know that it should succeed in all valid cases or fail+ elSet :: [Many (Tree ElemHead)]+ elSet = takeTill (\case { One a -> True; _ -> False}) manyElHeads+++ + (e,attrs) <- parseOpeningTag (Just $ fmap (fst . rootLabel . fromMany) elSet) []+ + (innerForest, outputStack) <- tryElHeads (e,attrs) elSet + -- at this point in the case where we have parsed an opening tag we have two possibilities+ -- manyElHeads = [] | x:xs+ -- [] -> then why do we have an opening tag? this should have been either an IText or the endTag+ + (m, inTx, inTr) <- innerParserSpecific match e innerForest+ let+ manyElHeads' :: [Many (Tree ElemHead)]+ manyElHeads' = drop ((length manyElHeads) - (length outputStack)) manyElHeads+ return $ (,) manyElHeads' (TreeHTML e attrs m inTx inTr)++--------------------------------------------------------------------------------------------------------------------+--------------------------------------------------------------------------------------------------------------------++-- | This is largely a subfunc of htmlGenParserContains +-- | Accepts any element and if element is in the order of our checklist-of-elems, we give the tail of elems back+-- | if the tail reaches [] before we hit the end tag then we are successful +treeElemParserContains :: (Stream s m Char, ShowHTML a) => Maybe (ParsecT s u m a)+ -> [Many (Tree ElemHead)]+ -> ParsecT s u m ([Many (Tree ElemHead)], TreeHTML a)+treeElemParserContains match manyElHeads = do+ -- (Just $ fmap (fst . rootLabel . fromMany) elSet) [] -- <|> (fmap Left $ parseOpeningTag Nothing [])+ (e,ats) <- parseOpeningTag Nothing []+ -- char '>'+ let+ elSet = takeTill (\case { One a -> True; _ -> False}) manyElHeads+ -- forestNStack = tryElHeads' elAttrs elSet+ case tryElHeads' (e, ats) elSet of+ Right (innerForest, outputStack) -> do+ let+ manyElHeads' :: [Many (Tree ElemHead)]+ manyElHeads' = drop ((length manyElHeads) - (length outputStack)) manyElHeads+ if innerForest == []+ then -- this can be selfclosing+ do+ case elem e selfClosing of+ True -> do+ (try (string ">") <|> string "/>")+ return $ (,) manyElHeads' (TreeHTML e ats mempty mempty mempty)+ False -> do+ (m, inTx, inTr) <- innerParserContains match e innerForest+ return $ (,) manyElHeads' (TreeHTML e ats m inTx inTr)+ else -- this cannot be selfClosing+ do + (m, inTx, inTr) <- innerParserContains match e innerForest+ return $ (,) manyElHeads' (TreeHTML e ats m inTx inTr)++ -- string "/>" >> return (mempty, mempty, mempty) <|> string ">" >> innerParserContains ++ + Left someError -> do+ (inText, matchBook, treees) <- innerTreeElemParser e match+ return $ (,) manyElHeads (TreeHTML e ats matchBook inText treees) + + + -- ParsecT s u m ([a], String, [Tree ElemHead]) ++htmlGenParserContains :: (Stream s m Char, ShowHTML a) =>+ String + -> Maybe (ParsecT s u m a)+ -> [Many (Tree ElemHead)]+ -> ParsecT s u m [HTMLMatcher TreeHTML a]+htmlGenParserContains elemTag match manyElHeadss = {-parsesTreeHs-}+ case manyElHeadss of+ [] -> do+ (htMMers, _) <- manyTill_ (htmlGenParserFlex match) (endTag elemTag)+ return htMMers+ manyElHeads -> + liftA2 (:) (fmap Match $ try (fromMaybe parserZero match)) (htmlGenParserContains elemTag match manyElHeads)+ <|> liftA2 (:) (fmap IText $ try stylingElem) (htmlGenParserContains elemTag match manyElHeads) + <|> try ((treeElemParserContains match manyElHeads)+ >>= (\(sM, a) -> fmap ((Element a):) (htmlGenParserContains elemTag match sM)))+ <|> liftA2 (:) (fmap (IText . (:[])) (try $ specificChar' elemTag)) (htmlGenParserContains elemTag match manyElHeads)+ <|> (endTag elemTag+ >> case length (filter (\case {One a -> True; _ -> False}) manyElHeadss) == 0 of+ True -> return []+ False -> parserFail $ "still havent yielded " <> show manyElHeadss) ++specificChar' :: Stream s m Char => Elem -> ParsecT s u m Char+specificChar' elemTag = do+ notFollowedBy (parseOpeningTag Nothing [] >> char '>') <?> "error on specificChar' (tag found)"+ notFollowedBy (endTag elemTag) + anyChar ++++innerParserContains :: (Stream s m Char, ShowHTML a) =>+ Maybe (ParsecT s u m a)+ -> Elem+ -> SubTree ElemHead+ -> ParsecT s u m ([a], String, [Tree ElemHead]) +innerParserContains match tag subTree =+ case elem tag selfClosing of+ True -> if not $ null subTree then undefined else do+ (try (string ">") <|> string "/>")+ return (mempty, mempty, mempty)+ False -> do + -- char '>'+ x <- htmlGenParserContains tag match (reverse $ groupify subTree [])+ let+ -- | need to ensure all the trees are in order + (inText, matchBook, treees) = foldr foldFuncTrup mempty (x)+ return (matchBook, (reverse inText), (reverse treees))--(_matches itr) (_innerText itr) (innerTree itr)++-- | Very similar to treeElemParserSpecific except that it allows for a new nodes in the HTML DOM tree+-- | to exist at random as long as when we resume parsing we still find all of the branches we found in the+-- | TreeHTML a that is given as an arg to this function+similarTreeH :: (Stream s m Char, ShowHTML a)+ => Maybe (ParsecT s u m a)+ -> TreeHTML a+ -> ParsecT s u m (TreeHTML a)+similarTreeH matchh treeH = do+ (e,at) <- parseOpeningTag (Just $ [elTag treeH]) (((fmap . fmap) Just) . Map.toList $ attrs treeH)+ (inTx, m, inTr) <-+ fmap (foldr foldFuncTrup mempty) (htmlGenParserContains e matchh (groupify (_innerTree' treeH) []))+ return $ TreeHTML e at m inTx inTr+ + -- treeElemParserContains matchh (elTag treeH) (Map.toList $ attrs treeH) (_innerTree' treeH)+ +-- treeElemParserContains :: (Stream s m Char, ShowHTML a) => Maybe (ParsecT s u m a)+ -- -> [Many (Tree ElemHead)]+ -- -> ParsecT s u m ([Many (Tree ElemHead)], TreeHTML a)++-- | Returns an entire group of highly similar elements based on their specifications such+-- | as their innerTrees, the element tag, and attributes.+-- |+-- | This can be used to autonomously determine the structure of and find search result items after you've submitted a form+-- htmlGroupSimilar :: (Stream s m Char, ShowHTML a)+-- => Maybe [Elem]+-- -> Maybe (ParsecT s u m a)+-- -> [(String, Maybe String)]+-- -> ParsecT s u m (GroupHtml TreeHTML a)+-- htmlGroupSimilar elemOpts matchh attrsSubset = +-- -- Not sure about the order yet tho+-- fmap mkGH $ try (treeElemParser elemOpts matchh attrsSubset+-- >>= (\treeH -> fmap (treeH :) (some (try $ similarTreeH matchh treeH))))++-- I could rewrite groups to become more versatile by allowing optionally+-- any number of '\n' after parsing a similar tree +++-- some (try $ similarTreeH matchh treeH) <* optional (many $ char '\n')++++htmlGroupSimilar :: (Stream s m Char, ShowHTML a)+ => Maybe [Elem]+ -> Maybe (ParsecT s u m a)+ -> [(String, Maybe String)]+ -> ParsecT s u m (GroupHtml TreeHTML a)+htmlGroupSimilar elemOpts matchh attrsSubset = + -- Not sure about the order yet tho+ fmap mkGH $ (do+ + treeH <- treeElemParser elemOpts matchh attrsSubset <* nl + treeHs <- some $ try $ similarTreeH matchh treeH <* nl+ pure $ treeH : treeHs + )+++--------------------------------------------------------------------------------------------------------------------+--------------------------------------------------------------------------------------------------------------------+takeTill :: (a -> Bool) -> [a] -> [a]+takeTill _ [] = []+takeTill f (x:xs) = if f x then x:[] else x : takeTill f xs ++-- | yields how many are still worth trying+tryElHeads :: (Elem, Attrs)+ -> [Many (Tree ElemHead)]+ -> ParsecT s u m ([Tree ElemHead], [Many (Tree ElemHead)])+tryElHeads _ [] = parserFail "none of me opening tags worked laddy" +tryElHeads tagAttrs ((Many (Node label forest)):outputStack) =+ if tagAttrs == label+ then return $ (forest, (Many (Node label forest)):outputStack) -- added back to stack + else tryElHeads tagAttrs outputStack -- deleted from temp stack if not found +tryElHeads tagAttrs ((One (Node label forest)):outputStack) =+ if tagAttrs == label+ then return $ (forest, outputStack)+ else parserFail $ "missing element" <> show label ++tryElHeads' :: (Elem, Attrs)+ -> [Many (Tree ElemHead)]+ -> Either String ([Tree ElemHead], [Many (Tree ElemHead)])+tryElHeads' _ [] = Left "none of me opening tags worked laddy" +tryElHeads' tagAttrs ((Many (Node label forest)):outputStack) =+ if tagAttrs == label+ then return $ (forest, (Many (Node label forest)):outputStack) -- added back to stack + else tryElHeads' tagAttrs outputStack -- deleted from temp stack if not found +tryElHeads' tagAttrs ((One (Node label forest)):outputStack) =+ if tagAttrs == label+ then return $ (forest, outputStack)+ else Left $ "missing element" <> show label -- I believe Left "missing element"++++innerParserSpecific :: (Stream s m Char, ShowHTML a) =>+ Maybe (ParsecT s u m a)+ -> Elem+ -> SubTree ElemHead+ -> ParsecT s u m ([a], String, [Tree ElemHead]) +innerParserSpecific match tag subTree =+ case elem tag selfClosing of+ True -> if not $ null subTree then undefined else do+ (try (string ">") <|> string "/>")+ return (mempty, mempty, mempty)+ False -> do + -- char '>'+ x <- htmlGenParserRepeat tag match (reverse $ groupify subTree [])+ let+ -- | need to ensure all the trees are in order + (inText, matchBook, treees) = foldr foldFuncTrup mempty (x)+ return (matchBook, (reverse inText), (reverse treees))--(_matches itr) (_innerText itr) (innerTree itr)++++++-- currentElHead :: Stream s m Char =>+-- ParsecT s u m a+-- -> [Many (Tree ElemHead)]+-- -> ParsecT s u m [HTMLMatcher TreeHTML a]+-- currentElHead = do+-- (m, inTx, inTr) <- innerParserSpecific mElHead1 match elem +-- (:) <$> (TreeHTML e at m inTx inTr) <*> htmlGenParserRepeat match (mElHead1:mElHead2:manyElHeads)++++-- treeElemParserSpecificContinuous match (manyElHeads) = do+-- (eIns, at) <- parseOpeningTagDesc (Just [(fst mElHead1), (fst mEleHead2)]) []+-- if attrs e == snd mElHead1 +-- then currentElHead match manyElHeads +-- else nextElHead match manyElHeads <|> parserFail "did not match on either of the next two previous elements" +-- if attrs e == snd mElHead2 -- should also have this or similar behaviour in case (One a) +-- then+-- do+-- (matches, inText, inTree) <- innerParserSpecific mElHead2 match eIns+-- (:[]) <$> (TreeHTML e at matches inText inTree) <*> htmlGenParserRepeat match (mElHead2:manyElHeads)+-- else parserFail "did not match on either of the next two previous elements" +-- -- case e1,e2,parserFail++ + -- x <- specificRepetitiveForest (reverse $ groupify subTree []) (fromMaybe parserZero matchh)+ -- ---+ -- -- Everything here is to avoid false positives from being too+ -- -- general while developing + -- option "" (string "Hockey")+ -- many space+ -- option "" (string "tour case suing ")+ -- ---+ -- endTag tag+ -- --can be followed by whatever: + -- -- (y, _) <- manyTill_ (htmlGenParserFlex matchh) (endTag tag) + -- let+ -- -- | need to ensure all the trees are in order + -- (inText, matchBook, treees) = foldr foldFuncTrup mempty (x)+ -- return $ TreeHTML tag attrsOut matchBook (reverse inText) (reverse treees)--(_matches itr) (_innerText itr) (innerTree itr)+++-- | IS THIS IN THE RIGHT ORDER OR DOES IT NEED TO BE REVERSED?+-- | Creates a simplified set of instructions for parsing a very specific Tree structure +groupify :: Eq a => [Tree a] -> [Many (Tree a)] -> [Many (Tree a)]+groupify [] acc = acc+groupify (tree:forest) [] = groupify forest (One tree:[])+groupify ((Node elemHead subForest):forest) (mTree:acc) =+ case mTree of+ One (Node elemHeadPrev subForestPrev) ->+ if elemHead == elemHeadPrev+ -- here is maybe where I could add in checking if forests are equal ? + then groupify forest $ ((Many (Node elemHeadPrev subForestPrev)):acc)+ else groupify forest $ ((One (Node elemHead subForest)) : (One (Node elemHeadPrev subForestPrev)) : acc)+ -- we want to ensure then that this One constructor isn't touched again, we need to create+ -- another One constructor with the incoming `tree` that was peeled off+ Many (Node elemHeadPrev subForestPrev) ->+ if elemHead == elemHeadPrev+ then groupify forest ((Many (Node elemHeadPrev subForestPrev)):acc)+ else groupify forest ((One (Node elemHead subForest))+ : (Many (Node elemHeadPrev subForestPrev))+ : acc)++++-------------------------------------------------------------------------------------------------------------------+++-- | Returns a minimum of 2 --> almost like `same` should be function ; same :: a -> [a] to be applied to some doc/String+-- | note: not sure if this exists but here's where we could handle iterating names of attributes +-- | Can generalize to ElementRep e+htmlGroup :: (Stream s m Char, ShowHTML a)+ => Maybe [Elem]+ -> Maybe (ParsecT s u m a)+ -> [(String, Maybe String)]+ -> ParsecT s u m (GroupHtml TreeHTML a)+htmlGroup elemOpts matchh attrsSubset = + -- Not sure about the order yet tho+ fmap mkGH $ try (treeElemParser elemOpts matchh attrsSubset+ >>= (\treeH -> fmap (treeH :) (some (try $ sameTreeH matchh treeH))))++-- | Html table group +table :: Stream s m Char => ParsecT s u m (GroupHtml TreeHTML String) +table = htmlGroup (Just ["tr"]) Nothing []++++++-- test for++-- Previous Element of (if Many) :: Many a+-- Next element of Many a+-- Match?+-- IText String+ + -- until endTag +++-- | Build [Many (Tree ElemHead)]+-- | Write parser that tries each case OR parses openingTag and then decides what case it fits+ -- | For set (Previous, Next) if Next is True then delete Previous parser+ -- | Next becomes "Previous" in future equation(s)+ +-- | Fail onto plain IText (of parent element that the parser is currently in)+++++--------------------------------------------------------------------------------------------------------------------+---Generalizations----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------+++-- | Inner parser of treeElemParserSpecific +-- specificRepetitiveForest :: (Stream s m Char, ShowHTML a)+-- => [Many (Tree ElemHead)]+-- -> ParsecT s u m a+-- -> ParsecT s u m [HTMLMatcher TreeHTML a]+-- specificRepetitiveForest [] _ = return []+-- specificRepetitiveForest (mElHead1:mElHead2:manyElHeads) match = do+-- -- | ysA could be == []+-- htmlGenParserRepeat match (manyElHeads) -- NEW +-- ysA {-maybeNext-} <- multiTreeElemHeadParser match mElHead2+-- ysB <- case ysA of+-- Just a -> specificRepetitiveForest (mElHead2:manyElHeads) match +-- Nothing ->+-- -- WHat happens to the rest of Many ElHeads in this case? +-- htmlGenParserRepeat match (multiTreeElemHeadParser match mElHead1)+-- htmlGenParserRepeat match (manyElHeads) -- NEW +-- return (ysA <> ysB)+ -- let+ -- -- funcP :: (ShowHTML a, Stream s m Char) => ParsecT s u m [TreeHTML a]+ -- funcP = multiTreeElemHeadParser match mElHead1 + -- y <- htmlGenParserRepeat match funcP -- this literally just allows for matching on multiple elems too+ -- -- Only applies to "specific" functions, prev: any case + -- ys <- case y of+ -- -- Discard last parsed pattern and go to next element formula on success of `y` + -- ((Element _):xs') -> specificRepetitiveForest manyElHeads match+ -- _ -> specificRepetitiveForest (manyElHead:manyElHeads) match+ -- -- return all results +++++++-- | This is all I actually need , no need for recursion here, since thats already done in top level func+{-# DEPRECATED multiTreeElemHeadParser "use specificContinuous style functions" #-} +multiTreeElemHeadParser :: (Stream s m Char, ShowHTML a) =>+ ParsecT s u m a+ -> Many (Tree ElemHead)+ -> ParsecT s u m [HTMLMatcher TreeHTML a]+multiTreeElemHeadParser match mTree = case mTree of+ Many (Node (elem, attrs) subTree) ->+ (fmap . fmap) Element (many (try $ treeElemParserSpecific (Just match) elem (Map.toList attrs) subTree ))+ One (Node (elem, attrs) subTree) ->+ treeElemParserSpecific (Just match) elem (Map.toList attrs) subTree >>= return . flip (:) [] . Element+ -- like return . (\x -> x :[])++++-- | Is able to repeat / execute any pattern that returns multiple elements of same type+-- |(see manyTreeElemHeadParser)+-- htmlGenParserRepeat :: (Stream s m Char, ShowHTML a) =>+ -- ParsecT s u m a+ -- -> [Many (Tree ElemHead)]+ -- -> ParsecT s u m [TreeHTML a] -- Can just apply multiTreeElemHeadParser (if i should) inside+ -- -> ParsecT s u m [HTMLMatcher TreeHTML a]+++-- | HTMLGenParserRepeat is in this use case always going to be exact ie these 3 elems then the end tag+-- | ... and maybe some text in between there++-- | OF the cases we can do this:+ -- | parse and repeat function/recurse+ -- | or find end tag >> return [] which ends list + ++++ -- -- (eIns, at) <- parseOpeningTagDesc (Just [(fst mElHead1), (fst mEleHead2)]) []+ -- let+ -- atSet :: Elem -> [Tree ElemHead] -> [Tree ElemHead]+ -- atSet = filter (\(Node (e, a)) -> if eIns == e then True else False) elSet + ++ + -- f' eIns at elHeads+ ++ -- -- | Note that this is not a manyTill but should behave like any parser, f (however f is defined)+ -- -- | then once thats complete, parse endTag (with maybe some text) ++ -- f :: Stream s m Char =>+ -- Maybe (ParsecT s u m a)+ -- -> Elem+ -- -> Attrs+ -- -> [Many (Tree ElemHead)]+ -- -> ParsecT s u m ([Many (Tree ElemHead)], TreeHTML a)+ --+ -- At this point, we 100% know that the head of the list is the correct one + -- f match endT at elHeads = do+ -- (m, inTx, inTr) <- innerParserSpecific match endT (fromMany . fst $ elHeads)++ -- case fst elHeads of+ -- Many a -> "" --doesnt have to be there at all + -- One a -> "" -- has to be there + + -- then get attrs +++ -- OR filter for successful el tag eg "a" was apart of allowed set, it was "a" and now you+ -- filter the allowed set for "a" to reference attrs to try++ --eg: ref "a" ("a", fromList [("x", "y")])+ ++ -- This function should also handle (Many a) control flow+ -- case manyA+ -- One a -> delete elHead from state if openTag matches+ -- Many a -> delete if++ -- if (Many a) on second one then reset (call treeElePSC again with delete elHeads) + -- f' match eIns at manyElHeads+ -- at == (snd mElHead1) && eIns == (fst mElHead1) = f eIns at manyElHeads + -- at == (snd mElHead2) && eIns == (fst mElHead2) = f eIns at (tail manyElHeads) + -- otherwise = parserFail "does not match on elements"+ ++fromMany :: Many a -> a+fromMany (One a) = a+fromMany (Many a) = a ++++---OLD+ -- <|> (do+ -- -- this gets into treeElemParserSpecific territory+ -- (eIns, at) <- parseOpeningTagDesc (Just [(fst mElHead1), (fst mEleHead2)]) []+ -- if attrs e == snd mElHead1 -- (elTag e == (fst mElHead1) && (attrs a) == (snd mElHead1)+ -- then f manyElHeads + -- do+ -- (m, inTx, inTr) <- innerParserSpecific mElHead1 match eIns + -- (:) <$> (TreeHTML e at m inTx inTr) <*> htmlGenParserRepeat match (mElHead1:mElHead2:manyElHeads)+ -- else+ -- -- should also have this or similar behaviour in case (One a) + -- if attrs e == snd mElHead2+ -- then+ -- do+ -- (matches, inText, inTree) <- innerParserSpecific mElHead2 match elem + -- (:[]) <$> (TreeHTML e at matches inText inTree) <*> htmlGenParserRepeat match (mElHead2:manyElHeads)+ -- else parserFail "did not match on either of the next two previous elements" + -- -- case e1,e2,parserFail+ -- )++ +-- | Note that multiTreeElemHeadParser is still not handled, all I need to do is auto delete if only one+-- | actual function of multiTreeElemHeadParser will not be used but broken up+++ -- <|> ((fmap . fmap) (Element) parsesTreeHs) -- list of elements, could be single element or multiple + -- <|> (do { x <- anyChar; return (IText (x:[]):[]) }) -- just allows for singleton creation (x:[])++++ + -- then f manyElHeads+ -- else+ -- if at == (snd mElHead2) && eIns == (fst mElHead2)+ -- then f (tail manyElHeads)+ -- else parserFail "does not match on elements"++ +-- -- should also have this or similar behaviour in case (One a) +-- i+-- then+-- do+-- (matches, inText, inTree) <- innerParserSpecific mElHead2 match elem +-- (:[]) <$> (TreeHTML e at matches inText inTree) <*> htmlGenParserRepeat match (mElHead2:manyElHeads)+-- else parserFail "did not match on either of the next two previous elements" +-- -- case e1,e2,parserFail+-- )+++-- might still be:++-- htmlGenParserRepeat+-- endTag tag++-- as opposed to:++-- manyTill_ htmlGenParserRepeat (endTag tag)++-- but it could still need to be the second in order to work ++---------- where htmlGenParserRepeat =+-- <|> +-- --- if this succeeds (we try this first) then we reset I believe with this parser as Prev ++-- (do { x <- try match; return $ (Match x):[] })+-- <|> (do { txt <- try stylingElem; return $ (IText txt):[] }) ++ +-- -- <|> ((fmap . fmap) (if innerText' == searchTerm then Element else (IText . innerText')) parsesTreeHs) -- list of elements, could be single element or multiple+-- <|> multiTreeElemHeadParser match mElHead1+ + + +-- <|> ((fmap . fmap) (Element) parsesTreeHs) -- list of elements, could be single element or multiple +-- <|> (do { x <- anyChar; return (IText (x:[]):[]) }) -- just allows for singleton creation (x:[])+-- -----------++++-- Doesnt change the structure of the page at all just how text is styled like MS word stuff+stylingTags = ["abbr", "b", "big", "acronym", "dfn", "em", "font", "i", "mark", "q", "small"] -- , "strong"]++-- | Just gives the inners +stylingElem :: Stream s m Char => ParsecT s u m String +stylingElem = do+ (e,_) <- parseOpeningTag (Just stylingTags) []+ char '>'+ fmap (reverse . fst) $ manyTill_ anyChar (endTag e) + -- matches : Reversed >-> RW+ +++++-- | Interface to find same element +sameTreeH :: (Stream s m Char, ShowHTML a)+ => Maybe (ParsecT s u m a)+ -> TreeHTML a+ -> ParsecT s u m (TreeHTML a)+sameTreeH matchh treeH = treeElemParserSpecific matchh (elTag treeH) (Map.toList $ attrs treeH) (_innerTree' treeH)++-- I could do 2 things at the same time as calling findSameTreeH : use in findNaive, use in `some` ++ ++-- this implementation would cause issues for when we want to check equality of trees+-- we would need to set the inside tree element parser + we would also need to think about how to handle matches -->> maybe check after for matches > 0?+htmlGenParserFlex :: (Stream s m Char, ShowHTML a) =>+ Maybe (ParsecT s u m a)+ -> ParsecT s u m (HTMLMatcher TreeHTML a)+htmlGenParserFlex a = (try (Match <$> (fromMaybe parserZero a)))+ <|> try (Element <$> treeElemParser Nothing a []) --(treeElemParserAnyInside a))+ <|> ((IText . (:[])) <$> anyChar)+ ++++++++--- Not in use: ----------------------------------------------------------------------------------------------------+++++++++htmlGenParser :: (Stream s m Char, ShowHTML a)+ => ParsecT s u m a+ -> ParsecT s u m (TreeHTML a)+ -> ParsecT s u m (HTMLMatcher TreeHTML a)+htmlGenParser a parseTreeH = (Match <$> try a)+ <|> (Element <$> try parseTreeH)+ <|> (fmap (IText . (:[])) anyChar)+++++{-# DEPRECATED specificForest "you likely need specificRepetitiveForest" #-}+-- | Library function for when you want an exact match, if 3 of ElemHead A then it looks for 3 Elemhead A+ -- accumMaybe' :: [HTMLMatcher] -> ParsecT s u m a+specificForest :: (Stream s m Char, ShowHTML a) =>+ [Tree ElemHead]+ -> ParsecT s u m a+ -> ParsecT s u m [HTMLMatcher TreeHTML a]+specificForest [] _ = return [] --or could be allowing for tail text+specificForest (x:xs) match = do+ y <- htmlGenParser match (nodeToTreeElemExpr x match)+ ys <- case y of+ Element _ -> specificForest xs match+ _ -> specificForest (x:xs) match+ return (y : ys) +++ +nodeToTreeElemExpr :: (Stream s m Char, ShowHTML a) =>+ Tree ElemHead+ -> ParsecT s u m a+ -> ParsecT s u m (TreeHTML a)+nodeToTreeElemExpr (Node (elem, attrs) subTree) match =+ treeElemParserSpecific (Just match) elem (Map.toList attrs) subTree++++-----------------------------------------------------------------------------------------------------------------------------Main---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------+++-- | Used by treeElemParser' +innerElemParser2 :: (ShowHTML a, Stream s m Char) =>+ String+ -> Maybe (ParsecT s u m a)+ -> ParsecT s u m [HTMLMatcher TreeHTML a]+innerElemParser2 eTag innerSpec = char '>'+ -- >> manyTill (try (Element <$> treeElemParser Nothing innerSpec [])) (try (endTag eTag))+ >> manyTill (try (Match <$> (fromMaybe parserZero innerSpec))+ <|> (try (IText <$> stylingElem))+ <|> try (Element <$> treeElemParser' Nothing innerSpec [])+ <|> ((IText . (:[])) <$> anyChar)) (try $ endTag eTag)++--- NEXT 3 ARE NOT IN USE, useful for API?++treeElemParserAnyInside :: (Stream s m Char, ShowHTML a) => Maybe (ParsecT s u m a) -> ParsecT s u m (TreeHTML a)+treeElemParserAnyInside match = treeElemParser Nothing match []++--------------------------------------------------------------------------------------------------------------------+-------------------------------------------Groupings--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------++ -- (_, treeH) <- manyTill_ (anyChar) (try $ treeElemParser elemOpts matchh attrsSubset)+ -- treeHs <- some (try $ findSameTreeH matchh treeH)+ -- return $ mkGH (treeH : treeHs) +++anyHtmlGroup :: (ShowHTML a, Stream s m Char) => ParsecT s u m (GroupHtml TreeHTML a)+anyHtmlGroup = htmlGroup Nothing Nothing [] +++-- Maybe this func should go in Find.hs+-- 0 -> Nothing+findAllSpaceMutExGroups :: (ShowHTML a, Stream s m Char) => ParsecT s u m (Maybe [GroupHtml TreeHTML a])+findAllSpaceMutExGroups = findNaive anyHtmlGroup +++++findAllMutExGroups' = undefined -- prime in name until renaming errors complete+-- deals with cases where attr:selected="true" exists since there will be two subgroups that+-- require concatenations++-- find == runParserOnHtml :: ParsecT s u m (Maybe [a]) ; a ~ GroupHtml b++-- Note: If we can find all groups, then we can find all non-groups ~ tree/display functionality +++-- findSomeHtmlNaive (try findAnyHtmlGroup) htmlText +++------------------------------------------------------------------------------------------------------------------------------------------------------Numerically Flexible Pattern Matching On Specific Elements----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------++ +-- | What if above was of type :: [Many (Tree a)] -> ParsecT s u m [HTMLMatcher a]++-- [Node a _, Node b _, Node c _, Node d _, Node e _] -> [Many tree1, Many tree2, One tree3]++ -- (((IText . (:[])) <$> anyChar) >>= return . flip (:) [])+ -- (Match <$> try a) >>= return . flip (:) [])++--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------++++++++++++++++++++-- <|> (parseOpeningTag+-- >>= (\(e,a) -> do+-- a <- parseInnerBodySpecific *> endTag e+-- if e == (fst mElHead1) && a == (snd mElHead1)+-- then +-- case e of+-- (fst mElHead1) -> +-- htmlGenParserRepeat match + +-- a <> b+-- where b = +-- case e of+-- mElHead1 -> do+-- do innerBody of TreeElem(Specific) + +-- htmlGenParserRepeat match (mElHead1:mEleHead2:manyElHeads)+-- a <> b++-- mElHead2 -> htmlGenParserRepeat match (mElHead_1_OR_Both:manyElHeads) +-- )+-- <|> element2 +++-- elemSkeleton :: Stream s m Char => ParsecT s u m (Tree ElemHead)+-- elemSkeleton tags attrsIn pat = do+-- (e, a) <- parseOpeningTag --+-- branches <- case elem e selfClosing of+-- True -> return $ Node (e, a) []+-- False -> fmap (Node (e, a)) (manyHtml (elemSkeleton (ANY _ _))) *> endTag e+-- return Node
+ src/Scrappy/Elem/Types.hs view
@@ -0,0 +1,762 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RecordWildCards #-}+-- <-- Only for RecursiveTree a b c ; remove if changed +{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}++module Scrappy.Elem.Types where++import Scrappy.Links++import Data.Aeson+import Text.URI (URI)+import Data.Text (Text, unpack)+import Data.Map (Map, toList)+import qualified Data.Map as Map++import Data.Graph (Tree (Node), Forest)+--import Text.Megaparsec as MParsec (some)+import Control.Applicative (some)+import Text.Parsec (ParsecT, Stream, parserZero, string, (<|>), anyChar, char, optional, try, manyTill, alphaNum+ , parserFail)+import Data.Maybe (fromMaybe)+-- Goals: eliminate need for sub tree and inner datatypes ; so Element --> foldr [HTMLMatcher] empty :: Element +++----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------++-- MAYBE:+class HtmlMatcher a where+ --defines relation between Element -> ITR ++-- practically just show but we dont wanna restrict the entirety+-- of the show class for any sub-datatype in the context of html+-- laws:+ -- in the expression:+ -- x <- parser input+ -- showH x == input+-- This is useful for extracting values while retaining structure for successive parsing +class ShowHTML a where+ showH :: a -> String++instance ShowHTML Char where+ showH = show++instance Show a => ShowHTML [a] where+ showH x = show x++instance ShowHTML Text where+ showH = unpack ++-- a b c are the three main types+-- class RecursiveTree a b c where+-- type (Element c)+-- type (InnerForest c)-- type (HMatcher c) -- may not need this tho+ +-- toHtmlGen :: Element c -> HMatcher c+-- elToITR :: Element c -> InnerForest c+-- htmlGenToITR :: HMatcher c -> InnerForest c +-- concatForest :: InnerForest c -> InnerForest c -> InnerForest c+-- -- must be instance of monoid -- dont need to declare each time +-- label :: ElemHead -> InnerForest c -> Element c++-- need system too for +-- Just shared accessors of html datatypes +class ElementRep (a :: * -> *) where+--type InnerHTMLRep a = something + elTag :: a b -> Elem+ attrs :: a b -> Attrs+ innerText' :: a b -> String + matches' :: a b -> [b]+--++-- Elem should determine InnerText+-- Summarizes finds as a result of parsing then folding +-- Recursive fold of multi-constructor structure +class (ShowHTML c, ElementRep a) => InnerHTMLRep (a :: * -> *) (b :: * -> *) c | a c -> b c where+ -- type HMatcher a b c :: * -> *+ foldHtmlMatcher :: [HTMLMatcher a c] -> b c+ -- emptyInner :: a d+ innerText :: b c -> String + matches :: b c -> [c]++++noPat :: Maybe (ParsecT s u m String)+noPat = Nothing++-- | Parser is configured via the return type but gives the input type +coerceAttrs :: Attrs -> [(String, Maybe String)]+coerceAttrs as = (fmap.fmap) f $ toList as ++f :: String -> Maybe String+f "" = Nothing+f s = Just s ++-- f :: ([a], [b], [c]) -> Elem' a+-- f (x,y,z) = f' x y z++-- f' el attrs = Elem' el attrs++-------------------------------------------------------------------------------------------------------------------++instance Semigroup (InnerTextHTMLTree a) where+ InnerTextHTMLTree a b c <> InnerTextHTMLTree d e f = InnerTextHTMLTree (a <> d) (b <> e) (c <> f)++instance Monoid (InnerTextHTMLTree a) where+ mempty = InnerTextHTMLTree { _matches = [], _innerText = "", innerTree = [] }++instance Semigroup (InnerTextResult a) where+ InnerTextResult a b <> InnerTextResult a' b' = InnerTextResult (a <> a') (b <> b')++instance Monoid (InnerTextResult a) where+ mempty = InnerTextResult { _matchesITR = [], _fullInner = "" }++-- instance Num GroupHtml e a where+-- GroupHtml+++--Note that the fullInner would be useful for stepping in cases as well needing some pieces of the+-- whole, in the case, that theres a match (like a form: want a form if it has search in it, then+-- we'd want to use certain html elements within the form such as <input> or <select>+--so result would be : InnerTextResult { match = "Search", fullInner = """<input> ... <select> """ } ++----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------+++-- foldFuncToITR' :: [Elem' a] -> InnerTextResult a -> InnerTextResult a+-- foldFuncToITR' InnerTextResult{..} (Elem'{..}:xs) =+-- func (InnerTextResult (matchesITR <> matchesEl) (fullInner <> innerHtmlFull)) xs ++-- case x of+ -- Elem' x -> [Element (Elem' x)]++++-- foldElements' :: [Elem' a] -> InnerTextResult a+-- foldElements' elems = foldr func (mempty :: InnerTextResult a) (fmap Element elems) +++++-- | Tree+-- func :: Show a => [HTMLMatcher a] -> InnerTextHTMLTree a -> InnerTextHTMLTree a+-- func [] state = state+-- func (htmlM:htmlMatchers) (InnerTextHTMLTree{..}) = case htmlM of+-- IText str -> +-- func htmlMatchers (InnerTextHTMLTree matches (innerText <> str) innerTree)+-- -- | May need to enforce a Show Instance on 'mat'+-- Match mat -> +-- func htmlMatchers (InnerTextHTMLTree (mat : matches) (innerText <> (show mat)) innerTree)+-- --concat to fullInnerText+-- Element htmlTree -> --interEl :: ElemHead [HtmlMatcher]+-- func htmlMatchers (InnerTextHTMLTree (matches <> matches' htmlTree) (innerText <> treeElemToStr htmlTree) ((makeBranch htmlTree) : innerTree))+++-- | SimpleElem+-- func :: (ShowHTML a, ElementRep e) => [HTMLMatcher e a] -> InnerTextResult a+-- func state [] = state+-- func InnerTextResult{..} (next:inners) = case next of+-- IText str -> +-- func (InnerTextResult matches (innerText <> str)) inners +-- -- | May need to enforce a Show Instance on 'mat'+-- Match mat -> +-- func (InnerTextResult (mat : matches) (innerText <> (showH mat))) inners +-- --concat to fullInnerText+-- Element elem -> --interEl :: ElemHead [HtmlMatcher]+-- func (InnerTextResult (matches' elem <> matches) (innerText <> (innerText' elem))) inners++++-- instance InnerHTMLRep Elem' InnerTextHTMLTree c --> deletion of tree; we no longer care for this info+ +instance ShowHTML c => InnerHTMLRep TreeHTML InnerTextHTMLTree c where+ -- type HMatcher TreeHTML InnerTextHTMLTree c = HMatcher' c + -- emptyInner = InnerTextHTMLTree { matches = []+ -- , innerText = ""+ -- , innerTree = [] }+ foldHtmlMatcher = foldr fHM_c mempty -- original one+ matches = _matches+ innerText = _innerText + +instance ShowHTML c => InnerHTMLRep Elem' InnerTextResult c where+ foldHtmlMatcher = foldr foldFuncITR mempty -- partially applied, expecting some a + matches = _matchesITR+ innerText = _fullInner ++-- instance InnerHTMLRep InnerTextResult where+-- type HtmlMatcherM a = HTMLMatcher Elem' a+-- foldHtmlMatcher = foldInners++++instance ElementRep (Elem') where+ elTag = _el+ attrs = _attrs+ innerText' = innerHtmlFull+ matches' = innerMatches++instance ElementRep (TreeHTML) where+ elTag = _topEl+ attrs = _topAttrs+ innerText' = _innerText'+ matches' = _matches'++++++instance ShowHTML a => ShowHTML (Elem' a) where+ showH = elemToStr ++++instance ShowHTML a => ShowHTML (TreeHTML a) where+ showH = treeElemToStr++----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------+ ++++ +-------------------------------------------------------------------------------------------------------------------+++-- | Note, this is the representation i'll be using+data TreeHTML a = TreeHTML { _topEl :: Elem+ , _topAttrs :: Map String String+ --+ , _matches' :: [a]+ , _innerText' :: String+ , _innerTree' :: Forest ElemHead + } deriving Show +++---Future: Make both below into semigroups+data InnerTextHTMLTree a = InnerTextHTMLTree { _matches :: [a]+ , _innerText :: String+ , innerTree :: Forest ElemHead+ } +-------------------------------------------------------------------------------------------------------------------+-- | node-like+data Elem' a = Elem' { _el :: Elem -- change to Elem?+ , _attrs :: Map String String --Attrs needs to become map+ , innerMatches :: [a] --will be "" if not specified+ , innerHtmlFull :: String+ } deriving Show++-- instance ToJSON (Elem' a) where+-- toJSON = writeTheHtmlEquivalent +++data InnerTextResult a = InnerTextResult { _matchesITR :: [a]+ , _fullInner :: String -- set to Nothing if TextOnly+ } deriving Show+-------------------------------------------------------------------------------------------------------------------++type HMatcher' a b c = [HTMLMatcher b c] -> a c++++++data HTMLMatcher (a :: * -> *) b = IText String | Element (a b) | Match b deriving Show++++++++type HTMLMatcherM a = HTMLMatcher TreeHTML a+-- data HTMLMatcher a = IText String | Match a | Element (TreeHTML a)+type Inner a = HTMLMatcher Elem' a+++type HTMLMatcherList a = HTMLMatcher [] a+-- IText String | Match a | Element [] a ++++-- mainly for testing+-- allows for minimal steps and ensuring that low level parsing is working+data HTMLBare e a = HTMLBare { tag :: Elem+ , attrsss :: Attrs+ , htmlM :: [HTMLMatcher e a]+ }++++type ElemHead = (Elem, Attrs) +type Attrs = Map String String+type Elem = String+++data AttrsError = IncorrectAttrs deriving Show+++instance Eq (GroupHtml e a) where+ GroupHtml _ gl1 ml1 == GroupHtml _ gl2 ml2 = (gl1 * ml1) == (gl2 * ml2)++-- allows for max+instance Ord (GroupHtml e a) where+ -- compare multiples of Glength * MaxLength+ (GroupHtml _ gl1 ml1) <= (GroupHtml _ gl2 ml2) = (gl1 * ml1) <= (gl2 * ml2)++--Note, maybe there's a way to extend this to being capable of gathering all text-distinct pieces of+--the page++-- | At end will be able to do Eq2 of trees where tree params are (tag,attrs)+-- | Need some "Flexible Equality" match++++++++-- | Would treeElemParser fail on cases like <input> with no end tag? ++++-------------------------------------------------------------------------------------------------------------------+-------------------------------------Experimental---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------++data MessyTree a b = Noise b | Nodee a [MessyTree a b]+-- where the data at each node, describes the branch .. eg ElemHead+data MessyTreeMatch a b c = Noise' a | Match' b | Node' c [MessyTreeMatch a b c] +++type TreeIndex = [Int]+-- What if we made trees a lense? accessible through treeindex ++-------------------------------------------------------------------------------------------------------------------+-------------------------------------Experimental---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------+++-- data GroupHtml a = GroupHtml [a] Glength MaxLength deriving Eq -- ... | Nil+data GroupHtml element a = GroupHtml [element a] Glength MaxLength++instance (ElementRep e, Show (e a), Show a, ShowHTML a) => Show (GroupHtml (e :: * -> *) a) where+ show (GroupHtml (e:_) count maxELen) =+ "GroupHtml { count =" <> (show count) <> ", longestElem= " <> show maxELen <> ", elemStructure=" <> (show e)++type Glength = Int -- number of items in group+type MaxLength = Int -- could also just be length of head ++++-- a ~ TreeHTML match+ungroup :: ElementRep e => GroupHtml e a -> [e a]+ungroup (GroupHtml xs _ _) = xs ++++mkGH :: ElementRep e => [e a] -> GroupHtml e a+mkGH result = GroupHtml result (length result) ((length (innerText' (head result))))+++-- so then id go from++ -- Just GroupHtml { count =20, longestElem= 6047, elemStructure=TreeHTML .. ++-- to:++ -- (e,a) ; in this case -> ("li", [("class", "resultItem ltr")])++ ---- > put to state+ ---- > In order to be safe: findNaive (elemParser "li"..) + ---- > with innerText's ; do findNaive linkScraper+ ---- > + ++longestElem :: [Elem' a] -> Maybe (Elem' a)+longestElem [] = Nothing+longestElem (a:[]) = Just a+longestElem (x:xs) = if length (innerText' x) > length (innerText' $ head xs)+ then longestElem (x: (tail xs))+ else longestElem xs++++maxLength :: [[a]] -> [a]+maxLength (a:[]) = a+maxLength (x:xs) = if length x > length (head xs) then maxLength (x: (tail xs)) else maxLength xs++++biggestHtmlGroup :: [GroupHtml e a] -> GroupHtml e a +biggestHtmlGroup ghs = foldr maxE (GroupHtml [] 0 0) ghs+ where+ maxE :: GroupHtml e a -> GroupHtml e a -> GroupHtml e a -- like max elem+ maxE (GroupHtml xs cnt lng) (GroupHtml ys cnt' lng') =+ if (cnt * lng) > (cnt' * lng')+ then (GroupHtml xs cnt lng)+ else (GroupHtml ys cnt' lng')+ ++-- Note: findAllMutExGroups +biggestGroup :: ElementRep e => [GroupHtml e a] -> GroupHtml e a+biggestGroup (gh:[]) = gh +biggestGroup (n0@(GroupHtml a x1 y1) :n1@(GroupHtml b x2 y2):ghs) = case (x1 * y1) > (x2 * y2) of+ True -> biggestGroup (n0:ghs)+ False -> biggestGroup (n1:ghs)+ +++++getHrefEl :: ElementRep e => Bool -> LastUrl -> e a -> Maybe Link+getHrefEl b cUrl e = getHrefAttrs b cUrl $ attrs e ++getHrefAttrs :: Bool -> LastUrl -> Map String String -> Maybe Link +getHrefAttrs b cUrl atribs = parseLink b cUrl =<< Map.lookup "href" atribs ++ ++-- getHref :: ElementRep e => e a -> Maybe String+-- getHref e = ((Map.lookup "href") . attrs) e++++-- f+elemToStr :: Elem' a -> String+elemToStr elem = "<" <> elTag elem <> buildAttrs (toList (attrs elem)) <> ">" <> innerHtmlFull elem <> "</" <> elTag elem <> ">"+ where+ buildAttrs [] = ""+ buildAttrs (attr:attrss) = " " <> fst attr <> "=" <> "\"" <> snd attr <> "\"" <> buildAttrs attrss+++treeElemToStr :: (ShowHTML a) => TreeHTML a -> String+treeElemToStr (TreeHTML{..}) =+ "<" <> _topEl <> mdToStringPairs _topAttrs <> ">" <> _innerText' <> "</" <> _topEl <> ">"+ where mdToStringPairs attrsSet = go (toList attrsSet)+ go [] = ""+ go (atr:[]) = (fst atr) <> "=" <> ('"' : snd atr) <> ('"' : []) + go (atr: attrsSet) = (fst atr) <> "=" <> ('"' : snd atr) <> ('"' : []) <> go attrsSet+++-- Future concern:+ -- elem with tree as [Elem a] --> due to lazy evaluation, we dont actually need to summarize these, can just+ -- leave as is, then the user can execute a command+ --- especially easily with accompanying+ -- type TreeIndex = [Int] ; eg [1,4,7] 1st el then 4th el then 7th el++-- Future concern: just discards non matching tokensx+foldFuncMatchlist :: (ShowHTML a, ElementRep e) => HTMLMatcher e a -> InnerTextResult a -> InnerTextResult a+foldFuncMatchlist hMatcher itr = undefined --case hMatcher of+-- IText str -> +-- InnerTextResult (_matchesITR itr) (_fullInner itr <> str)+-- -- | May need to enforce a Show Instance on 'mat'+-- Match mat -> +-- InnerTextResult (mat : _matchesITR itr) (_fullInner itr <> (showH mat))+-- --concat to fullInnerText+-- Element elem -> --interEl :: ElemHead [HtmlMatcher]+-- InnerTextResult (matches' elem <> _matchesITR itr) (_fullInner itr <> (innerText' elem))++--------------------------------------------------------------------------------------------------------------------Testing-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------+++-- | Bug found: matches start right way then get reversed ++foldFuncTup :: (ShowHTML (e a), ShowHTML a, ElementRep e) => HTMLMatcher e a -> (String, [a]) -> (String, [a]) +foldFuncTup hMatcher itr = case hMatcher of+ IText str -> + (fst itr <> str, snd itr)+ -- May need to enforce a Show Instance on 'mat'+ Match mat -> + (fst itr <> (reverse $ showH mat), snd itr <> [mat])+ --concat to fullInnerText+ Element elem -> --interEl :: ElemHead [HtmlMatcher]+ (fst itr <> (reverse $ showH elem), snd itr <> matches' elem)++foldFuncTrup :: (ShowHTML a) => HTMLMatcher TreeHTML a -> (String, [a], Forest ElemHead) -> (String, [a], Forest ElemHead) +foldFuncTrup hMatcher itr = case hMatcher of+ IText str -> + (fst' itr <> str, snd' itr, thd' itr)+ -- May need to enforce a Show Instance on 'mat'+ Match mat -> + (fst' itr <> (showH mat), snd' itr <> [mat], thd' itr)+ --concat to fullInnerText+ Element elem -> --interEl :: ElemHead [HtmlMatcher]+ (fst' itr <> (reverse $ showH elem), snd' itr <> matches' elem, thd' itr <> ((makeBranch elem):[]))++-- | In our failed test case with the command : parse f "" "<a></div></a>"+ -- where f :: (Stream s m Char) => ParsecT s u m (TreeHTML String); f = treeElemParser (Just ["a"]) Nothing []+ --+ -- we can tell that foldFuncTrup has been called twice (we believe)+ --+ -- we will test how an element named "div" inside of "a" element would behave++-- | TODO(galen): As we advance scrappy we need to be more realistic in what a clickable is+-- | since here we really have a LinkEl rather than a button (which is clickable but doesn't fit here)+-- | and can emit a side effect such as that of a LinkEl or some other event like we can handle with lazy-js+data Clickable = Clickable ElemHead Link deriving (Eq, Show)+++-- | In the future this definitely could be expanded upon for our JS interface+-- | right now this only works for links but wouldn't literally click a button +--mkClickable :: ElemHead -> Elem' a -> Maybe Clickable+--mkClickable eHead emnt = do+ -- href <- getHref emnt+ -- pure $ Clickable eHead href++++ +-- scrapeClickable :: Stream s m Char => LastUrl -> ParsecT s u m Clickable+-- scrapeClickable lastUrl = do+-- e <- elemParser Nothing (Just $ string "download") [("href", Nothing)]+-- href <- mapMaybe getHref $ pure e +-- let+-- mkURI' :: Text -> Maybe URI+-- mkURI' = mkURI+-- uri <- mapMaybe mkURI' . pure . pack $ fixUrl lastUrl href +-- return $ Clickable (elTag e, attrs e) (unpack . render $ uri)+++mkClickableEH :: Bool -> LastUrl -> ElemHead -> Maybe Clickable+mkClickableEH booly cUrl (e, ats) = do+ h <- getHrefAttrs booly cUrl ats+ pure $ Clickable (e, ats) h+++mkClickable :: ElementRep e => Bool -> LastUrl -> e a -> Maybe Clickable+mkClickable booly cUrl e = do+ let ats = attrs e+ h <- getHrefAttrs booly cUrl ats+ pure $ Clickable (elTag e,ats) h+++getLink :: Clickable -> Link+getLink (Clickable _ link) = link++getSrc = undefined -- just like getHref xo++-- -- |data ElemHead = (Elem/Text, Attrs)+-- -- | Note: Attrs will be changed to being a Map String String+-- makeBranch :: ShowHTML a => TreeHTML a -> Tree ElemHead+-- makeBranch treeH = Node (elTag treeH, attrs treeH) (_innerTree' treeH)+++++----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------++fst' :: (a, b, c) -> a+fst' (a,_,_) = a++snd' :: (a,b,c) -> b+snd' (_,b,_) = b++thd' :: (a,b,c) -> c+thd' (_,_,c) = c++foldFuncITR :: (ShowHTML a, ElementRep e) => HTMLMatcher e a -> InnerTextResult a -> InnerTextResult a+foldFuncITR hMatcher itr = case hMatcher of+ IText str -> + InnerTextResult (_matchesITR itr) (_fullInner itr <> str)+ -- May need to enforce a Show Instance on 'mat'+ Match mat -> + InnerTextResult (mat : _matchesITR itr) (_fullInner itr <> (showH mat))+ --concat to fullInnerText+ Element elem -> --interEl :: ElemHead [HtmlMatcher]+ InnerTextResult (matches' elem <> _matchesITR itr) (_fullInner itr <> (innerText' elem))+++-- foldFuncITHT :: (ShowHTML a, ElementRep e) => HTMLMatcher TreeHTML a -> InnerTextResult a -> InnerTextResult a+-- We could also implement (with a proper class system, a way to fold to InnerTextResult not just tree+ -- has performance benefits+ +fHM_c :: (InnerHTMLRep TreeHTML InnerTextHTMLTree a, ShowHTML a) =>+ HTMLMatcher TreeHTML a+ -> InnerTextHTMLTree a+ -> InnerTextHTMLTree a+fHM_c hMatcher ithT = case hMatcher of + IText str -> + InnerTextHTMLTree (_matches ithT) (_innerText ithT <> str) (innerTree ithT)+ -- May need to enforce a Show Instance on 'mat'+ Match mat -> + InnerTextHTMLTree (mat : (_matches ithT)) (_innerText ithT <> (showH mat)) (innerTree ithT)+ --concat to fullInnerText+ Element htmlTree -> --interEl :: ElemHead [HtmlMatcher]+ InnerTextHTMLTree (_matches ithT <> matches' htmlTree) ((_innerText ithT) <> showH htmlTree) ((makeBranch htmlTree) : innerTree ithT)+++makeBranch :: TreeHTML a -> Tree ElemHead+makeBranch treeH = Node (elTag treeH, attrs treeH) (_innerTree' treeH) -- 2 cases: + ++++endTag :: Stream s m Char => String -> ParsecT s u m String +endTag elem = try (string ("</" <> elem <> ">"))+++enoughMatches :: Int -> String -> Map String String -> (String, [a]) -> ParsecT s u m (Elem' a)+enoughMatches required e a (asString, matches) = + if required <= (length matches)+ then return $ Elem' e a matches (reverse asString)+ else parserFail "not enough matches" -- should throw real error ++enoughMatchesTree :: Int -> String -> Map String String -> (String, [a], Forest ElemHead) -> ParsecT s u m (TreeHTML a)+enoughMatchesTree required e a (asString, matches, forest) = + if required <= (length matches)+ then return $ TreeHTML e a matches (reverse asString) forest+ else parserFail "not enough matches" -- should throw real error ++++-- | Explanation: This is for the edge case of <p> tags that are allowed to "contain" text without actually having+-- | an end tag+-- | If i recall correctly, self-closing tags dont allow embedded elements, only plaintext.+-- | this means that the text belonging to the tag read, is that up until the next HTML control section+selfClosingTextful :: (ShowHTML a, Stream s m Char) =>+ Maybe (ParsecT s u m a)+ -> ParsecT s u m [HTMLMatcher e a]+selfClosingTextful innerP = do+ -- Fix: all is prefixed with + + char '>'+ manyTill+ (+ (try (Match <$> innerP'))+ <|> (try ((IText . (:[])) <$> anyChar))+ )+ (+ (try anyEndTag) <|> (char '<' >> some alphaNum)+ )+ where anyEndTag = (try (char '<'+ >> (optional (char '/'))+ >> some anyChar+ >> (string " " <|> string ">")))+ innerP' = fromMaybe parserZero innerP++-- is (selfClosingTextful Nothing) if no match desired +++++---- # DEPRECATED UrlPagination "use CurrentQuery" #+data UrlPagination = UrlPagination String String deriving (Eq, Show)++++-- where+-- func :: Show a => [HTMLMatcher a] -> InnerTextHTMLTree a -> InnerTextHTMLTree a+-- func [] state = state+-- func (htmlM:htmlMatchers) (InnerTextHTMLTree{..}) = case htmlM of+-- IText str -> +-- func htmlMatchers (InnerTextHTMLTree matches (innerText <> str) innerTree)+-- -- | May need to enforce a Show Instance on 'mat'+-- Match mat -> +-- func htmlMatchers (InnerTextHTMLTree (mat : matches) (innerText <> (show mat)) innerTree)+-- --concat to fullInnerText+-- Element htmlTree -> --interEl :: ElemHead [HtmlMatcher]+-- func htmlMatchers (InnerTextHTMLTree (matches <> matches' htmlTree) (innerText <> treeElemToStr htmlTree) ((makeBranch htmlTree) : innerTree))++++ +-- -- In future, I may generalize this along with HtmlMatcher to be something * -> * -> *++-- instance ToHTMLString a => ToHTMLString (Inner a) where+-- showH NonMatch str = str+-- showH IsMatch x = showH x++-- instance ToHTMLString a => ToHTMLString (HTMLMatcher a) where+-- showH IText str = str+-- showH Match x = showH x+-- showH Element treeH = treeElemToStr++-- Behaves just like two are right beside each other +++ ++-- Note: I could fold Elem' by labeling as Element then folding to ITR++-- (Element $ elem) : [] --> ITR++++++-- foldr :: (Elem' -> ITR -> ITR) -> ITR -> [] Element -> ITR ++-- for InnerTextResult, should preserve as string+-- for InnerTextHTMLTree , elem and attrs should build new single branch where branch = (,) elem attrs++-- my recursive functions can build off of this mutual foldability and work for anything that can provide+-- mutual foldability for any two relations ++-- foldFuncToITR :: [Elem' a] -> InnerTextResult a -> InnerTextResult a+-- foldFuncToITR InnerTextResult{..} (Elem'{..}:xs) =+-- func (InnerTextResult (matchesITR <> matchesEl) (fullInner <> innerHtmlFull)) xs ++-- case x of+ -- Elem' x -> [Element (Elem' x)]++++-- foldElements :: [Elem' a] -> InnerTextResult a+-- foldElements elems = foldr func (mempty :: InnerTextResult a) (fmap Element elems) ++-- foldr func mempty htmlMatchers ++-- foldrForHTMLGen :: func@(HMatcher a -> ITR -> ITR) -> mempty -> +++++-- this builds off the type classification of IsHTMLRep++++-- -- Note: Inner a = HtmlMatcher (String, a) a+-- foldInners :: [Inner a] -> InnerTextResult a+-- foldInners htmlMatchers = func emptyInner htmlMatchers+-- where+-- func :: (ShowHTML a, ElementRep e) => [HTMLMatcher e a] -> InnerTextResult a -> InnerTextResult a+-- func state [] = state+-- func itr (next:inners) = case next of+-- IText str -> +-- func (InnerTextResult matches (innerText <> str)) inners +-- -- | May need to enforce a Show Instance on 'mat'+-- Match mat -> +-- func (InnerTextResult (mat : matches) (innerText <> (showH mat))) inners +-- --concat to fullInnerText+-- Element elem -> --interEl :: ElemHead [HtmlMatcher]+-- func (InnerTextResult (matches' elem <> matches itr) (innerText itr <> (innerText' elem))) inners++++++++++++++++++++++-- instance Eq ((->) a b) where+ -- eq fx fx' = f (x:xs) = fx x == fx' x && f xs+++--- > A prerequisite would need to be Universe instance +type Tag = String
+ src/Scrappy/Files.hs view
@@ -0,0 +1,65 @@+module Scrappy.Files where++import Scrappy.Types+import Scrappy.Scrape+import Text.Parsec+import Scrappy.Elem+import qualified Data.Map.Strict as Map+import Control.Monad +import Data.Map.Strict (Map,keys)+import Data.List (foldl')+import System.FilePath+import System.Directory++-- TEMPORARY: move to own package when im not lazy++++-- | Recursively lists all files in a directory, returning absolute file paths.+listFilesRecursive :: FilePath -> IO [FilePath]+listFilesRecursive dir = do+ contents <- listDirectory dir -- Get directory contents+ paths <- forM contents $ \name -> do+ let fullPath = dir </> name -- Create full path+ isDir <- doesDirectoryExist fullPath+ if isDir+ then listFilesRecursive fullPath -- Recursively search subdirectories+ else do+ absPath <- makeAbsolute fullPath -- Get absolute path in IO context+ return [absPath] -- Wrap in list for concatenation+ return (concat paths) -- Flatten list of lists+++searchFile :: ScraperT a -> FilePath -> IO Bool+searchFile p fp = do+ str <- readFile fp+ pure $ exists p str++searchStrFile :: String -> FilePath -> IO Bool+searchStrFile s fp = searchFile (string "s") fp + +searchManyFile :: [String] -> FilePath -> IO (Map String Int)+searchManyFile strs fp = do+ file <- readFile fp+ case scrape (buildElemsOpts strs) file of+ Nothing -> pure mempty+ Just results -> pure $ countOccurrences results++-- | Function to count occurrences of each unique string in a list+countOccurrences :: [String] -> Map String Int+countOccurrences = foldl' (\acc word -> Map.insertWith (+) word 1 acc) Map.empty++++areFilesUsed :: FilePath -> FilePath -> IO ()+areFilesUsed sourceDir usageDir = do+ sources <- listFilesRecursive sourceDir+ searchFiles <- listFilesRecursive usageDir+ let sources' = takeFileName <$> sources+ maps <- mapM (\x -> searchManyFile sources' x) searchFiles+ let mapped = mconcat maps+ print mapped++ print "---"++ print $ filter (\s -> not $ elem s (keys mapped)) sources'
+ src/Scrappy/Find.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE FlexibleContexts #-}++module Scrappy.Find where++--import Scrappy.Elem.Types (ElementRep, GroupHtml(GroupHtml), Elem, mkGH, Elem', TreeHTML, ShowHTML)+-- import Elem.TreeElemParser (findSameTreeH)+--import Scrappy.Types (ScrapeFail(..))++import Control.Monad.IO.Class+import Text.Parsec (ParsecT, ParseError, Parsec, Stream, parse, eof, anyChar, (<|>), try, parserZero, anyChar+ , many) +import Data.Text (Text)+import Data.Functor.Identity (Identity)+import Data.Either (fromRight)+import Scrappy.Types (ScrapeFail(..))++--data ScrapeFail = Eof | NonMatch++-- | This module provides an interface for getting patterns seperated by whatever in a given source+-- | that you plan to parse++-- | findSequential(_x) is for information rich elements such as products that should have multiple fields+-- | that the user would like to return +++++-- | Converts a parsing/scraping pattern to one which either returns Nothing+-- | or Just a list of at least 1 element. Maybe type is used so that there is a clearer+-- | distinction between a failed search and a successful one+findNaive :: Stream s m Char => ParsecT s u m a -> ParsecT s u m (Maybe [a])+findNaive p = (justify . (fromRight mempty) . sequenceA) <$> (find p)+ where+ justify x = if length x == 0 then Nothing else Just x +++findNaiveIO :: (MonadIO m, Stream s m Char, Show a) => ParsecT s u m a -> ParsecT s u m (Maybe [a])+findNaiveIO p = (justify . (fromRight mempty) . sequenceA) <$> (findIO p)+ where+ justify x = if length x == 0 then Nothing else Just x +++-- | Great for debugging+findIO :: (MonadIO m, Stream s m Char, Show a) => ParsecT s u m a -> ParsecT s u m [Either ScrapeFail a]+findIO parser = do+ x <- (try (baseParser parser)) <|> givesNothing <|> endStream+ liftIO $ print x+ case x of+ Right a -> fmap (x :) (find parser)+ Left Eof -> return []+ Left NonMatch -> find parser+++-- givesNothing :: ParsecT e s m (Either ScrapeFail a) +-- givesNothing = Left NonMatch <$ anyChar++findSequential :: Stream s m Char => [ParsecT s u m a] -> ParsecT s u m [Either ScrapeFail a] +findSequential parsers = undefined -- builds off findUntilMatch++findSequential2 :: Stream s m Char => (ParsecT s u m a, ParsecT s u m b) -> ParsecT s u m (a,b)+findSequential2 (a,b) = do+ a' <- findUntilMatch a+ b' <- findUntilMatch b+ return (a', b')++findSequential3 :: Stream s m Char => (ParsecT s u m a, ParsecT s u m b, ParsecT s u m c) -> ParsecT s u m (a,b,c)+findSequential3 (a,b,c) = do+ a' <- findUntilMatch a+ + b' <- findUntilMatch b+ c' <- findUntilMatch c+ return (a', b', c')++-- | Like find naive except that finishes parsing on the first match it finds in the document+findUntilMatch :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a+findUntilMatch parser = do+ x <- (try (baseParser parser)) <|> givesNothing+ case x of+ Right a -> return a+ Left NonMatch -> findUntilMatch parser + Left Eof -> parserZero+++-- -- this is for sequencing matches amongst noise+-- findUntilMatch2 :: ParsecT s u m a -> ParsecT s u m (Either ScrapeFail a)+-- findUntilMatch2 parser = do+-- x <- (try (baseParser parser)) <|> givesNothing+-- case x of+-- Right a -> return $ Right a+-- Left NonMatch -> findUntilMatch parser +-- Left Eof -> parserZero + +++ +-- -- Note: List will be backwards as is +find :: Stream s m Char => ParsecT s u m a -> ParsecT s u m [Either ScrapeFail a]+find parser = do+ x <- (try (baseParser parser)) <|> givesNothing <|> endStream+ case x of+ Right a -> fmap (x :) (find parser)+ Left Eof -> return []+ Left NonMatch -> find parser+-- return (x:xs)++-- | Should never throw Left or I did it wrong+streamEdit :: ParsecT String () Identity a -> (a -> String) -> String -> String+streamEdit p f src = fromRight undefined $ parse (try $ findEdit f p) "" src+++-- -- Note: List will be backwards as is +findEdit :: Stream String m Char => (a -> String) -> ParsecT String u m a -> ParsecT String u m String +findEdit f parser = do+ let endStream = try eof >> (return EOF)+ x <- ((Edit . f) <$> (try parser)) <|> (Carry <$> anyChar) <|> endStream+ case x of+ Edit str -> fmap (str <>) (findEdit f parser) + Carry chr -> fmap ([chr] <>) (findEdit f parser) + EOF -> return [] +++-- -- Note: List will be backwards as is +editFirst :: Stream String m Char => (a -> String) -> ParsecT String u m a -> ParsecT String u m String +editFirst f parser = do+ let endStream = try eof >> (return EOF)+ x <- ((Edit . f) <$> (try parser)) <|> (Carry <$> anyChar) <|> endStream+ case x of+ Edit str -> fmap (str <>) $ many anyChar -- consume rest automatically -- (findEdit f parser) + Carry chr -> fmap ([chr] <>) (findEdit f parser) + EOF -> return [] ++++-- endStream :: (Stream s m t, Show t) => ParsecT s u m (Either ScrapeFail a)+-- endStream = try (eof) >> (return $ Left Eof)++ +-- return (x:xs)++-- | We can define Edit to be a string because we know it will turn back into one+data StreamEditCase = EOF+ | Carry Char+ | Edit String+++-- findSome = undefined+-- findSomeSame = findSomeSameEl++++baseParser :: Stream s m Char => ParsecT s u m a -> ParsecT s u m (Either ScrapeFail a)+baseParser parser = fmap Right parser++givesNothing :: Stream s m Char => ParsecT s u m (Either ScrapeFail a) +givesNothing = Left NonMatch <$ anyChar++endStream :: (Stream s m t, Show t) => ParsecT s u m (Either ScrapeFail a)+endStream = try (eof) >> (return $ Left Eof)+++++-- | Just since do we really care about non matches?+findSomeHTMLNaive :: Stream s Identity Char => Parsec s () a -> s -> (Maybe [a])+findSomeHTMLNaive parser text =+ let parser' = findNaive parser + in + case parse parser' "from html:add-in URL soon" text of+ Left _ -> Nothing + Right maybe_A -> maybe_A++findSomeHTML :: Stream s Identity Char => Parsec s () a -> s -> Either ParseError (Maybe [a])+findSomeHTML parser text =+ let parser' = findNaive parser + in parse parser' "from html at this url: <unimplemented - derp>" text++-- findFirst :: ParsecT s u m a -> Text -> Maybe a +-- findFirst = undefined++-- findAllHtml :: ParsecT s u m a -> Text -> Maybe a +-- findAllHtml = undefined+-- | My findAll' function design / runParserOnHtml + --use Maybe instead of Either to toss failure+ --case [] -> Nothing++-- | so it returns :: Maybe [a] = Just [a] | Nothing+ -- which will be beautiful for modeling at high level from scrape result to scrape result++-- | I also really need to implement non-zero, non-ending predicate inner function+-- | like nonZeroSep https://hackage.haskell.org/package/replace-megaparsec-1.4.4.0/docs/src/Replace.Megaparsec.html#sepCap++-- | NOTE: I can replace manyTill_ with anyTill from Replace.Megaparsec+++-- within :: m a -> m a -> m a+-- within ma mb = do+-- x <- do+-- ma +-- y <- mb+ +-- return mb ++++++-- -- Mutually exclusive/non-overlapping patterns +-- findAll' :: ParsecT s u m a -> ParsecT s u m [a]+-- findAll' parser = do+-- x <- skipManyTill anyChar parser <|> return []+-- xs <- findAll' parser+-- return (x : xs)+++ + +findAllBetween = undefined++++-- | Use with constructed for parsing datatype +buildSequentialElemsParser :: ParsecT s u m [a]+buildSequentialElemsParser = undefined+-- | to be applied to inner text of listlike elem+++-- findOnChangeInput :: ParsecT s u m (Elem' a)+-- findOnChangeInput = undefined+-- eg : <select id="s-lg-sel-subjects" name="s-lg-sel-subjects" class="form-control" data-placeholder="All Subjects" onchange="springSpace.publicObj.filterAzBySubject(jQuery(this).val(), 3848);">+++-- | Rewrite to being any pattern "a"++-- -- | Note: this isnt necessarily deprecated but just useful for when we want to find many of some pattern+-- -- | that doesnt need to exist right after the previous successful match+-- {-# DEPRECATED findSomeSameEl "need manytill out and useful for find, findAll" #-}+-- findSomeSameEl :: (Stream s m Char, ShowHTML a)+-- => Maybe (ParsecT s u m a)+-- -> Maybe [Elem]+-- -> [(String, Maybe String)]+-- -> ParsecT s u m [TreeHTML a]+-- findSomeSameEl matchh elemOpts attrsSubset = do+-- -- (_, treeH) <- manyTill_ (anyChar) (try $ treeElemParser elemOpts matchh attrsSubset)+-- treeH <- treeElemParser elemOpts matchh attrsSubset+-- treeHs <- findMore matchh treeH+-- case treeHs of+-- [] -> parserFail "no matches" -- by definition: this func should return at least 1 copy +-- _ -> return (treeH : treeHs)+-- where+-- findMore :: (Stream s m Char, ShowHTML a) =>+-- Maybe (ParsecT s u m a)+-- -> TreeHTML a+-- -> ParsecT s u m [TreeHTML a] +-- findMore matchh treeH = do+-- treeH' <- --( fmap (:[]) (skipManyTill anyChar (try $ findSameTreeH matchh treeH) ) )+-- (do+-- -- note: using skipManyTill VIOLATES expectations of this functions use+-- -- this is gonna return something like 19 <a></a> tags since it is not+-- -- in any way required for the congruent elements to be neighbours + +-- x <- skipManyTill anyChar (try $ findSameTreeH matchh treeH)+-- return (x:[])+-- )+-- <|> return []+-- case treeH' of+-- [] -> return []+-- _ -> fmap ((treeH:[]) <>) $ findMore matchh treeH -- TreeHTML : ParsecT s u m [TreeHTML]
+ src/Scrappy/Links.hs view
@@ -0,0 +1,419 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+++{-|+Description: In a way, this is the most central component of the entire library;++DOM -> Link >>= request --> DOM -> Link ...+ ^^ + this may be infinitely complicated by stuff such as JS ++The recursive nature of scraping is the central data structure of a URL ++Which makes me think that there may be more to consider at some point with the modern-uri package+And doing stuff such as building site trees +++-}++module Scrappy.Links where+++-- import Scrappy.Elem.Types (Elem'(..), ElemHead, innerText')+-- import Scrappy.Elem.ElemHeadParse (hrefParser)+-- import Find (findSomeHTMLNaive)++-- import qualified Network.URI as URI ++import Control.Monad (join)+import qualified Network.URI as NURI+-- TODO(galen): Replace with Network.URI and deprecate Text.URI+import Text.URI (URI, uriQuery, mkURI, uriPath, unRText, emptyURI, uriScheme, uriAuthority, RTextLabel(..))+import Control.Lens ((^.))+import qualified Text.URI.Lens as UL+import Text.Parsec (ParsecT, Stream )+import Data.Functor.Classes (eq1)+import Data.Map (Map)+import Data.Either (fromRight, isRight)+import Data.Maybe (catMaybes, fromJust, fromMaybe)+import Data.List (isSuffixOf, isInfixOf, isPrefixOf)+import qualified Data.List.NonEmpty as NE (length, last)+import Data.Text (Text, pack, unpack, splitOn+ )+import Data.Char (toLower)++import Data.Aeson.TH (defaultOptions, deriveJSON)++type PageNumber = Int++-- |+type BaseUrl = Link+type Url = String ++++type HrefURI = String ++-- TODO(galen): make this a Link +type CurrentUrl = Url ++type DOI = String -- Change to URI if this works ++-- linkToURI :: Link -> URI+-- linkToURI = undefined++-- evalLink :: Link -> String+-- evalLink = linkToText+-- where+-- linkToText x = case x of+-- OuterPage x' -> x'+-- SearchFormURL y -> y+-- ListingPage _ _ _ _ -> undefined+-- PageHasPdf r -> r+-- Sourcery _ _ -> undefined++++type Src = Url+type RelativeUrl = Url +++fixRelativeUrl :: BaseUrl -> Url -> Url+fixRelativeUrl (Link bUrl) url+ | url == "" = bUrl + | url == "/" = bUrl + | isInfixOf bUrl url = url+ | last bUrl == '/' && (isPrefixOf "/" url) = bUrl <> (tail url) -- both+ | last bUrl == '/' && (not $ isPrefixOf "/" url) = bUrl <> url -- a + | last bUrl /= '/' && (isPrefixOf "/" url) = bUrl <> url -- b + | last bUrl /= '/' && (not $ isPrefixOf "/" url) = bUrl <> "/" <> url -- neither ++ --- || ((last bUrl /= '/') && (isPrefixOf "/" url)) = bUrl <> url++-- fixRelativeURI :: UURI -> URI.URI -> URI.URI+-- fixRelativeURI base relative = undefined+-- -- confirm that it truly is relative+ -- ++-- | Could set last url in state +getHtmlStateful :: Url -> {- StateT SiteDetails -} String+getHtmlStateful = undefined++-- Whatever man+type LastUrl = Link+type Href = String +++fixSameSiteURL :: LastUrl -> Href -> Maybe Url+fixSameSiteURL lastUrl href = undefined+++-- | Generic algorithm for determining full path given last url +fixURL :: LastUrl -> Href -> Url+fixURL previous href = + -- checkIfSchemeInHref+ let+ base = if isPrefixOf "/" href then fromJust $ deriveBaseUrl previous else previous+ hrefURI = mkURI . pack $ href+ in+ case join $ uriScheme <$> hrefURI of+ -- We could easily check here if authority is the same + Just _ -> href + Nothing -> fixRelativeUrl base href + -- checkIfRelativeToLast -- doesnt start with /+ -- case isPrefixOf "/" href of+ -- True -> fixRelativeUrl (deriveBaseUrl previous) href+ -- False -> fixRelativeUrl previous href + +-- fixURL :: LastUrl -> Href -> Maybe Url+-- fixURL prev href = do++-- -- | The fromJust should never be called if Links are used properly+-- deriveBaseUrl :: Link -> BaseUrl+-- deriveBaseUrl (Link url) = Link $ mkBaseUrl $ fromJust $ mkURI . pack $ url ++-- -- | I think this is good (might also bee good lens practice tho to simplify)+-- mkBaseUrl :: URI -> String+-- mkBaseUrl uri =+-- (unpack $ ((unRText . fromJust) $ uri ^. UL.uriScheme))+-- <> ("://")+-- <> (unpack (unRText $ (fromRight undefined (uri ^. UL.uriAuthority)) ^. UL.authHost))+ +------------------------------++-- | the fromJust should never be called if Links are used properly+deriveBaseUrl :: Link -> Maybe BaseUrl+deriveBaseUrl (Link url) = mkBaseUrl =<< (mkURI . pack $ url)+++-- | I think this is good (might also bee good lens practice tho to simplify)+mkBaseUrl :: URI -> Maybe Link +mkBaseUrl uri = do+ scheme <- fmap unRText $ uri ^. UL.uriScheme+ host <- case uri ^. UL.uriAuthority of+ Right author -> Just $ unRText $ author ^. UL.authHost + Left _ -> Nothing + Just . Link $ (unpack scheme) <> ("://") <> (unpack host)+ + -- (unpack $ ((unRText . fromJust) $ uri ^. UL.uriScheme))+ -- <> ("://")+ -- <> (unpack (unRText $ (fromRight undefined (uri ^. UL.uriAuthority)) ^. UL.authHost))+++ + -- if yes + -- then weNeedTheLastUrl+ -- else deriveBaseUrl + -- deriveBaseUrl++-- for the scraper, instead of keeping the baseURL we should store the current URL+-- which can still be used to derive the++-- baseURL :: SiteDetails (-> CurrentUrl ->) -> BaseUrl + +class IsLink a where+ renderLink :: a -> Url +++++-- lets view Link as meant to contain Informationally derived meaning from internet ; that contains how to get+-- Keeps state for generic streaming +-- data Link = OuterPage String+-- | SearchFormURL String+-- | ListingPage [GeneratedLink] PageNumber PageKey String+-- | PageHasPdf String+-- -- PdfLink String+-- | Sourcery (PdfLink) ReferenceSys++-- pageKey=param+++++getFileName :: Link -> Maybe String+getFileName = getLastPath+++++doiParser :: ParsecT s u m DOI +doiParser = undefined+ -- baseURL is doi.org+ + -- isDOI :: Url -> Bool ++data ReferenceSys = RefSys [String] [String]++type GeneratedLink = String+++-- type PdfLink = String +-- | Name and Namespace are really same shit; might just converge+-- | Refer to literally "name" attribute+type Namespace = Text++-- | This is an operationally focused type where+-- | a certain namespace is found to have n num of Options+type Option = Text +++-- | More for show / reasoning rn .. non-optimal+data QParams = Opt (Map Namespace [Option]) | SimpleKV (Text, Text)++++-- SiteTree can be modelled as a stream ; just depends on how we apply it -- if lazily+-- | Inter site urls and whether they have been checked for some pattern+type SiteTree = [(Bool, Text)]+++-- | This wouldnt need to be exported as our interfaces would implement it under the hood+-- | and return a Link'+data DOMLink = Href' Href+ | Src Url+ | PlainLink Url +-- | LastUrl' String+ ++-- scrapeSameSiteLinks :: ParsecT s u m Link+-- scrapeSameSiteLinks = undefined++-- scrapeLinks :: ParsecT s u m Link+-- scrapeLinks = undefined+++newtype Link = Link Url deriving (Eq, Show, Read, Ord)++-- | This is a general interface for extracting a raw link+-- | from scraping according to specs about the scraper itself+-- | IE if it is 100% same site+parseLink :: Bool -> Link -> Url -> Maybe Link+parseLink onlySameSite lastLink newLink = + case hasNoURIScheme newLink of+ True -> Just . Link $ fixRelativeUrl (fromJust $ deriveBaseUrl lastLink) newLink+ False -> case isHTTP newLink of+ False -> Nothing + True -> case onlySameSite of+ False -> Just . Link $ newLink+ True -> case sameAuthority newLink lastLink of+ False -> Nothing+ True -> Just . Link $ newLink+ where+ hasNoURIScheme url = (join $ fmap uriScheme $ mkURI . pack $ url) == Nothing+ isHTTP url = elem (fromMaybe "" (fmap NURI.uriScheme $ NURI.parseURI url)) ["https:", "http:"]++sameAuthority :: Url -> Link -> Bool+sameAuthority href (Link linky) =+ let+ getMainAuthority = last . splitOn "." . pack+ getRegName l = fmap (getMainAuthority . NURI.uriRegName) $ NURI.uriAuthority =<< NURI.parseURI l+ in case (==) <$> (getRegName href) <*> (getRegName linky) of+ Nothing -> False + Just b -> b+++type HostName = String +-- MOVE TO SCRAPPY+getHostName :: Link -> Maybe HostName+getHostName (Link url) = do + uri <- mkURI $ pack url+ case fmap (unpack . unRText . (^. UL.authHost)) (uri ^. UL.uriAuthority) of+ Right hn -> Just hn+ _ -> Nothing + +-- | Only exported interface +instance IsLink Link where+ renderLink (Link url) = url +++--getHtmlST :: sv -> Link -> m (sv, Html) +++-- -- | In reality, this is 4 helper functions +-- link :: (Maybe LastUrl) -> ScraperT Link+-- link onlyThisSite = do+-- link' <- parseOpeningTag linkStuff+-- validateLink onlyThisSite link' +++-- doesnt have a scheme:+-- NoScheme -> must be same site and relative;-> Just $ relative to current or base URL ? +-- HasScheme -> if mustBeSS && isSSite then Just url else Nothing +++-- -- validateLink is gonna be an interface that may use fixURL and sees if its the same site +-- -- | All 4 scrapers would use validateLink +-- validateLink :: Bool -> LastUrl -> DOMLink -> Link+-- validateLink ots lastUrl iLink = case ots of+-- True -> ""+-- False -> "" +++-- Note following ideas++-- data Source = Source (Citations, Html)++++-- findAdvancedSearchLinks :: ParsecT s u m [String]+-- findAdvancedSearchLinks = undefined+++-- | Core function of module, filters for any links which point to other pages on the current site+-- | and have not been found over the course of scraping the site yet +-- | filters out urls like https://othersite.com and "#"+maybeUsefulNewUrl :: Link -> [(Link, a)] -> Link -> Maybe Link+maybeUsefulNewUrl baseUrl tree url = maybeUsefulUrl baseUrl url >>= maybeNewUrl tree +++++urlIsNew :: [(a, Url)] -> HrefURI -> Bool+urlIsNew [] uri = True+urlIsNew (branch:tree) uri+ | eq1 (fmap uriPath (mkURI' (uri))) (fmap uriPath (mkURI' (snd branch))) = False+ | otherwise = urlIsNew tree uri+ where+ mkURI' :: String -> Maybe URI+ mkURI' url = mkURI (pack url)++++maybeNewUrl :: [(Link, a)] -> Link -> Maybe Link+maybeNewUrl [] uri = Just uri+maybeNewUrl (branch:tree) uri =+ if eq1 (fmap uriPath (mkURI' (renderLink uri))) (fmap uriPath (mkURI' . renderLink . fst $ branch))+ then Nothing+ else maybeNewUrl tree uri+ -- eq1 (fmap uriPath (mkURI' (pack uri))) (fmap uriPath (mkURI' (fst branch))) = False+ -- otherwise = urlIsNew tree uri+ where+ mkURI' :: String -> Maybe URI+ mkURI' url = mkURI (pack url)+ ++++-- | Filters javascript refs, inner page DOM refs, urls with query strings and those that+-- | do not contain the base url of the host site+maybeUsefulUrl :: Link -> Link -> Maybe Link+maybeUsefulUrl (Link baseUrl) url = do+ noJSorShit url+ numberOfQueryParamsIsZero url+ if isInfixOf baseUrl (renderLink url) then return url else Nothing+ allowableEndings url++ where+ noJSorShit :: Link -> Maybe Link+ noJSorShit link =+ if (not $ elem True (urlContains link ["javascript", "about", "help", "#"]))+ then Just url+ else Nothing++ urlContains :: Link -> [String] -> [Bool]+ urlContains (Link url) icases = fmap ((flip isInfixOf) (fmap toLower url)) icases+ + allowableEndings url =+ let lastPath = fromMaybe "" $ getLastPath url+ in+ if (elem '.' lastPath)+ then allowableFile lastPath url -- must be of allowable+ else Just url+ + allowableFile endPath url =++ if elem True $ fmap (\x -> isSuffixOf x (fmap toLower endPath)) allowed+ then Just url+ else Nothing+ where allowed = [".aspx", ".html", ".pdf", ".php"]++ +-- getLastPath :: Url -> String+-- getLastPath url = unpack (unRText (NE.last (snd (fromJust (fromJust (fmap uriPath (mkURI (pack url))))))))++getLastPath :: Link -> Maybe String+getLastPath (Link url) = do + x <- mkURI $ pack url + x' <- uriPath x+ Just . unpack . unRText . NE.last . snd $ x'++-- | Input is meant to be right from +usefulNewUrls :: Link -> [(Link, a)] -> [Link] -> [Maybe Link]+usefulNewUrls _ _ [] = []+usefulNewUrls baseUrl tree (link:links) = (maybeUsefulNewUrl baseUrl tree link) : usefulNewUrls baseUrl tree links++usefulUrls :: Link -> [Link] -> [Maybe Link]+usefulUrls baseUrl (link:links) = maybeUsefulUrl baseUrl link : usefulUrls baseUrl links ++numberOfQueryParamsIsZero :: Link -> Maybe String+numberOfQueryParamsIsZero (Link uri) = do+ x <- mkURI (pack uri)+ if length (uriQuery x) == 0+ then Just uri+ else Nothing+++deriveJSON defaultOptions ''Link
+ src/Scrappy/Scrape.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}++module Scrappy.Scrape where++-- -- Basically just html patterns from testing / courtney market stuff+import Scrappy.Elem.Types (Elem', innerText')+import Scrappy.Elem.ElemHeadParse (hrefParser, parseOpeningTag)+import Scrappy.Elem.SimpleElemParser (el)+import Scrappy.Elem.ChainHTML ((</>>))+import Scrappy.Find (findNaive, findNaiveIO)+import Scrappy.Links (maybeUsefulUrl)+import Scrappy.Types++import Control.Monad.Trans.Maybe (MaybeT(..))+import Control.Monad.IO.Class (MonadIO)+import Data.Functor.Identity (Identity)+import Data.Either (fromRight)+import Data.Maybe (catMaybes, fromMaybe)+import Text.Parsec (Stream, ParsecT, parse, string, parserZero, anyChar, manyTill, char, many, try, runParserT)+import Control.Applicative (liftA2) ++type ScraperT a = ParsecT Html () Identity a +---type Html = String+++-- | Generate a scraping expression where when found, it will generate and link in a data structure+-- | to a relevant next pattern. For instance, an element of interest being found then switches the+-- | scraper expression to be a reference to itselfo+-- |+-- | for instance (el "a" [("id", "x")]) -> let ALPHANUM = document.select(this) -> someThingUsing ALPHANUM_MATCH+-- | in a statement --> which references [A, B, C] +scrapeLinked :: ParsecT s u m a -> ParsecT s u m [String]+scrapeLinked = undefined+++-- TODO(galen): move to Scrappy.Scrape+-- Generic function for dropping an abstract pattern from text +filterFromTextP :: ScraperT a -> ScraperT String+filterFromTextP p = (many $ try p) >> (liftA2 (:) anyChar $ filterFromTextP p)++-- We can return a string since this will never fail+-- its provably impossible +filterPattern :: String -> ScraperT a -> String+filterPattern txt p = either undefined id $ parse (filterFromTextP p) "" txt ++++-- | Super common case analysis+coerceMaybeParser :: Maybe a -> ScraperT a+coerceMaybeParser = \case+ Just a -> return a+ Nothing -> parserZero+++hoistMaybe :: Applicative m => Maybe a -> MaybeT m a +hoistMaybe = MaybeT . pure+++exists :: ScraperT a -> Html -> Bool +exists p html = maybe False (const True) $ runScraperOnHtml p html ++scrape :: ScraperT a -> Html -> Maybe [a]+scrape = runScraperOnHtml++scrapeFirst' :: ScraperT a -> Html -> Maybe a+scrapeFirst' f h = case scrape f h of+ Just (x:xs) -> return x+ _ -> Nothing +++-- fmap head+getFirstSafe :: Maybe [a] -> Maybe a+getFirstSafe (Just (x:_)) = Just x+getFirstSafe _ = Nothing+++getFirstFitSafe :: (a -> Bool) -> Maybe [a] -> Maybe a+getFirstFitSafe f (Just (x:xs)) = findFit f (x:xs) +getFirstFitSafe _ _ = Nothing ++findFit :: (a -> Bool) -> [a] -> Maybe a+findFit _ [] = Nothing+findFit cond (x:xs) = if cond x then Just x else findFit cond xs ++++-- | Find all occurences of a given parsing/scraping pattern+-- | e.g. getHtml' "https://google.ca" >>= return . runScraperOnHtml (el "a" []) , would give all 'a' tag html elements on google.ca +runScraperOnHtml :: ParsecT String () Identity a -> String -> Maybe [a]+runScraperOnHtml p html = fromRight Nothing $ parse (findNaive $ p) "" html +++runScraperOnHtmlIO :: (MonadIO m, Show a, Stream String m Char) => ParsecT String () m a -> String -> m (Maybe [a])+runScraperOnHtmlIO p html = do+ x <- runParserT (findNaiveIO $ p) () "" html + pure $ fromRight Nothing x ++scrapeIO :: (MonadIO m, Show a, Stream String m Char) => ParsecT String () m a -> String -> m (Maybe [a])+scrapeIO = runScraperOnHtmlIO ++runScraperInBody :: ParsecT String () Identity a -> String -> Maybe [a]+runScraperInBody prsr html = fromRight Nothing $ parse (skipToInBody >> findNaive prsr) "" html++skipToInBody :: Stream s m Char => ParsecT s u m ()+skipToInBody = manyTill anyChar (parseOpeningTag (Just ["html"]) [] >> char '>')+ </>> el "head" []+ </>> parseOpeningTag (Just ["body"]) []+ >> char '>'+ >> return () ++ +runScraperOnBody :: ParsecT String () Identity a -> String -> Maybe [a] +runScraperOnBody prsr html = fromRight Nothing $ parse (skipToBody >> findNaive prsr) "" html ++skipToBody :: Stream s m Char => ParsecT s u m ()+skipToBody = manyTill anyChar (parseOpeningTag (Just ["html"]) [] >> char '>') </>> el "head" [] >> return () +++runScraperOnHtml1 :: ParsecT String () Identity a -> String -> Maybe a+runScraperOnHtml1 p = (fmap head) . runScraperOnHtml p++++++-- {-# DEPRECATED simpleScrape' "from fba project - gives confusing String output" #-}+-- simpleScrape' :: ParsecT String () Identity String -> String -> String +-- simpleScrape' p html = case parse (findNaive p) "" html of+-- Right (Just (x:_)) -> x+-- Right (Just []) -> "NothingA"+-- Right (Nothing) -> "NothingB"+-- Left err -> "Nothing" <> show err++++-- clean :: String -> String+-- clean = undefined -- drop if == ( \n | \" | '\\' )+++-- -- | uses maybeUsefulUrl to get all links on page pointing only to same site links+-- allLinks :: String -> ParsecT String () Identity [String] +-- allLinks baseUrl = do+-- x <- findNaive hrefParser +-- return $ case x of+-- Just (x':xs') -> catMaybes $ fmap (maybeUsefulUrl baseUrl) (x':xs')+-- Just [] -> []+-- Nothing -> [] ++-- type Name = String -- placeholder+-- tableItem :: Name -> Elem' String+-- tableItem = undefined+++++-- scrapeInnerText :: ParsecT String () Identity (Elem' String) -> String +-- scrapeInnerText p = case parse (findNaive p) "" body of+-- Right (Just (x:_)) -> innerText' x+-- Right (Just []) -> "Nothing"+-- Right (Nothing) -> "Nothing"+-- Left err -> show err+++++scrapeFirst :: Stream s m Char => ParsecT s u m a -> ParsecT s u m (Maybe a)+scrapeFirst p = do+ x <- findNaive p+ case x of+ Just (x:_) -> return $ Just x+ Nothing -> return $ Nothing++ +findCount :: Stream s m Char => ParsecT s u m a -> ParsecT s u m Int+findCount p = do+ x <- findNaive p+ return $ length (fromMaybe [] x)+++++type Prefix' = String+{-# DEPRECATED scrapeBracketed "experimental, first attempt" #-}+scrapeBracketed :: Prefix' -> ScraperT a -> Html -> Maybe [a]+scrapeBracketed pre scraper html = mconcat <$> scrape (string pre >> manyTill scraper (string pre)) html++++type Prefix = String +scrapePrefixed :: Prefix -> ScraperT a -> Html -> Maybe [a]+scrapePrefixed pre scraper html = scrape (string pre >> scraper) html+
+ src/Scrappy/Types.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE KindSignatures #-}++module Scrappy.Types where++-- may change Types + Links -> Navigation + Something else ++++-- import Network.HTTP.Client (CookieJar, requestBody, method, destroyCookieJar, responseCookieJar, httpLbs, RequestBody (RequestBodyBS, RequestBodyLBS), parseRequest, newManager, responseBody, Manager)+import Control.Concurrent (ThreadId)+import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.Trans.State.Lazy (StateT)+--import Data.Time.Clock.System+import Data.Text (Text)++import Text.Parsec (ParsecT, parserZero)+--import Witherable+++-- -- | Upgrade an error to discard parser +-- instance Filterable (ParsecT s u f) where+-- mapMaybe f ma = do+-- x <- ma+-- case f x of+-- Just a -> return a +-- Nothing -> parserZero++++mapMaybe :: (a -> Maybe b) -> ParsecT s u m a -> ParsecT s u m b+mapMaybe f ma = do+ x <- ma+ case f x of+ Just a -> pure a+ Nothing -> parserZero++++data ScrapeFail = Eof | NonMatch deriving Show++-- | Note: both elemParser and treeElemParser are capable of doing greedy or non-greedy matching+ --treeElemParser (unless its really slow) should be better for non-greedy/focused+ --elemParser should be better for greedy++++-- eitherP :: Alternative m => m a -> m b -> m (Either a b)+-- eitherP a b = (Left <$> a) <|> (Right <$> b)++++ ++-- IO for requests+-- Either for high level important errors+-- Maybe for Naive scraping logic +++-- State looking important for managing status of each site as well+-- as scrape coin ++-- | data Processor a b = Processor ThreadId { runFunc :: (a -> b) }+type Html = String -- or could be just the pdf, but maybe even URL for storage sake --> could become research graph+ -- but in a sense, would be a forest of uncited (yet) publicationsop