packages feed

html-tokenizer 0.4.1 → 0.6.4

raw patch · 15 files changed

Files

Setup.hs view
@@ -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
− doctest/Main.hs 
@@ -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
html-tokenizer.cabal view
@@ -1,24 +1,17 @@ name:   html-tokenizer version:-  0.4.1+  0.6.4 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 -  <http://hackage.haskell.org/package/list-t-attoparsec the "list-t-attoparsec" library>-  you can produce a token stream,-  thus becoming able to implement a highly efficient stream-parser,-  which works in a single pass, constant memory and is capable of early termination.-  <http://hackage.haskell.org/package/list-t-html-parser "list-t-html-parser"> is such a parser.+  This library can be used as a basis for streaming HTML parsers. category:   Parsing, HTML, XML 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 <nikita.y.volkov@mail.ru> maintainer:@@ -30,58 +23,66 @@ 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+    HTMLTokenizer.Rendering.Text+    HTMLTokenizer.Rendering.Text.Builder+  other-modules:+    HTMLTokenizer.Data.Types+    HTMLTokenizer.Data.Instances.Show+    HTMLTokenizer.Data.Instances.Eq+    HTMLTokenizer.Data.Instances.Generic+    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
− library/HTMLTokenizer.hs 
@@ -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 "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML+RDFa 1.0//EN\" \"http://www.w3.org/MarkUp/DTD/xhtml-rdfa-1.dtd\">"--- 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 "<!"-    skipSpace-    asciiCI "doctype"-    space-    skipSpace-    contents <- takeWhile1 (/= '>')-    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 "&quot;"--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 "<!--" *> content)-  where-    content =-      (liftA2 mappend-        (fmap convert (takeWhile1 (/= '-')))-        (mplus-          (fmap (const mempty) (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 ())-
+ library/HTMLTokenizer/Data.hs view
@@ -0,0 +1,13 @@+module HTMLTokenizer.Data+(+  module HTMLTokenizer.Data.Types,+  module HTMLTokenizer.Data.Instances.Show,+  module HTMLTokenizer.Data.Instances.Eq,+  module HTMLTokenizer.Data.Instances.Generic,+)+where++import HTMLTokenizer.Data.Types+import HTMLTokenizer.Data.Instances.Show+import HTMLTokenizer.Data.Instances.Eq+import HTMLTokenizer.Data.Instances.Generic
+ library/HTMLTokenizer/Data/Instances/Eq.hs view
@@ -0,0 +1,10 @@+module HTMLTokenizer.Data.Instances.Eq+where++import HTMLTokenizer.Prelude+import HTMLTokenizer.Data.Types+++deriving instance Eq Token+deriving instance Eq Name+deriving instance Eq Attribute
+ library/HTMLTokenizer/Data/Instances/Generic.hs view
@@ -0,0 +1,10 @@+module HTMLTokenizer.Data.Instances.Generic+where++import HTMLTokenizer.Prelude+import HTMLTokenizer.Data.Types+++deriving instance Generic Token+deriving instance Generic Name+deriving instance Generic Attribute
+ library/HTMLTokenizer/Data/Instances/Show.hs view
@@ -0,0 +1,16 @@+module HTMLTokenizer.Data.Instances.Show+where++import HTMLTokenizer.Prelude+import HTMLTokenizer.Data.Types+import qualified HTMLTokenizer.Rendering.Text as A+++instance Show Token where+  show = textString . A.token++instance Show Name where+  show = textString . A.name++instance Show Attribute where+  show = textString . A.attribute
+ library/HTMLTokenizer/Data/Types.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}+module HTMLTokenizer.Data.Types+where++import HTMLTokenizer.Prelude+++data Token =+  OpeningTagToken !Name !(Vector Attribute) !Bool |+  ClosingTagToken !Name |+  TextToken !Text |+  CommentToken !Text |+  DoctypeToken !Text++data Name =+  UnprefixedName !Text |+  PrefixedName !Text !Text++data Attribute =+  Attribute !Name !Text
+ library/HTMLTokenizer/MonadPlus.hs view
@@ -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)
+ library/HTMLTokenizer/Parsing.hs view
@@ -0,0 +1,191 @@+module HTMLTokenizer.Parsing+(+  token,+  attribute,+  name,+)+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" $+  join+    (mplus+      (do+        char '<'+        mplus+          (do+            char '!'+            mplus+              (string "--" $> commentTagBody)+              (asciiCI "doctype" $> doctypeTagBody))+          (mplus+            (char '/' $> closingTagBody)+            (pure+              (mplus+                openingTagBody+                (pure (TextToken "<"))))))+      (pure (TextToken <$> textBetweenTags)))+  where+    commentTagBody =+      labeled "Comment" (CommentToken . A.run <$> loop mempty)+      where+        loop !builder =+          do+            textWithoutDashes <- A.text <$> takeWhile (/= '-')+            mplus+              (string "-->" $> builder <> textWithoutDashes)+              (mplus+                (char '-' *> loop (builder <> textWithoutDashes <> A.char '-'))+                (return (builder <> textWithoutDashes)))+          where+            textWithoutDashes =+              A.text <$> takeWhile1 (/= '-')+    doctypeTagBody =+      labeled "Doctype" $ do+        space+        skipSpace+        contents <- takeWhile1 (/= '>')+        char '>'+        return (DoctypeToken contents)+    closingTagBody =+      labeled "Closing tag" $+      skipSpace *> (ClosingTagToken <$> name) <* skipSpace <* char '>'+    openingTagBody =+      labeled "Opening tag" $ do+        skipSpace+        tagName <- name+        attributes <- C.many (space *> skipSpace *> attribute)+        skipSpace+        closed <- (char '/' $> True) <|> pure False+        char '>'+        return (OpeningTagToken tagName attributes closed)++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 ' ')++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 <- D.toLower <$> isolatedTextInsideTag+    (mplus+      (do+        skipSpace+        char ':'+        skipSpace+        c2 <- D.toLower <$> 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
+ library/HTMLTokenizer/Prelude.hs view
@@ -0,0 +1,36 @@+module HTMLTokenizer.Prelude+( +  module Exports,+  textString,+  showText,+)+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)++--------------------------------------------------------------------------------++import qualified Data.Text as A++textString :: Text -> String+textString =+  A.unpack++showText :: Show a => a -> Text+showText =+  fromString . show
+ library/HTMLTokenizer/Rendering/Text.hs view
@@ -0,0 +1,17 @@+module HTMLTokenizer.Rendering.Text+where++import HTMLTokenizer.Prelude+import HTMLTokenizer.Data.Types+import qualified Text.Builder as A+import qualified HTMLTokenizer.Rendering.Text.Builder as B+++token :: Token -> Text+token = A.run . B.token++attribute :: Attribute -> Text+attribute = A.run . B.attribute++name :: Name -> Text+name = A.run . B.name
+ library/HTMLTokenizer/Rendering/Text/Builder.hs view
@@ -0,0 +1,55 @@+module HTMLTokenizer.Rendering.Text.Builder+(+  token,+  attribute,+  name,+)+where++import HTMLTokenizer.Prelude hiding (takeWhile)+import HTMLTokenizer.Data.Types+import Text.Builder+import qualified Data.Text as D+import qualified HTMLEntities.Text as B+++encodedText :: Text -> Builder+encodedText =+  text . B.text++name :: Name -> Builder+name =+  \ case+    UnprefixedName localName ->+      encodedText localName+    PrefixedName space localName ->+      encodedText space <> char ':' <> encodedText localName++attribute :: Attribute -> Builder+attribute (Attribute attributeName content) =+  if D.null content+    then name attributeName+    else name attributeName <> text "=\"" <> encodedText content <> char '"'++token :: Token -> Builder+token =+  \ case+    OpeningTagToken tagName attrVec closed ->+      char '<' <> name tagName <> attrs <> closing+      where+        attrs =+          foldMap (\ x -> char ' ' <> attribute x) attrVec+        closing =+          if closed+            then text "/>"+            else char '>'+    ClosingTagToken tagName ->+      text "</" <> name tagName <> char '>'+    TextToken theText ->+      encodedText theText+    CommentToken commentText ->+      text "<!--" <> encodedText commentText <> text "-->"+    DoctypeToken doctypeText ->+      text "<!doctype" <>+      (if D.null doctypeText then mempty else char ' ' <> encodedText doctypeText) <>+      char '>'
+ tests/Main.hs view
@@ -0,0 +1,123 @@+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+import qualified Data.Text.IO as E+++main =+  defaultMain $+  testGroup "All tests" $+  [+    testTokenParsing "Opening tag"+      (Right (A.OpeningTagToken (A.UnprefixedName "script") (D.fromList []) False))+      "<script>"+    ,+    testTokenParsing "Opening tag with arguments"+      (Right+        (A.OpeningTagToken+          (A.UnprefixedName "script")+          (D.fromList+            [+              A.Attribute (A.UnprefixedName "type") "text/javascript",+              A.Attribute (A.UnprefixedName "src") "https://optimize-stats.voxmedia.com/loader.min.js?key=efd28c71b5699c36"+            ])+          False))+      "<script type=\"text/javascript\" src=\"https://optimize-stats.voxmedia.com/loader.min.js?key=efd28c71b5699c36\">"+    ,+    testTokenParsing "Closed opening tag"+      (Right (A.OpeningTagToken (A.UnprefixedName "script") (D.fromList []) True))+      "<script/>"+    ,+    testTokenParsing "Spaces"+      (Right (A.OpeningTagToken (A.UnprefixedName "script") (D.fromList []) True))+      "<  script  />"+    ,+    testTokenParsing "Entities in names"+      (Right (A.OpeningTagToken (A.UnprefixedName "xxr") (D.fromList []) True))+      "<x&#120;r/>"+    ,+    testTokenParsing "Entities in attributes"+      (Right (A.OpeningTagToken (A.UnprefixedName "x") (D.fromList [A.Attribute (A.UnprefixedName "attr") "YyY"]) True))+      "<x attr=\"Y&#121;Y\"/>"+    ,+    testTokenParsing "Empty attributes"+      (Right (A.OpeningTagToken (A.UnprefixedName "x") (D.fromList [A.Attribute (A.UnprefixedName "attr") ""]) True))+      "<x attr/>"+    ,+    testTokenParsing "Quoteless attributes"+      (Right (A.OpeningTagToken (A.UnprefixedName "x") (D.fromList [A.Attribute (A.UnprefixedName "attr") "abc"]) True))+      "<x attr=abc/>"+    ,+    testTokenParsing "Closing tag"+      (Right (A.ClosingTagToken (A.UnprefixedName "x")))+      "</x>"+    ,+    testTokenParsing "Closing tag"+      (Right (A.DoctypeToken "html PUBLIC \"-//W3C//DTD XHTML+RDFa 1.0//EN\" \"http://www.w3.org/MarkUp/DTD/xhtml-rdfa-1.dtd\""))+      "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML+RDFa 1.0//EN\" \"http://www.w3.org/MarkUp/DTD/xhtml-rdfa-1.dtd\">"+    ,+    testTokensParsing "Text between tags, stripped"+      (Right+        [+          A.OpeningTagToken (A.UnprefixedName "x") mempty False,+          A.TextToken "abc",+          A.ClosingTagToken (A.UnprefixedName "x")+        ])+      "<x>abc</x>"+    ,+    testTokensParsing "Text between tags, unstripped"+      (Right+        [+          A.OpeningTagToken (A.UnprefixedName "x") mempty False,+          A.TextToken " abc ",+          A.ClosingTagToken (A.UnprefixedName "x")+        ])+      "<x>   abc \n </x>"+    ,+    testTokensParsing "Text between tags, entities"+      (Right+        [+          A.OpeningTagToken (A.UnprefixedName "x") mempty False,+          A.TextToken "a<c x",+          A.ClosingTagToken (A.UnprefixedName "x")+        ])+      "<x>a&lt;c &#120;</x>"+    ,+    testTokensParsing "Text between tags, broken entities"+      (Right+        [+          A.OpeningTagToken (A.UnprefixedName "x") mempty False,+          A.TextToken "a<c & #120;",+          A.ClosingTagToken (A.UnprefixedName "x")+        ])+      "<x>a&lt;c & #120;</x>"+    ,+    sample1+  ]+  where+    testTokenParsing name expectedResult text =+      testCase name $+      assertEqual "" expectedResult (C.parseOnly (B.token <* C.endOfInput) text)+    testTokensParsing name expectedResult text =+      testCase name $+      assertEqual "" expectedResult (C.parseOnly (many B.token <* C.endOfInput) text)++sample1 :: TestTree+sample1 =+  testGroup "sample1" $+  [+    testCase "A quite broken stream should parse in full" $+    assertBool "" (not (null (C.parseOnly (many B.token <* C.endOfInput) pageContents)))+  ]+  where+    pageContents =+      unsafePerformIO (E.readFile "samples/1.html")