diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2017, William Yao +Copyright (c) 2017-2024, William Yao All rights reserved. diff --git a/Text/HTML/Onama.hs b/Text/HTML/Onama.hs deleted file mode 100644 --- a/Text/HTML/Onama.hs +++ /dev/null @@ -1,318 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{-| - Module: Text.HTML.Onama - Description: Parsec extended with functions to handle HTML parsing. - Copyright: (c) William Yao, 2017 - License: BSD-3 - Maintainer: williamyaoh@gmail.com - Stability: experimental - - Some extra primitives to parse HTMl with Parsec. - - You'll still need to import "Text.Parsec" along with this library. These - primitives will work with all the combinators from Parsec. Note that you'll - need to override Parsec's @satisfies@, since that one only works on - character streams (for some reason). - - > testParser = dp - > tagOpen "b" - > bolded <- text - > tagClose "b" - - > testParser2 = do - > tagClose "div" - > tagOpen "p" - > inner <- text - > tagClose "p" - -} -module Text.HTML.Onama - ( Tag(..) - , Position - - , parseTags - - , tag - , satisfy - - , TagOpenSelector(..) - , TagCloseSelector(..) - , AttrName(..) - , AttrValue(..) - , AttrSelector(..) - - , (@:), (@=) - - , tagOpen_, tagOpen - , tagClose_, tagClose - , tagText - , balancedTags - , anyOpenTag, anyCloseTag, anyValue - , innerText - - , skip - ) -where - -import qualified Text.HTML.TagSoup as TS -import Text.StringLike - -import qualified Text.Parsec as P -import Text.Parsec - ( (<|>), (), label, labels - , try, unexpected - , choice - , count, skipMany1, many1 - , sepBy, sepBy1, endBy, endBy1, sepEndBy, sepEndBy1 - , chainl, chainl1, chainr, chainr1 - , eof - , notFollowedBy - , manyTill - , lookAhead - , anyToken - , between - , option, optionMaybe, optional - , unknownError, sysUnExpectError, mergeErrorReply - ) - -import qualified Data.Sequence as S -import Data.Sequence - ( (<|), (|>), (><) ) - -import Data.String (IsString, fromString) - -import Data.Foldable (toList) - -type Position = (TS.Row, TS.Column) - -data Tag str - = TagOpen str [TS.Attribute str] Position - | TagClose str Position - | TagText str Position - deriving (Eq, Show) - -parseOptions :: StringLike str => TS.ParseOptions str -parseOptions = TS.parseOptions { TS.optTagPosition = True } - -type CurrentPos str = (Position, [Tag str]) - -startPos :: CurrentPos str -startPos = ((1, 1), []) - --- | Return a list of tags parsed from some sort of string. --- This list should then get fed into an Onama parser. -parseTags :: StringLike str => str -> [Tag str] -parseTags str = - reverse $ snd $ foldl attachPos startPos $ - TS.canonicalizeTags $ TS.parseTagsOptions parseOptions str - where attachPos (pos, tags) tag = - case tag of - TS.TagOpen name attrs -> (pos, TagOpen name attrs pos : tags) - TS.TagClose name -> (pos, TagClose name pos : tags) - TS.TagText text -> (pos, TagText text pos : tags) - TS.TagComment _ -> (pos, tags) - TS.TagWarning _ -> (pos, tags) - TS.TagPosition row col -> ((row, col), tags) - -updatePos :: P.SourcePos -> Tag str -> [Tag str] -> P.SourcePos -updatePos pos tok _ = - let (row, col) = case tok of - TagOpen _ _ pos -> pos - TagClose _ pos -> pos - TagText _ pos -> pos - in flip P.setSourceLine row $ flip P.setSourceColumn col $ pos - -tagName :: Tag str -> Maybe str -tagName (TagOpen name _ _) = Just name -tagName (TagClose name _ ) = Just name -tagName _other = Nothing - -data TagOpenSelector - = AnyOpenTag [AttrSelector] - | TagOpenSelector String [AttrSelector] - -data TagCloseSelector - = AnyCloseTag - | TagCloseSelector String - -instance IsString TagOpenSelector where - fromString str = TagOpenSelector str [] - -instance IsString TagCloseSelector where - fromString = TagCloseSelector - -tagSelectorAttrs :: TagOpenSelector -> [AttrSelector] -tagSelectorAttrs (AnyOpenTag attrs) = attrs -tagSelectorAttrs (TagOpenSelector _ attrs) = attrs - -newtype AttrName = AttrName String - -instance IsString AttrName where - fromString = AttrName - -data AttrValue - = AnyAttr - | AttrValue String - -instance IsString AttrValue where - fromString = AttrValue - -data AttrSelector = AttrSelector AttrName AttrValue - -instance IsString AttrSelector where - fromString str = AttrSelector (AttrName str) AnyAttr - -(@:) :: TagOpenSelector -> [AttrSelector] -> TagOpenSelector -(@:) tagS attrS = - case tagS of - AnyOpenTag _ -> AnyOpenTag attrS - TagOpenSelector name _ -> TagOpenSelector name attrS - -(@=) :: AttrName -> AttrValue -> AttrSelector -(@=) = AttrSelector - --- | Primitive. Return the next input tag. --- All other primitive parsers should be implemented in terms of this. -tag :: (Monad m, Show str) => P.ParsecT [Tag str] u m (Tag str) -tag = P.tokenPrim show updatePos Just - --- | Create a parser which parses a single HTML tag if it passes --- the given predicate. Return the parsed tag. -satisfy :: (Monad m, Show str) => (Tag str -> Bool) -> P.ParsecT [Tag str] u m (Tag str) -satisfy f = P.tokenPrim show updatePos $ \tag -> - if f tag then Just tag else Nothing - -matchAttrValue :: StringLike str => str -> AttrValue -> Bool -matchAttrValue val attrS = case attrS of - AnyAttr -> True - AttrValue val' -> toString val == val' - -tagOpen_ :: (Monad m, StringLike str, Show str) - => TagOpenSelector - -> P.ParsecT [Tag str] u m (Tag str) -tagOpen_ tagS = - satisfy (\tag -> case tag of - TagOpen name attrs _ -> - let attrS = tagSelectorAttrs tagS in - case tagS of - AnyOpenTag _ -> matchAttrs attrS attrs - TagOpenSelector name' _ -> - toString name == name' && matchAttrs attrS attrs - _other -> False) - "Couldn't parse an open tag." - where matchAttrs attrS attrs = - all (\(AttrSelector (AttrName name) attrValS) -> - case lookup (fromString name) attrs of - Just val -> matchAttrValue val attrValS - Nothing -> False) - attrS - -tagOpen :: (Monad m, StringLike str, Show str) - => TagOpenSelector - -> P.ParsecT [Tag str] u m (Tag str) -tagOpen tagS = try (optional tagText >> tagOpen_ tagS) - -tagClose_ :: (Monad m, StringLike str, Show str) - => TagCloseSelector - -> P.ParsecT [Tag str] u m (Tag str) -tagClose_ tagS = - satisfy (\tag -> case tag of - TagClose name _ -> - case tagS of - AnyCloseTag -> True - TagCloseSelector name' -> toString name == name' - _other -> False) - -tagClose :: (Monad m, StringLike str, Show str) - => TagCloseSelector - -> P.ParsecT [Tag str] u m (Tag str) -tagClose tagS = try (optional tagText >> tagClose_ tagS) - --- | Take a parser, return a parser which only succeeds if the given parser --- fails. Consumes no input. -notParse :: P.Stream s m t => P.ParsecT s u m t -> P.ParsecT s u m () -notParse parser = do - parsed <- try $ Just <$> parser - <|> return Nothing - case parsed of - Nothing -> return () - Just _ -> unexpected "parser given to notParse succeeded" - -tagText :: (Monad m, Show str) => P.ParsecT [Tag str] u m str -tagText = P.tokenPrim show updatePos $ \tag -> case tag of - TagText text _ -> Just text - _other -> Nothing - --- | Certain HTML elements are self closing. In addition, they can show --- up /without/ their closing slash. For these, we just want to go over --- their opening tag. --- These elements are void, according to the W3C spec: --- --- --- * area --- * base --- * br --- * col --- * command --- * embed --- * hr --- * img --- * input --- * keygen --- * link --- * meta --- * param --- * source --- * track --- * wbr -voidElement :: (Monad m, StringLike str, Show str) => P.ParsecT [Tag str] u m (Tag str) -voidElement = choice $ fmap tagOpen_ [ "area", "base", "br", "col", "command" - , "embed", "hr", "img", "input", "keygen" - , "link", "meta", "param", "source", "track" - , "wbr" - ] - -balancedTags_ :: (Monad m, StringLike str, Show str) - => TagOpenSelector - -> P.ParsecT [Tag str] u m (S.Seq (Tag str)) -balancedTags_ tagS = do - openTag <- tagOpen_ tagS - tailTags <- tagTail openTag - return $ openTag <| tailTags - -tagTail :: (Monad m, StringLike str, Show str) - => Tag str - -> P.ParsecT [Tag str] u m (S.Seq (Tag str)) -tagTail (TagOpen name _ _) = do - innerTags <- P.many $ try notMatchingClose - matchingClose <- tagClose_ closeS - return $ mconcat innerTags |> matchingClose - where closeS = TagCloseSelector $ toString name - notMatchingClose = ( S.singleton <$> (notParse (tagClose_ closeS) >> tag) - <|> S.singleton <$> voidElement - <|> (balancedTags_ anyOpenTag) - ) - -balancedTags :: (Monad m, StringLike str, Show str) - => TagOpenSelector - -> P.ParsecT [Tag str] u m [Tag str] -balancedTags tagS = optional tagText >> toList <$> balancedTags_ tagS - -anyOpenTag :: TagOpenSelector -anyOpenTag = AnyOpenTag [] - -anyCloseTag :: TagCloseSelector -anyCloseTag = AnyCloseTag - -anyValue :: AttrValue -anyValue = AnyAttr - --- | @skip p@ produces a parser which will ignore the output of @p@. -skip :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m () -skip p = p >> return () - -innerText :: StringLike str => [Tag str] -> str -innerText tags = fromString $ toList $ mconcat $ fmap tagInner tags - where tagInner (TagOpen "br" _ _) = S.singleton '\n' - tagInner (TagText text _) = S.fromList $ toString text - tagInner _other = S.empty diff --git a/onama.cabal b/onama.cabal --- a/onama.cabal +++ b/onama.cabal @@ -1,73 +1,30 @@ --- Initial onama.cabal generated by cabal init. For further documentation, --- see http://haskell.org/cabal/users-guide/ - --- The name of the package. -name: onama - --- The package version. See the Haskell package versioning policy (PVP) --- for standards guiding when and how versions should be incremented. --- http://www.haskell.org/haskellwiki/Package_versioning_policy --- PVP summary: +-+------- breaking API changes --- | | +----- non-breaking API additions --- | | | +--- code changes with no API change -version: 0.2.2.0 +cabal-version: >=1.10 +name: onama +version: 0.2.3.0 synopsis: HTML-parsing primitives for Parsec. - --- A longer description of the package. description: Provides Parsec primitives for parsing various HTML entities. Requires Parsec in order to use and combine them. - --- The license under which the package is released. -license: BSD3 - --- The file containing the license text. -license-file: LICENSE - --- The package author(s). +homepage: https://github.com/williamyaoh/onama/ +bug-reports: https://github.com/williamyaoh/onama/issues/ +category: Data, Text author: William Yao - --- An email address to which users can send suggestions, bug reports, and --- patches. maintainer: williamyaoh@gmail.com - --- A copyright notice. --- copyright: - -category: Text - +license: BSD3 +license-file: LICENSE build-type: Simple --- Extra files to be distributed with the package, such as examples or a --- README. --- extra-source-files: - --- Constraint on the version of Cabal needed to build this package. -cabal-version: >=1.10 - --- Information about the package's version control system. source-repository head type: git location: https://www.github.com/williamyaoh/onama/ library - -- Modules exported by the library. - exposed-modules: Text.HTML.Onama - - -- Modules included in this library but not exported. - -- other-modules: - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: - - -- Other library packages from which modules are imported. - build-depends: base >=4.8 && <4.9 - , tagsoup - , parsec - , containers - - -- Directories containing source files. - -- hs-source-dirs: - - -- Base language which the package is written in. + exposed-modules: + Text.HTML.Onama + build-depends: + base ==4.* + , tagsoup ==0.14.* + , parsec <3.2 + , containers <0.7 + hs-source-dirs: src/lib default-language: Haskell2010 diff --git a/src/lib/Text/HTML/Onama.hs b/src/lib/Text/HTML/Onama.hs new file mode 100644 --- /dev/null +++ b/src/lib/Text/HTML/Onama.hs @@ -0,0 +1,319 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| + Module: Text.HTML.Onama + Description: Parsec extended with functions to handle HTML parsing. + Copyright: (c) William Yao, 2017-2024 + License: BSD-3 + Maintainer: williamyaoh@gmail.com + Stability: experimental + + Some extra primitives to parse HTMl with Parsec. + + You'll still need to import "Text.Parsec" along with this library. These + primitives will work with all the combinators from Parsec. Note that you'll + need to override Parsec's @satisfies@, since that one only works on + character streams (for some reason). + + > testParser = dp + > tagOpen "b" + > bolded <- text + > tagClose "b" + + > testParser2 = do + > tagClose "div" + > tagOpen "p" + > inner <- text + > tagClose "p" + -} +module Text.HTML.Onama + ( Tag(..) + , Position + + , parseTags + + , tag + , satisfy + + , TagOpenSelector(..) + , TagCloseSelector(..) + , AttrName(..) + , AttrValue(..) + , AttrSelector(..) + + , (@:), (@=) + + , tagOpen_, tagOpen + , tagClose_, tagClose + , tagText + , voidElement + , balancedTags + , anyOpenTag, anyCloseTag, anyValue + , innerText + + , skip + ) +where + +import qualified Text.HTML.TagSoup as TS +import Text.StringLike + +import qualified Text.Parsec as P +import Text.Parsec + ( (<|>), (), label, labels + , try, unexpected + , choice + , count, skipMany1, many1 + , sepBy, sepBy1, endBy, endBy1, sepEndBy, sepEndBy1 + , chainl, chainl1, chainr, chainr1 + , eof + , notFollowedBy + , manyTill + , lookAhead + , anyToken + , between + , option, optionMaybe, optional + , unknownError, sysUnExpectError, mergeErrorReply + ) + +import qualified Data.Sequence as S +import Data.Sequence + ( (<|), (|>), (><) ) + +import Data.String (IsString, fromString) + +import Data.Foldable (toList) + +type Position = (TS.Row, TS.Column) + +data Tag str + = TagOpen str [TS.Attribute str] Position + | TagClose str Position + | TagText str Position + deriving (Eq, Show) + +parseOptions :: StringLike str => TS.ParseOptions str +parseOptions = TS.parseOptions { TS.optTagPosition = True } + +type CurrentPos str = (Position, [Tag str]) + +startPos :: CurrentPos str +startPos = ((1, 1), []) + +-- | Return a list of tags parsed from some sort of string. +-- This list should then get fed into an Onama parser. +parseTags :: StringLike str => str -> [Tag str] +parseTags str = + reverse $ snd $ foldl attachPos startPos $ + TS.canonicalizeTags $ TS.parseTagsOptions parseOptions str + where attachPos (pos, tags) tag = + case tag of + TS.TagOpen name attrs -> (pos, TagOpen name attrs pos : tags) + TS.TagClose name -> (pos, TagClose name pos : tags) + TS.TagText text -> (pos, TagText text pos : tags) + TS.TagComment _ -> (pos, tags) + TS.TagWarning _ -> (pos, tags) + TS.TagPosition row col -> ((row, col), tags) + +updatePos :: P.SourcePos -> Tag str -> [Tag str] -> P.SourcePos +updatePos pos tok _ = + let (row, col) = case tok of + TagOpen _ _ pos -> pos + TagClose _ pos -> pos + TagText _ pos -> pos + in flip P.setSourceLine row $ flip P.setSourceColumn col $ pos + +tagName :: Tag str -> Maybe str +tagName (TagOpen name _ _) = Just name +tagName (TagClose name _ ) = Just name +tagName _other = Nothing + +data TagOpenSelector + = AnyOpenTag [AttrSelector] + | TagOpenSelector String [AttrSelector] + +data TagCloseSelector + = AnyCloseTag + | TagCloseSelector String + +instance IsString TagOpenSelector where + fromString str = TagOpenSelector str [] + +instance IsString TagCloseSelector where + fromString = TagCloseSelector + +tagSelectorAttrs :: TagOpenSelector -> [AttrSelector] +tagSelectorAttrs (AnyOpenTag attrs) = attrs +tagSelectorAttrs (TagOpenSelector _ attrs) = attrs + +newtype AttrName = AttrName String + +instance IsString AttrName where + fromString = AttrName + +data AttrValue + = AnyAttr + | AttrValue String + +instance IsString AttrValue where + fromString = AttrValue + +data AttrSelector = AttrSelector AttrName AttrValue + +instance IsString AttrSelector where + fromString str = AttrSelector (AttrName str) AnyAttr + +(@:) :: TagOpenSelector -> [AttrSelector] -> TagOpenSelector +(@:) tagS attrS = + case tagS of + AnyOpenTag _ -> AnyOpenTag attrS + TagOpenSelector name _ -> TagOpenSelector name attrS + +(@=) :: AttrName -> AttrValue -> AttrSelector +(@=) = AttrSelector + +-- | Primitive. Return the next input tag. +-- All other primitive parsers should be implemented in terms of this. +tag :: (Monad m, Show str) => P.ParsecT [Tag str] u m (Tag str) +tag = P.tokenPrim show updatePos Just + +-- | Create a parser which parses a single HTML tag if it passes +-- the given predicate. Return the parsed tag. +satisfy :: (Monad m, Show str) => (Tag str -> Bool) -> P.ParsecT [Tag str] u m (Tag str) +satisfy f = P.tokenPrim show updatePos $ \tag -> + if f tag then Just tag else Nothing + +matchAttrValue :: StringLike str => str -> AttrValue -> Bool +matchAttrValue val attrS = case attrS of + AnyAttr -> True + AttrValue val' -> toString val == val' + +tagOpen_ :: (Monad m, StringLike str, Show str) + => TagOpenSelector + -> P.ParsecT [Tag str] u m (Tag str) +tagOpen_ tagS = + satisfy (\tag -> case tag of + TagOpen name attrs _ -> + let attrS = tagSelectorAttrs tagS in + case tagS of + AnyOpenTag _ -> matchAttrs attrS attrs + TagOpenSelector name' _ -> + toString name == name' && matchAttrs attrS attrs + _other -> False) + "Couldn't parse an open tag." + where matchAttrs attrS attrs = + all (\(AttrSelector (AttrName name) attrValS) -> + case lookup (fromString name) attrs of + Just val -> matchAttrValue val attrValS + Nothing -> False) + attrS + +tagOpen :: (Monad m, StringLike str, Show str) + => TagOpenSelector + -> P.ParsecT [Tag str] u m (Tag str) +tagOpen tagS = try (optional tagText >> tagOpen_ tagS) + +tagClose_ :: (Monad m, StringLike str, Show str) + => TagCloseSelector + -> P.ParsecT [Tag str] u m (Tag str) +tagClose_ tagS = + satisfy (\tag -> case tag of + TagClose name _ -> + case tagS of + AnyCloseTag -> True + TagCloseSelector name' -> toString name == name' + _other -> False) + +tagClose :: (Monad m, StringLike str, Show str) + => TagCloseSelector + -> P.ParsecT [Tag str] u m (Tag str) +tagClose tagS = try (optional tagText >> tagClose_ tagS) + +-- | Take a parser, return a parser which only succeeds if the given parser +-- fails. Consumes no input. +notParse :: P.Stream s m t => P.ParsecT s u m t -> P.ParsecT s u m () +notParse parser = do + parsed <- try $ Just <$> parser + <|> return Nothing + case parsed of + Nothing -> return () + Just _ -> unexpected "parser given to notParse succeeded" + +tagText :: (Monad m, Show str) => P.ParsecT [Tag str] u m str +tagText = P.tokenPrim show updatePos $ \tag -> case tag of + TagText text _ -> Just text + _other -> Nothing + +-- | Certain HTML elements are self closing. In addition, they can show +-- up /without/ their closing slash. For these, we just want to go over +-- their opening tag. +-- These elements are void, according to the W3C spec: +-- +-- +-- * area +-- * base +-- * br +-- * col +-- * command +-- * embed +-- * hr +-- * img +-- * input +-- * keygen +-- * link +-- * meta +-- * param +-- * source +-- * track +-- * wbr +voidElement :: (Monad m, StringLike str, Show str) => P.ParsecT [Tag str] u m (Tag str) +voidElement = choice $ fmap tagOpen_ [ "area", "base", "br", "col", "command" + , "embed", "hr", "img", "input", "keygen" + , "link", "meta", "param", "source", "track" + , "wbr" + ] + +balancedTags_ :: (Monad m, StringLike str, Show str) + => TagOpenSelector + -> P.ParsecT [Tag str] u m (S.Seq (Tag str)) +balancedTags_ tagS = do + openTag <- tagOpen_ tagS + tailTags <- tagTail openTag + return $ openTag <| tailTags + +tagTail :: (Monad m, StringLike str, Show str) + => Tag str + -> P.ParsecT [Tag str] u m (S.Seq (Tag str)) +tagTail (TagOpen name _ _) = do + innerTags <- P.many $ try notMatchingClose + matchingClose <- tagClose_ closeS + return $ mconcat innerTags |> matchingClose + where closeS = TagCloseSelector $ toString name + notMatchingClose = ( S.singleton <$> (notParse (tagClose_ closeS) >> tag) + <|> S.singleton <$> voidElement + <|> (balancedTags_ anyOpenTag) + ) + +balancedTags :: (Monad m, StringLike str, Show str) + => TagOpenSelector + -> P.ParsecT [Tag str] u m [Tag str] +balancedTags tagS = optional tagText >> toList <$> balancedTags_ tagS + +anyOpenTag :: TagOpenSelector +anyOpenTag = AnyOpenTag [] + +anyCloseTag :: TagCloseSelector +anyCloseTag = AnyCloseTag + +anyValue :: AttrValue +anyValue = AnyAttr + +-- | @skip p@ produces a parser which will ignore the output of @p@. +skip :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m () +skip p = p >> return () + +innerText :: StringLike str => [Tag str] -> str +innerText tags = fromString $ toList $ mconcat $ fmap tagInner tags + where tagInner (TagOpen "br" _ _) = S.singleton '\n' + tagInner (TagText text _) = S.fromList $ toString text + tagInner _other = S.empty