diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,42 +1,2 @@ --- The code is mostly ripped from --- https://github.com/ekmett/lens/blob/697582fb9a980f273dbf8496253c5bbefedd0a8b/Setup.lhs -import Data.List ( nub ) -import Data.Version ( showVersion ) -import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName ) -import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) -import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) -import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles ) -import Distribution.Simple.BuildPaths ( autogenModulesDir ) -import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref)) -import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) -import Distribution.Text ( display ) -import Distribution.Verbosity ( Verbosity, normal ) -import System.FilePath ( () ) - -main :: IO () -main = defaultMainWithHooks simpleUserHooks - { buildHook = \pkg lbi hooks flags -> do - generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi - buildHook simpleUserHooks pkg lbi hooks flags - } - -generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () -generateBuildModule verbosity pkg lbi = do - let dir = autogenModulesDir lbi - createDirectoryIfMissingVerbose verbosity True dir - withLibLBI pkg lbi $ \_ libcfg -> do - withTestLBI pkg lbi $ \suite suitecfg -> do - rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines - [ "module Build_" ++ testName suite ++ " where" - , "import Prelude" - , "deps :: [String]" - , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) - ] - where - formatdeps = map (formatone . snd) - formatone p = case packageName p of - PackageName n -> n ++ "-" ++ showVersion (packageVersion p) - -testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] -testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys - +import Distribution.Simple +main = defaultMain diff --git a/doctest/Main.hs b/doctest/Main.hs deleted file mode 100644 --- a/doctest/Main.hs +++ /dev/null @@ -1,66 +0,0 @@ --- The code is mostly ripped from --- https://github.com/ekmett/lens/blob/d1d97469f0e93c1d3535308954a060e8a04e37aa/tests/doctests.hsc -import BasePrelude -import System.Directory -import System.FilePath -import Test.DocTest -import Build_doctest (deps) - -main :: IO () -main = do - sources <- getSources - doctest $ dfltParams ++ map ("-package="++) deps ++ sources - where - dfltParams = - [ - "-isrc", - "-idist/build/autogen", - "-optP-include", - "-optPdist/build/autogen/cabal_macros.h", - "-XArrows", - "-XBangPatterns", - "-XConstraintKinds", - "-XDataKinds", - "-XDefaultSignatures", - "-XDeriveDataTypeable", - "-XDeriveFunctor", - "-XDeriveGeneric", - "-XEmptyDataDecls", - "-XFlexibleContexts", - "-XFlexibleInstances", - "-XFunctionalDependencies", - "-XGADTs", - "-XGeneralizedNewtypeDeriving", - "-XImpredicativeTypes", - "-XLambdaCase", - "-XLiberalTypeSynonyms", - "-XMultiParamTypeClasses", - "-XMultiWayIf", - "-XNoImplicitPrelude", - "-XNoMonomorphismRestriction", - "-XOverloadedStrings", - "-XPatternGuards", - "-XParallelListComp", - "-XQuasiQuotes", - "-XRankNTypes", - "-XRecordWildCards", - "-XScopedTypeVariables", - "-XStandaloneDeriving", - "-XTemplateHaskell", - "-XTupleSections", - "-XTypeFamilies", - "-XTypeOperators", - "-hide-all-packages" - ] - -getSources :: IO [FilePath] -getSources = filter (isSuffixOf ".hs") <$> go "library" - where - go dir = do - (dirs, files) <- getFilesAndDirectories dir - (files ++) . concat <$> mapM go dirs - -getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) -getFilesAndDirectories dir = do - c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir - (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c diff --git a/html-tokenizer.cabal b/html-tokenizer.cabal --- a/html-tokenizer.cabal +++ b/html-tokenizer.cabal @@ -1,13 +1,13 @@ name: html-tokenizer version: - 0.4.1 + 0.5 synopsis: An "attoparsec"-based HTML tokenizer description: This library can be used as a basis for complex HTML parsers, or for streaming. - E.g., by composing it with + E.g., by composing it with you can produce a token stream, thus becoming able to implement a highly efficient stream-parser, @@ -18,7 +18,7 @@ homepage: https://github.com/nikita-volkov/html-tokenizer bug-reports: - https://github.com/nikita-volkov/html-tokenizer/issues + https://github.com/nikita-volkov/html-tokenizer/issues author: Nikita Volkov maintainer: @@ -30,58 +30,60 @@ license-file: LICENSE build-type: - Custom + Simple cabal-version: >=1.10 - source-repository head type: git location: git://github.com/nikita-volkov/html-tokenizer.git - library hs-source-dirs: library - other-modules: - exposed-modules: - HTMLTokenizer - build-depends: - conversion >= 1.0.1 && < 2, - conversion-text >= 1.0.0.1 && < 2, - conversion-case-insensitive == 1.*, - case-insensitive == 1.2.*, - text >= 1 && < 2, - attoparsec >= 0.10 && < 0.14, - base-prelude >= 0.1.19 && < 2 - ghc-options: - -funbox-strict-fields default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples default-language: Haskell2010 - + exposed-modules: + HTMLTokenizer.Data + HTMLTokenizer.Parsing + other-modules: + HTMLTokenizer.MonadPlus + HTMLTokenizer.Prelude + build-depends: + attoparsec >=0.10 && <0.14, + base >=4.7 && <5, + base-prelude >=0.1.19 && <2, + html-entities >=1.1.4 && <1.2, + semigroups >=0.18 && <0.19, + text >=1 && <2, + text-builder >=0.5.1 && <0.6, + vector >=0.10 && <0.13, + vector-builder >=0.3.4 && <0.4 -test-suite doctest +test-suite tests type: exitcode-stdio-1.0 hs-source-dirs: - doctest + tests main-is: Main.hs - ghc-options: - -threaded - "-with-rtsopts=-N" - -funbox-strict-fields default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples default-language: Haskell2010 build-depends: - doctest == 0.11.*, - directory == 1.2.*, - filepath >= 1.3 && < 1.5, - base-prelude, - base + -- + html-tokenizer, + attoparsec, + -- testing: + tasty >=0.12 && <0.13, + tasty-quickcheck >=0.9 && <0.10, + tasty-hunit >=0.9 && <0.10, + quickcheck-instances >=0.3.11 && <0.4, + QuickCheck >=2.8.1 && <3, + -- + rerebase >=1.1 && <2 diff --git a/library/HTMLTokenizer.hs b/library/HTMLTokenizer.hs deleted file mode 100644 --- a/library/HTMLTokenizer.hs +++ /dev/null @@ -1,164 +0,0 @@ -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/Data.hs b/library/HTMLTokenizer/Data.hs new file mode 100644 --- /dev/null +++ b/library/HTMLTokenizer/Data.hs @@ -0,0 +1,23 @@ +{-# OPTIONS_GHC -funbox-strict-fields #-} +module HTMLTokenizer.Data +where + +import HTMLTokenizer.Prelude + + +data Token = + OpeningTagToken !Name !(Vector Attribute) !Bool | + ClosingTagToken !Name | + TextToken !Text | + CommentToken !Text | + DoctypeToken !Text + deriving (Show, Eq) + +data Name = + UnprefixedName !Text | + PrefixedName !Text !Text + deriving (Show, Eq) + +data Attribute = + Attribute !Name !Text + deriving (Show, Eq) diff --git a/library/HTMLTokenizer/MonadPlus.hs b/library/HTMLTokenizer/MonadPlus.hs new file mode 100644 --- /dev/null +++ b/library/HTMLTokenizer/MonadPlus.hs @@ -0,0 +1,46 @@ +module HTMLTokenizer.MonadPlus +where + +import HTMLTokenizer.Prelude hiding (foldl, foldl1, concat) + + +{-# INLINE foldl #-} +foldl :: MonadPlus m => (a -> b -> a) -> a -> m b -> m a +foldl step start fetch = + loop start + where + loop !state = + mplus + (do + !element <- fetch + loop (step state element)) + (return state) + +{-# INLINE foldl1 #-} +foldl1 :: MonadPlus m => (a -> a -> a) -> m a -> m a +foldl1 step fetch = + do + !start <- fetch + foldl step start fetch + +{-# INLINE concat #-} +concat :: (MonadPlus m, Monoid a) => m a -> m a +concat = + foldl mappend mempty + +{-# INLINE concat1 #-} +concat1 :: (MonadPlus m, Semigroup a) => m a -> m a +concat1 = + foldl1 (<>) + +{-# INLINE foldlM #-} +foldlM :: MonadPlus m => (a -> b -> m a) -> a -> m b -> m a +foldlM step start fetch = + loop start + where + loop !state = + mplus + (do + !element <- fetch + loop =<< step state element) + (return state) diff --git a/library/HTMLTokenizer/Parsing.hs b/library/HTMLTokenizer/Parsing.hs new file mode 100644 --- /dev/null +++ b/library/HTMLTokenizer/Parsing.hs @@ -0,0 +1,194 @@ +module HTMLTokenizer.Parsing +( + token, +) +where + +import HTMLTokenizer.Prelude hiding (takeWhile) +import HTMLTokenizer.Data +import Data.Attoparsec.Text +import HTMLEntities.Parser (htmlEntity) +import qualified Text.Builder as A +import qualified HTMLTokenizer.MonadPlus as B +import qualified VectorBuilder.MonadPlus as C +import qualified Data.Text as D + + +{-| +Token parser, which also decodes entities. +-} +token :: Parser Token +token = + labeled "HTML Token" $ + openingTag OpeningTagToken <|> + ClosingTagToken <$> closingTag <|> + TextToken <$> textBetweenTags <|> + CommentToken <$> comment <|> + DoctypeToken <$> doctype <|> + fail "Invalid token" + +{-| +>>> 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 = + labeled "Doctype" $ do + string "') + char '>' + return contents + +openingTag :: (Name -> Vector Attribute -> Bool -> openingTag) -> Parser openingTag +openingTag openingTag = + labeled "Opening tag" $ do + char '<' + skipSpace + tagName <- name + attributes <- C.many (space *> skipSpace *> attribute) + skipSpace + closed <- (char '/' $> True) <|> pure False + char '>' + return (openingTag tagName attributes closed) + +closingTag :: Parser Name +closingTag = + labeled "Closing tag" $ + string " skipSpace *> name <* skipSpace <* char '>' + +textBetweenTags :: Parser Text +textBetweenTags = + labeled "Text between tags" $ do + prefixSpace <- (space *> skipSpace $> A.char ' ') <|> pure mempty + text <- loop prefixSpace mempty + if A.null text + then mzero + else return (A.run text) + where + loop !builder !unconsumedSpace = + mplus word end + where + word = + do + parsedWord <- word + space <- takeWhile isSpace + if D.null space + then return (builder <> A.text unconsumedSpace <> parsedWord) + else loop (builder <> A.text unconsumedSpace <> parsedWord) space + where + word = + B.concat1 (normalChunk <|> entity <|> ampersand) + where + normalChunk = + A.text <$> takeWhile1 (\ x -> not (isSpace x) && x /= '<' && x /= '&') + entity = + A.text <$> htmlEntity + ampersand = + A.char <$> char '&' + end = + if D.null unconsumedSpace + then return builder + else return (builder <> A.char ' ') + +comment :: Parser Text +comment = + labeled "Comment" $ + string "" $> builder <> textWithoutDashes) + (mplus + (char '-' *> loop (builder <> textWithoutDashes <> A.char '-')) + (return (builder <> textWithoutDashes))) + where + textWithoutDashes = + A.text <$> takeWhile1 (/= '-') + +attribute :: Parser Attribute +attribute = + labeled "Attribute" $ do + attributeName <- name + mplus + (do + skipSpace + char '=' + skipSpace + attributeValue <- msum (map quotedContent ['"', '\'', '`']) <|> unquotedContent + return (Attribute attributeName attributeValue)) + (return (Attribute attributeName "")) + +quotedContent :: Char -> Parser Text +quotedContent quotChar = + char quotChar *> (A.run <$> B.concat escapedContentChunk) <* char quotChar + where + escapedContentChunk = + normal <|> entity <|> escaped <|> failedEscaping + where + normal = + A.text <$> takeWhile1 (\ x -> x /= quotChar && x /= '&' && x /= '\\') + entity = + A.text <$> htmlEntity + escaped = + char '\\' *> (A.char <$> satisfy (\ x -> x == quotChar || x == '\\')) + failedEscaping = + A.char <$> char '\\' + +unquotedContent :: Parser Text +unquotedContent = + isolatedTextInsideTag + +name :: Parser Name +name = + labeled "Name" $ do + c1 <- isolatedTextInsideTag + (mplus + (do + skipSpace + char ':' + skipSpace + c2 <- isolatedTextInsideTag + return (PrefixedName c1 c2)) + (return (UnprefixedName c1))) + +isolatedTextInsideTag :: Parser Text +isolatedTextInsideTag = + A.run <$> B.concat1 (normal <|> entity <|> ampersand) + where + normal = + A.text <$> takeWhile1 predicate + where + predicate x = + x /= '>' && x /= '/' && not (isSpace x) && x /= '=' && + x /= '&' && x /= '<' && + x /= '"' && x /= '\'' && x /= '`' + entity = + A.text <$> htmlEntity + ampersand = + A.char <$> char '&' + +shouldFail :: Parser a -> Parser () +shouldFail p = + join ((p $> empty) <|> pure (pure ())) + +skipSpaceLeaving1 :: Parser () +skipSpaceLeaving1 = + mplus + (do + space + peekedChar <- peekChar' + if isSpace peekedChar + then skipSpaceLeaving1 + else mzero) + (return ()) + +{-# INLINE labeled #-} +labeled :: String -> Parser a -> Parser a +labeled label parser = + parser label diff --git a/library/HTMLTokenizer/Prelude.hs b/library/HTMLTokenizer/Prelude.hs new file mode 100644 --- /dev/null +++ b/library/HTMLTokenizer/Prelude.hs @@ -0,0 +1,22 @@ +module HTMLTokenizer.Prelude +( + module Exports, +) +where + + +-- base-prelude +------------------------- +import BasePrelude as Exports hiding ((<>), First(..), Last(..)) + +-- semigroups +------------------------- +import Data.Semigroup as Exports + +-- text +------------------------- +import Data.Text as Exports (Text) + +-- vector +------------------------- +import Data.Vector as Exports (Vector) diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,106 @@ +module Main where + +import Prelude +import Test.QuickCheck.Instances +import Test.Tasty +import Test.Tasty.Runners +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import qualified HTMLTokenizer.Data as A +import qualified HTMLTokenizer.Parsing as B +import qualified Data.Attoparsec.Text as C +import qualified Data.Vector as D + + +main = + defaultMain $ + testGroup "All tests" $ + [ + testTokenParsing "Opening tag" + (Right (A.OpeningTagToken (A.UnprefixedName "script") (D.fromList []) False)) + "