list-t-html-parser 0.2.1.0 → 0.2.2.0

raw patch · 4 files changed

+211/−7 lines, 4 filesdep +case-insensitivedep +conversiondep +conversion-textdep ~base-preludedep ~html-tokenizerdep ~textPVP ok

version bump matches the API change (PVP)

Dependencies added: case-insensitive, conversion, conversion-text, hspec, html-entities, list-t-attoparsec, list-t-html-parser, list-t-text

Dependency ranges changed: base-prelude, html-tokenizer, text

API changes (from Hackage documentation)

Files

• hspec/Main.hs +91/−0
• library/ListT/HTMLParser.hs +44/−6
• library/ListT/HTMLParser/Renderer.hs +45/−0
• list-t-html-parser.cabal +31/−1

@@ -0,0 +1,91 @@+module Main where++import BasePrelude+import Test.Hspec+import Conversion+import Conversion.Text+import Data.Text (Text)+import qualified HTMLTokenizer.Parser+import qualified ListT.Attoparsec+import qualified ListT.HTMLParser+import qualified ListT.Text+import qualified ListT.HTMLParser as P+++main =+  hspec $ do+    it "Backtracking" $ do+      let +        text = "<a><b></b></a>"+        parser = +          a <|> b+          where+            a = +              do+                P.openingTag+                P.openingTag+                P.openingTag+                return 1+            b =+              do+                P.openingTag+                P.openingTag+                P.closingTag+                P.closingTag+                return 2+      result <- parse parser text+      shouldBe result (Right 2)+    it "Complex" $ do+      let +        text = "<a><b><c></c></b></a>"+        parser = +          a <|> b+          where+            a = +              do+                P.openingTag+                b <|> c+                P.openingTag+                return 1+              where+                b =+                  do+                    ("b", _, _) <- P.openingTag+                    P.closingTag+                c =+                  do+                    ("b", _, _) <- P.openingTag+                    ("c", _, _) <- P.openingTag+                    P.closingTag+            b =+              do+                P.openingTag+                P.openingTag+                P.openingTag+                P.closingTag+                P.closingTag+                P.closingTag+                return 2+      result <- parse parser text+      shouldBe result (Right 2)++++-- | Scrape the body of a GET response using an HTML parser.+parse :: ListT.HTMLParser.Parser IO a -> Text -> IO (Either Error a)+parse parser =+  fmap (either (Left . parseSomeException) id) . try .+  fmap (either (Left . Error_Parsing) Right) .+  ListT.HTMLParser.run parser . ListT.Attoparsec.textParser HTMLTokenizer.Parser.token . +  ListT.Text.stream 2+  where+    parseSomeException e =+      fromMaybe (error $ showString "Unexpected exception: " $ shows e $ "") $+        Error_Lexing <$> fromException e++data Error =+  -- | A tokenization failure+  Error_Lexing ListT.Attoparsec.ParsingFailure |+  -- | A token-stream parsing failure+  Error_Parsing ListT.HTMLParser.Error+  deriving (Show, Eq)

