diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for readability + +## 0.0.1.0 – 2020-06-26 + +* First version diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2020, G. Eyaeb + +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 G. Eyaeb 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,131 @@ +# readability + +Give `readability` an HTML document and it will detect and extract text of the article while removing everything unnecessary like menus, advertisements or sidebars. It is more or less reimplementation of [python-readability](https://github.com/buriy/python-readability). + +The package contains both a library and simple executable. + +## Example of using `readability` executable + +Having an article that looks like following image: + +![Original HTML](https://hg.sr.ht/~geyaeb/haskell-readability/raw/doc/orig.png "Original HTML") + +we can extract text by calling: + +```shell +$> readability https://mises.org/wire/why-central-banks-are-threat-our-savings +``` + +and we get the following HTML: + +![Extracted text](https://hg.sr.ht/~geyaeb/haskell-readability/raw/doc/readable.png "Extracted text") + + +If we are interested in plain text, we can further use `pandoc`: + +```text +$> readability https://mises.org/wire/why-central-banks-are-threat-our-savings | pandoc -f html -t plain + +The US personal savings rate jumped to 33 percent in April from 12.7 +percent in March and 8 percent in April last year. An increase in +savings is regarded by popular economics as less expenditure on +consumption. Since consumption expenditure is considered as the main +driving force of the economy, obviously a rebound in savings, which +implies less consumption, cannot be good for economic activity, so it is +held. Saving and wealth—what is the relation? + +To maintain their life and well-being, individuals require access to +consumer goods. An increase in various consumer goods permits an +increase in individuals’ living standards. What allows an increase in +the production of consumer goods is the maintenance and the enhancement +of the infrastructure of an economy. With better infrastructure, a +greater quantity and better quality of consumer goods could be generated +and more real wealth can be produced. + +The enhancement and the maintenance of the infrastructure becomes +possible because of the availability of final consumer goods that +sustain the various individuals who are busy expanding and maintaining +the infrastructure. It is the producers of final consumer goods who pay +the various individuals engaged in maintenaning and enhancing the +infrastructure. The producers of final consumer goods pay these +individuals (i.e., the intermediary producers) out of the saved or +unconsumed production of final consumer goods. + +Note that when a producer of final consumer goods decides to save more, +i.e., to consume less, the fall in his consumption is offset by the +increase in the consumption of individuals who are engaged in the +intermediary stages of production. This means that overall consumption +is not declining because of an increase in saving—as popular thinking +has it. +``` + +Had we not processed the article through `readability`, we would have gotten: + +``` text +$> curl https://mises.org/wire/why-central-banks-are-threat-our-savings | pandoc -f html -t plain + +Skip to main content + +[Home] + +Toggle navigation + +- Blog +- Mises Wire +- Books +- Podcast +- Video +- Events +- Store +- Graduate Program + +- Ver en Español + +Stay Connected + +GO + +SUPPORT MISES + +JOIN OR RENEW TODAY + +SUPPORT MISES + +JOIN OR RENEW TODAY + +Mises Wire + +GET NEWS AND ARTICLES IN YOUR INBOXPrint + +A + +A + +Home | Wire | Why Central Banks Are a Threat to Our Savings + +Why Central Banks Are a Threat to Our Savings + +- [dollars] + +0 Views + +Tags + +Money and Banking + +06/25/2020Frank Shostak + +The US personal savings rate jumped to 33 percent in April from 12.7 +percent in March and 8 percent in April last year. An increase in +savings is regarded by popular economics as less expenditure on +consumption. Since consumption expenditure is considered as the main +driving force of the economy, obviously a rebound in savings, which +implies less consumption, cannot be good for economic activity, so it is +held. Saving and wealth—what is the relation? +``` + +## Contribute + +Project is hosted at https://sr.ht/~geyaeb/haskell-readability/ . The homepage provides links to [Mercurial repository](https://hg.sr.ht/~geyaeb/haskell-readability), [mailing list](https://lists.sr.ht/~geyaeb/haskell-readability) and [ticket tracker](https://todo.sr.ht/~geyaeb/haskell-readability). + +Patches, suggestions, questions and general discussions can be send to the [mailing list](https://lists.sr.ht/~geyaeb/haskell-readability). Detailed information about sending patches by email can be found at [https://man.sr.ht/hg.sr.ht/email.md](https://man.sr.ht/hg.sr.ht/email.md). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BlockArguments #-} + +module Main where + +import qualified Data.Text.Lazy.IO as TL +import Network.HTTP.Simple +import Options.Applicative +import qualified Readability as R +import Text.XML + +data Source = File FilePath | Web Request deriving (Show) + +data Opts = Opts {optInput :: Source} deriving (Show) + +main :: IO () +main = do + (Opts src) <- execParser opts + article <- case src of + File f -> R.fromFile f + Web req -> R.fromByteString . getResponseBody <$> httpLBS req + case R.summary <$> article of + Just doc -> TL.putStrLn $ renderText def {rsPretty = True, rsXMLDeclaration = True} doc + Nothing -> return () + +opts :: ParserInfo Opts +opts = + info + (options <**> helper) + ( fullDesc + <> progDesc "Provide FILE or URL as source" + <> header "readability - extract article from HTML" + ) + +options :: Parser Opts +options = do + inf <- argument source (metavar "SOURCE") + pure $ Opts inf + +source :: ReadM Source +source = maybeReader \s -> Web <$> parseRequest s <|> Just (File s) diff --git a/readability.cabal b/readability.cabal new file mode 100644 --- /dev/null +++ b/readability.cabal @@ -0,0 +1,69 @@ +cabal-version: >= 1.10 + +name: readability +version: 0.0.1.0 +synopsis: Extracts text of main article from HTML document +description: Give @readability@ an HTML document and it will detect and extract text of the article while removing everything unnecessary like menus, advertisements or sidebars. It is more or less reimplementation of [python-readability](https://github.com/buriy/python-readability). +homepage: https://sr.ht/~geyaeb/haskell-readability +bug-reports: https://todo.sr.ht/~geyaeb/haskell-readability +license: BSD3 +license-file: LICENSE +author: G. Eyaeb +maintainer: geyaeb@protonmail.com +copyright: 2020 G. Eyaeb +category: Text, HTML +build-type: Simple +extra-source-files: CHANGELOG.md, README.md + +source-repository head + type: mercurial + location: https://hg.sr.ht/~geyaeb/haskell-readability + +library + exposed-modules: + Readability + Readability.Clean + Readability.Helper + Readability.Internal + Readability.Metrics + Readability.Types + hs-source-dirs: + src + ghc-options: + -Wall + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + -Wredundant-constraints + -fhide-source-paths + -Wmissing-export-lists + -Wpartial-fields + build-depends: + base >=4.7 && <5 + , bytestring == 0.10.* + , containers == 0.6.* + , html-conduit == 1.3.* + , text == 1.2.* + , xml-conduit >=1.7 && <2 + default-language: + Haskell2010 + +executable readability + main-is: Main.hs + hs-source-dirs: + app + ghc-options: + -threaded + -rtsopts + -with-rtsopts=-N + -Wall + build-depends: + base >=4.7 && <5 + , http-conduit == 2.3.* + , optparse-applicative == 0.15.* + , readability + , text == 1.2.* + , xml-conduit >=1.7 && <2 + default-language: + Haskell2010 diff --git a/src/Readability.hs b/src/Readability.hs new file mode 100644 --- /dev/null +++ b/src/Readability.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Readability + ( -- * Data types + Article (..), + + -- * Construction + fromByteString, + fromDocument, + fromFile, + fromText, + ) +where + +import Data.ByteString.Lazy (ByteString) +import Data.Text.Lazy (Text) +import Readability.Internal as I +import Readability.Types +import qualified Text.HTML.DOM as DOM +import Text.XML (Document) + +-- | Extracts article from HTML represented as HTML document. +fromDocument :: Document -> Maybe Article +fromDocument = fromDocument' strictSettings + +-- | Extracts article from HTML represented as HTML document. +fromDocument' :: Settings -> Document -> Maybe Article +fromDocument' s d = Article <$> I.summary s d + +-- | Extracts article from HTML in ByteString. +fromByteString :: ByteString -> Maybe Article +fromByteString = fromDocument . DOM.parseLBS + +-- | Extracts article from HTML in given file. +fromFile :: FilePath -> IO (Maybe Article) +fromFile f = fromDocument <$> DOM.readFile f + +-- | Extracts article from HTML in given text. +fromText :: Text -> Maybe Article +fromText = fromDocument . DOM.parseLT + +strictSettings :: Settings +strictSettings = + Settings + { reRemoveAttributes = (`elem` ["class"]) + } + +{- +looseSettings :: Settings +looseSettings = + Settings + { reRemoveAttributes = const False + } +-} diff --git a/src/Readability/Clean.hs b/src/Readability/Clean.hs new file mode 100644 --- /dev/null +++ b/src/Readability/Clean.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Readability.Clean + ( cleanElement, + paradivs, + sanitizeNode, + ) +where + +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) +import Data.Maybe (fromMaybe, mapMaybe) +import qualified Data.Text as T +import Data.Text (Text) +import Readability.Helper +import Readability.Metrics +import Readability.Types +import Text.XML +import Text.XML.Cursor + +-- | Remove elements that do not contribute to the article. +-- +-- Removes: +-- +-- * headings that are part of ads, menus, widgets etc. +-- * forms, textareas +-- * iframes +-- * block elements (div, section, table etc.) with enough textual content +-- +-- Preserves: +-- +-- * textual content +sanitizeNode :: Settings -> Scores -> Node -> Maybe Node +sanitizeNode s _ n@(NodeElement e@(Element t as children)) + | t `elem` ["h1", "h2", "h3", "h4", "h5", "h6"] = + guarded (const $ classWeight e >= 0 && linkDensity (fromNode n) <= 0.33) (NodeElement (Element t (sanitizeAttributes s as) children)) +sanitizeNode _ _ (NodeElement e) | e `elin` ["form", "textarea"] = Nothing +sanitizeNode _ _ (NodeElement e) + | e `elin` ["iframe"] = + case Map.lookup "src" $ elementAttributes e of + Just v | "videoRe" `T.isInfixOf` v -> Just (NodeContent "VIDEO") + _ -> Nothing +sanitizeNode s m (NodeElement e@(Element t as children)) + | e `elin` ["table", "ul", "div", "aside", "header", "footer", "section"] = + sanitizeContent m (NodeElement $ Element t (sanitizeAttributes s as) (mapMaybe (sanitizeNode s m) children)) +sanitizeNode s m (NodeElement (Element t as children)) = + Just $ NodeElement $ Element t (sanitizeAttributes s as) (mapMaybe (sanitizeNode s m) children) +sanitizeNode _ _ c@(NodeContent _) = Just c +sanitizeNode _ _ _ = Nothing + +-- | Remove content of block elements that do not have enough textual content. +sanitizeContent :: Scores -> Node -> Maybe Node +sanitizeContent m n + | score + weight < 0 = Nothing + | T.count "," txt >= 10 = Just n + | cntP > 0 && (fromIntegral cntImg :: Double) > 1.0 + fromIntegral cntP * 1.3 = Nothing + | cntLi > cntP && not isList = Nothing + | (fromIntegral cntInput :: Double) > fromIntegral cntP / 3 = Nothing + | len < 25 && cntImg == 0 = Nothing + | len < 25 && cntImg > 2 = Nothing + | weight < 25 && density > 0.2 = Nothing + | weight >= 25 && density > 0.5 = Nothing + | (cntEmbed == 1 && len < 75) || cntEmbed > 1 = Nothing + | len > 0 && preds + succs > 1000 = Just n + | otherwise = Just n + where + score = fromMaybe 0 $ lookupScore n m + weight = maybe 0 classWeight $ getElement n + cursor = fromMaybe (fromNode n) $ lookupCursor n m + txt = innerText cursor + density = linkDensity cursor + len = T.length txt + cntP = count "p" cursor + cntImg = count "img" cursor + cntLi = count "li" cursor - 100 + cntEmbed = count "embed" cursor + cntInput = count "input" cursor - cntInputHidden + cntInputHidden = length (checkElement isHiddenInput cursor) + isList = maybe False (`elin` ["ol", "ul"]) $ getElement n + count :: Name -> Cursor -> Int + count en = length . checkName (== en) + preds = sum $ take 1 $ T.length . innerText <$> precedingSibling cursor + succs = sum $ take 1 $ T.length . innerText <$> followingSibling cursor + +-- | Remove element attributes. +sanitizeAttributes :: Settings -> Map Name T.Text -> Map Name T.Text +sanitizeAttributes Settings {..} = Map.filterWithKey (\k _ -> not $ reRemoveAttributes k) + +-- | Tests whether element is `input` of type `hidden`. +isHiddenInput :: Element -> Bool +isHiddenInput (Element n as _) = n == "input" && Map.lookup "type" as == Just "hidden" + +cleanNode :: Bool -> Node -> Maybe Node +cleanNode _ (NodeElement e) | elementName e `elem` ["script", "style", "link"] = Nothing +cleanNode True (NodeElement e) | isUnlikely e = Nothing +cleanNode r (NodeElement e) = Just $ NodeElement $ cleanElement r e +cleanNode _ c@(NodeContent _) = Just c +cleanNode _ _ = Nothing + +cleanElement :: Bool -> Element -> Element +cleanElement ruthless (Element t as children) = + Element + t + (Map.filterWithKey (\k _ -> k /= "style") as) + (mapMaybe (cleanNode ruthless) children) + +unlikely :: Text -> Bool +unlikely t = any (`T.isInfixOf` t) ["combx", "comment", "community", "disqus", "extra", "foot", "header", "menu", "remark", "rss", "shoutbox", "sidebar", "sponsor", "ad-break", "agegate", "pagination", "pager", "popup", "tweet", "twitter"] + +likely :: Text -> Bool +likely t = any (`T.isInfixOf` t) ["and", "article", "body", "column", "main", "shadow"] + +isUnlikely :: Element -> Bool +isUnlikely e = maybe False unl (attr "class" <> Just " " <> attr "id") + where + attr = flip Map.lookup (elementAttributes e) + unl s = unlikely s && not (likely s) && ((nameLocalName . elementName) e `notElem` ["html", "body"]) + +{- This works slightly differently than 'transform_misused_divs_into_paragraphs', + mainly because I did not understand how that was supposed to work. But also, + this implementation gives better results for our testcases. -} +paradivs :: Node -> Node +paradivs n@(NodeElement (Element "div" as children)) = + if null $ fromNode n $// checkName (`elem` ["blockquote", "dl", "div", "img", "ol", "p", "pre", "table", "ul"]) + then NodeElement $ Element "p" as children + else NodeElement $ Element "div" as (paradivs <$> children) +paradivs (NodeElement (Element n as children)) = NodeElement $ Element n as (paradivs <$> children) +paradivs e = e diff --git a/src/Readability/Helper.hs b/src/Readability/Helper.hs new file mode 100644 --- /dev/null +++ b/src/Readability/Helper.hs @@ -0,0 +1,30 @@ +module Readability.Helper + ( innerText, + content', + elin, + getElement, + guarded, + ) +where + +import Control.Applicative (Alternative (..)) +import Data.Text as T (Text, concat, strip) +import Text.XML +import Text.XML.Cursor + +innerText :: Cursor -> Text +innerText c = T.concat (c $// content') + +content' :: Cursor -> [Text] +content' = content &| T.strip + +getElement :: Node -> Maybe Element +getElement (NodeElement e) = Just e +getElement _ = Nothing + +elin :: Element -> [Name] -> Bool +elin e [n] = elementName e == n +elin e ns = elementName e `elem` ns + +guarded :: (Alternative f) => (a -> Bool) -> a -> f a +guarded p x = if p x then pure x else empty diff --git a/src/Readability/Internal.hs b/src/Readability/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Readability/Internal.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Readability.Internal + ( Readability.Internal.summary, + rootSummary, + ) +where + +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Readability.Clean +import Readability.Helper +import Readability.Metrics +import Readability.Types +import Text.XML +import Text.XML.Cursor +import Prelude hiding (div) + +summary :: Settings -> Document -> Maybe Document +summary s doc = document <$> rootSummary s True (documentRoot doc) + +rootSummary :: Settings -> Bool -> Element -> Maybe Element +rootSummary s ruthless root = + if ruthless && T.length (innerText clean) <= 250 + then rootSummary s False root + else cleanedArticle + where + clean = fromNode $ paradivs $ NodeElement (cleanElement ruthless root) + candidates = clean $// checkName (`elem` ["p", "pre", "td"]) + + cleanedArticle = case scoreParagraphs candidates of + Nothing -> Nothing + Just scores -> + let (bestCursor, score) = maxScore scores + article = getArticle bestCursor score scores + in sanitizeNode s scores article >>= getElement + +getArticle :: Cursor -> Double -> Scores -> Node +getArticle best score scores = html $ body $ div $ node <$> filter f siblings + where + siblings = precedingSibling best ++ best : followingSibling best + threshold = 10 `max` score * 0.2 + f c = + node c == node best + || any (>= threshold) (lookupScore (node c) scores) + || (any (\e -> elementName e == "p") (getElement (node c)) && textualSibling c) + +html, body :: Node -> Node +html n = NodeElement $ Element "html" Map.empty [n] +body n = NodeElement $ Element "body" Map.empty [n] + +div :: [Node] -> Node +div ns = NodeElement $ Element "div" Map.empty ns + +document :: Element -> Document +document e = Document (Prologue [] Nothing []) e [] diff --git a/src/Readability/Metrics.hs b/src/Readability/Metrics.hs new file mode 100644 --- /dev/null +++ b/src/Readability/Metrics.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Readability.Metrics + ( classWeight, + contentScore, + linkDensity, + scoreAncestor, + scoreParagraph, + scoreParagraphs, + textualSibling, + ) +where + +import qualified Data.Map.Strict as Map +import Data.Monoid (Sum (..)) +import Data.Text (Text) +import qualified Data.Text as T +import Readability.Helper +import Readability.Types +import Text.XML +import Text.XML.Cursor + +positive :: Text -> Bool +positive t = any (`T.isInfixOf` t) ["article", "body", "content", "entry", "hentry", "main", "page", "pagination", "post", "text", "blog", "story"] + +negative :: Text -> Bool +negative t = any (`T.isInfixOf` t) ["combx", "comment", "com-", "contact", "foot", "footer", "footnote", "masthead", "media", "meta", "outbrain", "promo", "related", "scroll", "shoutbox", "sidebar", "sponsor", "shopping", "tags", "tool", "widget"] + +linkDensity :: Cursor -> Double +linkDensity c = links / (total `max` 1) + where + len = fromIntegral . T.length . T.strip + total = len $ innerText c + links = len $ T.concat $ c $// element "a" &// content' + +classWeight :: Element -> Double +classWeight e = maybe 0 getSum (sa "class" `mappend` sa "id") + where + sa :: Name -> Maybe (Sum Double) + sa attr = Sum . st <$> Map.lookup attr (elementAttributes e) + st :: Text -> Double + st t + | positive t = 25 + | negative t = -25 + st _ = 0 + +contentScore :: Cursor -> Maybe Double +contentScore c = if len < 25 then Nothing else Just score + where + text = innerText c + -- TODO clean(elem.text_content() or "") + len = T.length text + score = + 1 + + fromIntegral (length $ T.split (== ',') text) + + min 3 (fromIntegral len / 100) + +scoreAncestor :: Cursor -> Double +scoreAncestor cursor = maybe 0 (\e -> score e + classWeight e) elm + where + elm = getElement $ node cursor + score :: Element -> Double + score e = case T.toLower $ nameLocalName $ elementName e of + n + | n `elem` ["div", "article"] -> 5 + | n `elem` ["pre", "td", "blockquote"] -> 3 + | n `elem` ["address", "ol", "ul", "dl", "dd", "dt", "li", "form", "aside"] -> -3 + | n `elem` ["h1", "h2", "h3", "h4", "h5", "h6", "th", "header", "footer", "nav"] -> -5 + _ -> 0 + +scoreParagraphs :: [Cursor] -> Maybe Scores +scoreParagraphs cs = if nullScores scores then Nothing else Just scores + where + scores = mapScores (\c s -> (c, s * (1 - linkDensity c))) $ foldl scoreParagraph emptyScores cs + +scoreParagraph :: Scores -> Cursor -> Scores +scoreParagraph scores cursor = + case contentScore cursor of + Nothing -> scores + Just score -> + case take 2 $ ancestor cursor of + [pc, gpc] -> insert (scoreAncestor pc) score pc $ insert (scoreAncestor gpc) (score / 2) gpc scores + [pc] -> insert (scoreAncestor pc) score pc scores + _ -> scores + where + insert ns cs c = + alterScores + ( \case + Nothing -> Just (c, ns + cs) + Just (c', v) -> Just (c', v + cs) + ) + (node c) + +textualSibling :: Cursor -> Bool +textualSibling c = (nodelen > 80 && ld < 0.25) || (nodelen <= 80 && ld == 0 && (". " `T.isInfixOf` nodetxt || "." `T.isSuffixOf` nodetxt)) + where + nodetxt = innerText c + nodelen = T.length nodetxt + ld = linkDensity c diff --git a/src/Readability/Types.hs b/src/Readability/Types.hs new file mode 100644 --- /dev/null +++ b/src/Readability/Types.hs @@ -0,0 +1,60 @@ +module Readability.Types + ( Article (..), + Settings (..), + Scores (..), + alterScores, + emptyScores, + lookupCursor, + lookupScore, + mapScores, + maxScore, + nullScores, + ) +where + +import Data.List (maximumBy) +import qualified Data.Map.Strict as M +-- import qualified Data.Text as T +import Text.XML +import Text.XML.Cursor + +-- | Result of processing HTML through /readability/. +data Article = Article + { -- | Body of article of original HTML. + summary :: Document + {- Title of original HTML if found. + title :: Maybe T.Text, + -- Possibly simplified title. + shortTitle :: Maybe T.Text-} + } + deriving (Show) + +data Settings = Settings + { -- | Remove HTML attributes for which the function returns true + reRemoveAttributes :: Name -> Bool + } + +newtype Scores = Scores {scoreMap :: M.Map Node (Cursor, Double)} deriving (Show) + +alterScores :: (Maybe (Cursor, Double) -> Maybe (Cursor, Double)) -> Node -> Scores -> Scores +alterScores f n (Scores sm) = Scores (M.alter f n sm) + +emptyScores :: Scores +emptyScores = Scores M.empty + +nullScores :: Scores -> Bool +nullScores (Scores sm) = M.null sm + +mapScores :: (Cursor -> Double -> (Cursor, Double)) -> Scores -> Scores +mapScores f (Scores sm) = Scores $ M.map (uncurry f) sm + +lookupScore :: Node -> Scores -> Maybe Double +lookupScore n (Scores sm) = snd <$> M.lookup n sm + +lookupCursor :: Node -> Scores -> Maybe Cursor +lookupCursor n (Scores sm) = fst <$> M.lookup n sm + +maxScore :: Scores -> (Cursor, Double) +maxScore (Scores sm) = snd $ maximumBy (\a b -> compare (ssnd a) (ssnd b)) $ M.toList sm + where + ssnd = snd . snd