diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -6,7 +6,6 @@ import TagSoup.Test import TagSoup.Benchmark import Data.Char(toLower) -import Text.HTML.TagSoup -- just to make it easier to use in GHCi helpMsg :: IO () diff --git a/TagSoup/Benchmark.hs b/TagSoup/Benchmark.hs --- a/TagSoup/Benchmark.hs +++ b/TagSoup/Benchmark.hs @@ -7,9 +7,6 @@ import Control.Monad import Data.List import Data.Maybe -import Data.Char -import System.CPUTime -import System.IO import System.IO.Unsafe(unsafeInterleaveIO) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS diff --git a/TagSoup/Sample.hs b/TagSoup/Sample.hs --- a/TagSoup/Sample.hs +++ b/TagSoup/Sample.hs @@ -6,8 +6,6 @@ import Data.Char import Data.List -import Data.Maybe -import System.IO openItem :: String -> IO String diff --git a/TagSoup/Test.hs b/TagSoup/Test.hs --- a/TagSoup/Test.hs +++ b/TagSoup/Test.hs @@ -6,7 +6,6 @@ import Text.HTML.TagSoup.Entity import Text.HTML.TagSoup.Match -import Control.Exception import Control.Monad import Data.List import Test.QuickCheck @@ -42,6 +41,7 @@ test :: IO () test = runTest $ do + warnTests parseTests optionsTests renderTests @@ -117,6 +117,12 @@ parseTags "hello &haskell; world" === [TagText "hello &haskell; world"] parseTags "hello \n\t world" === [TagText "hello \n\t world"] parseTags "" === [TagOpen "a" [("href","http://www.google.com")]] + parseTags "" === [TagOpen "foo" [("bar","bar6baz")]] + parseTags "" === [TagOpen "foo" [("bar","bar&baz")]] + parseTags "hey &how are you" === [TagText "hey &how are you"] + parseTags "hey &how; are you" === [TagText "hey &how; are you"] + parseTags "hey & are you" === [TagText "hey & are you"] + parseTags "hey & are you" === [TagText "hey & are you"] -- real cases reported by users parseTags "" === [TagOpen "a" [("href","series.php?view=single&ID=72710")]] @@ -174,6 +180,7 @@ rp "" === "" rp "" === "" rp "" === "" + escapeHTML "this is a &\" " === "this is a &" <test>" check $ \(HTML x) -> let y = rp x in rp y == (y :: String) @@ -205,15 +212,6 @@ warnTests :: Test () warnTests = do - return () -{- - -- TODO: Check that when there is a warning, it shows up at the right place - warns "neil &foo bar" = missing ; - let parse = parseTagsOptions parseOptions{ - let noWarn x = - - - - {optTagPosition :: Bool -- ^ Should 'TagPosition' values be given before some items (default=False,fast=False) - ,optTagWarning :: Bool -- ^ Should 'TagWarning' values be given (default=False,fast=False) --} + let p = parseTagsOptions parseOptions{optTagPosition=True,optTagWarning=True} + wt x = [(msg,c) | TagWarning msg:TagPosition _ c:_ <- tails $ p x] + wt "neil &foo bar" === [("Unknown entity: foo",10)] diff --git a/Text/HTML/TagSoup/Implementation.hs b/Text/HTML/TagSoup/Implementation.hs --- a/Text/HTML/TagSoup/Implementation.hs +++ b/Text/HTML/TagSoup/Implementation.hs @@ -2,7 +2,6 @@ module Text.HTML.TagSoup.Implementation where -import Data.List import Text.HTML.TagSoup.Type import Text.HTML.TagSoup.Options import Text.StringLike as Str @@ -16,19 +15,18 @@ data Out = Char Char - | Tag -- < - | TagShut -- - | TagEndClose -- /> - | Comment -- - | Entity -- & - | EntityNum -- &# - | EntityHex -- &#x - | EntityEnd -- ; - | EntityEndAtt -- missing the ; and in an attribute + | TagEnd -- > + | TagEndClose -- /> + | Comment -- + | EntityName -- & + | EntityNum -- &# + | EntityHex -- &#x + | EntityEnd Bool -- Attributed followed by ; for True, missing ; for False | Warn String | Pos Position deriving (Show,Eq) @@ -98,9 +96,9 @@ (z,b) = atts y go x | isComment x = pos x $ TagComment a : go (skip isCommentEnd y) where (y,a) = charsStr $ next x - go x | isEntity x = poss x ((if optTagWarning then id else filter (not . isTagWarning)) $ optEntityData a) ++ go (skip isEntityEnd y) + go x | isEntityName x = poss x ((if optTagWarning then id else filter (not . isTagWarning)) $ optEntityData (a, getEntityEnd y)) ++ go (skip isEntityEnd y) where (y,a) = charsStr $ next x - go x | isEntityChr x = pos x $ TagText (fromChar $ entityChr x a) : go (skip isEntityEnd y) + go x | isEntityNumHex x = pos x $ TagText (fromChar $ entityChr x a) : go (skip isEntityEnd y) where (y,a) = chars $ next x go x | Just a <- fromWarn x = if optTagWarning then pos x $ TagWarning (fromString a) : go (next x) else go (next x) go x | isEof x = [] @@ -122,14 +120,14 @@ charss :: Bool -> ((Position,[Tag str]),[Out]) -> ( ((Position,[Tag str]),[Out]) , String) charss t x | Just a <- fromChr x = (y, a:b) where (y,b) = charss t (next x) - charss t x | t, isEntity x = second (toString n ++) $ charss t $ addWarns m z + charss t x | t, isEntityName x = second (toString n ++) $ charss t $ addWarns m z where (y,a) = charsStr $ next x - b = not $ isEntityEndAtt y - z = if b then skip isEntityEnd y else next y + b = getEntityEnd y + z = skip isEntityEnd y (n,m) = optEntityAttrib (a,b) - charss t x | t, isEntityChr x = second (entityChr x a:) $ charss t z + charss t x | t, isEntityNumHex x = second (entityChr x a:) $ charss t z where (y,a) = chars $ next x - (z,b) = charss t $ if isEntityEnd y then next y else skip isEntityEndAtt y + z = skip isEntityEnd y charss t ((_,w),Pos p:xs) = charss t ((p,w),xs) charss t x | Just a <- fromWarn x = charss t $ (if optTagWarning then addWarns [TagWarning $ fromString a] else id) $ next x charss t x = (x, []) @@ -157,16 +155,17 @@ isTagEndClose (_,TagEndClose{}:_) = True; isTagEndClose _ = False isComment (_,Comment{}:_) = True; isComment _ = False isCommentEnd (_,CommentEnd{}:_) = True; isCommentEnd _ = False -isEntity (_,Entity{}:_) = True; isEntity _ = False -isEntityChr (_,EntityNum{}:_) = True; isEntityChr (_,EntityHex{}:_) = True; isEntityChr _ = False +isEntityName (_,EntityName{}:_) = True; isEntityName _ = False +isEntityNumHex (_,EntityNum{}:_) = True; isEntityNumHex (_,EntityHex{}:_) = True; isEntityNumHex _ = False isEntityNum (_,EntityNum{}:_) = True; isEntityNum _ = False isEntityHex (_,EntityHex{}:_) = True; isEntityHex _ = False isEntityEnd (_,EntityEnd{}:_) = True; isEntityEnd _ = False -isEntityEndAtt (_,EntityEndAtt{}:_) = True; isEntityEndAtt _ = False isWarn (_,Warn{}:_) = True; isWarn _ = False fromChr (_,Char x:_) = Just x ; fromChr _ = Nothing fromWarn (_,Warn x:_) = Just x ; fromWarn _ = Nothing + +getEntityEnd (_,EntityEnd b:_) = b -- Merge all adjacent TagText bits diff --git a/Text/HTML/TagSoup/Options.hs b/Text/HTML/TagSoup/Options.hs --- a/Text/HTML/TagSoup/Options.hs +++ b/Text/HTML/TagSoup/Options.hs @@ -12,7 +12,7 @@ data ParseOptions str = ParseOptions {optTagPosition :: Bool -- ^ Should 'TagPosition' values be given before some items (default=False,fast=False) ,optTagWarning :: Bool -- ^ Should 'TagWarning' values be given (default=False,fast=False) - ,optEntityData :: str -> [Tag str] -- ^ How to lookup an entity + ,optEntityData :: (str,Bool) -> [Tag str] -- ^ How to lookup an entity (Bool = has ending @';'@) ,optEntityAttrib :: (str,Bool) -> (str,[Tag str]) -- ^ How to lookup an entity in an attribute (Bool = has ending @';'@?) ,optTagTextMerge :: Bool -- ^ Require no adjacent 'TagText' values (default=True,fast=False) } @@ -23,13 +23,10 @@ parseOptions :: StringLike str => ParseOptions str parseOptions = ParseOptions False False entityData entityAttrib True where - entityData x = case lookupEntity y of - Just y -> [TagText $ fromChar y] - Nothing -> [TagText $ fromString $ "&" ++ y ++ ";" - ,TagWarning $ fromString $ "Unknown entity: " ++ y] - where y = toString x + entityData x = TagText a : b + where (a,b) = entityAttrib x - entityAttrib (x,b) = case lookupEntity y of + entityAttrib ~(x,b) = case lookupEntity y of Just y -> (fromChar y, []) Nothing -> (fromString $ "&" ++ y ++ [';'|b], [TagWarning $ fromString $ "Unknown entity: " ++ y]) where y = toString x @@ -44,7 +41,7 @@ fmapParseOptions :: (StringLike from, StringLike to) => ParseOptions from -> ParseOptions to fmapParseOptions (ParseOptions a b c d e) = ParseOptions a b c2 d2 e where - c2 x = map (fmap castString) $ c $ castString x - d2 (x,y) = (castString r, map (fmap castString) s) + c2 ~(x,y) = map (fmap castString) $ c (castString x, y) + d2 ~(x,y) = (castString r, map (fmap castString) s) where (r,s) = d (castString x, y) diff --git a/Text/HTML/TagSoup/Parser.hs b/Text/HTML/TagSoup/Parser.hs --- a/Text/HTML/TagSoup/Parser.hs +++ b/Text/HTML/TagSoup/Parser.hs @@ -6,7 +6,6 @@ import Text.HTML.TagSoup.Type import Text.HTML.TagSoup.Options -import Text.StringLike import qualified Text.HTML.TagSoup.Generated as Gen diff --git a/Text/HTML/TagSoup/Render.hs b/Text/HTML/TagSoup/Render.hs --- a/Text/HTML/TagSoup/Render.hs +++ b/Text/HTML/TagSoup/Render.hs @@ -5,7 +5,7 @@ module Text.HTML.TagSoup.Render ( - renderTags, renderTagsOptions, + renderTags, renderTagsOptions, escapeHTML, RenderOptions(..), renderOptions ) where @@ -26,17 +26,16 @@ } --- | The default render options value, described in 'RenderOptions'. -renderOptions :: StringLike str => RenderOptions str -renderOptions = RenderOptions - (\x -> fromString $ concatMap esc1 $ toString x) - (\x -> toString x == "br") +-- | Replace the four characters @&\"\<\>@ with their HTML entities. +escapeHTML :: StringLike str => str -> str +escapeHTML = fromString . concatMap esc1 . toString where esc = IntMap.fromList [(b, "&"++a++";") | (a,b) <- htmlEntities] esc1 x = IntMap.findWithDefault [x] (ord x) esc -fmapRenderOptions :: (StringLike a, StringLike b) => RenderOptions a -> RenderOptions b -fmapRenderOptions (RenderOptions x y) = RenderOptions (castString . x . castString) (y . castString) +-- | The default render options value, described in 'RenderOptions'. +renderOptions :: StringLike str => RenderOptions str +renderOptions = RenderOptions escapeHTML (\x -> toString x == "br") -- | Show a list of tags, as they might have been parsed, using the default settings given in diff --git a/Text/HTML/TagSoup/Specification.hs b/Text/HTML/TagSoup/Specification.hs --- a/Text/HTML/TagSoup/Specification.hs +++ b/Text/HTML/TagSoup/Specification.hs @@ -288,18 +288,18 @@ charRefNum3 resume hex S{..} = pos $ case hd of _ | hexChar hex hd -> hd & charRefNum3 resume hex tl - ';' -> EntityEnd & resume tl - _ -> errWant ";" & EntityEnd & resume s + ';' -> EntityEnd True & resume tl + _ -> EntityEnd False & errWant ";" & resume s charRefAlpha resume att S{..} = pos $ case hd of - _ | isAlpha hd -> Entity & hd & charRefAlpha2 resume att tl + _ | isAlpha hd -> EntityName & hd & charRefAlpha2 resume att tl _ -> errSeen "&" & '&' & resume s charRefAlpha2 resume att S{..} = pos $ case hd of _ | alphaChar hd -> hd & charRefAlpha2 resume att tl - ';' -> EntityEnd & resume tl - _ | att -> EntityEndAtt & resume s - _ -> errWant ";" & EntityEnd & resume s + ';' -> EntityEnd True & resume tl + _ | att -> EntityEnd False & resume s + _ -> EntityEnd False & errWant ";" & resume s alphaChar x = isAlphaNum x || x `elem` ":-_" diff --git a/Text/HTML/TagSoup/Type.hs b/Text/HTML/TagSoup/Type.hs --- a/Text/HTML/TagSoup/Type.hs +++ b/Text/HTML/TagSoup/Type.hs @@ -19,7 +19,6 @@ ) where -import Data.Char import Data.List import Data.Maybe import Text.StringLike diff --git a/Text/StringLike.hs b/Text/StringLike.hs --- a/Text/StringLike.hs +++ b/Text/StringLike.hs @@ -6,8 +6,6 @@ -- TagSoup to work with String (list of Char), ByteString.Char8 and ByteString.Lazy.Char8. module Text.StringLike where -import Data.List -import Data.Maybe import Data.Typeable import qualified Data.ByteString.Char8 as BS diff --git a/tagsoup.cabal b/tagsoup.cabal --- a/tagsoup.cabal +++ b/tagsoup.cabal @@ -1,6 +1,6 @@ cabal-version: >= 1.6 name: tagsoup -version: 0.8 +version: 0.9 copyright: Neil Mitchell 2006-2010 author: Neil Mitchell maintainer: Neil Mitchell