packages feed

tagsoup-ht 0.2 → 0.3

raw patch · 20 files changed

+1227/−488 lines, 20 filesdep +bytestringdep +containersdep +explicit-exceptiondep −mtldep ~basedep ~data-accessornew-component:exe:tagsoupspeed

Dependencies added: bytestring, containers, explicit-exception, old-time, transformers, utility-ht, xml-basic

Dependencies removed: mtl

Dependency ranges changed: base, data-accessor

Files

+ example/Speed.hs view
@@ -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 "<li>item</li>" :: Tag.T Name.T String)+      measureTime "ByteString.Strict" $ print $+         (last $ Parser.runSoup $ BS.concat $ replicate number $ BS.pack "<li>item</li>" :: Tag.T Name.T String)+      measureTime "ByteString.Lazy" $ print $+         (last $ Parser.runSoup $ BL.concat $ replicate number $ BL.pack "<li>item</li>" :: Tag.T Name.T String)++      measureTime "Pointer.Strict" $ print $+         (last $ Parser.runSoup $ Str.pointerFromByteStringStrict $ BS.concat $ replicate number $ BS.pack "<li>item</li>" :: Tag.T Name.T String)+      measureTime "Pointer.Lazy" $ print $+         (last $ Parser.runSoup $ Str.pointerFromByteStringLazy $ BL.concat $ replicate number $ BL.pack "<li>item</li>" :: 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+-}
example/Validate.hs view
@@ -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 ()
+ src/Text/HTML/TagSoup/HT/Format.hs view
@@ -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 "<?xml version=1.0 ?>" :: [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. @<a></a>@ becomes @<a/>@.+-}+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. @<br>@.+-}+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. @<br/>@.+-}+xhtml :: (Ord name, Name.Tag name, Name.Attribute name, Fmt.C string) =>+   [Tag.T name string] -> ShowS+xhtml =+   xmlCondensedGen+      -- e.g. <div></div> must not be merged to <div/>+      (\nameOpen nameClose ->+          nameOpen==nameClose && TagH.isEmpty nameOpen)++{- |+If the first tag is @<?xml ...?>@ 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
− src/Text/HTML/TagSoup/HT/HTMLChar.hs 
@@ -1,7 +0,0 @@-module Text.HTML.TagSoup.HT.HTMLChar where--data T =-     Char Char-   | NumericRef Int-   | NamedRef String-      deriving (Show, Eq)
− src/Text/HTML/TagSoup/HT/Match.hs 
@@ -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)--}
src/Text/HTML/TagSoup/HT/Parser.hs view
@@ -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 \"\<bla\>\"@ is the same as @runInnerOfTag \"\<bla\>\"@. -}-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 &lt; 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. "&amp ;" is considered as plain "&amp ;",+and only "&amp;" 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 ()
src/Text/HTML/TagSoup/HT/Parser/Combinator.hs view
@@ -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", "<!-- comment --> 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
src/Text/HTML/TagSoup/HT/Parser/Custom.hs view
@@ -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)
src/Text/HTML/TagSoup/HT/Parser/MTL.hs view
@@ -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)
src/Text/HTML/TagSoup/HT/Parser/Status.hs view
@@ -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
+ src/Text/HTML/TagSoup/HT/Parser/Stream.hs view
@@ -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
src/Text/HTML/TagSoup/HT/ParserNM.hs view
@@ -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) :    []
− src/Text/HTML/TagSoup/HT/Position.hs 
@@ -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 : [])
src/Text/HTML/TagSoup/HT/PositionTag.hs view
@@ -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)+      []
+ src/Text/HTML/TagSoup/HT/Process.hs view
@@ -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 @<a><a></a></a>@ the second @<a>@ is considered+to be enclosed in the first @<a>@ and the first @</a>@+and the second @</a>@ 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
src/Text/HTML/TagSoup/HT/Tag.hs view
@@ -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 @\<!DOCTYPE ...\>@-   | Processing String (Processing char)+   | Processing (Name name) (PI.T name string)         -- ^ A tag like @\<?xml ...\>@    | 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 "<!--" . showString c . showString "-->"+         Warning e ->+            showString "<!-- Warning: " . showString 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
+ src/Text/HTML/TagSoup/HT/Tag/Match.hs view
@@ -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)+-}
src/Text/HTML/TagSoup/HT/Test.hs view
@@ -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 $ "</html " ++ cycle " abc=a_b&c"@@ -27,9 +29,9 @@ you have found a laziness stopper. -} laziness :: [Char]-laziness = lazyTags ++ lazyWarnings+laziness = lazyTags ++ lazyWarnings ++ restrictedWarnings -runSoup :: String -> [Tag.T Char]+runSoup :: String -> [Tag.T Name.T String] runSoup = Parser.runSoup  lazyTags :: [Char]@@ -37,6 +39,8 @@    map ((!!1000) . show . runSoup) $       (cycle "Rhabarber") :       (repeat '&') :+      ('&' : '#' : repeat '1') :+      ('&' : repeat 'a') :       ("<"++cycle "html") :       ("<html "++cycle "name") :       ("<html "++cycle "na!me=value ") :@@ -61,11 +65,18 @@    map ((!!1000) . show . tail . runSoup) $       (repeat '&') :       ("<html "++cycle "na!me=value ") :+      ("</html "++cycle "junk") :+      (cycle "1<2 ") :+      []++restrictedWarnings :: [Char]+restrictedWarnings =+   map (last . show . head .+        dropWhile (not . maybe False (isPrefixOf "further") . Tag.maybeWarning) .+        runSoup) $       ("<html name="++cycle "val!ue") :       ("<html name="++cycle "val&ue") :       ("<html name="++cycle "va&l!ue") :-      ("</html "++cycle "junk") :-      (cycle "1<2 ") :       []  @@ -79,9 +90,9 @@  sections_rec :: (a -> Bool) -> [a] -> [[a]] sections_rec f =-   let recurse [] = []-       recurse (x:xs) = (f x, x:xs) ?: recurse xs-   in  recurse+   let recourse [] = []+       recourse (x:xs) = (f x, x:xs) ?: recourse xs+   in  recourse  propSections :: Int -> [Int] -> Bool propSections y xs  =
− src/Text/HTML/TagSoup/HT/Utility.hs 
@@ -1,4 +0,0 @@-module Text.HTML.TagSoup.HT.Utility where--mapSnd :: (b -> c) -> (a,b) -> (a,c)-mapSnd f ~(a,b) = (a, f b)
tagsoup-ht.cabal view
@@ -1,5 +1,5 @@ Name:           tagsoup-ht-Version:        0.2+Version:        0.3 License:        GPL License-File:   LICENSE Author:         Henning Thielemann <tagsoup@henning-thielemann.de>@@ -12,28 +12,38 @@    Here I present my own parser,    which I find (of course) more comprehensible and easier to extend.    It also handles XML declarations and CDATA sections correctly.+   This package is abandoned and will be renamed to Tagchup. Build-Type:  Simple-Build-Depends:  base, mtl, tagsoup >=0.6 && <0.7, data-accessor >=0.1 && <0.2--- mtl for StateT monad transformer---    you can omit it and the module Text.HTML.TagSoup.HT.Parser.MTL,---    falling back to Text.HTML.TagSoup.HT.Parser.Custom+Build-Depends:+   xml-basic >=0.0.1 && <0.1,+   transformers >=0.0 && <0.2,+      -- 'transformers' for StateT monad transformer+      --    you can omit it and the module Text.HTML.TagSoup.HT.Parser.MTL,+      --    falling back to Text.HTML.TagSoup.HT.Parser.Custom+   explicit-exception >=0.1 && <0.2,+   tagsoup >=0.6 && <0.7,+   bytestring >=0.9.0.1 && <0.10,+   containers >=0.1 && <0.3,+   data-accessor >=0.2 && <0.3,+   utility-ht >=0.0.1 && <0.1,+   base >=3 && <4 GHC-Options: -Wall Hs-Source-Dirs: src Exposed-Modules:    Text.HTML.TagSoup.HT.ParserNM    Text.HTML.TagSoup.HT.Parser+   Text.HTML.TagSoup.HT.Format    Text.HTML.TagSoup.HT.Tag+   Text.HTML.TagSoup.HT.Tag.Match    Text.HTML.TagSoup.HT.PositionTag-   Text.HTML.TagSoup.HT.Position-   Text.HTML.TagSoup.HT.Match-   Text.HTML.TagSoup.HT.HTMLChar+   Text.HTML.TagSoup.HT.Process  Other-Modules:    Text.HTML.TagSoup.HT.Parser.Combinator    Text.HTML.TagSoup.HT.Parser.Custom    Text.HTML.TagSoup.HT.Parser.MTL    Text.HTML.TagSoup.HT.Parser.Status-   Text.HTML.TagSoup.HT.Utility+   Text.HTML.TagSoup.HT.Parser.Stream  Executable: tagsouptest GHC-Options: -Wall@@ -41,6 +51,12 @@ Other-Modules:    Text.HTML.TagSoup.HT.Test Main-Is:     example/Test.hs++Executable: tagsoupspeed+GHC-Options: -Wall+Hs-Source-Dirs: src, .+Build-Depends: old-time >=1.0 && <1.1+Main-Is:     example/Speed.hs  Executable: validate-tagsoup GHC-Options: -Wall