diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2015, Nikita Volkov + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,42 @@ +-- 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 + diff --git a/doctest/Main.hs b/doctest/Main.hs new file mode 100644 --- /dev/null +++ b/doctest/Main.hs @@ -0,0 +1,66 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/html-tokenizer.cabal @@ -0,0 +1,88 @@ +name: + html-tokenizer +version: + 0.2.1.1 +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 + + you can produce a token stream with HTML-entities decoded, + thus becoming able to implement a highly efficient stream-parser, + which works in a single pass, constant memory and is capable of early termination. + is such a parser. +category: + Parsing, HTML, XML +homepage: + https://github.com/nikita-volkov/html-tokenizer +bug-reports: + https://github.com/nikita-volkov/html-tokenizer/issues +author: + Nikita Volkov +maintainer: + Nikita Volkov +copyright: + (c) 2015, Nikita Volkov +license: + MIT +license-file: + LICENSE +build-type: + Custom +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.Parser + build-depends: + html-entities == 1.0.*, + conversion >= 1.0.1 && < 2, + conversion-text == 1.0.*, + conversion-case-insensitive == 1.*, + case-insensitive == 1.2.*, + text >= 1 && < 1.3, + attoparsec >= 0.10 && < 0.13, + base-prelude >= 0.1.19 && < 0.2 + ghc-options: + -funbox-strict-fields + default-extensions: + Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators + default-language: + Haskell2010 + + +test-suite doctest + type: + exitcode-stdio-1.0 + hs-source-dirs: + doctest + 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, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators + default-language: + Haskell2010 + build-depends: + doctest == 0.9.*, + directory == 1.2.*, + filepath >= 1.3 && < 1.5, + base-prelude, + base diff --git a/library/HTMLTokenizer/Parser.hs b/library/HTMLTokenizer/Parser.hs new file mode 100644 --- /dev/null +++ b/library/HTMLTokenizer/Parser.hs @@ -0,0 +1,143 @@ +module HTMLTokenizer.Parser +( + -- * Model + Token(..), + OpeningTag, + ClosingTag, + Attribute, + -- * Parsers + token, +) +where + +import BasePrelude +import Conversion +import Conversion.Text +import Conversion.CaseInsensitive +import Data.Text (Text) +import Data.Text.Lazy.Builder (Builder) +import Data.CaseInsensitive (CI) +import HTMLEntities.Parser +import Data.Attoparsec.Text +import qualified Data.Text + + +-- | +-- An HTML token. +data Token = + -- | + -- An opening tag. + Token_OpeningTag OpeningTag | + -- | + -- A closing tag name. + Token_ClosingTag (CI Text) | + -- | + -- A text between tags with HTML-entities decoded. + 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 = + (CI Text, [Attribute], Bool) + +-- | +-- A closing tag name. +type ClosingTag = + CI Text + +-- | +-- A tag attribute identifier and a value with HTML-entities decoded. +type Attribute = + (CI Text, Maybe Text) + +-- | +-- A token parser. +token :: Parser Token +token = + skipSpace *> ( + Token_Comment <$> comment <|> + Token_ClosingTag <$> closingTag <|> + Token_OpeningTag <$> openingTag <|> + Token_Text <$> text + ) + +openingTag :: Parser OpeningTag +openingTag = + do + char '<' + skipSpace + name <- identifier + attributes <- many $ space *> skipSpace *> attribute + skipSpace + closed <- convert <$> optional (char '/') + char '>' + return (convert name, attributes, closed) + +attribute :: Parser Attribute +attribute = + do + identifierValue <- identifier + value <- + optional $ do + skipSpace + char '=' + skipSpace + msum (map quotedValue quotChars) <|> entityQuotedValue <|> unquotedValue + return (convert identifierValue, value) + where + quotedValue q = + do + char q + value <- + fmap ((convert :: Builder -> Text) . mconcat) $ many $ + fmap convert htmlEntity <|> fmap convert (satisfy (/= q)) + char q + return value + unquotedValue = + takeWhile1 isAlphaNum + entityQuotedValue = + do + q <- htmlEntity >>= \c -> bool mzero (return c) (elem c (map convert quotChars)) + fmap ((convert :: Builder -> Text) . mconcat) $ + manyTill' (fmap convert anyChar) (htmlEntity >>= guard . (==) q) + quotChars = + ['"', '\'', '`'] + + +identifier :: Parser Text +identifier = + takeWhile1 (flip any [isAlphaNum, flip elem ['_', '-', '!', '?']] . flip ($)) + +comment :: Parser Text +comment = + (convert :: Builder -> Text) <$> (string "")) + (liftA2 mappend + (fmap convert (char '-')) + (content)))) + +closingTag :: Parser ClosingTag +closingTag = + string " skipSpace *> fmap convert identifier <* skipSpace <* char '>' + +text :: Parser Text +text = + fmap ((convert :: Builder -> Text) . mconcat) $ many1 $ + convert <$> htmlEntity <|> convert <$> nonTagChar + where + nonTagChar = + shouldFail comment *> shouldFail closingTag *> shouldFail openingTag *> anyChar + +shouldFail :: Parser a -> Parser () +shouldFail p = + ((p $> False) <|> pure True) >>= bool empty (pure ()) +