dom-selector 0.1.0.0 → 0.2.0.0

raw patch · 8 files changed

+229/−91 lines, 8 filesdep ~textPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: text

API changes (from Hackage documentation)

Files

• Text/XML/Scraping.hs +123/−75
• Text/XML/Selector.hs +1/−0
• Text/XML/Selector/Parser.hs +21/−2
• Text/XML/Selector/TH.hs +0/−1
• Text/XML/Selector/Test.hs +2/−0
• Text/XML/Selector/Types.hs +5/−0
• dom-selector.cabal +33/−13
• test-scraping.hs +44/−0

@@ -1,8 +1,25 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings,FlexibleInstances #-}  -- |Scraping (innerHTML/innerText) and modification (node removal) functions.-module Text.XML.Scraping where+module Text.XML.Scraping (+  -- * InnerHTML / InnerText+  GetInner (..)+  -- * Attirbutes+  , GetAttribute (..)+  -- * Removing descendant nodes+  -- |These functions work on 'Node' or [Node]+  , remove+  , removeDepth+  , removeTags+  , removeQueries+  , rmElem+  -- * Other+  , nodeHaving+  -- * Deprecated+  , removeQuery+) where +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Text.XML as X@@ -13,92 +30,131 @@ import Data.List import Data.Maybe import System.Environment (getArgs)-import Text.Blaze.Html as Bl+import qualified Text.Blaze.Html as Bl import Text.Blaze.Html.Renderer.Text import Data.Text.Lazy  (fromStrict,toStrict, unpack)  import Text.XML.Selector import Text.XML.Selector.Types --- * InnerHTML / InnerText --- |Get ''innerHTML'' from a list of cursors.-innerHtml :: [Cursor] -> TL.Text-innerHtml cs = renderNodes $ map node $ concatMap child cs+-- |Type class for getting lazy text representation of HTML element(s). This can be used for 'Node', 'Cursor', [Node], and [Cursor].+class GetInner elem where+  -- | ''innerHtml'' of the element(s).+  innerHtml :: elem -> TL.Text+  -- | ''innerText'' of the element(s).+  innerText :: elem -> TL.Text+  -- | ''toHtml'' of the element(s).+  toHtml :: elem -> TL.Text --- |Get ''innerText'' from a list of cursors.-innerText :: [Cursor] -> T.Text-innerText cs = T.concat $ map (innerTextN . node) cs--- |''toHTML'' of a list of nodes.-renderNodes :: [Node] -> TL.Text-renderNodes ns = TL.concat $ map (renderHtml . Bl.toHtml) ns+instance GetInner Node where+  innerHtml = TL.concat . map toHtml . child . fromNode+  +  innerText (NodeElement (Element _ _ cs)) = (TL.concat . map innerText) cs+  innerText (NodeContent txt) = fromStrict txt+  innerText _ = "" --- |''toHTML'' of a list of cursors.-toHtml :: [Cursor] -> TL.Text-toHtml cs = renderNodes $ map node cs+  toHtml = renderHtml . Bl.toHtml --- |''innerText'' of a single node.-innerTextN :: Node -> T.Text-innerTextN (NodeElement (Element _ _ cs)) = T.concat $ map innerTextN cs-innerTextN (NodeContent txt) = txt-innerTextN _ = ""+instance GetInner Cursor where+  innerHtml = TL.concat . map (toHtml . node) . child+  innerText = innerText . node+  toHtml = toHtml . node +instance (GetInner a) => GetInner [a] where+  innerHtml = TL.concat . map innerHtml+  innerText = TL.concat . map innerText+  toHtml = TL.concat . map toHtml+ -- * Attirbutes--- |Tag name of element node. Return Nothing if the node is not an element.-ename :: Node -> Maybe T.Text-ename (NodeElement (Element n _ _)) = Just $ nameLocalName n-ename _ = Nothing --- |Return an element id. If node is not an element or does not have an id, return Nothing.-eid :: Node -> Maybe T.Text-eid (NodeElement (Element _ as _)) = M.lookup "id" as-eid _ = Nothing+class GetAttribute elem where+  -- |Tag name of element node. Returns Nothing if the node is not an element.+  ename :: elem -> Maybe Text+  -- |Returns an element id. If node is not an element or does not have an id, returns Nothing.+  eid :: elem -> Maybe Text+  -- |Returns element classes. If node is not an element or does not have a class, returns an empty list.+  eclass :: elem -> [Text]+  -- | Searches a meta with a specified name under a cursor, and gets a ''content'' field. +  getMeta :: Text -> elem -> [Text]  --- |Return element classes. If node is not an element or does not have a class, return an empty list.-eclass :: Node -> [T.Text]-eclass (NodeElement (Element _ as _)) = maybe [] T.words $ M.lookup "class" as-eclass _ = []+instance GetAttribute Node where+  ename (NodeElement (Element n _ _)) = Just $ nameLocalName n+  ename _ = Nothing --- | Search a meta with a specified name under a cursor, and get a ''content'' field. -getMeta :: T.Text -> Cursor -> [T.Text] -getMeta n cursor = concat $ cursor $// element "meta" &| attributeIs "name" n &.// attribute "content"+  eid (NodeElement (Element _ as _)) = M.lookup "id" as+  eid _ = Nothing +  eclass (NodeElement (Element _ as _)) = maybe [] T.words $ M.lookup "class" as+  eclass _ = [] +  getMeta n = getMeta n . fromNode++instance GetAttribute Cursor where+  ename = ename . node+  eid = eid . node+  eclass = eclass . node+  getMeta n cursor = concat $ cursor $// element "meta" &| attributeIs "name" n &.// attribute "content"++ -- * Removing Nodes--- |Remove descendant nodes that satisfie predicate (''Destructive'').++{-+data ScrapingOp = RemoveOp String+data Scraping a = Scraping {+  ops :: [ScrapingOp],+  runScraping :: a -> a+}++instance Monad Scraping where+  a >>= f = +-}+-- +--+--++-- |Removes descendant nodes that satisfy predicate, and returns a new updated 'Node'.+-- This is a general function, and internally used for other remove* functions in this module. remove :: (Node->Bool)->Node->Node remove f (NodeElement (Element a b cs)) = NodeElement (Element a b (map (remove f) (filter (not . f) cs))) remove _ n = n --- |Similar to 'remove', but with a depth.+-- |Similar to 'remove', but with a limit of depth. removeDepth :: (Node->Bool)->Int->Node->Node removeDepth _ (-1) n = n removeDepth f d (NodeElement (Element a b cs)) = NodeElement (Element a b (map (removeDepth f (d-1)) (filter (not . f) cs))) removeDepth _ _ n = n --- |Remove elements with specified tags.-removeTags :: [T.Text] -> [Node] -> [Node]-removeTags ts ns = map (remove (\n -> ename n `elem` map Just ts)) ns---- |Remove descendant nodes that match a query string.-removeQuery :: String -> [Node] -> [Node]-removeQuery q ns = map (remove (queryMatchNode q)) ns+-- |Remove all descendant nodes with specified tag names.+removeTags :: [String] -> [Node] -> [Node]+removeTags ts ns = map (remove (\n -> ename n `elem` map (Just . T.pack) ts)) ns --- |Remove descendant nodes that match any of query strings.+-- | Remove all descendant nodes that match any of query strings.+-- ''removeQuery'' in ver 0.1 was merged into this. removeQueries :: [String] -> [Node] -> [Node]+removeQueries [q] ns = map (remove (queryMatchNode q)) ns removeQueries qs ns = map (remove f) ns   where     f :: Node -> Bool     f n = any (flip queryMatchNode n) qs --- |See if the node contains any descendant (and self) node that satisfies predicate.--- To return false, this function needs to traverse all descendant elements....+{-# DEPRECATED removeQuery "Use removeQueries instead." #-}+-- | Remove all descendant nodes that match a query string.+removeQuery :: String -> [Node] -> [Node]+removeQuery q ns = removeQueries [q] ns++-- |Checks whether the node contains any descendant (and self) node that satisfies predicate.+-- To return false, this function needs to traverse all descendant elements, so this is not efficient. nodeHaving :: (Node->Bool)->Node->Bool nodeHaving f n@(NodeElement (Element _ _ cs)) = f n || any (nodeHaving f) cs nodeHaving _ _ = False ---- |Remove descendant nodes that match the condition (similar to 'remove')+-- |Remove descendant nodes that match specified tag, id, and class (similar to 'remove', but more specific.)+--  If you pass an empty string to tag or id, that does not filter tag or id (Read the source code for details).+--+-- @+-- rmElem ''div'' ''div-id'' [''div-class'', ''div-class2''] nodes = newnodes+-- @ rmElem :: String -> String -> [String] -> [Node] -> [Node] rmElem tag id kl ns = map (remove f) ns   where@@ -109,33 +165,25 @@     g "" = Nothing     g s = Just s ------- Conversion to trees--- {--toTree :: Node -> Tr.Tree String-toTree (TextNode t) = Tr.Node ("\""++T.unpack t++"\"") []-toTree (Comment t) = Tr.Node ("<-- "++T.unpack t++" -->") []-toTree (Element t as c) = Tr.Node str (map toTree c)-	where-		str = T.unpack t ++ g as-		g as | null as = ""-					| otherwise = ": [" ++ intercalate "," (map f as) ++ "]"-		f (k,v) = T.unpack k ++ "=\"" ++ T.unpack v ++ "\""+-- Not yet finished. ToDo: Look at State monad. This should be similar.+type Query = String+data ScrapingOp = Remove Query +data Scraping = Scraping [ScrapingOp] -showTree :: [Node] -> IO ()-showTree ns = do-	mapM_ (putStr . Tr.drawTree . toTree) ns--}------ Helper functions for XmlHtml data----{--(!!!) :: Node -> Int -> Node-(Element _ _ c) !!! i = c !! i-_ !!! _ = error "No child elements"--}+removeBy :: String -> Scraping +instance Functor Scraping where+  fmap f (Scraping ops) = Scraping (map f ops) +instance Applicative Scraping where+  pure ops = Scraping ops+  Scraping f <*> Scraping a = Scraping (f a)++instance Monad Scraping where+  return = pure+  Scraping a >>= f = Scraping (+++-}

