diff --git a/example/Escape.hs b/example/Escape.hs new file mode 100644 --- /dev/null +++ b/example/Escape.hs @@ -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 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" diff --git a/example/Escape/iso8859.html b/example/Escape/iso8859.html new file mode 100644 --- /dev/null +++ b/example/Escape/iso8859.html @@ -0,0 +1,18 @@ + + + + + + + + +Hennings HomePage + + + +

De Bärchschafft vonne Früdrüch Schöller

+ +]]> + + + diff --git a/example/Escape/iso8859.xhtml b/example/Escape/iso8859.xhtml new file mode 100644 --- /dev/null +++ b/example/Escape/iso8859.xhtml @@ -0,0 +1,26 @@ + + + + + + + + + Märchenstunde + + + +

De Bärchschafft vonne Früdrüch Schöller

+ +

+]]> +

+ + + diff --git a/example/Escape/utf8.html b/example/Escape/utf8.html new file mode 100644 --- /dev/null +++ b/example/Escape/utf8.html @@ -0,0 +1,18 @@ + + + + + + + + +Hennings HomePage + + + +

De Bärchschafft vonne Früdrüch Schöller

+ +]]> + + + diff --git a/example/Escape/utf8.xhtml b/example/Escape/utf8.xhtml new file mode 100644 --- /dev/null +++ b/example/Escape/utf8.xhtml @@ -0,0 +1,26 @@ + + + + + + + + + Märchenstunde + + + +

De Bärchschafft vonne Früdrüch Schöller

+ +

+]]> +

+ + + diff --git a/example/Strip.hs b/example/Strip.hs new file mode 100644 --- /dev/null +++ b/example/Strip.hs @@ -0,0 +1,25 @@ +{- | +Strip HTML comments, script and style tags. + +> strip-html 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) diff --git a/example/Strip/example.xhtml b/example/Strip/example.xhtml new file mode 100644 --- /dev/null +++ b/example/Strip/example.xhtml @@ -0,0 +1,32 @@ + + + + + + + + + Märchenstunde + + + + + +

De Bärchschafft vonne Früdrüch Schöller

+ + + +

+Really irrelevant text! +

+ + + diff --git a/example/Validate.hs b/example/Validate.hs --- a/example/Validate.hs +++ b/example/Validate.hs @@ -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) -> diff --git a/src/Text/HTML/Tagchup/Character.hs b/src/Text/HTML/Tagchup/Character.hs new file mode 100644 --- /dev/null +++ b/src/Text/HTML/Tagchup/Character.hs @@ -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 diff --git a/src/Text/HTML/Tagchup/Parser.hs b/src/Text/HTML/Tagchup/Parser.hs --- a/src/Text/HTML/Tagchup/Parser.hs +++ b/src/Text/HTML/Tagchup/Parser.hs @@ -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 < 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. @
@. - -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. "& ;" is considered as plain "& ;", -and only "&" is considered an escaped ampersand. -It is a very common error in HTML documents to not escape an ampersand. -With the interpretation used here, -those ampersands are left as they are. - -At most one warning can be emitted. --} -parseHTMLChar :: - (Stream.C source) => - (Char -> Bool) -> Parser 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) diff --git a/src/Text/HTML/Tagchup/Parser/Tag.hs b/src/Text/HTML/Tagchup/Parser/Tag.hs new file mode 100644 --- /dev/null +++ b/src/Text/HTML/Tagchup/Parser/Tag.hs @@ -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 < 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. @
@. + +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. "& ;" is considered as plain "& ;", +and only "&" is considered an escaped ampersand. +It is a very common error in HTML documents to not escape an ampersand. +With the interpretation used here, +those ampersands are left as they are. + +At most one warning can be emitted. +-} +parseHTMLChar :: + (Stream.C source) => + (Char -> Bool) -> Parser 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) diff --git a/src/Text/HTML/Tagchup/PositionTag.hs b/src/Text/HTML/Tagchup/PositionTag.hs --- a/src/Text/HTML/Tagchup/PositionTag.hs +++ b/src/Text/HTML/Tagchup/PositionTag.hs @@ -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 diff --git a/src/Text/HTML/Tagchup/Process.hs b/src/Text/HTML/Tagchup/Process.hs --- a/src/Text/HTML/Tagchup/Process.hs +++ b/src/Text/HTML/Tagchup/Process.hs @@ -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 diff --git a/src/Text/HTML/Tagchup/Tag.hs b/src/Text/HTML/Tagchup/Tag.hs --- a/src/Text/HTML/Tagchup/Tag.hs +++ b/src/Text/HTML/Tagchup/Tag.hs @@ -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 diff --git a/src/Text/HTML/Tagchup/Tag/Match.hs b/src/Text/HTML/Tagchup/Tag/Match.hs --- a/src/Text/HTML/Tagchup/Tag/Match.hs +++ b/src/Text/HTML/Tagchup/Tag/Match.hs @@ -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 diff --git a/tagchup.cabal b/tagchup.cabal --- a/tagchup.cabal +++ b/tagchup.cabal @@ -1,5 +1,5 @@ Name: tagchup -Version: 0.3.1 +Version: 0.4 License: GPL License-File: LICENSE Author: Henning Thielemann @@ -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