diff --git a/example/Speed.hs b/example/Speed.hs
new file mode 100644
--- /dev/null
+++ b/example/Speed.hs
@@ -0,0 +1,82 @@
+module Main where
+
+import qualified Text.HTML.TagSoup.HT.Tag as Tag
+import qualified Text.HTML.TagSoup.HT.Parser as Parser
+import qualified Text.HTML.TagSoup.HT.Parser.Stream as Str
+import qualified Text.XML.Basic.Name.MixedCase as Name
+
+import System.Time (getClockTime, diffClockTimes, tdSec, tdPicosec, )
+
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.Lazy.Char8 as BL
+
+
+measureTime :: String -> IO () -> IO ()
+measureTime name act =
+ do putStr (name++": ")
+ timeA <- getClockTime
+ act
+ timeB <- getClockTime
+ let td = diffClockTimes timeB timeA
+ print (fromIntegral (tdSec td) +
+ fromInteger (tdPicosec td) * 1e-12 :: Double)
+
+number :: Int
+number = 100000
+
+main :: IO ()
+main =
+ do measureTime "String" $ print $
+ (last $ Parser.runSoup $ concat $ replicate number "item" :: Tag.T Name.T String)
+ measureTime "ByteString.Strict" $ print $
+ (last $ Parser.runSoup $ BS.concat $ replicate number $ BS.pack "item" :: Tag.T Name.T String)
+ measureTime "ByteString.Lazy" $ print $
+ (last $ Parser.runSoup $ BL.concat $ replicate number $ BL.pack "item" :: Tag.T Name.T String)
+
+ measureTime "Pointer.Strict" $ print $
+ (last $ Parser.runSoup $ Str.pointerFromByteStringStrict $ BS.concat $ replicate number $ BS.pack "item" :: Tag.T Name.T String)
+ measureTime "Pointer.Lazy" $ print $
+ (last $ Parser.runSoup $ Str.pointerFromByteStringLazy $ BL.concat $ replicate number $ BL.pack "item" :: Tag.T Name.T String)
+
+{-
+Results without inlining on euler:
+
+String: Close "li"
+2.182197
+ByteString.Strict: Close "li"
+2.704024
+ByteString.Lazy: Close "li"
+3.203038
+
+These figures remain, when Stream methods are inlined.
+
+
+Results without inlining on anubis:
+String: Close "li"
+3.507383
+ByteString.Strict: Close "li"
+4.406978
+ByteString.Lazy: Close "li"
+5.266979
+Pointer.Strict: Close "li"
+3.37898
+Pointer.Lazy: Close "li"
+3.185808
+
+
+The figures become worse, when MTL and Combinator functions are inlined, too:
+String: Close "li"
+3.56803
+ByteString.String: Close "li"
+4.314474
+ByteString.Lazy: Close "li"
+4.855984
+
+With the main parser functions inlined we get:
+tring: Close "li"
+2.951519
+ByteString.String: Close "li"
+2.910444
+ByteString.Lazy: Close "li"
+3.046311
+-}
diff --git a/example/Validate.hs b/example/Validate.hs
--- a/example/Validate.hs
+++ b/example/Validate.hs
@@ -5,9 +5,10 @@
module Main where
import Text.HTML.TagSoup.HT.Parser
-import qualified Text.HTML.TagSoup.HT.Position as Position
+import qualified Text.XML.Basic.Position as Position
import qualified Text.HTML.TagSoup.HT.PositionTag as PosTag
import qualified Text.HTML.TagSoup.HT.Tag as Tag
+import qualified Text.XML.Basic.Name.MixedCase as Name
import System.Environment (getArgs)
@@ -16,16 +17,19 @@
validate :: FilePath -> String -> String
validate fileName input =
- let tags :: [PosTag.T Char]
+ let tags :: [PosTag.T Name.T String]
tags = runSoupWithPositionsName fileName input
warnings =
- mapMaybe (\(pos,tag) -> fmap ((,) pos) $ Tag.maybeWarning tag) tags
- in unlines $ map (\(pos,msg) -> Position.toReportText pos ++ " " ++ msg) warnings
+ mapMaybe
+ (\(PosTag.Cons pos tag) ->
+ fmap (\msg -> Position.toReportText pos ++ " " ++ msg) $
+ Tag.maybeWarning tag)
+ tags
+ in unlines warnings
validateIO :: FilePath -> IO ()
validateIO fileName =
- do text <- readFile fileName
- putStrLn (validate fileName text)
+ putStrLn . validate fileName =<< readFile fileName
main :: IO ()
diff --git a/src/Text/HTML/TagSoup/HT/Format.hs b/src/Text/HTML/TagSoup/HT/Format.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/HTML/TagSoup/HT/Format.hs
@@ -0,0 +1,90 @@
+{-|
+Convert a tag soup to its text representation
+respecting various conventions for merging open and close tags.
+-}
+module Text.HTML.TagSoup.HT.Format (
+ xml, xmlCondensed, html, xhtml, htmlOrXhtml,
+ ) where
+
+import qualified Text.HTML.TagSoup.HT.Tag as Tag
+import qualified Text.HTML.Basic.Tag as TagH
+import qualified Text.XML.Basic.Name as Name
+import qualified Text.XML.Basic.Format as Fmt
+
+import Data.List.HT (viewL, )
+import Data.Maybe (fromMaybe, )
+import Control.Monad (guard, )
+
+
+{-
+*Text.HTML.TagSoup.HT.Format> flip xml "" $ (Text.HTML.TagSoup.HT.Parser.runSoup "" :: [Tag.T Text.XML.Basic.Name.LowerCase.T String])
+-}
+
+
+{- |
+All tags are formatted as they are.
+-}
+xml :: (Eq name, Name.Tag name, Name.Attribute name, Fmt.C string) =>
+ [Tag.T name string] -> ShowS
+xml = Fmt.many Fmt.run
+
+
+{- |
+Adjacent corresponding open and close tags are merged to a self-closing tag.
+E.g. @@ becomes @@.
+-}
+xmlCondensed :: (Eq name, Name.Tag name, Name.Attribute name, Fmt.C string) =>
+ [Tag.T name string] -> ShowS
+xmlCondensed = xmlCondensedGen (==)
+
+{- |
+All tags that are defined being self-closing by the HTML standard
+are formatted only as open tag.
+E.g. @
@.
+-}
+html :: (Ord name, Name.Tag name, Name.Attribute name, Fmt.C string) =>
+ [Tag.T name string] -> ShowS
+html =
+ Fmt.many Fmt.run .
+ filter (maybe True (not . TagH.isEmpty) . Tag.maybeClose)
+
+{- |
+All tags that are defined being self-closing by the XHTML standard
+are formatted as self-closing open tag.
+E.g. @
@.
+-}
+xhtml :: (Ord name, Name.Tag name, Name.Attribute name, Fmt.C string) =>
+ [Tag.T name string] -> ShowS
+xhtml =
+ xmlCondensedGen
+ -- e.g. must not be merged to
+ (\nameOpen nameClose ->
+ nameOpen==nameClose && TagH.isEmpty nameOpen)
+
+{- |
+If the first tag is @@ then format in XHTML style,
+else in HTML style.
+-}
+htmlOrXhtml :: (Ord name, Name.Tag name, Name.Attribute name, Fmt.C string) =>
+ [Tag.T name string] -> ShowS
+htmlOrXhtml tags =
+ fromMaybe (html tags) $
+ do (tag,_) <- viewL tags
+ (name,_) <- Tag.maybeProcessing tag
+ guard (Name.match "xml" name)
+ return (xhtml tags)
+
+
+xmlCondensedGen :: (Eq name, Name.Tag name, Name.Attribute name, Fmt.C string) =>
+ (Tag.Name name -> Tag.Name name -> Bool) ->
+ [Tag.T name string] -> ShowS
+xmlCondensedGen check =
+ let recourse (Tag.Open nameOpen attrs : Tag.Close nameClose : ts) =
+ (if check nameOpen nameClose
+ then Tag.formatOpen True nameOpen attrs
+ else Tag.formatOpen False nameOpen attrs .
+ Tag.formatClose nameClose)
+ . recourse ts
+ recourse (t : ts) = Fmt.run t . recourse ts
+ recourse [] = id
+ in recourse
diff --git a/src/Text/HTML/TagSoup/HT/HTMLChar.hs b/src/Text/HTML/TagSoup/HT/HTMLChar.hs
deleted file mode 100644
--- a/src/Text/HTML/TagSoup/HT/HTMLChar.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module Text.HTML.TagSoup.HT.HTMLChar where
-
-data T =
- Char Char
- | NumericRef Int
- | NamedRef String
- deriving (Show, Eq)
diff --git a/src/Text/HTML/TagSoup/HT/Match.hs b/src/Text/HTML/TagSoup/HT/Match.hs
deleted file mode 100644
--- a/src/Text/HTML/TagSoup/HT/Match.hs
+++ /dev/null
@@ -1,96 +0,0 @@
-module Text.HTML.TagSoup.HT.Match where
-
-import qualified Text.HTML.TagSoup.HT.Tag as Tag
-
-
-ignore :: a -> Bool
-ignore _ = True
-
-
--- | match an opening tag
-open :: (String -> Bool) -> ([Tag.Attribute char] -> Bool) -> Tag.T char -> Bool
-open pName pAttrs (Tag.Open name attrs) =
- pName name && pAttrs attrs
-open _ _ _ = False
-
--- | match an closing tag
-close :: (String -> Bool) -> Tag.T char -> Bool
-close pName (Tag.Close name) = pName name
-close _ _ = False
-
--- | match a text
-text :: ([char] -> Bool) -> Tag.T char -> Bool
-text p (Tag.Text str) = p str
-text _ _ = False
-
-comment :: (String -> Bool) -> Tag.T char -> Bool
-comment p (Tag.Comment str) = p str
-comment _ _ = False
-
-special :: (String -> Bool) -> (String -> Bool) -> Tag.T char -> Bool
-special pType pInfo (Tag.Special typ info) = pType typ && pInfo info
-special _ _ _ = False
-
-
--- | match a opening tag's name literally
-openLit :: String -> ([Tag.Attribute char] -> Bool) -> Tag.T char -> Bool
-openLit name = open (name==)
-
--- | match a closing tag's name literally
-closeLit :: String -> Tag.T char -> Bool
-closeLit name = close (name==)
-
-openAttrLit :: (Eq char) =>
- String -> Tag.Attribute char -> Tag.T char -> Bool
-openAttrLit name attr =
- openLit name (anyAttrLit attr)
-
-{- |
-Match a tag with given name, that contains an attribute
-with given name, that satisfies a predicate.
-If an attribute occurs multiple times,
-all occurrences are checked.
--}
-openAttrNameLit :: String -> String -> ([char] -> Bool) -> Tag.T char -> Bool
-openAttrNameLit tagName attrName pAttrValue =
- openLit tagName
- (anyAttr (\(name,value) -> name==attrName && pAttrValue value))
-
-
--- | Check if the 'Tag.T' is 'Tag.Open' and matches the given name
-openNameLit :: String -> Tag.T char -> Bool
-openNameLit name = openLit name ignore
-
--- | Check if the 'Tag.T' is 'Tag.Close' and matches the given name
-closeNameLit :: String -> Tag.T char -> Bool
-closeNameLit name = closeLit name
-
-
-
-
-anyAttr :: ((String,[char]) -> Bool) -> [Tag.Attribute char] -> Bool
-anyAttr = any
-
-anyAttrName :: (String -> Bool) -> [Tag.Attribute char] -> Bool
-anyAttrName p = any (p . fst)
-
-anyAttrValue :: ([char] -> Bool) -> [Tag.Attribute char] -> Bool
-anyAttrValue p = any (p . snd)
-
-
-anyAttrLit :: (Eq char) => (String,[char]) -> [Tag.Attribute char] -> Bool
-anyAttrLit attr = anyAttr (attr==)
-
-anyAttrNameLit :: String -> [Tag.Attribute char] -> Bool
-anyAttrNameLit name = anyAttrName (name==)
-
-anyAttrValueLit :: (Eq char) => [char] -> [Tag.Attribute char] -> Bool
-anyAttrValueLit value = anyAttrValue (value==)
-
-
-{-
-getTagContent :: String -> ([Tag.Attribute char] -> Bool) -> [Tag.T char] -> [Tag.T char]
-getTagContent name pAttrs =
- takeWhile (not . tagCloseLit name) . drop 1 .
- head . sections (tagOpenLit name pAttrs)
--}
diff --git a/src/Text/HTML/TagSoup/HT/Parser.hs b/src/Text/HTML/TagSoup/HT/Parser.hs
--- a/src/Text/HTML/TagSoup/HT/Parser.hs
+++ b/src/Text/HTML/TagSoup/HT/Parser.hs
@@ -14,26 +14,40 @@
import Text.HTML.TagSoup.HT.Parser.Combinator
(allowFail, withDefault,
char, dropSpaces, getPos,
- many, many1, many1Satisfy, readUntil,
+ many, manyNull, many0toN, many1toN,
+ many1Satisfy, readUntil,
satisfy, string,
- emit, mfix, )
+ emit, modifyEmission, )
import qualified Text.HTML.TagSoup.HT.Parser.Combinator as Parser
-import qualified Text.HTML.TagSoup.HT.Tag as Tag
import qualified Text.HTML.TagSoup.HT.PositionTag as PosTag
-import qualified Text.HTML.TagSoup.HT.Position as Position
-import qualified Text.HTML.TagSoup.HT.HTMLChar as HTMLChar
+import qualified Text.HTML.TagSoup.HT.Tag as Tag
+import qualified Text.XML.Basic.Position as Position
+import qualified Text.HTML.Basic.Character as HTMLChar
+import qualified Text.XML.Basic.ProcessingInstruction as PI
+import qualified Text.XML.Basic.Attribute as Attr
+import qualified Text.XML.Basic.Name as Name
+import qualified Text.XML.Basic.Tag as TagName
-import qualified Text.HTML.TagSoup.Entity as HTMLEntity
+import qualified Text.HTML.TagSoup.HT.Parser.Stream as Stream
+import qualified Text.HTML.Basic.Entity as HTMLEntity
+
+import qualified Control.Monad.Exception.Synchronous as Exc
+
+import Control.Monad.Fix (MonadFix, mfix, )
import Control.Monad (mplus, msum, when, liftM, )
--- import Control.Monad.Identity (Identity(..), )
+import Data.Monoid (Monoid, mempty, mconcat, )
-import Data.Char (isAlphaNum, isAscii, isDigit, chr, )
+import qualified Data.Map as Map
+
+import Data.Tuple.HT (mapSnd, )
+import Data.Char (isAlphaNum, isAscii, chr, ord, )
import Data.Maybe (fromMaybe, )
+-- import qualified Numeric
-- * run parser in several ways
@@ -42,8 +56,10 @@
Parse a single tag, throws an error if there is a syntax error.
This is useful for parsing a match pattern.
-}
-runTag :: (CharType char, Show char) =>
- String -> Tag.T char
+runTag ::
+ (Stream.C source, StringType sink, Show sink,
+ Name.Attribute name, Name.Tag name, Eq name, Show name) =>
+ source -> Tag.T name sink
runTag str =
let tags =
fromMaybe (error "runTag: no parse at all") $
@@ -52,50 +68,63 @@
"runTag: parsing results in\n" ++
unlines (map show tags)
in case tags of
- [(_,tag)] ->
- if Tag.isWarning tag
- then makeError
- else tag
+ [postag] ->
+ let tag = PosTag.tag_ postag
+ in if Tag.isWarning tag
+ then makeError
+ else tag
_ -> makeError
{- |
Parse the inner of a single tag.
That is, @runTag \"\\"@ is the same as @runInnerOfTag \"\\"@.
-}
-runInnerOfTag :: (CharType char, Show char) =>
- String -> Tag.T char
+runInnerOfTag ::
+ (StringType sink, Show sink,
+ Name.Attribute name, Name.Tag name, Eq name, Show name) =>
+ String -> Tag.T name sink
runInnerOfTag str = runTag $ "<"++str++">"
-runSoupWithPositionsName :: CharType char =>
- FilePath -> String -> [PosTag.T char]
+runSoupWithPositionsName ::
+ (Stream.C source, StringType sink,
+ Name.Attribute name, Name.Tag name, Eq name) =>
+ FilePath -> source -> [PosTag.T name sink]
runSoupWithPositionsName fileName =
+ PosTag.concatTexts .
Parser.runIdentity .
- Parser.write fileName (many parsePosTag >> return ())
+ Parser.write fileName (manyNull parsePosTag)
-- | Parse an HTML document to a list of 'Tag.T'.
-- Automatically expands out escape characters.
-runSoupWithPositions :: CharType char =>
- String -> [PosTag.T char]
+runSoupWithPositions ::
+ (Stream.C source, StringType sink,
+ Name.Attribute name, Name.Tag name, Eq name) =>
+ source -> [PosTag.T name sink]
runSoupWithPositions =
- Parser.runIdentity .
- Parser.write "input" (many parsePosTag >> return ())
+ runSoupWithPositionsName "input"
-- | Like 'runSoupWithPositions' but hides source file positions.
-runSoup :: CharType char => String -> [Tag.T char]
-runSoup = map snd . runSoupWithPositions
+runSoup ::
+ (Stream.C source, StringType sink,
+ Name.Attribute name, Name.Tag name, Eq name) =>
+ source -> [Tag.T name sink]
+runSoup = map PosTag.tag_ . runSoupWithPositions
-- * parser parts
-type Parser char a = Parser.Full (PosTag.T char) a
-type ParserEmit char a = Parser.Emitting (PosTag.T char) a
+type Parser name source sink a = Parser.Full source (PosTag.T name sink) a
+type ParserEmit name source sink a = Parser.Emitting source (PosTag.T name sink) a
-parsePosTag :: CharType char => Parser char ()
+parsePosTag ::
+ (Stream.C source, StringType sink,
+ Name.Attribute name, Name.Tag name, Eq name) =>
+ Parser name source sink ()
parsePosTag = do
pos <- getPos
mplus
@@ -107,20 +136,21 @@
parseCloseTag pos :
parseOpenTag pos :
[])
- (do emitTag pos (Tag.Text [fromChar '<'])
+ (do emitTag pos (Tag.Text $ stringFromChar '<')
emitWarning pos "A '<', that is not part of a tag. Encode it as < please."))
(parseText pos)
-parseOpenTag :: CharType char => Position.T -> Parser char ()
+parseOpenTag ::
+ (Stream.C source, StringType sink,
+ Name.Attribute name, Name.Tag name) =>
+ Position.T -> Parser name source sink ()
parseOpenTag pos =
do name <- parseName
allowFail $
do dropSpaces
- mfix
- (\attrs ->
- emit (pos, Tag.Open name attrs) >>
- many parseAttribute)
+ emittingTag pos (Tag.Open name) $
+ modifyEmission (restrictSoup 10) $ many parseAttribute
withDefault
(do closePos <- getPos
string "/>"
@@ -131,9 +161,11 @@
emitWarningWhen
(not $ null junk)
junkPos ("Junk in opening tag: \"" ++ junk ++ "\""))
- ("Unterminated open tag \"" ++ name ++ "\"") ">")
+ ("Unterminated open tag \"" ++ Name.toString name ++ "\"") ">")
-parseCloseTag :: Position.T -> Parser char ()
+parseCloseTag ::
+ (Stream.C source, Name.Tag name) =>
+ Position.T -> Parser name source sink ()
parseCloseTag pos =
do char '/'
name <- parseName
@@ -146,9 +178,11 @@
emitWarningWhen
(not $ null junk)
junkPos ("Junk in closing tag: \"" ++ junk ++"\""))
- ("Unterminated closing tag \"" ++ name ++"\"") ">"
+ ("Unterminated closing tag \"" ++ Name.toString name ++"\"") ">"
-parseSpecialTag :: Position.T -> Parser char ()
+parseSpecialTag ::
+ (Stream.C source, Name.Tag name) =>
+ Position.T -> Parser name source sink ()
parseSpecialTag pos =
do char '!'
msum $
@@ -156,80 +190,89 @@
allowFail $ readUntilTerm
(\ cmt -> emitTag pos (Tag.Comment cmt))
"Unterminated comment" "-->") :
- (do string "[CDATA["
+ (do string TagName.cdataString
allowFail $ readUntilTerm
- (\ cdata -> emitTag pos (Tag.Special "[CDATA[" cdata))
+ (\ cdata -> emitTag pos (Tag.Special (Name.fromString TagName.cdataString) cdata))
"Unterminated cdata" "]]>") :
- (do name <- many1Satisfy isAlphaNum
+ (do name <- parseName
allowFail $
do dropSpaces
readUntilTerm
(\ info -> emitTag pos (Tag.Special name info))
- ("Unterminated special tag \"" ++ name ++ "\"") ">") :
+ ("Unterminated special tag \"" ++ Name.toString name ++ "\"") ">") :
[]
-parseProcessingTag :: CharType char => Position.T -> Parser char ()
+parseProcessingTag ::
+ (Stream.C source, StringType sink,
+ Name.Attribute name, Name.Tag name, Eq name) =>
+ Position.T -> Parser name source sink ()
parseProcessingTag pos =
do char '?'
name <- parseName
allowFail $
do dropSpaces
- mfix
- (\proc ->
- emit (pos, Tag.Processing name proc) >>
- if elem name ["xml", "xml-stylesheet"]
- then
- do attrs <- many parseAttribute
- junkPos <- getPos
- readUntilTerm
- (\ junk ->
- emitWarningWhen (not $ null junk) junkPos
- ("Junk in processing info tag: \"" ++ junk ++ "\""))
- ("Unterminated processing info tag \"" ++ name ++ "\"") "?>"
- return $ Tag.KnownProcessing attrs
- else readUntilTerm (return . Tag.UnknownProcessing)
- "Unterminated processing instruction" "?>")
- return ()
+ emittingTag pos (Tag.Processing name) $
+ if Name.matchAny ["xml", "xml-stylesheet"] name
+ then
+ do attrs <- many parseAttribute
+ junkPos <- getPos
+ readUntilTerm
+ (\ junk ->
+ emitWarningWhen (not $ null junk) junkPos
+ ("Junk in processing info tag: \"" ++ junk ++ "\""))
+ ("Unterminated processing info tag \"" ++ Name.toString name ++ "\"") "?>"
+ return $ PI.Known attrs
+ else readUntilTerm (return . PI.Unknown)
+ "Unterminated processing instruction" "?>"
-parseText :: CharType char => Position.T -> Parser char ()
+parseText ::
+ (Stream.C source, StringType sink) =>
+ Position.T -> Parser name source sink ()
parseText pos =
- mfix
- (\ text ->
- allowFail (emitTag pos (Tag.Text text)) >>
- parseString1 ('<'/=))
- >> return ()
+ emittingTag pos Tag.Text (parseCharAsString (const True))
+-- emittingTag pos Tag.Text (parseCharAsString ('<'/=))
+-- emittingTag pos Tag.Text (parseString1 ('<'/=))
-parseAttribute :: CharType char => Parser char (Tag.Attribute char)
+parseAttribute ::
+ (Stream.C source, StringType sink, Name.Attribute name) =>
+ Parser name source sink (Attr.T name sink)
parseAttribute =
parseName >>= \name -> allowFail $
do dropSpaces
value <-
withDefault
(string "=" >> allowFail (dropSpaces >> parseValue))
- (return [])
+ (return mempty)
dropSpaces
- return (name, value)
+ return $ Attr.Cons name value
-parseName :: Parser char String
+parseName ::
+ (Stream.C source, Name.C pname) =>
+ Parser name source sink pname
parseName =
+ liftM Name.fromString $
-- we must restrict to ASCII alphanum characters in order to exclude umlauts
- many1Satisfy (\c -> isAlphaNum c && isAscii c || c `elem` "_-:")
+ many1Satisfy (\c -> isAlphaNum c && isAscii c || c `elem` "_-.:")
-parseValue :: CharType char => ParserEmit char [char]
+parseValue ::
+ (Stream.C source, StringType sink) =>
+ ParserEmit name source sink sink
parseValue =
(msum $
parseQuoted "Unterminated doubly quoted value string" '"' :
parseQuoted "Unterminated singly quoted value string" '\'' :
[])
`withDefault`
- parseUnquotedValue
+ parseUnquotedValueAsString
-parseUnquotedValueChar :: ParserEmit Char String
+parseUnquotedValueChar ::
+ (Stream.C source) =>
+ ParserEmit name source String String
parseUnquotedValueChar =
let parseValueChar =
do pos <- getPos
- str <- parseChar (not . flip elem " >\"\'")
+ str <- parseUnicodeChar (not . flip elem " >\"\'")
let wrong = filter (not . isValidValueChar) str
allowFail $
emitWarningWhen (not (null wrong)) pos $
@@ -237,24 +280,35 @@
return str
in liftM concat $ many parseValueChar
-parseUnquotedValueHTMLChar :: ParserEmit HTMLChar.T [HTMLChar.T]
+parseUnquotedValueHTMLChar ::
+ (Stream.C source) =>
+ ParserEmit name source [HTMLChar.T] [HTMLChar.T]
parseUnquotedValueHTMLChar =
let parseValueChar =
do pos <- getPos
hc <- parseHTMLChar (not . flip elem " >\"\'")
- case hc of
- HTMLChar.Char c ->
- allowFail $
- emitWarningWhen (not (isValidValueChar c)) pos $
- "Illegal characters in unquoted value: '" ++ c : "'"
- _ -> return ()
+ {- We do the check after each parseHTMLChar
+ and not after (many parseValueChar)
+ in order to correctly interleave warnings. -}
+ allowFail $ mapM_ (checkUnquotedChar pos) hc
return hc
- in many parseValueChar
+ in liftM concat $ many parseValueChar
+checkUnquotedChar :: Position.T -> HTMLChar.T -> ParserEmit name source sink ()
+checkUnquotedChar pos x =
+ case x of
+ HTMLChar.Unicode c ->
+ emitWarningWhen (not (isValidValueChar c)) pos $
+ "Illegal characters in unquoted value: '" ++ c : "'"
+ _ -> return ()
+
+
isValidValueChar :: Char -> Bool
isValidValueChar c = isAlphaNum c || c `elem` "_-:."
-parseQuoted :: CharType char => String -> Char -> Parser char [char]
+parseQuoted ::
+ (Stream.C source, StringType sink) =>
+ String -> Char -> Parser name source sink sink
parseQuoted termMsg quote =
char quote >>
(allowFail $
@@ -270,7 +324,8 @@
in 'mfix' in order to emit a tag, where some information is read later.
-}
readUntilTerm ::
- (String -> ParserEmit char a) -> String -> String -> ParserEmit char a
+ (Stream.C source) =>
+ (String -> ParserEmit name source sink a) -> String -> String -> ParserEmit name source sink a
readUntilTerm generateTag termWarning termPat =
do ~(termFound,str) <- readUntil termPat
result <- generateTag str
@@ -281,42 +336,87 @@
class CharType char where
fromChar :: Char -> char
- parseString :: (Char -> Bool) -> ParserEmit char [char]
- parseString1 :: (Char -> Bool) -> Parser char [char]
- parseUnquotedValue :: ParserEmit char [char]
+ parseChar :: (Stream.C source) => (Char -> Bool) -> Parser name source sink [char]
+ parseUnquotedValue :: (Stream.C source) => ParserEmit name source [char] [char]
instance CharType Char where
fromChar = id
- parseString p = liftM concat $ many (parseChar p)
- parseString1 p = liftM concat $ many1 (parseChar p)
+ parseChar = parseUnicodeChar
parseUnquotedValue = parseUnquotedValueChar
instance CharType HTMLChar.T where
- fromChar = HTMLChar.Char
- parseString p = many (parseHTMLChar p)
- parseString1 p = many1 (parseHTMLChar p)
+ fromChar = HTMLChar.Unicode
+ parseChar = parseHTMLChar
parseUnquotedValue = parseUnquotedValueHTMLChar
-parseChar :: (Char -> Bool) -> Parser char String
-parseChar p =
+class Monoid sink => StringType sink where
+ stringFromChar :: Char -> sink
+ parseCharAsString ::
+ (Stream.C source) =>
+ (Char -> Bool) -> Parser name source sink sink
+ parseUnquotedValueAsString ::
+ (Stream.C source) =>
+ ParserEmit name source sink sink
+
+instance CharType char => StringType [char] where
+ stringFromChar c = [fromChar c]
+ parseCharAsString = parseChar
+ parseUnquotedValueAsString = parseUnquotedValue
+
+
+parseString ::
+ (Stream.C source, StringType sink) =>
+ (Char -> Bool) -> ParserEmit name source sink sink
+parseString p = liftM mconcat $ many (parseCharAsString p)
+
+{-
+parseString1 ::
+ (Stream.C source, StringType sink) =>
+ (Char -> Bool) -> Parser name source sink sink
+parseString1 p = liftM mconcat $ many1 (parseCharAsString p)
+-}
+
+
+
+parseUnicodeChar ::
+ (Stream.C source) =>
+ (Char -> Bool) -> Parser name source sink String
+parseUnicodeChar p =
do pos <- getPos
x <- parseHTMLChar p
- let returnChar c = return $ c:[]
- allowFail $
- case x of
- HTMLChar.Char c -> returnChar c
- HTMLChar.NumericRef num -> returnChar (chr num)
- HTMLChar.NamedRef name ->
- maybe
- (let refName = '&':name++";"
- in emitWarning pos ("Unknown HTML entity " ++ refName) >>
- return refName)
- (returnChar . chr)
- (lookup name HTMLEntity.htmlEntities)
+ allowFail $ liftM concat $
+ mapM (htmlCharToString pos) x
+htmlCharToString ::
+ Position.T -> HTMLChar.T -> ParserEmit name source sink String
+htmlCharToString pos x =
+ let returnChar c = return $ c:[]
+ in case x of
+ HTMLChar.Unicode c -> returnChar c
+ HTMLChar.CharRef num -> returnChar (chr num)
+ HTMLChar.EntityRef name ->
+ maybe
+ (let refName = '&':name++";"
+ in emitWarning pos ("Unknown HTML entity " ++ refName) >>
+ return refName)
+ returnChar
+ (Map.lookup name HTMLEntity.mapNameToChar)
-parseHTMLChar :: (Char -> Bool) -> Parser char HTMLChar.T
+{- |
+Only well formed entity references are interpreted as single HTMLChars,
+whereas ill-formed entity references are interpreted as sequence of unicode characters without special meaning.
+E.g. "& ;" is considered as plain "& ;",
+and only "&" is considered an escaped ampersand.
+It is a very common error in HTML documents to not escape an ampersand.
+With the interpretation used here,
+those ampersands are left as they are.
+
+At most one warning can be emitted.
+-}
+parseHTMLChar ::
+ (Stream.C source) =>
+ (Char -> Bool) -> Parser name source sink [HTMLChar.T]
parseHTMLChar p =
do pos <- getPos
c <- satisfy p
@@ -326,22 +426,91 @@
withDefault
(do ent <-
mplus
- (char '#' >>
- liftM (HTMLChar.NumericRef . read) (many1Satisfy isDigit))
- (liftM HTMLChar.NamedRef $ many1Satisfy isAlphaNum)
+ (do char '#'
+ digits <- allowFail $ many0toN 10 (satisfy isAlphaNum)
+ -- exclude ';', '"', '<'
+ -- include 'x'
+ Exc.switch
+ (\e ->
+ allowFail (emitWarning pos ("Error in numeric entity: " ++ e)) >>
+ return (map HTMLChar.fromUnicode ('&':'#':digits)))
+ (return . (:[]) . HTMLChar.CharRef . ord)
+ (HTMLEntity.numberToChar digits))
+ (liftM ((:[]) . HTMLChar.EntityRef) $
+ many1toN 10 (satisfy isAlphaNum))
char ';'
return ent)
+ (emitWarning pos "Non-terminated entity reference" >>
+ return [HTMLChar.Unicode '&'])
+ else return [HTMLChar.Unicode c]
+
+{-
+readHex :: (Num a) => String -> a
+readHex str =
+ case Numeric.readHex str of
+ [(n,"")] -> n
+ _ -> error "readHex: no parse"
+
+{-
+We cannot emit specific warnings,
+because the sub-parsers simply fail
+and then throw away the warnings.
+-}
+parseHTMLCharGenericWarning ::
+ (Stream.C source) =>
+ (Char -> Bool) -> Parser name source sink [HTMLChar.T]
+parseHTMLCharGenericWarning p =
+ do pos <- getPos
+ c <- satisfy p
+ allowFail $
+ if c=='&'
+ then
+ withDefault
+ (do ent <-
+ mplus
+ (char '#' >>
+ liftM HTMLChar.CharRef
+ (mplus
+ (char 'x' >> liftM readHex (many1toN 8 (satisfy isHexDigit)))
+ (liftM read (many1toN 10 (satisfy isDigit)))))
+ (liftM HTMLChar.EntityRef $ many1toN 10 (satisfy isAlphaNum))
+ char ';'
+ return [ent])
(emitWarning pos "Ill formed entity" >>
- return (HTMLChar.Char '&'))
- else return (HTMLChar.Char c)
+ return [HTMLChar.Unicode '&'])
+ else return [HTMLChar.Unicode c]
+-}
-emitWarningWhen :: Bool -> Position.T -> String -> ParserEmit char ()
+restrictSoup :: Int -> [PosTag.T name sink] -> [PosTag.T name sink]
+restrictSoup n =
+ uncurry (++) .
+ mapSnd
+ (\rest ->
+ case rest of
+ (PosTag.Cons pos _) : _ ->
+ [PosTag.Cons pos (Tag.Warning "further warnings suppressed")]
+ _ -> []) .
+ splitAt n
+
+
+-- these functions have intentionally restricted types
+
+emitWarningWhen :: Bool -> Position.T -> String -> ParserEmit name source sink ()
emitWarningWhen cond pos msg =
when cond $ emitWarning pos msg
-emitWarning :: Position.T -> String -> ParserEmit char ()
+emitWarning :: Position.T -> String -> ParserEmit name source sink ()
emitWarning pos msg = emitTag pos (Tag.Warning msg)
-emitTag :: Position.T -> Tag.T char -> ParserEmit char ()
-emitTag = curry emit
+emitTag :: Position.T -> Tag.T name sink -> ParserEmit name source sink ()
+emitTag p t = emit (PosTag.cons p t)
+
+emittingTag ::
+ (MonadFix fail) =>
+ Position.T ->
+ (a -> Tag.T name sink) ->
+ Parser.T source [PosTag.T name sink] fail a ->
+ Parser.T source [PosTag.T name sink] fail ()
+emittingTag pos f x =
+ mfix (\r -> emit (PosTag.cons pos (f r)) >> x) >> return ()
diff --git a/src/Text/HTML/TagSoup/HT/Parser/Combinator.hs b/src/Text/HTML/TagSoup/HT/Parser/Combinator.hs
--- a/src/Text/HTML/TagSoup/HT/Parser/Combinator.hs
+++ b/src/Text/HTML/TagSoup/HT/Parser/Combinator.hs
@@ -1,23 +1,24 @@
module Text.HTML.TagSoup.HT.Parser.Combinator (
Parser.T, Full, Emitting, Fallible, Plain,
- char, dropSpaces, eof, getPos,
- many, many1, many1Satisfy, manySatisfy, readUntil,
+ char, dropSpaces, getPos,
+ many, many1, manyNull, many1Null, many0toN, many1toN,
+ many1Satisfy, manySatisfy, readUntil,
satisfy, string,
- emit,
- eval, write, gets, mfix,
+ emit, modifyEmission,
+ eval, write, gets,
withDefault, allowFail, allowEmit,
Identity, runIdentity, )
where
-import qualified Text.HTML.TagSoup.HT.Position as Position
+import qualified Text.XML.Basic.Position as Position
import qualified Text.HTML.TagSoup.HT.Parser.Status as Status
+import qualified Text.HTML.TagSoup.HT.Parser.Stream as Stream
-import Text.HTML.TagSoup.HT.Parser.Custom as Parser
--- import Text.HTML.TagSoup.HT.Parser.MTL as Parser
+-- import Text.HTML.TagSoup.HT.Parser.Custom as Parser
+import Text.HTML.TagSoup.HT.Parser.MTL as Parser
-import Control.Monad (liftM, liftM2, )
-import Control.Monad.Fix (mfix, )
+import Control.Monad (liftM, liftM2, guard, )
-- import Control.Monad.Trans (lift, )
import Data.Monoid (Monoid)
@@ -26,21 +27,21 @@
-type Full w = Parser.T [w] Maybe
-type Fallible = Parser.T () Maybe
-type Emitting w = Parser.T [w] Identity
-type Plain = Parser.T () Identity
+type Full input w = Parser.T input [w] Maybe
+type Fallible input = Parser.T input () Maybe
+type Emitting input w = Parser.T input [w] Identity
+type Plain input = Parser.T input () Identity
write :: Monad fail =>
- FilePath -> Parser.T [w] fail () -> String -> fail [w]
+ FilePath -> Parser.T input [w] fail () -> input -> fail [w]
write fileName p =
liftM (\ ~(_,_,ws) -> ws) .
run p .
Status.Cons (Position.initialize fileName)
eval :: Monad fail =>
- FilePath -> Parser.T [w] fail a -> String -> fail a
+ FilePath -> Parser.T input [w] fail a -> input -> fail a
eval fileName p =
liftM (\ ~(x,_,_) -> x) .
run p .
@@ -48,17 +49,14 @@
-eof ::
- (Monoid output, Monad fail) =>
- Parser.T output fail Bool
-eof = gets (null . Status.source)
-
getPos ::
(Monoid output, Monad fail) =>
- Parser.T output fail Position.T
+ Parser.T input output fail Position.T
getPos = gets Status.sourcePos
-satisfy :: Monoid output => (Char -> Bool) -> Parser.T output Maybe Char
+satisfy ::
+ (Monoid output, Stream.C input) =>
+ (Char -> Bool) -> Parser.T input output Maybe Char
satisfy p =
do c <- nextChar
if p c
@@ -66,51 +64,88 @@
else fail "character not matched"
-- | does never fail
-many :: Monoid output => Parser.T output Maybe a -> Parser.T output Identity [a]
+many :: Monoid output =>
+ Parser.T input output Maybe a -> Parser.T input output Identity [a]
many x =
{- It is better to have 'force' at the place it is,
instead of writing it to the recursive call,
because 'x' can cause an infinite loop. -}
withDefault (many1 x) (return [])
-many1 :: Monoid output => Parser.T output Maybe a -> Parser.T output Maybe [a]
+-- | fails when trying the sub-parser the first time or never
+many1 :: Monoid output =>
+ Parser.T input output Maybe a -> Parser.T input output Maybe [a]
many1 x = liftM2 (:) x (allowFail $ many x)
-manySatisfy :: (Char -> Bool) -> Parser.T [w] Identity String
+
+manyNull :: Monoid output =>
+ Parser.T input output Maybe () -> Parser.T input output Identity ()
+manyNull x =
+ withDefault (many1Null x) (return ())
+
+many1Null :: Monoid output =>
+ Parser.T input output Maybe () -> Parser.T input output Maybe ()
+many1Null x = x >> (allowFail $ manyNull x)
+
+
+many0toN :: Monoid output =>
+ Int -> Parser.T input output Maybe a -> Parser.T input output Identity [a]
+many0toN n x =
+ withDefault (guard (n>0) >> many1toN n x) (return [])
+
+-- | condition: n>0, this will not be checked
+many1toN :: Monoid output =>
+ Int -> Parser.T input output Maybe a -> Parser.T input output Maybe [a]
+many1toN n x = liftM2 (:) x (allowFail $ many0toN (pred n) x)
+
+
+manySatisfy :: (Stream.C input) =>
+ (Char -> Bool) -> Parser.T input [w] Identity String
manySatisfy =
allowEmit . many . satisfy
-many1Satisfy :: (Char -> Bool) -> Parser.T [w] Maybe String
+many1Satisfy :: (Stream.C input) =>
+ (Char -> Bool) -> Parser.T input [w] Maybe String
many1Satisfy =
allowEmit . many1 . satisfy
-dropSpaces :: Parser.T [w] Identity ()
+dropSpaces :: (Stream.C input) =>
+ Parser.T input [w] Identity ()
dropSpaces =
manySatisfy isSpace >> return ()
-char :: Monoid output => Char -> Parser.T output Maybe Char
+char ::
+ (Monoid output, Stream.C input) =>
+ Char -> Parser.T input output Maybe Char
char c = satisfy (c==)
-string :: String -> Parser.T [w] Maybe String
+string :: (Stream.C input) =>
+ String -> Parser.T input [w] Maybe String
string = allowEmit . mapM char
-readUntil :: String -> Parser.T [w] Identity (Bool,String)
+readUntil :: (Stream.C input) =>
+ String -> Parser.T input [w] Identity (Bool,String)
readUntil pattern =
- let recurse =
+ let recourse =
foldr withDefault (return (False,[])) $
liftM (const (True,[])) (mapM char pattern) :
(do c <- nextChar
- ~(found,str) <- allowFail recurse
+ ~(found,str) <- allowFail recourse
return (found,c:str)) :
[]
- in allowEmit recurse
+ in allowEmit recourse
{-
runStateT (readUntil "-->") (Position.initialize "input", " other stuff")
-}
-emit :: Monad fail => w -> Parser.T [w] fail ()
+emit :: Monad fail =>
+ w -> Parser.T input [w] fail ()
emit w = tell [w]
+
+modifyEmission :: Monad fail =>
+ ([w] -> [w]) -> Parser.T input [w] fail a -> Parser.T input [w] fail a
+modifyEmission f = censor f
diff --git a/src/Text/HTML/TagSoup/HT/Parser/Custom.hs b/src/Text/HTML/TagSoup/HT/Parser/Custom.hs
--- a/src/Text/HTML/TagSoup/HT/Parser/Custom.hs
+++ b/src/Text/HTML/TagSoup/HT/Parser/Custom.hs
@@ -7,9 +7,16 @@
) where
-import qualified Text.HTML.TagSoup.HT.Position as Position
+import qualified Text.XML.Basic.Position as Position
import qualified Text.HTML.TagSoup.HT.Parser.Status as Status
+import qualified Text.HTML.TagSoup.HT.Parser.Stream as Stream
+{-
+If we want to stay independent from transformers package
+we have to define Stream without StateT.
+-}
+import Control.Monad.Trans.State (runStateT, )
+
import Control.Monad (MonadPlus, mzero, mplus, liftM, )
import Control.Monad.Fix (MonadFix, mfix, fix, )
@@ -30,11 +37,11 @@
but its monadic combinator @>>=@ is defined more lazily.
See Parser.MTL.
-}
-newtype T output fail a =
- Cons { run :: Status.T -> fail (a, Status.T, output) }
+newtype T input output fail a =
+ Cons { run :: Status.T input -> fail (a, Status.T input, output) }
-instance (Monoid output, Monad fail) => Monad (T output fail) where
+instance (Monoid output, Monad fail) => Monad (T input output fail) where
return a = Cons $ \s -> return (a, s, mempty)
m >>= k = Cons $ \s -> do
~(a, s', w) <- run m s
@@ -42,7 +49,7 @@
return (b, s'', mappend w w')
fail msg = Cons $ \_ -> fail msg
-instance (Monoid output, MonadPlus fail) => MonadPlus (T output fail) where
+instance (Monoid output, MonadPlus fail) => MonadPlus (T input output fail) where
mzero = Cons $ \_ -> mzero
m `mplus` n = Cons $ \s -> run m s `mplus` run n s
@@ -50,45 +57,47 @@
{- |
Cf. 'Control.Monad.State.gets'
-}
-gets :: (Monoid output, Monad fail) => (Status.T -> a) -> T output fail a
+gets :: (Monoid output, Monad fail) =>
+ (Status.T input -> a) -> T input output fail a
gets f =
Cons $ \ st -> return (f st, st, mempty)
{- |
Cf. 'Control.Monad.Writer.tell'
-}
-tell :: (Monad fail) => output -> T output fail ()
+tell :: (Monad fail) => output -> T input output fail ()
tell ws = Cons $ \ st -> return ((),st,ws)
-instance (Monoid output, MonadFix fail) => MonadFix (T output fail) where
+instance (Monoid output, MonadFix fail) => MonadFix (T input output fail) where
mfix f = Cons $ \ st -> mfix $ \ ~(a, _, _) -> run (f a) st
-nextChar :: (Monoid output, MonadPlus fail) => T output fail Char
+nextChar ::
+ (Monoid output, Stream.C input) =>
+ T input output Maybe Char
nextChar =
Cons $ \ (Status.Cons pos str) ->
- case str of
- [] -> mzero
- (c:cs) -> return (c, Status.Cons (Position.updateOnChar c pos) cs, mempty)
+ do (c,cs) <- runStateT Stream.getChar str
+ return (c, Status.Cons (Position.updateOnChar c pos) cs, mempty)
-- this replaces 'ignoreEmit'
allowEmit ::
Monad fail =>
- T () fail a -> T [w] fail a
+ T input () fail a -> T input [w] fail a
allowEmit p =
Cons $ liftM (\ ~(a,s,_) -> (a,s,mempty)) . run p
-- this replaces 'force'
-allowFail :: T output Identity a -> T output Maybe a
+allowFail :: T input output Identity a -> T input output Maybe a
allowFail p =
Cons $ return . runIdentity . run p
withDefault ::
- T output Maybe a ->
- T output Identity a ->
- T output Identity a
+ T input output Maybe a ->
+ T input output Identity a ->
+ T input output Identity a
withDefault p q =
Cons $ \s -> maybe (run q s) Identity (run p s)
diff --git a/src/Text/HTML/TagSoup/HT/Parser/MTL.hs b/src/Text/HTML/TagSoup/HT/Parser/MTL.hs
--- a/src/Text/HTML/TagSoup/HT/Parser/MTL.hs
+++ b/src/Text/HTML/TagSoup/HT/Parser/MTL.hs
@@ -1,20 +1,25 @@
module Text.HTML.TagSoup.HT.Parser.MTL (
T,
nextChar, withDefault,
- run, gets, tell, mfix,
+ run, gets, tell, censor, mfix,
allowFail, allowEmit,
module Control.Monad.Identity,
) where
-import qualified Text.HTML.TagSoup.HT.Position as Position
+import qualified Text.XML.Basic.Position as Position
import qualified Text.HTML.TagSoup.HT.Parser.Status as Status
-import Text.HTML.TagSoup.HT.Utility (mapSnd, )
+import qualified Text.HTML.TagSoup.HT.Parser.Stream as Stream
+import Data.Tuple.HT (mapSnd, )
-import Control.Monad.Writer (WriterT(..), mapWriterT, tell, lift, liftM, )
-import Control.Monad.State (StateT(..), mapStateT, gets, )
+import qualified Control.Monad.Trans.State as State
+
+import Control.Monad.Trans.Writer (WriterT(..), mapWriterT, tell, censor, )
+import Control.Monad.Trans.State (StateT(..), mapStateT, )
import Control.Monad.Fix (mfix)
import Control.Monad.Identity (Identity(..), )
+import Control.Monad.Trans (lift, )
+import Control.Monad (liftM, )
import Data.Monoid (Monoid)
@@ -27,32 +32,48 @@
if the assumptions of non-failing or non-emission were wrong.
Now, since we declare this properties in types,
runtime errors cannot happen.
+
+The downside is that we cannot easily extend that scheme
+to embedded monads that are sources of Chars.
+@StateT s Maybe@ and @MaybeT (State s)@ significantly differ
+in case of parser failures.
+The first one "resets" its state
+(more precisely, you would use 'mplus' to give alternative parsers a try,
+and 'mplus' would keep the original state),
+and the second one stays with the updated state.
+The second one would be close to @MaybeT (ReaderT Handle IO)@
+which would allow to use @hGetChar@ as character source,
+but for IO functions we had to maintain a list of characters
+that might have to be re-parsed by a parser alternative.
-}
-type T output fail = WriterT output (StateT Status.T fail)
+type T input output fail = WriterT output (StateT (Status.T input) fail)
run :: Monad fail =>
- T output fail a -> Status.T -> fail (a, Status.T, output)
+ T input output fail a -> Status.T input -> fail (a, Status.T input, output)
run p =
liftM (\((a,w),st) -> (a,st,w)) . runStateT (runWriterT p)
-nextChar :: Monoid output => T output Maybe Char
+nextChar :: (Monoid output, Stream.C input) =>
+ T input output Maybe Char
nextChar =
lift $
StateT $ \ (Status.Cons pos str) ->
- case str of
- [] -> Nothing
- (c:cs) -> Just (c, Status.Cons (Position.updateOnChar c pos) cs)
+ do (c,cs) <- runStateT Stream.getChar str
+ return (c, Status.Cons (Position.updateOnChar c pos) cs)
+gets :: (Monoid output, Monad fail) =>
+ (Status.T input -> a) -> T input output fail a
+gets = lift . State.gets
-- this replaces 'ignoreEmit'
allowEmit ::
Monad fail =>
- T () fail a -> T [w] fail a
+ T input () fail a -> T input [w] fail a
allowEmit =
- mapWriterT (fmap (mapSnd (const [])))
+ mapWriterT (liftM (mapSnd (const [])))
allowFail' ::
StateT s Identity a -> StateT s Maybe a
@@ -60,7 +81,7 @@
mapStateT (Just . runIdentity)
-- this replaces 'force'
-allowFail :: T output Identity a -> T output Maybe a
+allowFail :: T input output Identity a -> T input output Maybe a
allowFail =
mapWriterT allowFail'
@@ -73,8 +94,8 @@
maybe (runStateT q st) Identity (runStateT p st)
withDefault ::
- T output Maybe a ->
- T output Identity a ->
- T output Identity a
+ T input output Maybe a ->
+ T input output Identity a ->
+ T input output Identity a
withDefault p q =
WriterT $ withDefault' (runWriterT p) (runWriterT q)
diff --git a/src/Text/HTML/TagSoup/HT/Parser/Status.hs b/src/Text/HTML/TagSoup/HT/Parser/Status.hs
--- a/src/Text/HTML/TagSoup/HT/Parser/Status.hs
+++ b/src/Text/HTML/TagSoup/HT/Parser/Status.hs
@@ -1,10 +1,10 @@
module Text.HTML.TagSoup.HT.Parser.Status where
-import qualified Text.HTML.TagSoup.HT.Position as Position
+import qualified Text.XML.Basic.Position as Position
-data T =
+data T stream =
Cons {
sourcePos :: Position.T,
- source :: String
+ source :: stream
}
deriving Show
diff --git a/src/Text/HTML/TagSoup/HT/Parser/Stream.hs b/src/Text/HTML/TagSoup/HT/Parser/Stream.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/HTML/TagSoup/HT/Parser/Stream.hs
@@ -0,0 +1,68 @@
+module Text.HTML.TagSoup.HT.Parser.Stream where
+
+import Control.Monad.Trans.State (StateT(StateT), gets, put, )
+import Control.Monad (guard, mzero, )
+import qualified Data.List.HT as L
+
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.Lazy.Char8 as BL
+
+import qualified Prelude as P
+import Prelude hiding (Char, getChar, )
+
+
+class C stream where
+ getChar :: StateT stream Maybe P.Char
+
+
+class Char char where
+ toChar :: char -> P.Char
+
+instance Char P.Char where
+ toChar = id
+
+
+instance Char char => C [char] where
+ getChar = fmap toChar $ StateT L.viewL
+
+instance C BS.ByteString where
+ getChar = StateT BS.uncons
+
+instance C BL.ByteString where
+ getChar = StateT BL.uncons
+
+
+data PointerStrict =
+ PointerStrict {psSource :: !BS.ByteString, psIndex :: !Int}
+
+pointerFromByteStringStrict :: BS.ByteString -> PointerStrict
+pointerFromByteStringStrict str =
+ PointerStrict str 0
+
+instance C PointerStrict where
+ getChar =
+ do s <- gets psSource
+ i <- gets psIndex
+ guard (i < BS.length s)
+ put $ PointerStrict s (i+1)
+ return (BS.index s i)
+
+
+
+data PointerLazy =
+ PointerLazy {plSource :: ![BS.ByteString], plIndex :: !Int}
+
+pointerFromByteStringLazy :: BL.ByteString -> PointerLazy
+pointerFromByteStringLazy str =
+ PointerLazy (BL.toChunks str) 0
+
+instance C PointerLazy where
+ getChar =
+ do s <- gets plSource
+ i <- gets plIndex
+ case s of
+ [] -> mzero
+ (c:cs) ->
+ if i < BS.length c
+ then put (PointerLazy s (i+1)) >> return (BS.index c i)
+ else put (PointerLazy cs (i - BS.length c)) >> getChar
diff --git a/src/Text/HTML/TagSoup/HT/ParserNM.hs b/src/Text/HTML/TagSoup/HT/ParserNM.hs
--- a/src/Text/HTML/TagSoup/HT/ParserNM.hs
+++ b/src/Text/HTML/TagSoup/HT/ParserNM.hs
@@ -6,32 +6,44 @@
) where
import qualified Text.HTML.TagSoup as TagSoup
+import qualified Text.HTML.TagSoup.HT.Parser as Parser
import qualified Text.HTML.TagSoup.HT.Tag as Custom
import qualified Text.HTML.TagSoup.HT.PositionTag as PosTag
-import qualified Text.HTML.TagSoup.HT.Parser as Parser
-import qualified Text.HTML.TagSoup.HT.Position as Position
+import qualified Text.XML.Basic.Position as Position
+import qualified Text.XML.Basic.ProcessingInstruction as PI
+import qualified Text.XML.Basic.Attribute as Attr
+import qualified Text.XML.Basic.Name as Name
+import qualified Text.XML.Basic.Name.MixedCase as NameMC
import Data.Accessor.Basic ((^.), )
runSoup :: String -> [TagSoup.Tag]
runSoup =
- concatMap convertTag . Parser.runSoupWithPositions
+ concatMap convertTag .
+ (\x -> x :: [PosTag.T NameMC.T String]) .
+ Parser.runSoupWithPositions
-convertTag :: PosTag.T Char -> [TagSoup.Tag]
-convertTag (pos,tag) =
+convertTag ::
+ (Name.Tag name, Name.Attribute name) =>
+ PosTag.T name String -> [TagSoup.Tag]
+convertTag (PosTag.Cons pos tag) =
TagSoup.TagPosition (pos ^. Position.row) (pos ^. Position.column) :
(case tag of
- Custom.Open name attrs -> TagSoup.TagOpen name attrs
- Custom.Close name -> TagSoup.TagClose name
- Custom.Text text -> TagSoup.TagText text
- Custom.Comment text -> TagSoup.TagComment text
- Custom.Special name content
- -> TagSoup.TagOpen ('!':name) [("",content)]
- Custom.Processing name p
- -> TagSoup.TagOpen ('?':name) $
+ Custom.Open name attrs ->
+ TagSoup.TagOpen (Name.toString name) (map Attr.toPair attrs)
+ Custom.Close name ->
+ TagSoup.TagClose (Name.toString name)
+ Custom.Text text ->
+ TagSoup.TagText text
+ Custom.Comment text ->
+ TagSoup.TagComment text
+ Custom.Special name content ->
+ TagSoup.TagOpen ('!' : Name.toString name) [("",content)]
+ Custom.Processing name p ->
+ TagSoup.TagOpen ('?' : Name.toString name) $
case p of
- Custom.KnownProcessing attrs -> attrs
- Custom.UnknownProcessing content -> [("",content)]
+ PI.Known attrs -> map Attr.toPair attrs
+ PI.Unknown content -> [("",content)]
Custom.Warning text -> TagSoup.TagWarning text) :
[]
diff --git a/src/Text/HTML/TagSoup/HT/Position.hs b/src/Text/HTML/TagSoup/HT/Position.hs
deleted file mode 100644
--- a/src/Text/HTML/TagSoup/HT/Position.hs
+++ /dev/null
@@ -1,93 +0,0 @@
-{- |
-Module : Text.HTML.TagSoup.HT.Position
-
-Maintainer : tagsoup@henning-thielemann.de
-Stability : provisional
-Portability : portable
-
-Position in a file.
-
-Cf. to Text.ParserCombinators.Parsec.Pos
--}
-
-module Text.HTML.TagSoup.HT.Position (
- T, FileName, Row, Column,
- new, initialize,
- row, column, fileName,
- updateOnChar, updateOnString,
- toReportText,
- ) where
-
-import qualified Data.Accessor.Basic as Accessor
--- import Data.Accessor.Basic ((^=), )
-
-import Data.List (foldl')
-
-
-type FileName = String
-type Row = Int
-type Column = Int
-
-{- |
-Position in a file consisting of file name, row and column coordinates.
-Upper left is (0,0), but show routines can display this with different offsets.
--}
-data T =
- Cons {
- fileName_ :: FileName,
- row_ :: !Row,
- column_ :: !Column
- } deriving (Eq,Ord)
-
-
-new :: FileName -> Row -> Column -> T
-new = Cons
-
-initialize :: FileName -> T
-initialize fn = new fn 0 0
-
-
--- * access functions
-
-fileName :: Accessor.T T FileName
-fileName = Accessor.fromSetGet (\fn p -> p{fileName_ = fn}) fileName_
-
-row :: Accessor.T T Row
-row = Accessor.fromSetGet (\n p -> p{row_ = n}) row_
-
-column :: Accessor.T T Column
-column = Accessor.fromSetGet (\n p -> p{column_ = n}) column_
-
-
--- * update position according to read characters
-
-updateOnString :: T -> String -> T
-updateOnString pos string =
- foldl' (flip updateOnChar) pos string
-
-updateOnChar :: Char -> T -> T
-updateOnChar char (Cons name r c) =
- let (newRow, newColumn) =
- case char of
- '\n' -> (succ r, 0)
- '\t' -> (r, c + 8 - mod c 8)
- _ -> (r, succ c)
- in Cons name newRow newColumn
--- in (row ^= newRow) $ (column ^= newColumn) $ pos
-
-
--- * update position according to read characters
-
-{- |
-Convert the file position to a format
-that development environments can understand.
--}
-toReportText :: T -> String
-toReportText (Cons name r c) =
- concatMap (++":") [name, show (r+1), show (c+1)]
-
-instance Show T where
- showsPrec p (Cons name r c) =
- showParen (p >= 10)
- (showString $ unwords $
- "Position.new" : show name : show r : show c : [])
diff --git a/src/Text/HTML/TagSoup/HT/PositionTag.hs b/src/Text/HTML/TagSoup/HT/PositionTag.hs
--- a/src/Text/HTML/TagSoup/HT/PositionTag.hs
+++ b/src/Text/HTML/TagSoup/HT/PositionTag.hs
@@ -1,25 +1,81 @@
module Text.HTML.TagSoup.HT.PositionTag where
import qualified Text.HTML.TagSoup.HT.Tag as Tag
-import qualified Text.HTML.TagSoup.HT.Position as Position
+import qualified Text.XML.Basic.Name as Name
+import qualified Text.XML.Basic.Position as Position
-import Text.HTML.TagSoup.HT.Utility (mapSnd, )
+import Data.Tuple.HT (mapFst, )
+import Data.Monoid (Monoid, mempty, mappend, )
+import qualified Data.Accessor.Basic as Accessor
-type T char = (Position.T, Tag.T char)
+import Data.Foldable (Foldable(foldMap), )
+import Data.Traversable (Traversable(sequenceA), )
+import Control.Applicative (liftA, )
-lift :: (Tag.T char0 -> Tag.T char1) -> (T char0 -> T char1)
-lift = mapSnd
-canonicalizeSoup :: [T char] -> [T char]
-canonicalizeSoup =
- map canonicalize
+data T name string =
+ Cons {
+ position_ :: Position.T,
+ tag_ :: Tag.T name string
+ }
-{- |
-See 'Tag.canonicalize'.
+instance (Name.Attribute name, Show string, Show name) =>
+ Show (T name string) where
+ showsPrec p (Cons pos t) =
+ showParen (p > 10)
+ (showString "PosTag.cons " .
+ showsPrec 11 pos . showString " " .
+ showsPrec 11 t)
+
+{-
+> cons (Position.new "bla" 0 0) (Tag.Close $ Name.fromString "bla" :: Tag.T Text.XML.Basic.Name.LowerCase.T String)
-}
-canonicalize :: T char -> T char
-canonicalize = lift Tag.canonicalize
+cons :: Position.T -> Tag.T name string -> T name string
+cons = Cons
-textFromCData :: T Char -> T Char
+position :: Accessor.T (T name string) Position.T
+position = Accessor.fromSetGet (\n p -> p{position_ = n}) position_
+
+tag :: Accessor.T (T name string) (Tag.T name string)
+tag = Accessor.fromSetGet (\n p -> p{tag_ = n}) tag_
+
+lift ::
+ (Tag.T name0 string0 -> Tag.T name1 string1) ->
+ (T name0 string0 -> T name1 string1)
+lift f (Cons p t) = Cons p (f t)
+
+instance Functor (T name) where
+ fmap f = lift (fmap f)
+
+instance Foldable (T name) where
+ foldMap f = foldMap f . tag_
+
+instance Traversable (T name) where
+ sequenceA (Cons p t) = liftA (Cons p) $ sequenceA t
+
+
+textFromCData ::
+ (Eq name, Name.Tag name) =>
+ T name String -> T name String
textFromCData = lift Tag.textFromCData
+
+
+{- |
+Merge adjacent Text sections.
+-}
+concatTexts ::
+ Monoid string =>
+ [T name string] -> [T name string]
+concatTexts =
+ foldr
+ (\t ts ->
+ case t of
+ Cons pos (Tag.Text str0) ->
+ uncurry (:) $
+ mapFst (cons pos . Tag.Text . mappend str0) $
+ case ts of
+ Cons _ (Tag.Text str1) : rest -> (str1,rest)
+ _ -> (mempty,ts)
+ _ -> t:ts)
+ []
diff --git a/src/Text/HTML/TagSoup/HT/Process.hs b/src/Text/HTML/TagSoup/HT/Process.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/HTML/TagSoup/HT/Process.hs
@@ -0,0 +1,103 @@
+module Text.HTML.TagSoup.HT.Process where
+
+import qualified Text.HTML.TagSoup.HT.Tag as Tag
+import qualified Text.HTML.TagSoup.HT.Tag.Match as Match
+
+import qualified Text.XML.Basic.Attribute as Attr
+import qualified Text.XML.Basic.Name as Name
+
+import qualified Data.Char as Char
+import Data.List.HT (viewL, takeWhileRev, )
+import Data.Tuple.HT (mapFst, )
+import Data.Maybe (fromMaybe, mapMaybe, )
+import Control.Monad (guard, liftM2, )
+
+
+-- * analyse soup
+
+{-
+Rather the same as wraxml:HTML.Tree.findMetaEncoding
+-}
+findMetaEncoding ::
+ (Name.Tag name, Name.Attribute name, Eq name) =>
+ [Tag.T name String] -> Maybe String
+findMetaEncoding =
+ fmap (map Char.toLower . takeWhileRev ('='/=)) .
+ lookup "content-type" .
+ map (mapFst (map Char.toLower)) .
+ getMetaHTTPHeaders
+
+{- |
+Extract META tags which contain HTTP-EQUIV attribute
+and present these values like HTTP headers.
+-}
+getMetaHTTPHeaders ::
+ (Name.Tag name, Name.Attribute name, Eq name) =>
+ [Tag.T name string] -> [(string, string)]
+getMetaHTTPHeaders =
+ mapMaybe
+ (\tag ->
+ do (name, attrs) <- Tag.maybeOpen tag
+ guard (Name.match "meta" name)
+ liftM2 (,)
+ (Attr.lookupLit "http-equiv" attrs)
+ (Attr.lookupLit "content" attrs)) .
+ getHeadTags
+
+getHeadTags ::
+ (Name.Tag name, Name.Attribute name, Eq name) =>
+ [Tag.T name string] -> [Tag.T name string]
+getHeadTags =
+ takeWhile (not . Match.closeLit "head") .
+ drop 1 .
+ dropWhile (not . Match.openLit "head" (const True)) .
+ takeWhile (not . Match.openLit "body" (const True))
+
+
+-- * transform soup
+
+{- |
+Modify attributes and tags of certain parts.
+For limitations, see 'parts'.
+-}
+partAttrs ::
+ (Eq name) =>
+ (Tag.Name name -> Bool) ->
+ (([Attr.T name string], [Tag.T name string]) ->
+ ([Attr.T name string], [Tag.T name string])) ->
+ [Tag.T name string] -> [Tag.T name string]
+partAttrs p f =
+ concatMap
+ (either
+ (\((name,attrs),part) ->
+ let (newAttrs, newPart) = f (attrs, part)
+ in Tag.Open name newAttrs : newPart ++ [Tag.Close name])
+ id) .
+ parts p
+
+{- |
+Extract parts from the tag soup
+that are enclosed in corresponding open and close tags.
+If a close tag is missing, the soup end is considered as end of the part.
+However nested tags are not supported,
+e.g. in @@ the second @@ is considered
+to be enclosed in the first @@ and the first @@
+and the second @@ is ignored.
+-}
+parts ::
+ (Eq name) =>
+ (Tag.Name name -> Bool) ->
+ [Tag.T name string] ->
+ [Either
+ ((Tag.Name name, [Attr.T name string]), [Tag.T name string])
+ [Tag.T name string]]
+parts p =
+ let recourse ts =
+ let (prefix0,suffix0) = break (Match.open p (const True)) ts
+ in Right prefix0 :
+ fromMaybe []
+ (do (t, suffix1) <- viewL suffix0
+ (name, attrs) <- Tag.maybeOpen t
+ let (part,suffix2) = break (Match.close (name==)) suffix1
+ return $ Left ((name, attrs), part) : recourse (drop 1 suffix2))
+ in recourse
diff --git a/src/Text/HTML/TagSoup/HT/Tag.hs b/src/Text/HTML/TagSoup/HT/Tag.hs
--- a/src/Text/HTML/TagSoup/HT/Tag.hs
+++ b/src/Text/HTML/TagSoup/HT/Tag.hs
@@ -1,106 +1,233 @@
-module Text.HTML.TagSoup.HT.Tag where
+module Text.HTML.TagSoup.HT.Tag (
+ T(..), Name(..),
+ mapName,
-import Data.Char (toLower, toUpper, )
-import Data.Maybe (mapMaybe, )
+ isOpen, maybeOpen,
+ isClose, maybeClose,
+ isText, maybeText, innerText,
+ isComment, maybeComment,
+ isSpecial, maybeSpecial,
+ isCData, maybeCData,
+ isProcessing, maybeProcessing,
+ isWarning, maybeWarning,
+ formatOpen, formatClose,
--- * type definitions
+ textFromCData, concatTexts,
+ mapText, mapTextA,
+ ) where
-{- | An HTML attribute @id=\"name\"@ generates @(\"id\",\"name\")@ -}
-type Attribute char = (String,[char])
+import qualified Text.XML.Basic.ProcessingInstruction as PI
+import qualified Text.XML.Basic.Attribute as Attr
+import qualified Text.XML.Basic.Name as Name
+import qualified Text.XML.Basic.Format as Fmt
+import Text.XML.Basic.Tag (Name(Name), cdata, )
+import Data.Tuple.HT (mapFst, )
+import Data.Maybe (mapMaybe, fromMaybe, )
+import Data.Monoid (Monoid, mempty, mappend, mconcat, )
+import Control.Monad (guard, )
+
+import Data.Foldable (Foldable(foldMap), )
+import Data.Traversable (Traversable(sequenceA), traverse, )
+import Control.Applicative (Applicative, pure, liftA, )
+
+
+-- * type definitions
+
{- |
An HTML element, a document is @[T]@.
There is no requirement for 'Open' and 'Close' to match.
-The type parameter @char@ lets you choose between
-@Char@ for interpreted HTML entity references and
-@HTMLChar.T@ for uninterpreted HTML entity.
+The type parameter @string@ lets you choose between
+@[Char]@ for interpreted HTML entity references and
+@[HTMLChar.T]@ for uninterpreted HTML entities.
You will most oftenly want plain @Char@,
since @HTMLChar.T@ is only necessary if you want to know,
whether a non-ASCII character was encoded as HTML entity
or as non-ASCII Unicode character.
-}
-data T char =
- Open String [Attribute char]
- -- ^ An open tag with 'Attribute's in their original order.
- | Close String
+data T name string =
+ Open (Name name) [Attr.T name string]
+ -- ^ An open tag with 'Attr.T's in their original order.
+ | Close (Name name)
-- ^ A closing tag
- | Text [char]
+ | Text string
-- ^ A text node, guaranteed not to be the empty string
| Comment String
-- ^ A comment
- | Special String String
+ | Special (Name name) String
-- ^ A tag like @\@
- | Processing String (Processing char)
+ | Processing (Name name) (PI.T name string)
-- ^ A tag like @\@
| Warning String
-- ^ Mark a syntax error in the input file
deriving (Show, Eq, Ord)
-data Processing char =
- KnownProcessing [Attribute char]
- | UnknownProcessing String
- deriving (Show, Eq, Ord)
+instance Functor (T name) where
+ fmap f tag =
+ case tag of
+ Open name attrs -> Open name $ map (fmap f) attrs
+ Close name -> Close name
+ Text text -> Text $ f text
+ Comment text -> Comment text
+ Special name content -> Special name content
+ Processing name proc -> Processing name $ fmap f proc
+ Warning text -> Warning text
+
+instance Foldable (T name) where
+ foldMap f tag =
+ case tag of
+ Open _name attrs -> foldMap (foldMap f) attrs
+ Close _name -> mempty
+ Text text -> f text
+ Comment _text -> mempty
+ Special _name _content -> mempty
+ Processing _name proc -> foldMap f proc
+ Warning _text -> mempty
+
+
+instance Traversable (T name) where
+ sequenceA tag =
+ case tag of
+ Open name attrs -> liftA (Open name) $ traverse sequenceA attrs
+ Close name -> pure $ Close name
+ Text text -> liftA Text $ text
+ Comment text -> pure $ Comment text
+ Special name content -> pure $ Special name content
+ Processing name proc -> liftA (Processing name) $ sequenceA proc
+ Warning text -> pure $ Warning text
+
+
+mapName :: (name0 -> name1) -> T name0 string -> T name1 string
+mapName f tag =
+ case tag of
+ Open (Name name) attrs -> Open (Name $ f name) $ map (Attr.mapName f) attrs
+ Close (Name name) -> Close (Name $ f name)
+ Text text -> Text text
+ Comment text -> Comment text
+ Special (Name name) content -> Special (Name $ f name) content
+ Processing (Name name) proc -> Processing (Name $ f name) $ PI.mapName f proc
+ Warning text -> Warning text
+
+
+
+
+
+instance (Eq name, Name.Tag name, Name.Attribute name, Fmt.C string) =>
+ Fmt.C (T name string) where
+ run t =
+ case t of
+ Open name attrs -> formatOpen False name attrs
+ Close name -> formatClose name
+ Text str -> Fmt.run str
+ Comment c ->
+ showString ""
+ Warning e ->
+ showString ""
+ Special name str ->
+ Fmt.angle $
+ Fmt.exclam .
+ Fmt.name name .
+ if cdata == name
+ then showString str . showString "]]"
+ else Fmt.blank . showString str
+ Processing name p ->
+ Fmt.angle $
+ Fmt.quest .
+ Fmt.name name .
+ Fmt.run p .
+ Fmt.quest
+
+
+formatOpen :: (Name.Tag name, Name.Attribute name, Fmt.C string) =>
+ Bool -> Name name -> [Attr.T name string] -> ShowS
+formatOpen selfClosing name attrs =
+ Fmt.angle $
+ Fmt.name name .
+ Attr.formatListBlankHead attrs .
+ if selfClosing then Fmt.slash else id
+
+formatClose :: (Name.Tag name) =>
+ Name name -> ShowS
+formatClose name =
+ Fmt.angle $
+ Fmt.slash . Fmt.name name
+
+
-- * check for certain tag types
-- | Test if a 'T' is a 'Open'
-isOpen :: T char -> Bool
+isOpen :: T name string -> Bool
isOpen tag = case tag of (Open {}) -> True; _ -> False
-maybeOpen :: T char -> Maybe (String, [Attribute char])
+maybeOpen :: T name string -> Maybe (Name name, [Attr.T name string])
maybeOpen tag = case tag of Open name attrs -> Just (name, attrs); _ -> Nothing
-- | Test if a 'T' is a 'Close'
-isClose :: T char -> Bool
+isClose :: T name string -> Bool
isClose tag = case tag of (Close {}) -> True; _ -> False
-maybeClose :: T char -> Maybe String
+maybeClose :: T name string -> Maybe (Name name)
maybeClose tag = case tag of Close x -> Just x; _ -> Nothing
-- | Test if a 'T' is a 'Text'
-isText :: T char -> Bool
+isText :: T name string -> Bool
isText tag = case tag of (Text {}) -> True; _ -> False
-- | Extract the string from within 'Text', otherwise 'Nothing'
-maybeText :: T char -> Maybe [char]
+maybeText :: T name string -> Maybe string
maybeText tag = case tag of Text x -> Just x; _ -> Nothing
-- maybeText tag = do Text x <- Just tag; return x
-- | Extract all text content from tags (similar to Verbatim found in HaXml)
-innerText :: [T char] -> [char]
-innerText = concat . mapMaybe maybeText
+innerText :: (Monoid string) => [T name string] -> string
+innerText = mconcat . mapMaybe maybeText
-isComment :: T char -> Bool
+isComment :: T name string -> Bool
isComment tag = case tag of (Comment {}) -> True; _ -> False
-maybeComment :: T char -> Maybe String
+maybeComment :: T name string -> Maybe String
maybeComment tag = case tag of Comment x -> Just x; _ -> Nothing
-isSpecial :: T char -> Bool
+isSpecial :: T name string -> Bool
isSpecial tag = case tag of (Special {}) -> True; _ -> False
-maybeSpecial :: T char -> Maybe (String, String)
+maybeSpecial :: T name string -> Maybe (Name name, String)
maybeSpecial tag = case tag of Special name content -> Just (name, content); _ -> Nothing
-isProcessing :: T char -> Bool
+isCData ::
+ (Eq name, Name.Tag name) =>
+ T name string -> Bool
+isCData tag = case tag of (Special name _) -> cdata == name; _ -> False
+
+maybeCData ::
+ (Eq name, Name.Tag name) =>
+ T name string -> Maybe String
+maybeCData tag =
+ do (name, content) <- maybeSpecial tag
+ guard (cdata == name)
+ return content
+
+
+isProcessing :: T name string -> Bool
isProcessing tag = case tag of (Processing {}) -> True; _ -> False
-maybeProcessing :: T char -> Maybe (String, Processing char)
+maybeProcessing :: T name string -> Maybe (Name name, PI.T name string)
maybeProcessing tag = case tag of Processing target instr -> Just (target, instr); _ -> Nothing
-isWarning :: T char -> Bool
+isWarning :: T name string -> Bool
isWarning tag = case tag of (Warning {}) -> True; _ -> False
-maybeWarning :: T char -> Maybe String
+maybeWarning :: T name string -> Maybe String
maybeWarning tag = case tag of Warning x -> Just x; _ -> Nothing
-- maybeWarning tag = do Warning x <- Just tag; return x
@@ -108,27 +235,74 @@
-- * tag processing
-canonicalizeSoup :: [T char] -> [T char]
-canonicalizeSoup =
- map canonicalize
-
{- |
-Turns all tag names to lower case and
-converts DOCTYPE to upper case.
+Replace CDATA sections by plain text.
-}
-canonicalize :: T char -> T char
-canonicalize t =
+textFromCData ::
+ (Eq name, Name.Tag name) =>
+ T name String -> T name String
+textFromCData t =
+ fromMaybe t $
+ do (name, text) <- maybeSpecial t
+ guard (cdata == name)
+ return $ Text text
+
+{-
case t of
- Open name attrs -> Open (map toLower name) attrs
- Close name -> Close (map toLower name)
- Special name info -> Special (map toUpper name) info
+ Special name text ->
+ if cdata == name
+ then Text text
+ else t
_ -> t
+-}
{- |
-Replace CDATA sections by plain text.
+Merge adjacent Text sections.
-}
-textFromCData :: T Char -> T Char
-textFromCData t =
+concatTexts ::
+ Monoid string =>
+ [T name string] -> [T name string]
+concatTexts =
+ foldr
+ (\t ts ->
+ case t of
+ Text str0 ->
+ uncurry (:) $
+ mapFst (Text . mappend str0) $
+ case ts of
+ Text str1 : rest -> (str1,rest)
+ _ -> (mempty,ts)
+ _ -> t:ts)
+ []
+
+
+{- |
+Modify content of a Text or a CDATA part.
+-}
+mapText ::
+ (Eq name, Name.Tag name) =>
+ (String -> String) ->
+ T name String -> T name String
+mapText f t =
case t of
- Special "[CDATA[" text -> Text text
+ Text s -> Text $ f s
+ Special name s ->
+ Special name $
+ if cdata == name
+ then f s
+ else s
_ -> t
+
+mapTextA ::
+ (Eq name, Name.Tag name, Applicative f) =>
+ (String -> f String) ->
+ T name String -> f (T name String)
+mapTextA f t =
+ case t of
+ Text s -> liftA Text $ f s
+ Special name s ->
+ liftA (Special name) $
+ if cdata == name
+ then f s
+ else pure s
+ _ -> pure t
diff --git a/src/Text/HTML/TagSoup/HT/Tag/Match.hs b/src/Text/HTML/TagSoup/HT/Tag/Match.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/HTML/TagSoup/HT/Tag/Match.hs
@@ -0,0 +1,89 @@
+module Text.HTML.TagSoup.HT.Tag.Match where
+
+import qualified Text.HTML.TagSoup.HT.Tag as Tag
+import qualified Text.XML.Basic.Attribute as Attr
+import qualified Text.XML.Basic.Name as Name
+
+
+ignore :: a -> Bool
+ignore _ = True
+
+
+-- | match an opening tag
+open :: (Tag.Name name -> Bool) -> ([Attr.T name string] -> Bool) -> Tag.T name string -> Bool
+open pName pAttrs (Tag.Open name attrs) =
+ pName name && pAttrs attrs
+open _ _ _ = False
+
+-- | match an closing tag
+close :: (Tag.Name name -> Bool) -> Tag.T name string -> Bool
+close pName (Tag.Close name) = pName name
+close _ _ = False
+
+-- | match a text
+text :: (string -> Bool) -> Tag.T name string -> Bool
+text p (Tag.Text str) = p str
+text _ _ = False
+
+comment :: (String -> Bool) -> Tag.T name string -> Bool
+comment p (Tag.Comment str) = p str
+comment _ _ = False
+
+special :: (Tag.Name name -> Bool) -> (String -> Bool) -> Tag.T name string -> Bool
+special pType pInfo (Tag.Special typ info) = pType typ && pInfo info
+special _ _ _ = False
+
+
+-- | match a opening tag's name literally
+openLit ::
+ (Eq name, Name.Tag name) =>
+ String -> ([Attr.T name string] -> Bool) -> Tag.T name string -> Bool
+openLit name = open (Name.match name)
+
+-- | match a closing tag's name literally
+closeLit ::
+ (Eq name, Name.Tag name) =>
+ String -> Tag.T name string -> Bool
+closeLit name = close (Name.match name)
+
+openAttrLit ::
+ (Eq name, Name.Attribute name, Name.Tag name, Eq string) =>
+ String -> String -> string -> Tag.T name string -> Bool
+openAttrLit name attrName attrValue =
+ openLit name (Attr.anyLit attrName attrValue)
+
+{- |
+Match a tag with given name, that contains an attribute
+with given name, that satisfies a predicate.
+If an attribute occurs multiple times,
+all occurrences are checked.
+-}
+openAttrNameLit ::
+ (Eq name, Name.Attribute name, Name.Tag name) =>
+ String -> String -> (string -> Bool) -> Tag.T name string -> Bool
+openAttrNameLit tagName attrName pAttrValue =
+ openLit tagName
+ (Attr.any (\(Attr.Cons name value) ->
+ Name.match attrName name && pAttrValue value))
+
+
+-- | Check if the 'Tag.T' is 'Tag.Open' and matches the given name
+openNameLit ::
+ (Eq name, Name.Tag name) =>
+ String -> Tag.T name string -> Bool
+openNameLit name = openLit name ignore
+
+-- | Check if the 'Tag.T' is 'Tag.Close' and matches the given name
+closeNameLit ::
+ (Eq name, Name.Tag name) =>
+ String -> Tag.T name string -> Bool
+closeNameLit name = closeLit name
+
+
+
+{-
+getTagContent :: String -> ([Attr.T name string] -> Bool) -> [Tag.T name string] -> [Tag.T name string]
+getTagContent name pAttrs =
+ takeWhile (not . tagCloseLit name) . drop 1 .
+ head . sections (tagOpenLit name pAttrs)
+-}
diff --git a/src/Text/HTML/TagSoup/HT/Test.hs b/src/Text/HTML/TagSoup/HT/Test.hs
--- a/src/Text/HTML/TagSoup/HT/Test.hs
+++ b/src/Text/HTML/TagSoup/HT/Test.hs
@@ -8,7 +8,9 @@
import qualified Text.HTML.TagSoup.HT.Tag as Tag
import qualified Text.HTML.TagSoup.HT.Parser as Parser
+import qualified Text.XML.Basic.Name.MixedCase as Name
import qualified Text.HTML.TagSoup as TagSoupNM
+import Data.List (isPrefixOf, )
{-
*Text.HTML.TagSoup.HT> mapM print $ runSoup $ "