@@ -68,6 +68,7 @@ -- byIdT :: String -> Axis byIdT s = [e| checkElement (elemHasId (Just s)) |] + -- | Axis for choosing elements by a class byClass :: String -> Axis byClass s = checkElement (elemHasClass [s])

@@ -3,6 +3,11 @@ -- {-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+ module Text.XML.Selector.Parser (parseJQ) where import Text.Parsec -- import Data.Either.Utils@@ -33,6 +38,7 @@     f ((Id s):xs) r = f xs (t1 r,Just s,t3 r,t4 r)     f ((Class s):xs) r = f xs (t1 r,t2 r,s:t3 r,t4 r)     f ((Attr k op v):xs) r = f xs (t1 r,t2 r,t3 r,(g k op v):(t4 r))+    f ((Not inners):xs) r = error ":not selector is not implemented yet."     t1 (a,_,_,_) = a     t2 (_,a,_,_) = a     t3 (_,_,a,_) = a@@ -56,11 +62,14 @@             Nothing -> Descendant             _ -> error "Incorrect option."   skipMany myspaces-  tok <- many1 $ choice [try selId, try selClass, try selTag, try selAttr]+  tok <- many1 $ choice [try selId, try selClass, try selTag, try selAttr, try selNot]   skipMany myspaces   return $ transformSelector (JQSelectorToken t tok) -data NameIdClassAttr = TagName String | Id String | Class String | Attr String (Maybe String) (Maybe String) deriving (Eq,Show,Ord)+data NameIdClassAttr =+  TagName String | Id String | Class String | Attr String (Maybe String) (Maybe String)+  | Not [NameIdClassAttr]  -- New at ver. 0.2+  deriving (Eq,Show,Ord)  selTag :: Parser NameIdClassAttr selTag = do@@ -92,6 +101,16 @@     return ' '   char ']'   return (Attr k op v)++selNot :: Parser NameIdClassAttr+selNot = do+  string ":not("+  inners <- sepBy (choice [try selId, try selClass, try selTag, try selAttr, try selNot]) $ do+              skipMany myspaces+              char ','+              skipMany myspaces+  char ')'+  return (Not inners)  -- stopDelim = (lookAhead (choice (map char ".#>+~ \t"))) 

@@ -43,4 +43,3 @@ queryT sels = searchTree sels  -

@@ -11,6 +11,8 @@ import Control.Monad import Data.Maybe ++ -- |QuickCheck for a parser. prop_parseJQ :: [JQSelector] -> Bool prop_parseJQ ss = (parseJQ . showJQ) ss == ss

@@ -1,3 +1,8 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Safe #-}+#endif+ module Text.XML.Selector.Types where   import Data.List (sort)

@@ -3,34 +3,46 @@  -- The name of the package. name:                dom-selector-version:             0.1.0.0+version:             0.2.0.0 synopsis:            DOM traversal by CSS selectors for xml-conduit package description:-  CSS selector support for xml-conduit/html-conduit. This package supports compile-time checking of CSS selectors using quasiquotes.+  CSS selector support for xml-conduit/html-conduit. This package supports compile-time checking of CSS selectors using quasiquotes. All DOM traversals are purely functional.   .   * Quick start   .   > -- The following pragmas should be put first (Haddock does not accept a pragma notation.)   > -- LANGUAGE OverloadedStrings, QuasiQuotes+  >    > module Main (main) where-  >-  > import Text.XML.Cursor-  > import qualified Text.HTML.DOM as H (readFile)+  > +  > import Text.XML.Cursor (fromDocument)+  > import Text.HTML.DOM (parseLBS)   > import qualified Data.Text.Lazy.IO as TI (putStrLn)+  > +  > import Control.Monad (mapM_)+  >    > import Text.XML.Scraping (innerHtml)-  > import Text.XML.Selector.TH -  >+  > import Text.XML.Selector.TH+  > +  > import Network.HTTP.Conduit+  > import Data.Conduit.Binary+  >    > main :: IO ()   > main = do-  >   c <- fmap fromDocument $ H.readFile "input.html"-  >   let cs = queryT [jq| ul#foo > li.bar |] c-  >   TI.putStrLn $ innerHtml cs+  >    root <- fmap (fromDocument . parseLBS) $ simpleHttp "https://news.google.com/"+  >    let cs = queryT [jq| h2 span.titletext |] root+  >    mapM_ (TI.putStrLn . innerHtml) cs+   .   You can use some elementary CSS selectors for traversing a DOM tree.   .   * Other examples   .   <https://github.com/nebuta/dom-selector/tree/master/examples>+  .+  Changes:+  .+    Ver 0.2: All scraping functions return lazy text now. It is implemented with a type class.  homepage:            https://github.com/nebuta/ license:             BSD3@@ -39,10 +51,11 @@ maintainer:          nebuta.office@gmail.com copyright:           Copyright 2012 by Nebuta Lab            category:            Web-stability:           alpha+stability:           beta build-type:          Simple cabal-version:       >=1.8 + source-repository head   type:     git   location: https://github.com/nebuta/dom-selector@@ -50,5 +63,12 @@ library   exposed-modules:     Text.XML.Scraping, Text.XML.Selector, Text.XML.Selector.Parser, Text.XML.Selector.Test, Text.XML.Selector.TH, Text.XML.Selector.Types   other-modules:       -  build-depends:       base >=4.0 && <5, text ==0.11.*, xml-conduit, html-conduit >=0.1, containers >=0.4, blaze-html >=0.5,  parsec >=3.1, QuickCheck >=2.4, template-haskell >=2.5, th-lift >=0.5-  +  build-depends:       base >=4.0 && <5, text >= 0.11, xml-conduit, html-conduit >=0.1, containers >=0.4, blaze-html >=0.5,  parsec >=3.1, QuickCheck >=2.4, template-haskell >=2.5, th-lift >=0.5++Test-Suite test+  type: exitcode-stdio-1.0+  main-is: test-scraping.hs+  build-depends:       base >=4.0 && <5, text >= 0.11, xml-conduit, html-conduit >=0.1, containers >=0.4, blaze-html >=0.5,  parsec >=3.1, QuickCheck >=2.4, template-haskell >=2.5, th-lift >=0.5+++

@@ -0,0 +1,44 @@+-- test-scraping.hs+{-# LANGUAGE QuasiQuotes,OverloadedStrings,DoAndIfThenElse #-}++module Main where++import System.Exit (exitFailure)++import Text.XML.Cursor+import Text.HTML.DOM as H+import Text.XML.Scraping+import Text.XML.Selector.TH+import Data.List+import Control.Monad+import qualified Data.Text.Lazy.IO as TLIO++main = do+  root <- fmap fromDocument $ H.readFile "examples/input2.html"+  mapM_ testOne (props root)+  props2 root+  return ()++testOne :: (String,Bool) -> IO ()+testOne (name,pred) = do+  if pred then do+    putStrLn $ "OK: " ++ name+    return ()+  else+  	exitFailure++props c = [+	("div li", length (queryT [jq| li |] c) == length (queryT [jq| div li |] c))+	,("ul li",length (queryT [jq| ul li |] c) == length (queryT [jq| ul > li |] c))+	,("inner",innerText (queryT [jq| #evening |] c) == (innerText . map node) (queryT [jq| #evening |] c))+	,("inner2",(innerText . head) (queryT [jq| #evening |] c) ==+		(innerText . head . map node) (queryT [jq| #evening |] c))+	]++props2 c = do+  TLIO.putStrLn $ (toHtml) (queryT [jq| #evening |] c)+  TLIO.putStrLn $ (toHtml . map node) (queryT [jq| #evening |] c)+  TLIO.putStrLn $ (innerHtml) (queryT [jq| #evening |] c)+  TLIO.putStrLn $ (innerHtml . map node) (queryT [jq| #evening |] c)+  TLIO.putStrLn $ (innerText) (queryT [jq| #evening |] c)+  TLIO.putStrLn $ (innerText . map node) (queryT [jq| #evening |] c)