@@ -11,7 +11,9 @@   closingTag,   text,   comment,+  html,   -- * Combinators+  many1,   manyTill,   skipTill,   total,@@ -23,8 +25,11 @@ import Control.Monad.Trans.Either hiding (left, right) import ListT (ListT) import Data.Text (Text)+import qualified Data.Text.Lazy.Builder as Text (Builder)+import qualified Data.Text.Lazy.Builder as Text.Builder import qualified ListT as L import qualified HTMLTokenizer.Parser as HT+import qualified ListT.HTMLParser.Renderer as Renderer   -- |@@ -46,7 +51,7 @@   ErrorDetails_UnexpectedToken |   -- | End of input   ErrorDetails_EOI-  deriving (Show)+  deriving (Show, Eq)  instance Monad m => Monad (Parser m) where   return =@@ -62,11 +67,13 @@   (<|>) a b =     Parser $ EitherT $ StateT $ \(incoming, backtrack) -> do       (aResult, (incoming', backtrack')) <- flip runStateT (incoming, []) $ runEitherT $ unwrap $ a-      case aResult of-        Left _ -> do-          flip runStateT (foldr L.cons incoming' backtrack', []) $ runEitherT $ unwrap $ b-        Right aResult -> do-          return (Right aResult, (incoming', backtrack'))+      (result'', (incoming'', backtrack'')) <-+        case aResult of+          Left _ -> do+            flip runStateT (foldl' (flip L.cons) incoming' backtrack', []) $ runEitherT $ unwrap $ b+          Right aResult -> do+            return (Right aResult, (incoming', backtrack'))+      return (result'', (incoming'', backtrack'' <> backtrack))  instance Monad m => MonadPlus (Parser m) where   mzero = empty@@ -127,6 +134,12 @@     _ -> throwError (Just ErrorDetails_UnexpectedToken)  -- |+-- Apply a parser at least one time.+many1 :: Monad m => Parser m a -> Parser m [a]+many1 a =+  (:) <$> a <*> many a++-- | -- Apply a parser multiple times until another parser is satisfied. -- Returns results of both parsers. manyTill :: Monad m => Parser m a -> Parser m b -> Parser m ([a], b)@@ -151,3 +164,28 @@ total :: Monad m => Parser m a -> Parser m a total a =   a <* eoi++-- |+-- The textual HTML representation of a proper HTML tree node.+-- +-- Useful for consuming HTML-formatted snippets.+html :: Monad m => Parser m Text.Builder+html =+  enclosingTag <|> brokenOpenTag <|> text' <|> comment'+  where+    enclosingTag =+      do+        ot@(n, _, False) <- openingTag  +        theHTML <- mconcat <$> many html+        ct <- closingTag+        guard $ ct == n+        return $ Renderer.openingTag ot <> theHTML <> Renderer.closingTag ct+    brokenOpenTag =+      Renderer.openingTag . repair <$> openingTag+      where+        repair (name, attrs, _) = (name, attrs, True)+    text' =+      Renderer.text <$> text+    comment' =+      Renderer.comment <$> comment+

@@ -0,0 +1,45 @@+module ListT.HTMLParser.Renderer where++import BasePrelude hiding (fromString)+import Data.Text (Text)+import Data.Text.Lazy.Builder+import HTMLTokenizer.Parser (Token(..), OpeningTag, ClosingTag, Attribute)+import qualified Data.CaseInsensitive as CI+import qualified HTMLEntities.Builder+++openingTag :: OpeningTag -> Builder+openingTag (name, attrs, closed) =+  singleton '<' <>+  ciText name <>+  mconcat (map (mappend (singleton ' ') . attribute) attrs) <>+  bool (singleton '>') (fromString "/>") closed++attribute :: Attribute -> Builder+attribute (name, value) =+  maybe id (flip mappend . mappend (fromString "=\"") . flip mappend (singleton '"') . HTMLEntities.Builder.text) value $+  ciText name++ciText :: CI.CI Text -> Builder+ciText =+  HTMLEntities.Builder.text . CI.foldedCase  ++closingTag :: ClosingTag -> Builder+closingTag name =+  fromString "</" <> ciText name <> singleton '>'++text :: Text -> Builder+text =+  HTMLEntities.Builder.text++comment :: Text -> Builder+comment content =+  fromString "<!--" <> fromText content <> fromString "-->"++token :: Token -> Builder+token =+  \case+    Token_OpeningTag x -> openingTag x+    Token_ClosingTag x -> closingTag x+    Token_Text x -> text x+    Token_Comment x -> comment x

@@ -1,7 +1,7 @@ name:   list-t-html-parser version:-  0.2.1.0+  0.2.2.0 synopsis:   Streaming HTML parser category:@@ -37,6 +37,7 @@   hs-source-dirs:     library   other-modules:+    ListT.HTMLParser.Renderer   exposed-modules:     ListT.HTMLParser   ghc-options:@@ -48,7 +49,36 @@   build-depends:     list-t == 0.4.*,     html-tokenizer >= 0.2.1 && < 0.3,+    html-entities >= 1.0.1 && < 1.2,+    case-insensitive == 1.2.*,     text >= 1 && < 1.3,     either == 4.*,     mtl-prelude >= 1 && < 3,     base-prelude >= 0.1.19 && < 0.2+++test-suite hspec+  type:+    exitcode-stdio-1.0+  hs-source-dirs:+    hspec+  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, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language:+    Haskell2010+  build-depends:+    hspec == 2.1.*,+    list-t-html-parser,+    list-t-attoparsec == 0.2.*,+    list-t-text == 0.2.*,+    html-tokenizer,+    conversion == 1.*,+    conversion-text == 1.*,+    text,+    base-prelude