packages feed

tagchup 0.3.1 → 0.4

raw patch · 16 files changed

+933/−544 lines, 16 filesdep +hxtdep ~xml-basicnew-component:exe:escape-htmlnew-component:exe:strip-html

Dependencies added: hxt

Dependency ranges changed: xml-basic

Files

+ example/Escape.hs view
@@ -0,0 +1,52 @@+{- |+Detects character encoding, decodes,+and convert all special characters to HTML references.+CDATA sections are converted to plain text.+Input is read from standard input,+output is written to standard output.+The encoding can be given as one argument,+which then overrides encoding information within the document.++> escape-html utf-8 <input.xhtml >output.xhtml+-}+module Main where++import qualified Text.XML.HXT.DOM.Unicode as Unicode++import qualified Text.HTML.Tagchup.Parser as Parser+import qualified Text.HTML.Tagchup.Format as Format+import qualified Text.HTML.Tagchup.Process as Process+import qualified Text.HTML.Tagchup.Tag     as Tag+import qualified Text.HTML.Basic.Character as HTMLChar+import qualified Text.XML.Basic.Name.LowerCase as Name++import System.Environment (getArgs, )+++getDecoder :: Process.Encoding -> Process.Encoded -> String+getDecoder =+   maybe Unicode.latin1ToUnicode (fst.) .+   Unicode.getDecodingFct++escape :: [Tag.T Name.T String] -> String+escape =+   flip Format.htmlOrXhtml "" .+   map (fmap (map HTMLChar.asciiFromUnicode) . Tag.textFromCData)++main :: IO ()+main =+   do argv <- getArgs+      case argv of+         [] ->+            interact+               (escape .+                Process.evalDecodeAdaptive .+                Process.decodeAdaptive getDecoder .+                Parser.runSoup)+         [encoding] ->+            interact+               (escape .+                Parser.runSoup .+                getDecoder encoding)+         _ ->+            putStrLn "Error: more than one decoding given"
+ example/Escape/iso8859.html view
@@ -0,0 +1,18 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2 Final//EN">+<HTML>+<HEAD>+<META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=ISO-8859-1">+<META HTTP-EQUIV="Content-Language" CONTENT="DE">+<META NAME="description" CONTENT="Testeingabe für Escape-Programm">+<META NAME="author" CONTENT="ich">+<META NAME="keywords" CONTENT="WWW, XML, HTML, XHTML, XML References">+<TITLE>Hennings HomePage</TITLE>+</HEAD>+<BODY>++<H1> De Bärchschafft vonne Früdrüch Schöller </H1>++<![CDATA[<gähn>]]>++</BODY>+</HTML>
+ example/Escape/iso8859.xhtml view
@@ -0,0 +1,26 @@+<?xml version="1.0" encoding="ISO-8859-1"?>+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"+    "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">+<html xmlns="http://www.w3.org/1999/xhtml">+<head>+<meta name="description" content="Testeingabe für Escape-Programm" />+<meta name="author" content="ich" />+<meta name="keywords" content="WWW, XML, HTML, XHTML, XML References" />+<style type="text/css">+    body {+         color: maroon;+         background-color: yellow;+    }+</style>+<title> Märchenstunde </title>+</head>+<body>++<h1> De Bärchschafft vonne Früdrüch Schöller </h1>++<p>+<![CDATA[<gähn>]]>+</p>++</body>+</html>
+ example/Escape/utf8.html view
@@ -0,0 +1,18 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2 Final//EN">+<HTML>+<HEAD>+<META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=UTF-8">+<META HTTP-EQUIV="Content-Language" CONTENT="DE">+<META NAME="description" CONTENT="Testeingabe für Escape-Programm">+<META NAME="author" CONTENT="ich">+<META NAME="keywords" CONTENT="WWW, XML, HTML, XHTML, XML References">+<TITLE>Hennings HomePage</TITLE>+</HEAD>+<BODY>++<H1> De Bärchschafft vonne Früdrüch Schöller </H1>++<![CDATA[<gähn>]]>++</BODY>+</HTML>
+ example/Escape/utf8.xhtml view
@@ -0,0 +1,26 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"+    "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">+<html xmlns="http://www.w3.org/1999/xhtml">+<head>+<meta name="description" content="Testeingabe für Escape-Programm" />+<meta name="author" content="ich" />+<meta name="keywords" content="WWW, XML, HTML, XHTML, XML References" />+<style type="text/css">+    body {+         color: maroon;+         background-color: yellow;+    }+</style>+<title> Märchenstunde </title>+</head>+<body>++<h1> De Bärchschafft vonne Früdrüch Schöller </h1>++<p>+<![CDATA[<gähn>]]>+</p>++</body>+</html>
+ example/Strip.hs view
@@ -0,0 +1,25 @@+{- |+Strip HTML comments, script and style tags.++> strip-html <input.xhtml >output.xhtml+-}+module Main where++import qualified Text.HTML.Tagchup.Parser as Parser+import qualified Text.HTML.Tagchup.Format as Format+import qualified Text.HTML.Tagchup.Process as Process+import qualified Text.HTML.Tagchup.Tag     as Tag+import qualified Text.XML.Basic.Name.LowerCase as NameLC+import qualified Text.XML.Basic.Name as Name+++strip :: [Tag.T NameLC.T String] -> String+strip =+   flip Format.htmlOrXhtml "" .+   concatMap (either (const []) id) .+   Process.parts (Name.matchAny ["script", "style"]) .+   filter (not . Tag.isComment)++main :: IO ()+main =+   interact (strip . Parser.runSoup)
+ example/Strip/example.xhtml view
@@ -0,0 +1,32 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"+    "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">+<html xmlns="http://www.w3.org/1999/xhtml">+<head>+<meta name="description" content="Testeingabe für Strip-Programm" />+<meta name="author" content="ich" />+<meta name="keywords" content="WWW, XML, HTML, XHTML, XML References" />+<style type="text/css">+    body {+         color: maroon;+         background-color: yellow;+    }+</style>+<title> Märchenstunde </title>+</head>+<body>++<!-- secret information -->++<h1> De Bärchschafft vonne Früdrüch Schöller </h1>++<script type="text/pseudocode">+<![CDATA[<gähn>]]>+</script>++<p>+Really irrelevant text!+</p>++</body>+</html>
example/Validate.hs view
@@ -1,24 +1,24 @@-{-+{- | Example program for TagSoup. Detects basic syntax errors like isolated ampersands and unquoted attribute values. -} module Main where -import Text.HTML.Tagchup.Parser-import qualified Text.XML.Basic.Position    as Position+import qualified Text.HTML.Tagchup.Parser      as Parser import qualified Text.HTML.Tagchup.PositionTag as PosTag import qualified Text.HTML.Tagchup.Tag         as Tag+import qualified Text.XML.Basic.Position       as Position import qualified Text.XML.Basic.Name.MixedCase as Name -import System.Environment (getArgs)+import System.Environment (getArgs, ) -import Data.Maybe (mapMaybe)+import Data.Maybe (mapMaybe, )   validate :: FilePath -> String -> String validate fileName input =    let tags :: [PosTag.T Name.T String]-       tags = runSoupWithPositionsName fileName input+       tags = Parser.runSoupWithPositionsName fileName input        warnings =           mapMaybe              (\(PosTag.Cons pos tag) ->
+ src/Text/HTML/Tagchup/Character.hs view
@@ -0,0 +1,13 @@+module Text.HTML.Tagchup.Character where++import qualified Text.HTML.Basic.Character as HTMLChar+++class C char where+   fromChar :: Char -> char++instance C Char where+   fromChar = id++instance C HTMLChar.T where+   fromChar = HTMLChar.Unicode
src/Text/HTML/Tagchup/Parser.hs view
@@ -14,43 +14,21 @@     runTag, runInnerOfTag,   ) where -import Text.HTML.Tagchup.Parser.Combinator-   (allowFail, withDefault,-    char, dropSpaces, getPos,-    many, manyS, many0toN, many1toN,-    many1Satisfy, readUntil,-    satisfy, string,-    emit, modifyEmission, )+import Text.HTML.Tagchup.Parser.Tag+   (CharType, StringType, parsePosTag, parsePosTagMergeWarnings, ) +import Text.HTML.Tagchup.Parser.Combinator (manyS, )+ import qualified Text.HTML.Tagchup.Parser.Combinator as Parser-import qualified Text.HTML.Tagchup.Parser.Status as Status+import qualified Text.HTML.Tagchup.Parser.Stream as Stream  import qualified Text.HTML.Tagchup.PositionTag as PosTag import qualified Text.HTML.Tagchup.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.Tagchup.Parser.Stream as Stream--import qualified Text.HTML.Basic.Entity as HTMLEntity--import qualified Control.Monad.Exception.Synchronous as Exc--import Control.Monad.Trans.Writer (runWriterT, )-import Control.Monad.Trans.State (StateT(..), )-import Control.Monad (mplus, msum, when, liftM, )--import Data.Monoid (Monoid, mempty, mconcat, )--import qualified Data.Map as Map+import Control.Monad (liftM, ) -import Data.Tuple.HT (mapSnd, )-import Data.Char (isAlphaNum, isAscii, chr, ord, )-import Data.Maybe (fromMaybe, maybeToList, )+import Data.Maybe (fromMaybe, )  -- import qualified Numeric @@ -118,440 +96,3 @@     Name.Attribute name, Name.Tag name) =>    source -> [Tag.T name sink] runSoup = map PosTag.tag_ . runSoupWithPositions------ * parser parts--type Warning = (Position.T, String)--type Parser     source a = Parser.Full     source Warning a-type ParserEmit source a = Parser.Emitting source Warning a---parsePosTagMergeWarnings ::-   (Stream.C source, StringType sink,-    Name.Attribute name, Name.Tag name) =>-   StateT (Status.T source) Maybe [PosTag.T name sink]-parsePosTagMergeWarnings =-   liftM (\((ot,ct),warns) ->-      ot :-      map (\(pos,warn) -> PosTag.cons pos $ Tag.Warning warn) warns ++-      maybeToList ct) $-   runWriterT parsePosTag--parsePosTag ::-   (Stream.C source, StringType sink,-    Name.Attribute name, Name.Tag name) =>-   Parser source (PosTag.T name sink, Maybe (PosTag.T name sink))-parsePosTag = do-   let omitClose :: Monad m => m t -> m (t, Maybe t)-       omitClose = liftM (\t -> (t, Nothing))-   pos <- getPos-   mplus-      (do char '<'-          allowFail $ withDefault-             (msum $-                omitClose (parseSpecialTag pos) :-                omitClose (parseProcessingTag pos) :-                omitClose (parseCloseTag pos) :-                parseOpenTag pos :-                [])-             (do emitWarning pos "A '<', that is not part of a tag. Encode it as &lt; please."-                 omitClose (returnTag pos (Tag.Text $ stringFromChar '<'))))-      (omitClose (parseText pos))---{- |-Parsing an open tag may also emit a close tag-if the tag is self-closing, e.g. @<br/>@.--For formatting self-closing tags correctly-it would be better to emit tags in the order @open tag, close tag, warnings@.-However, if there are infinitely many warnings,-we don't know whether a self-closing slash comes-and thus whether there is a close tag or not.-This implies, that we cannot even emit the warnings.--Thus we choose the order @open tag, warnings, close tag@.--}-parseOpenTag ::-   (Stream.C source, StringType sink,-    Name.Attribute name, Name.Tag name) =>-   Position.T ->-   Parser source-      (PosTag.T name sink, Maybe (PosTag.T name sink))-parseOpenTag pos =-   do name <- parseName-      allowFail $-         do dropSpaces-            tag <- returningTag pos (Tag.Open name) $-               modifyEmission (restrictWarnings 10) $ many parseAttribute-            liftM ((,) tag) $ withDefault-               (do closePos <- getPos-                   string "/>"-                   allowFail $ liftM Just $ returnTag closePos (Tag.Close name))-               (do junkPos <- getPos-                   readUntilTerm-                      (\ junk ->-                         emitWarningWhen-                            (not $ null junk)-                            junkPos ("Junk in opening tag: \"" ++ junk ++ "\""))-                      ("Unterminated open tag \"" ++ Name.toString name ++ "\"") ">"-                   return Nothing)--parseCloseTag ::-   (Stream.C source, Name.Tag name) =>-   Position.T -> Parser source (PosTag.T name sink)-parseCloseTag pos =-   do char '/'-      name <- parseName-      allowFail $-         do tag <- returnTag pos (Tag.Close name)-            dropSpaces-            junkPos <- getPos-            readUntilTerm-               (\ junk ->-                  emitWarningWhen-                     (not $ null junk)-                     junkPos ("Junk in closing tag: \"" ++ junk ++"\""))-               ("Unterminated closing tag \"" ++ Name.toString name ++"\"") ">"-            return tag--parseSpecialTag ::-   (Stream.C source, Name.Tag name) =>-   Position.T -> Parser source (PosTag.T name sink)-parseSpecialTag pos =-   do char '!'-      msum $-       (do string "--"-           allowFail $ readUntilTerm-              (\ cmt -> returnTag pos (Tag.Comment cmt))-              "Unterminated comment" "-->") :-       (do string TagName.cdataString-           allowFail $ readUntilTerm-              (\ cdata -> returnTag pos (Tag.Special TagName.cdata cdata))-              "Unterminated cdata" "]]>") :-       (do name <- parseName-           allowFail $-              do dropSpaces-                 readUntilTerm-                    (\ info -> returnTag pos (Tag.Special name info))-                    ("Unterminated special tag \"" ++ Name.toString name ++ "\"") ">") :-       []--parseProcessingTag ::-   (Stream.C source, StringType sink,-    Name.Attribute name, Name.Tag name) =>-   Position.T -> Parser source (PosTag.T name sink)-parseProcessingTag pos =-   do char '?'-      name <- parseName-      allowFail $-         do dropSpaces-            returningTag 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 ::-   (Stream.C source, StringType sink) =>-   Position.T -> Parser source (PosTag.T name sink)-parseText pos =-   returningTag pos Tag.Text (parseCharAsString (const True))---   returningTag pos Tag.Text (parseCharAsString ('<'/=))---   returningTag pos Tag.Text (parseString1 ('<'/=))---parseAttribute ::-   (Stream.C source, StringType sink, Name.Attribute name) =>-   Parser source (Attr.T name sink)-parseAttribute =-   parseName >>= \name -> allowFail $-   do dropSpaces-      value <--         withDefault-            (string "=" >> allowFail (dropSpaces >> parseValue))-            (return mempty)-      dropSpaces-      return $ Attr.Cons name value--parseName ::-   (Stream.C source, Name.C pname) =>-   Parser source 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` "_-.:")--parseValue ::-   (Stream.C source, StringType sink) =>-   ParserEmit source sink-parseValue =-   (msum $-      parseQuoted "Unterminated doubly quoted value string" '"' :-      parseQuoted "Unterminated singly quoted value string" '\'' :-      [])-   `withDefault`-   parseUnquotedValueAsString--parseUnquotedValueChar ::-   (Stream.C source) =>-   ParserEmit source String-parseUnquotedValueChar =-   let parseValueChar =-          do pos <- getPos-             str <- parseUnicodeChar (not . flip elem " >\"\'")-             let wrong = filter (not . isValidValueChar) str-             allowFail $-                emitWarningWhen (not (null wrong)) pos $-                "Illegal characters in unquoted value: " ++ wrong-             return str-   in  liftM concat $ many parseValueChar--parseUnquotedValueHTMLChar ::-   (Stream.C source) =>-   ParserEmit source [HTMLChar.T]-parseUnquotedValueHTMLChar =-   let parseValueChar =-          do pos <- getPos-             hc <- parseHTMLChar (not . flip elem " >\"\'")-             {- 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  liftM concat $ many parseValueChar--checkUnquotedChar :: Position.T -> HTMLChar.T -> ParserEmit source ()-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 ::-   (Stream.C source, StringType sink) =>-   String -> Char -> Parser source sink-parseQuoted termMsg quote =-   char quote >>-   (allowFail $-    do str <- parseString (quote/=)-       withDefault-          (char quote >> return ())-          (do termPos <- getPos-              emitWarning termPos termMsg)-       return str)--{--Instead of using 'generateTag' we could also wrap the call to 'readUntilTerm'-in 'mfix' in order to emit a tag, where some information is read later.--}-readUntilTerm ::-   (Stream.C source) =>-   (String -> ParserEmit source a) -> String -> String -> ParserEmit source a-readUntilTerm generateTag termWarning termPat =-   do ~(termFound,str) <- readUntil termPat-      result <- generateTag str-      termPos <- getPos-      emitWarningWhen (not termFound) termPos termWarning-      return result---class CharType char where-   fromChar :: Char -> char-   parseChar :: (Stream.C source) => (Char -> Bool) -> Parser source [char]-   parseUnquotedValue :: (Stream.C source) => ParserEmit source [char]--instance CharType Char where-   fromChar = id-   parseChar = parseUnicodeChar-   parseUnquotedValue = parseUnquotedValueChar--instance CharType HTMLChar.T where-   fromChar = HTMLChar.Unicode-   parseChar = parseHTMLChar-   parseUnquotedValue = parseUnquotedValueHTMLChar---class Monoid sink => StringType sink where-   stringFromChar :: Char -> sink-   parseCharAsString ::-      (Stream.C source) =>-      (Char -> Bool) -> Parser source sink-   parseUnquotedValueAsString ::-      (Stream.C source) =>-      ParserEmit source sink--instance CharType char => StringType [char] where-   stringFromChar c = [fromChar c]-   parseCharAsString = parseChar-   parseUnquotedValueAsString = parseUnquotedValue---parseString  ::-   (Stream.C source, StringType sink) =>-   (Char -> Bool) -> ParserEmit source 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 source String-parseUnicodeChar p =-   do pos <- getPos-      x <- parseHTMLChar p-      allowFail $ liftM concat $-         mapM (htmlCharToString pos) x--htmlCharToString ::-   Position.T -> HTMLChar.T -> ParserEmit source 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)--{- |-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 source [HTMLChar.T]-parseHTMLChar p =-   do pos <- getPos-      c <- satisfy p-      allowFail $-        if c=='&'-          then-            withDefault-              (do ent <--                     mplus-                        (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 source [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.Unicode '&'])-          else return [HTMLChar.Unicode c]--}---restrictWarnings :: Int -> [Warning] -> [Warning]-restrictWarnings n =-   uncurry (++) .-   mapSnd-      (\rest ->-          case rest of-             (pos, _) : _ ->-                [(pos, "further warnings suppressed")]-             _ -> []) .-   splitAt n----- these functions have intentionally restricted types--emitWarningWhen :: Bool -> Position.T -> String -> ParserEmit source ()-emitWarningWhen cond pos msg =-   when cond $ emitWarning pos msg--emitWarning :: Position.T -> String -> ParserEmit source ()-emitWarning = curry emit--returnTag ::-   Position.T ->-   Tag.T name sink ->-   ParserEmit source (PosTag.T name sink)-returnTag p t = return (PosTag.cons p t)--returningTag ::-   (Monad m) =>-   Position.T ->-   (a -> Tag.T name sink) ->-   m a ->-   m (PosTag.T name sink)-returningTag pos f =-   liftM (PosTag.cons pos . f)
+ src/Text/HTML/Tagchup/Parser/Tag.hs view
@@ -0,0 +1,472 @@+module Text.HTML.Tagchup.Parser.Tag where++import Text.HTML.Tagchup.Parser.Combinator+   (allowFail, withDefault,+    char, dropSpaces, getPos,+    many, many0toN, many1toN,+    many1Satisfy, readUntil,+    satisfy, string,+    emit, modifyEmission, )++import qualified Text.HTML.Tagchup.Parser.Combinator as Parser+import qualified Text.HTML.Tagchup.Parser.Status as Status+import qualified Text.HTML.Tagchup.Parser.Stream as Stream++import qualified Text.HTML.Tagchup.PositionTag as PosTag+import qualified Text.HTML.Tagchup.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.Tagchup.Character as Chr+import Text.HTML.Tagchup.Character (fromChar, )++import qualified Text.HTML.Basic.Entity as HTMLEntity++import qualified Control.Monad.Exception.Synchronous as Exc++import Control.Monad.Trans.Writer (runWriterT, )+import Control.Monad.Trans.State (StateT(..), )+import Control.Monad (mplus, msum, when, liftM, )++import Data.Monoid (Monoid, mempty, mconcat, )++import qualified Data.Map as Map++import Data.Tuple.HT (mapSnd, )+import Data.Char (isAlphaNum, chr, ord, )+import Data.Maybe (maybeToList, )++-- import qualified Numeric++type Warning = (Position.T, String)++type Parser     source a = Parser.Full     source Warning a+type ParserEmit source a = Parser.Emitting source Warning a+++parsePosTagMergeWarnings ::+   (Stream.C source, StringType sink,+    Name.Attribute name, Name.Tag name) =>+   StateT (Status.T source) Maybe [PosTag.T name sink]+parsePosTagMergeWarnings =+   liftM (\((ot,ct),warns) ->+      ot :+      map (\(pos,warn) -> PosTag.cons pos $ Tag.Warning warn) warns +++      maybeToList ct) $+   runWriterT parsePosTag++parsePosTag ::+   (Stream.C source, StringType sink,+    Name.Attribute name, Name.Tag name) =>+   Parser source (PosTag.T name sink, Maybe (PosTag.T name sink))+parsePosTag = do+   let omitClose :: Monad m => m t -> m (t, Maybe t)+       omitClose = liftM (\t -> (t, Nothing))+   pos <- getPos+   mplus+      (do char '<'+          allowFail $ withDefault+             (msum $+                omitClose (parseSpecialTag pos) :+                omitClose (parseProcessingTag pos) :+                omitClose (parseCloseTag pos) :+                parseOpenTag pos :+                [])+             (do emitWarning pos "A '<', that is not part of a tag. Encode it as &lt; please."+                 omitClose (returnTag pos (Tag.Text $ stringFromChar '<'))))+      (omitClose (parseText pos))+++{- |+Parsing an open tag may also emit a close tag+if the tag is self-closing, e.g. @<br/>@.++For formatting self-closing tags correctly+it would be better to emit tags in the order @open tag, close tag, warnings@.+However, if there are infinitely many warnings,+we don't know whether a self-closing slash comes+and thus whether there is a close tag or not.+This implies, that we cannot even emit the warnings.++Thus we choose the order @open tag, warnings, close tag@.+-}+parseOpenTag ::+   (Stream.C source, StringType sink,+    Name.Attribute name, Name.Tag name) =>+   Position.T ->+   Parser source+      (PosTag.T name sink, Maybe (PosTag.T name sink))+parseOpenTag pos =+   do name <- parseName+      allowFail $+         do dropSpaces+            tag <- returningTag pos (Tag.Open name) $+               modifyEmission (restrictWarnings 10) $ many parseAttribute+            liftM ((,) tag) $ withDefault+               (do closePos <- getPos+                   string "/>"+                   allowFail $ liftM Just $ returnTag closePos (Tag.Close name))+               (do junkPos <- getPos+                   readUntilTerm+                      (\ junk ->+                         emitWarningWhen+                            (not $ null junk)+                            junkPos ("Junk in opening tag: \"" ++ junk ++ "\""))+                      ("Unterminated open tag \"" ++ Name.toString name ++ "\"") ">"+                   return Nothing)++parseCloseTag ::+   (Stream.C source, Name.Tag name) =>+   Position.T -> Parser source (PosTag.T name sink)+parseCloseTag pos =+   do char '/'+      name <- parseName+      allowFail $+         do tag <- returnTag pos (Tag.Close name)+            dropSpaces+            junkPos <- getPos+            readUntilTerm+               (\ junk ->+                  emitWarningWhen+                     (not $ null junk)+                     junkPos ("Junk in closing tag: \"" ++ junk ++"\""))+               ("Unterminated closing tag \"" ++ Name.toString name ++"\"") ">"+            return tag++parseSpecialTag ::+   (Stream.C source, Name.Tag name) =>+   Position.T -> Parser source (PosTag.T name sink)+parseSpecialTag pos =+   do char '!'+      msum $+       (do string "--"+           allowFail $ readUntilTerm+              (\ cmt -> returnTag pos (Tag.Comment cmt))+              "Unterminated comment" "-->") :+       (do string TagName.cdataString+           allowFail $ readUntilTerm+              (\ cdata -> returnTag pos (Tag.cdata cdata))+              "Unterminated cdata" "]]>") :+       (do name <- parseName+           allowFail $+              do dropSpaces+                 readUntilTerm+                    (\ info -> returnTag pos (Tag.Special name info))+                    ("Unterminated special tag \"" ++ Name.toString name ++ "\"") ">") :+       []++parseProcessingTag ::+   (Stream.C source, StringType sink,+    Name.Attribute name, Name.Tag name) =>+   Position.T -> Parser source (PosTag.T name sink)+parseProcessingTag pos =+   do char '?'+      name <- parseName+      allowFail $+         do dropSpaces+            returningTag 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 ::+   (Stream.C source, StringType sink) =>+   Position.T -> Parser source (PosTag.T name sink)+parseText pos =+   returningTag pos Tag.Text (parseCharAsString (const True))+--   returningTag pos Tag.Text (parseCharAsString ('<'/=))+--   returningTag pos Tag.Text (parseString1 ('<'/=))+++parseAttribute ::+   (Stream.C source, StringType sink, Name.Attribute name) =>+   Parser source (Attr.T name sink)+parseAttribute =+   parseName >>= \name -> allowFail $+   do dropSpaces+      value <-+         withDefault+            (string "=" >> allowFail (dropSpaces >> parseValue))+            (return mempty)+      dropSpaces+      return $ Attr.Cons name value++parseName ::+   (Stream.C source, Name.C pname) =>+   Parser source pname+parseName =+   liftM Name.fromString $+   many1Satisfy (\c -> isAlphaNum c || c `elem` "_-.:")++parseValue ::+   (Stream.C source, StringType sink) =>+   ParserEmit source sink+parseValue =+   (msum $+      parseQuoted "Unterminated doubly quoted value string" '"' :+      parseQuoted "Unterminated singly quoted value string" '\'' :+      [])+   `withDefault`+   parseUnquotedValueAsString++parseUnquotedValueChar ::+   (Stream.C source) =>+   ParserEmit source String+parseUnquotedValueChar =+   let parseValueChar =+          do pos <- getPos+             str <- parseUnicodeChar (not . flip elem " >\"\'")+             let wrong = filter (not . isValidValueChar) str+             allowFail $+                emitWarningWhen (not (null wrong)) pos $+                "Illegal characters in unquoted value: " ++ wrong+             return str+   in  liftM concat $ many parseValueChar++parseUnquotedValueHTMLChar ::+   (Stream.C source) =>+   ParserEmit source [HTMLChar.T]+parseUnquotedValueHTMLChar =+   let parseValueChar =+          do pos <- getPos+             hc <- parseHTMLChar (not . flip elem " >\"\'")+             {- 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  liftM concat $ many parseValueChar++checkUnquotedChar :: Position.T -> HTMLChar.T -> ParserEmit source ()+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 ::+   (Stream.C source, StringType sink) =>+   String -> Char -> Parser source sink+parseQuoted termMsg quote =+   char quote >>+   (allowFail $+    do str <- parseString (quote/=)+       withDefault+          (char quote >> return ())+          (do termPos <- getPos+              emitWarning termPos termMsg)+       return str)++{-+Instead of using 'generateTag' we could also wrap the call to 'readUntilTerm'+in 'mfix' in order to emit a tag, where some information is read later.+-}+readUntilTerm ::+   (Stream.C source) =>+   (String -> ParserEmit source a) -> String -> String -> ParserEmit source a+readUntilTerm generateTag termWarning termPat =+   do ~(termFound,str) <- readUntil termPat+      result <- generateTag str+      termPos <- getPos+      emitWarningWhen (not termFound) termPos termWarning+      return result+++class Chr.C char => CharType char where+   parseChar :: (Stream.C source) => (Char -> Bool) -> Parser source [char]+   parseUnquotedValue :: (Stream.C source) => ParserEmit source [char]++instance CharType Char where+   parseChar = parseUnicodeChar+   parseUnquotedValue = parseUnquotedValueChar++instance CharType HTMLChar.T where+   parseChar = parseHTMLChar+   parseUnquotedValue = parseUnquotedValueHTMLChar+++class Monoid sink => StringType sink where+   stringFromChar :: Char -> sink+   parseCharAsString ::+      (Stream.C source) =>+      (Char -> Bool) -> Parser source sink+   parseUnquotedValueAsString ::+      (Stream.C source) =>+      ParserEmit source sink++instance CharType char => StringType [char] where+   stringFromChar c = [fromChar c]+   parseCharAsString = parseChar+   parseUnquotedValueAsString = parseUnquotedValue+++parseString  ::+   (Stream.C source, StringType sink) =>+   (Char -> Bool) -> ParserEmit source 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 source String+parseUnicodeChar p =+   do pos <- getPos+      x <- parseHTMLChar p+      allowFail $ liftM concat $+         mapM (htmlCharToString pos) x++htmlCharToString ::+   Position.T -> HTMLChar.T -> ParserEmit source 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)++{- |+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 source [HTMLChar.T]+parseHTMLChar p =+   do pos <- getPos+      c <- satisfy p+      allowFail $+        if c=='&'+          then+            withDefault+              (do ent <-+                     mplus+                        (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 source [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.Unicode '&'])+          else return [HTMLChar.Unicode c]+-}+++restrictWarnings :: Int -> [Warning] -> [Warning]+restrictWarnings n =+   uncurry (++) .+   mapSnd+      (\rest ->+          case rest of+             (pos, _) : _ ->+                [(pos, "further warnings suppressed")]+             _ -> []) .+   splitAt n+++-- these functions have intentionally restricted types++emitWarningWhen :: Bool -> Position.T -> String -> ParserEmit source ()+emitWarningWhen cond pos msg =+   when cond $ emitWarning pos msg++emitWarning :: Position.T -> String -> ParserEmit source ()+emitWarning = curry emit++returnTag ::+   Position.T ->+   Tag.T name sink ->+   ParserEmit source (PosTag.T name sink)+returnTag p t = return (PosTag.cons p t)++returningTag ::+   (Monad m) =>+   Position.T ->+   (a -> Tag.T name sink) ->+   m a ->+   m (PosTag.T name sink)+returningTag pos f =+   liftM (PosTag.cons pos . f)
src/Text/HTML/Tagchup/PositionTag.hs view
@@ -1,5 +1,6 @@ module Text.HTML.Tagchup.PositionTag where +import qualified Text.HTML.Tagchup.Character as Chr import qualified Text.HTML.Tagchup.Tag as Tag import qualified Text.XML.Basic.Name as Name import qualified Text.XML.Basic.Position as Position@@ -8,10 +9,11 @@ import Data.Monoid (Monoid, mempty, mappend, )  import qualified Data.Accessor.Basic as Accessor+import qualified Control.Applicative as App  import Data.Foldable (Foldable(foldMap), ) import Data.Traversable (Traversable(sequenceA), )-import Control.Applicative (liftA, )+import Control.Applicative (Applicative, )   data T name string =@@ -45,6 +47,13 @@    (T name0 string0 -> T name1 string1) lift f (Cons p t) = Cons p (f t) +liftA ::+   Applicative f =>+   (Tag.T name0 string0 -> f (Tag.T name1 string1)) ->+   (T name0 string0 -> f (T name1 string1))+liftA f (Cons p t) = App.liftA (Cons p) (f t)++ instance Functor (T name) where    fmap f = lift (fmap f) @@ -52,12 +61,12 @@    foldMap f = foldMap f . tag_  instance Traversable (T name) where-   sequenceA (Cons p t) = liftA (Cons p) $ sequenceA t+   sequenceA (Cons p t) = App.liftA (Cons p) $ sequenceA t   textFromCData ::-   (Name.Tag name) =>-   T name String -> T name String+   (Name.Tag name, Chr.C char) =>+   T name [char] -> T name [char] textFromCData = lift Tag.textFromCData
src/Text/HTML/Tagchup/Process.hs view
@@ -1,32 +1,126 @@-module Text.HTML.Tagchup.Process where+module Text.HTML.Tagchup.Process (+   Encoding, Encoded,+   evalDecodeAdaptive, decodeAdaptive, decodeTagAdaptive,+   getXMLEncoding,+   findMetaEncoding,+   getMetaHTTPHeaders,+   getHeadTags,+   partAttrs,+   parts,+   ) where  import qualified Text.HTML.Tagchup.Tag as Tag import qualified Text.HTML.Tagchup.Tag.Match as Match  import qualified Text.XML.Basic.Attribute as Attr import qualified Text.XML.Basic.Name as Name+import qualified Text.XML.Basic.Tag as TagX+import qualified Text.HTML.Basic.Tag as TagH+import qualified Text.HTML.Basic.Character as HTMLChar+import qualified Text.HTML.Basic.String as HTMLString +import Text.HTML.Basic.String (Encoded, )++import Control.Monad.Trans.State (State, put, get, evalState, )+import Data.Traversable (traverse, )+ import qualified Data.Char as Char-import           Data.List.HT (viewL, takeWhileRev, )-import           Data.Tuple.HT (mapFst, )+import           Data.List.HT (viewL, ) import           Data.Maybe (fromMaybe, mapMaybe, )-import           Control.Monad (guard, liftM2, )+import           Control.Monad.HT ((<=<), )+import           Control.Monad (msum, mplus, )   -- * analyse soup -{--Rather the same as wraxml:HTML.Tree.findMetaEncoding++type Encoding = String++++evalDecodeAdaptive ::+   State (Encoded -> String) a -> a+evalDecodeAdaptive =+   flip evalState id++{- |+Selects a decoder dynamically according+to xml-encoding and meta-http-equiv tags.+The @?xml@ tag should only appear at the beginning of a document,+but we respect it at every occurence.++> import qualified Text.XML.HXT.DOM.Unicode as Unicode++> evalDecodeAdaptive .+> decodeAdaptive+>    (maybe Unicode.latin1ToUnicode (fst.) .+>     Unicode.getDecodingFct) -}+decodeAdaptive ::+   (Name.Attribute name, Name.Tag name) =>+   (Encoding -> Encoded -> String) ->+   [Tag.T name [HTMLChar.T]] ->+   State (Encoded -> String) [Tag.T name String]+decodeAdaptive getDecoder =+   traverse (decodeTagAdaptive getDecoder)++{- |+@decodeTagAdaptive decoderSelector tag@ generates a state monad,+with a decoder as state.+It decodes encoding specific byte sequences+using the current decoder+and XML references using a fixed table.+-}+decodeTagAdaptive ::+   (Name.Attribute name, Name.Tag name) =>+   (Encoding -> Encoded -> String) ->+   Tag.T name [HTMLChar.T] ->+   State (Encoded -> String) (Tag.T name String)+decodeTagAdaptive getDecoder tag0 =+   do decoder <- get+      let tag1 =+             -- this is less elegant than using maybeCData but lazier+             maybe+                (fmap (HTMLString.decode decoder) tag0)+                (\(name, s) ->+                   Tag.special name $+                      if TagH.cdataName == name+                        then decoder s+                        else s)+                (Tag.maybeSpecial tag0)+      maybe+         (return ())+         (put . getDecoder) $+         mplus+            (uncurry TagH.maybeMetaEncoding =<<+             Tag.maybeOpen tag1)+            (uncurry TagX.maybeXMLEncoding =<<+             Tag.maybeProcessing tag1)+      return tag1++{- |+Check whether the first tag is an @xml@ processing instruction tag+and return the value of its @encoding@ attribute.+-}+getXMLEncoding ::+   (Name.Tag name, Name.Attribute name) =>+   [Tag.T name String] -> Maybe String+getXMLEncoding tags =+   do (t,_) <- viewL tags+      uncurry TagX.maybeXMLEncoding =<< Tag.maybeProcessing t++{- |+Rather the same as @wraxml:HTML.Tree.findMetaEncoding@+-} findMetaEncoding ::    (Name.Tag name, Name.Attribute name) =>    [Tag.T name String] -> Maybe String findMetaEncoding =-   fmap (map Char.toLower . takeWhileRev ('='/=)) .-   lookup "content-type" .-   map (mapFst (map Char.toLower)) .-   getMetaHTTPHeaders+   msum .+   map (uncurry TagH.maybeMetaEncoding <=< Tag.maybeOpen) .+   getHeadTags + {- | Extract META tags which contain HTTP-EQUIV attribute and present these values like HTTP headers.@@ -35,23 +129,18 @@    (Name.Tag name, Name.Attribute 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)) .+   mapMaybe (uncurry TagH.maybeMetaHTTPHeader <=< Tag.maybeOpen) .    getHeadTags + getHeadTags ::    (Name.Tag name, Name.Attribute 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))+   dropWhile (not . Match.openNameLit "head") .+   takeWhile (not . Match.openNameLit "body")   -- * transform soup
src/Text/HTML/Tagchup/Tag.hs view
@@ -17,11 +17,13 @@    mapText, mapTextA,    ) where +import qualified Text.HTML.Tagchup.Character as Chr+ 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 Text.XML.Basic.Tag (Name(Name), cdataName, )  import Data.Tuple.HT (mapFst, ) import Data.Maybe (mapMaybe, fromMaybe, )@@ -134,7 +136,7 @@             Fmt.angle $             Fmt.exclam .             Fmt.name name .-            if cdata == name+            if cdataName == name               then showString str . showString "]]"               else Fmt.blank . showString str          Processing name p ->@@ -177,6 +179,9 @@ special :: Name name -> String -> T name string special = Special +cdata :: (Name.Tag name) => String -> T name string+cdata = special cdataName+ processing :: Name name -> PI.T name string -> T name string processing = Processing @@ -234,14 +239,14 @@ isCData ::    (Name.Tag name) =>    T name string -> Bool-isCData tag = case tag of (Special name _) -> cdata == name; _ -> False+isCData tag = case tag of (Special name _) -> cdataName == name; _ -> False  maybeCData ::    (Name.Tag name) =>    T name string -> Maybe String maybeCData tag =    do (name, content) <- maybeSpecial tag-      guard (cdata == name)+      guard (cdataName == name)       return content  @@ -267,18 +272,29 @@ Replace CDATA sections by plain text. -} textFromCData ::+   (Name.Tag name, Chr.C char) =>+   T name [char] -> T name [char]+textFromCData t =+   fromMaybe t $+      do (name, content) <- maybeSpecial t+         guard (cdataName == name)+         return $ Text $ map Chr.fromChar content++{-+textFromCData ::    (Name.Tag name) =>    T name String -> T name String textFromCData t =    fromMaybe t $       do (name, content) <- maybeSpecial t-         guard (cdata == name)+         guard (cdataName == name)          return $ Text content+-}  {-    case t of       Special name text ->-         if cdata == name+         if cdataName == name            then Text text            else t       _ -> t@@ -316,7 +332,7 @@       Text s -> Text $ f s       Special name s ->          Special name $-            if cdata == name+            if cdataName == name               then f s               else s       _ -> t@@ -330,7 +346,7 @@       Text s -> liftA Text $ f s       Special name s ->          liftA (Special name) $-            if cdata == name+            if cdataName == name               then f s               else pure s       _ -> pure t
src/Text/HTML/Tagchup/Tag/Match.hs view
@@ -67,13 +67,13 @@           Name.match attrName name && pAttrValue value))  --- | Check if the 'Tag.T' is 'Tag.Open' and matches the given name+-- | Check whether the 'Tag.T' is 'Tag.Open' and matches the given name openNameLit ::    (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+-- | Check whether the 'Tag.T' is 'Tag.Close' and matches the given name closeNameLit ::    (Name.Tag name) =>    String -> Tag.T name string -> Bool
tagchup.cabal view
@@ -1,5 +1,5 @@ Name:           tagchup-Version:        0.3.1+Version:        0.4 License:        GPL License-File:   LICENSE Author:         Henning Thielemann <tagchup@henning-thielemann.de>@@ -22,45 +22,97 @@    .    The name Tagchup resembles Ketchup. Build-Type:  Simple-Build-Depends:-   xml-basic >=0.1 && <0.2,-   transformers >=0.0 && <0.2,-   explicit-exception >=0.1 && <0.2,-   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.Tagchup.Parser-   Text.HTML.Tagchup.Format-   Text.HTML.Tagchup.Tag-   Text.HTML.Tagchup.Tag.Match-   Text.HTML.Tagchup.PositionTag-   Text.HTML.Tagchup.Process+Cabal-Version: >= 1.6 -Other-Modules:-   Text.HTML.Tagchup.Parser.Combinator-   Text.HTML.Tagchup.Parser.Core-   Text.HTML.Tagchup.Parser.Status-   Text.HTML.Tagchup.Parser.Stream+Data-Files:+   example/Escape/iso8859.xhtml+   example/Escape/iso8859.html+   example/Escape/utf8.xhtml+   example/Escape/utf8.html+   example/Strip/example.xhtml -Executable: tagchuptest-GHC-Options: -Wall-Hs-Source-Dirs: src, .-Other-Modules:-   Text.HTML.Tagchup.Test-Main-Is:     example/Test.hs+Source-Repository head+   Type:     darcs+   Location: http://code.haskell.org/~thielema/tagchup/ -Executable: tagchupspeed-GHC-Options: -Wall-Hs-Source-Dirs: src, .-Build-Depends: old-time >=1.0 && <1.1-Main-Is:     example/Speed.hs+Source-Repository this+   Type:     darcs+   Location: http://code.haskell.org/~thielema/tagchup/+   Tag:      0.4 -Executable: validate-tagchup-GHC-Options: -Wall-Hs-Source-Dirs: src, .-Main-Is:     example/Validate.hs+Flag buildExamples+   description: Build example executables+   default:     False++Flag buildTests+   description: Build test suite+   default:     False+++Library+   Build-Depends:+      xml-basic >=0.1.1 && <0.2,+      transformers >=0.0 && <0.2,+      explicit-exception >=0.1 && <0.2,+      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.Tagchup.Parser+      Text.HTML.Tagchup.Format+      Text.HTML.Tagchup.Tag+      Text.HTML.Tagchup.Tag.Match+      Text.HTML.Tagchup.PositionTag+      Text.HTML.Tagchup.Process++   Other-Modules:+      Text.HTML.Tagchup.Character+      Text.HTML.Tagchup.Parser.Combinator+      Text.HTML.Tagchup.Parser.Core+      Text.HTML.Tagchup.Parser.Status+      Text.HTML.Tagchup.Parser.Stream+      Text.HTML.Tagchup.Parser.Tag++Executable tagchuptest+   If !flag(buildTests)+     Buildable: False+   GHC-Options:    -Wall+   Hs-Source-Dirs: src, example+   Other-Modules:  Text.HTML.Tagchup.Test+   Main-Is:        Test.hs++Executable tagchupspeed+   If flag(buildTests)+     Build-Depends: old-time >=1.0 && <1.1+   Else+     Buildable: False+   GHC-Options:    -Wall+   Hs-Source-Dirs: src, example+   Main-Is:        Speed.hs++Executable validate-tagchup+   If !flag(buildExamples)+     Buildable: False+   GHC-Options:    -Wall+   Hs-Source-Dirs: src, example+   Main-Is:        Validate.hs++Executable escape-html+   If flag(buildExamples)+     Build-Depends: hxt >=8.1 && <8.2+   Else+     Buildable: False+   GHC-Options:    -Wall+   Hs-Source-Dirs: src, example+   Main-Is:        Escape.hs++Executable strip-html+   If !flag(buildExamples)+     Buildable: False+   GHC-Options:    -Wall+   Hs-Source-Dirs: src, example+   Main-Is:        Strip.hs