diff --git a/html-tokenizer.cabal b/html-tokenizer.cabal --- a/html-tokenizer.cabal +++ b/html-tokenizer.cabal @@ -1,7 +1,7 @@ name: html-tokenizer version: - 0.3.0.3 + 0.4.0.0 synopsis: An "attoparsec"-based HTML tokenizer description: @@ -47,7 +47,7 @@ library other-modules: exposed-modules: - HTMLTokenizer.Parser + HTMLTokenizer build-depends: conversion >= 1.0.1 && < 2, conversion-text >= 1.0.0.1 && < 2, @@ -80,7 +80,7 @@ default-language: Haskell2010 build-depends: - doctest == 0.9.*, + doctest == 0.10.*, directory == 1.2.*, filepath >= 1.3 && < 1.5, base-prelude, diff --git a/library/HTMLTokenizer.hs b/library/HTMLTokenizer.hs new file mode 100644 --- /dev/null +++ b/library/HTMLTokenizer.hs @@ -0,0 +1,164 @@ +module HTMLTokenizer +( + -- * Model + Token(..), + OpeningTag, + Identifier(..), + Attribute, + -- * Parsers + token, +) +where + +import BasePrelude hiding (takeWhile) +import Conversion +import Conversion.Text +import Conversion.CaseInsensitive +import Data.Text (Text) +import Data.Text.Lazy.Builder (Builder) +import Data.CaseInsensitive (CI) +import Data.Attoparsec.Text +import qualified Data.Text + + +-- | +-- An HTML token. +data Token = + -- | + -- A Doctype declaration. + Token_Doctype Text | + -- | + -- An opening tag. + Token_OpeningTag OpeningTag | + -- | + -- A closing tag. + Token_ClosingTag Identifier | + -- | + -- A text between tags. + Token_Text Text | + -- | + -- Contents of a comment. + Token_Comment Text + deriving (Show, Ord, Eq, Generic, Data, Typeable) + +-- | +-- An opening tag name, attributes and whether it is closed. +type OpeningTag = + (Identifier, [Attribute], Bool) + +-- | +-- A case-insensitive identifier. +data Identifier = + Identifier (Maybe (CI Text)) (CI Text) + deriving (Show, Ord, Eq, Generic, Data, Typeable) + +instance IsString Identifier where + fromString = + either (error "Invalid identifier") id . + parseOnly identifier . + convert + +-- | +-- A tag attribute identifier and a value. +type Attribute = + (Identifier, Maybe Text) + +-- | +-- A token parser. +-- +-- Does not decode entities. +token :: Parser Token +token = + Token_Doctype <$> doctype <|> + Token_Comment <$> comment <|> + Token_ClosingTag <$> closingTag <|> + Token_OpeningTag <$> openingTag <|> + Token_Text <$> text + +-- | +-- +-- >>> parseOnly doctype "" +-- Right "html PUBLIC \"-//W3C//DTD XHTML+RDFa 1.0//EN\" \"http://www.w3.org/MarkUp/DTD/xhtml-rdfa-1.dtd\"" +doctype :: Parser Text +doctype = + do + string "') + char '>' + return contents + +openingTag :: Parser OpeningTag +openingTag = + do + char '<' + skipSpace + theIdentifier <- identifier + attributes <- many $ space *> skipSpace *> attribute + skipSpace + closed <- convert <$> optional (char '/') + char '>' + return (theIdentifier, attributes, closed) + +attribute :: Parser Attribute +attribute = + do + theIdentifier <- identifier + value <- + optional $ do + skipSpace + char '=' + skipSpace + msum (map quotedValue ['"', '\'', '`']) <|> entityQuotedValue <|> unquotedValue + return (theIdentifier, value) + where + quotedValue q = + char q *> takeWhile (/= q) <* char q + unquotedValue = + takeWhile1 $ flip all [not . isSpace, not . flip elem ['=', '<', '>', '/']] . (&) + -- | + -- For some really messed-up HTML. + entityQuotedValue = + fmap convert $ q *> manyTill' anyChar q + where + q = asciiCI """ + +identifier :: Parser Identifier +identifier = + Identifier <$> optional (component <* char ':') <*> component + where + component = + fmap convert $ takeWhile1 $ flip any [isAlphaNum, flip elem ['_', '-']] . (&) + +comment :: Parser Text +comment = + (convert :: Builder -> Text) <$> (string "")) + (liftA2 mappend + (fmap convert (char '-')) + (content)))) + +closingTag :: Parser Identifier +closingTag = + string " skipSpace *> identifier <* skipSpace <* char '>' + +text :: Parser Text +text = + fmap ((convert :: Builder -> Text) . mconcat) $ many1 $ + convert <$> nonTagChar + where + nonTagChar = + shouldFail comment *> shouldFail closingTag *> shouldFail openingTag *> shouldFail doctype *> anyChar + +shouldFail :: Parser a -> Parser () +shouldFail p = + join $ (p $> empty) <|> pure (pure ()) + diff --git a/library/HTMLTokenizer/Parser.hs b/library/HTMLTokenizer/Parser.hs deleted file mode 100644 --- a/library/HTMLTokenizer/Parser.hs +++ /dev/null @@ -1,130 +0,0 @@ -module HTMLTokenizer.Parser -( - -- * Model - Token(..), - OpeningTag, - Identifier, - Attribute, - -- * Parsers - token, -) -where - -import BasePrelude hiding (takeWhile) -import Conversion -import Conversion.Text -import Conversion.CaseInsensitive -import Data.Text (Text) -import Data.Text.Lazy.Builder (Builder) -import Data.CaseInsensitive (CI) -import Data.Attoparsec.Text -import qualified Data.Text - - --- | --- An HTML token. -data Token = - -- | - -- An opening tag. - Token_OpeningTag OpeningTag | - -- | - -- A closing tag. - Token_ClosingTag Identifier | - -- | - -- A text between tags. - Token_Text Text | - -- | - -- Contents of a comment. - Token_Comment Text - deriving (Show, Ord, Eq, Generic, Data, Typeable) - --- | --- An opening tag name, attributes and whether it is closed. -type OpeningTag = - (Identifier, [Attribute], Bool) - --- | --- A case-insensitive identifier. -type Identifier = - CI Text - --- | --- A tag attribute identifier and a value. -type Attribute = - (Identifier, Maybe Text) - --- | --- A token parser. -token :: Parser Token -token = - Token_Comment <$> comment <|> - Token_ClosingTag <$> closingTag <|> - Token_OpeningTag <$> openingTag <|> - Token_Text <$> text - -openingTag :: Parser OpeningTag -openingTag = - do - char '<' - skipSpace - theIdentifier <- identifier - attributes <- many $ space *> skipSpace *> attribute - skipSpace - closed <- convert <$> optional (char '/') - char '>' - return (theIdentifier, attributes, closed) - -attribute :: Parser Attribute -attribute = - do - theIdentifier <- identifier - value <- - optional $ do - skipSpace - char '=' - skipSpace - msum (map quotedValue ['"', '\'', '`']) <|> entityQuotedValue <|> unquotedValue - return (theIdentifier, value) - where - quotedValue q = - char q *> takeWhile (/= q) <* char q - unquotedValue = - takeWhile1 $ flip all [not . isSpace, not . flip elem ['=', '<', '>', '/']] . (&) - entityQuotedValue = - fmap convert $ q *> manyTill' anyChar q - where - q = asciiCI """ - -identifier :: Parser Identifier -identifier = - fmap convert $ takeWhile1 (flip any [isAlphaNum, flip elem ['_', '-', '!', '?']] . flip ($)) - -comment :: Parser Text -comment = - (convert :: Builder -> Text) <$> (string "")) - (liftA2 mappend - (fmap convert (char '-')) - (content)))) - -closingTag :: Parser Identifier -closingTag = - string " skipSpace *> identifier <* skipSpace <* char '>' - -text :: Parser Text -text = - fmap ((convert :: Builder -> Text) . mconcat) $ many1 $ - convert <$> nonTagChar - where - nonTagChar = - shouldFail comment *> shouldFail closingTag *> shouldFail openingTag *> anyChar - -shouldFail :: Parser a -> Parser () -shouldFail p = - join $ (p $> empty) <|> pure (pure ()) -