diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# 0.2.0 + +- `html-parse-utils` -> `html-parse-util` diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright Neil Mitchell 2006–2019, + Tony Zorman 2020–2022. +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 Neil Mitchell 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,8 @@ +# html-parse-utils + +This is a reimplementation of utility functions from Neil Mitchell's +[TagSoup library], as well as some extra functionality, for Ben Gamari's +[html-parse library]; because yay `Text` and yay `Attoparsec`. + +[TagSoup library]: https://hackage.haskell.org/package/tagsoup +[html-parse library]: https://hackage.haskell.org/package/html-parse diff --git a/html-parse-util.cabal b/html-parse-util.cabal new file mode 100644 --- /dev/null +++ b/html-parse-util.cabal @@ -0,0 +1,46 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.6. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 4509b87ce78b0d31cd8627a9f17a0d7e344fa10333c6ce49efc2dedc47d264d3 + +name: html-parse-util +version: 0.2.0 +synopsis: Utility functions for working with html-parse +description: See README.md +category: Text, XML +homepage: https://github.com/slotThe/html-parse-util#readme +bug-reports: https://github.com/slotThe/html-parse-util/issues +author: Neil Mitchell (TagSoup), Tony Zorman (port to html-parse) +maintainer: soliditsallgood@mailbox.org +copyright: 2006–2019 Neil Mitchell, 2020–2022 Tony Zorman +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/slotThe/html-parse-util + +library + exposed-modules: + Text.HTML.Parser.Util + other-modules: + Paths_html_parse_util + hs-source-dirs: + lib + default-extensions: + OverloadedStrings + LambdaCase + ghc-options: -Weverything -Wno-implicit-prelude -Wno-missing-import-lists -Wno-unused-packages -Wno-missing-safe-haskell-mode -Wno-all-missed-specialisations -Wno-unsafe -Wno-prepositive-qualified-module + build-depends: + attoparsec >=0.13 && <0.15 + , base >=4.7 && <5 + , html-parse >=0.2.0.2 && <0.3 + , text ==1.2.* + default-language: Haskell2010 diff --git a/lib/Text/HTML/Parser/Util.hs b/lib/Text/HTML/Parser/Util.hs new file mode 100644 --- /dev/null +++ b/lib/Text/HTML/Parser/Util.hs @@ -0,0 +1,237 @@ +{- | + Module : Text.HTML.Parser.Util + Description : Utility functions for the html-parse library + Copyright : (c) Neil Mitchell 2006–2019 (TagSoup), + Tony Zorman 2020–2022 (port to html-parse) + License : BSD-3 + Maintainer : Tony Zorman + Stability : experimental + Portability : non-portable + +Utility functions to make working with @html-parse@ as easy as working +with TagSoup! Most functions are one-to-one replacements for their +respective TagSoup analogues and work the same way. +-} +module Text.HTML.Parser.Util + ( -- * Conversion + toToken -- :: Text -> Token + , toTokenDefault -- :: Token -> Text -> Token + + -- * Tag identification + , isTagOpen -- :: Token -> Bool + , isTagClose -- :: Token -> Bool + , isTagSelfClose -- :: Token -> Bool + , isContentText -- :: Token -> Bool + , isContentChar -- :: Token -> Bool + , isComment -- :: Token -> Bool + , isDoctype -- :: Token -> Bool + , isTagOpenName -- :: Text -> Token -> Bool + , isTagCloseName -- :: Text -> Token -> Bool + + -- * Extraction + , fromContentText -- :: Token -> Text + , maybeContentText -- :: Token -> Maybe Text + , fromAttrib -- :: Attr -> Token -> Attr + , maybeAttrib -- :: Attr -> Token -> Maybe Attr + , innerText -- :: [Token] -> Text + , toHeadContentText -- :: [Token] -> Text + , between -- :: Token -> Token -> [Token] -> [Token] + , dropHeader -- :: [Attr] -> [Token] -> [Token] + , allContentText -- :: [Token] -> [Text] + + -- * Utility + , sections -- :: (a -> Bool) -> [a] -> [[a]] + , section -- :: (a -> Bool) -> [a] -> [a] + , partitions -- :: (a -> Bool) -> [a] -> [[a]] + + -- * Combinators + , (~==) -- :: Token -> Token -> Bool + , (~/=) -- :: Token -> Token -> Bool + ) where + +import qualified Data.Attoparsec.Text as A +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T + +import Data.Either (fromRight) +import Data.List (groupBy, tails) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Text (Text) +import Text.HTML.Parser (Attr (Attr), Token (Comment, ContentChar, ContentText, Doctype, TagClose, TagOpen, TagSelfClose), token) + + +-- | Like 'toTokenDefault', but with a supplied default value. +-- +-- >>> toToken "text" +-- ContentText "text" +toToken :: Text -> Token +toToken = toTokenDefault (Doctype "Could not parse string into token.") + +-- | Convert 'Text' to 'Token', with a default in case of a parse failure. +toTokenDefault :: Token -> Text -> Token +toTokenDefault d = fromRight d . A.parseOnly token + +-- | This function takes a list, and returns all suffixes whose first item +-- matches the predicate. +-- +-- >>> sections (== 'c') "abc cba ccb" +-- ["c cba ccb","cba ccb","ccb","cb"] +sections :: (a -> Bool) -> [a] -> [[a]] +sections p = filter (p . head) . init . tails + +-- | Like 'sections', but return the head element. Returns an empty list if no +-- head element is present. +-- +-- >>> section (== 'c') "abc cba ccb" +-- "c cba ccb" +section :: (a -> Bool) -> [a] -> [a] +section f = \case + [] -> [] + xs -> maybe [] NE.head (NE.nonEmpty (sections f xs)) + +-- | This function is similar to 'sections', but splits the list so no element +-- appears in any two partitions. +-- +-- >>> partitions (== 'c') "abc cba ccb" +-- ["c ","cba ","c","cb"] +partitions :: (a -> Bool) -> [a] -> [[a]] +partitions p = groupBy (const notp) . dropWhile notp + where notp = not . p + +-- | Get the first 'ContentText' element from a list of 'Token's. If no tag +-- could be found, return an empty string. +toHeadContentText :: [Token] -> Text +toHeadContentText = maybe "" NE.head . NE.nonEmpty . allContentText + +-- | Get all 'Token's between @start@ and @end@. +between :: Token -> Token -> [Token] -> [Token] +between start end = takeWhile (~/= end ) + . drop 1 -- drop the tag + . dropWhile (~/= start) + +-- | Drop an HTML header (i.e. the header tags and everything in between), as +-- well as everything before it, from a list of 'Token's. +dropHeader :: [Attr] -> [Token] -> [Token] +dropHeader attr = drop 1 -- drop + . dropWhile (~/= TagClose "header" ) + . dropWhile (~/= TagOpen "header" attr) + +-- | Get all 'ContentText' entries from a list of 'Token's and extract their +-- content. +allContentText :: [Token] -> [Text] +allContentText = mapMaybe maybeContentText + +-- | Test if a 'Token' is a 'TagOpen'. +isTagOpen :: Token -> Bool +isTagOpen = \case + TagOpen{} -> True + _ -> False + +-- | Test if a 'Token' is a 'TagClose'. +isTagClose :: Token -> Bool +isTagClose = \case + TagClose{} -> True + _ -> False + +-- | Test if a 'Token' is a 'ContentText'. +isContentText :: Token -> Bool +isContentText = \case + ContentText{} -> True + _ -> False + +-- | Extract the string from within 'ContentText', otherwise return 'Nothing'. +maybeContentText :: Token -> Maybe Text +maybeContentText = \case + ContentText t -> Just t + _ -> Nothing + +-- | Extract the string from within 'ContentText', crashes if not a +-- 'ContentText'. +fromContentText :: Token -> Text +fromContentText = \case + ContentText t -> t + t -> error $ "(" ++ show t ++ ") is not a ContentText" + +-- | Extract all text content from a list of Tokens (similar to Verbatim found +-- in HaXml). +innerText :: [Token] -> Text +innerText = mconcat . mapMaybe maybeContentText + +-- | Test if a 'Token' is a 'TagSelfClose'. +isTagSelfClose :: Token -> Bool +isTagSelfClose = \case + TagSelfClose{} -> True + _ -> False + +-- | Test if a 'Token' is a 'ContentChar'. +isContentChar :: Token -> Bool +isContentChar = \case + ContentChar{} -> True + _ -> False + +-- | Test if a 'Token' is a 'Comment'. +isComment :: Token -> Bool +isComment = \case + Comment{} -> True + _ -> False + +-- | Test if a 'Token' is a 'Doctype'. +isDoctype :: Token -> Bool +isDoctype = \case + Doctype{} -> True + _ -> False + +-- | Returns True if the 'Token' is 'TagOpen' and matches the given name. +isTagOpenName :: Text -> Token -> Bool +isTagOpenName name (TagOpen n _) = n == name +isTagOpenName _ _ = False + +-- | Returns True if the 'Token' is 'TagClose' and matches the given name. +isTagCloseName :: Text -> Token -> Bool +isTagCloseName name (TagClose n) = n == name +isTagCloseName _ _ = False + +-- | Extract an attribute; crashes if not a 'TagOpen'. Returns @Attr \"\" \"\"@ +-- if no attribute present. +-- +-- Warning: does not distinguish between missing attribute and present +-- attribute with values @\"\"@. +fromAttrib :: Attr -> Token -> Attr +fromAttrib att tag = fromMaybe (Attr "" "") $ maybeAttrib att tag + +-- | Extract an attribute; crashes if not a 'TagOpen'. Returns +-- 'Nothing' if no attribute present. +maybeAttrib :: Attr -> Token -> Maybe Attr +maybeAttrib att (TagOpen _ atts) + | att `elem` atts = Just att + | otherwise = Nothing +maybeAttrib _ t = error ("(" ++ show t ++ ") is not a TagOpen") + +infixl 9 ~== +-- | Performs an inexact match, the first item should be the thing to +-- match. +-- +-- >>> ContentText "test" ~== ContentText "" +-- True +-- +-- >>> TagOpen "div" [Attr "class" "division ", Attr "id" "dd"] ~== TagOpen "div" [Attr "class" "division "] +-- True +(~==) :: Token -> Token -> Bool +(~==) = f + where + f (ContentText y) (ContentText x) = T.null x || x == y + f (TagClose y) (TagClose x) = T.null x || x == y + f (Comment x) (Comment y) = x == mempty || x == y + f (TagOpen y ys) (TagOpen x xs) = (T.null x || x == y) && all g xs + where + g :: Attr -> Bool + g nv@(Attr name val) + | T.null name = val `elem` map (\(Attr o _) -> o) ys + | T.null val = name `elem` map (\(Attr _ t) -> t) ys + | otherwise = nv `elem` ys + f _ _ = False + +infixl 9 ~/= +-- | Negation of '(~==)'. +(~/=) :: Token -> Token -> Bool +(~/=) a b = not (a ~== b)