packages feed

hquery (empty) → 0.1.0.0

raw patch · 11 files changed

+591/−0 lines, 11 filesdep +HUnitdep +basedep +bytestringsetup-changed

Dependencies added: HUnit, base, bytestring, containers, filepath, hquery, parsec, test-framework, test-framework-hunit, text, xmlhtml

Files

+ LICENSE view
@@ -0,0 +1,21 @@+// MIT++Copyright (c) 2012 Tycho Andersen++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hquery.cabal view
@@ -0,0 +1,54 @@+name:                hquery+version:             0.1.0.0+synopsis:            A query language for transforming HTML5+license:             MIT+license-file:        LICENSE+author:              Tycho Andersen+maintainer:          Tycho Andersen <tycho@tycho.ws>+category:            Web+build-type:          Simple+cabal-version:       >=1.8+bug-reports:         https://github.com/tych0/hquery/issues+tested-with:         GHC == 7.4.1+description: Hquery is a tool for transforming XmlHtml trees. It is an+             implementation of Lift's CssSelectors in haskell. It operates over+             "xmlhtml" 'Node's, allowing you to build transformers for creating+             and modifying template trees. See "Text.Hquery" for some examples.++source-repository head+  type:              git+  location:          git://github.com/tych0/hquery.git++library+  build-depends: base ==4.5.*, parsec >= 3.1, xmlhtml >= 0.2.0.3,+                 text >= 0.11.2.3, containers >= 0.4.2.1++  hs-source-dirs: src+  exposed-modules: Text.Hquery, Text.Hquery.Utils,+                   Text.Hquery.Internal.Selector, Text.Hquery.Internal.Error,+                   Text.Hquery.Internal.Transform+  ghc-options: -Wall+  extensions: FlexibleInstances++test-suite TransformTests+  hs-source-dirs: tests+  main-is: TransformTests.hs+  type: exitcode-stdio-1.0+  build-depends: base ==4.5.*, hquery >= 0.1.0.0, xmlhtml >= 0.2.0.3, HUnit,+                 filepath >= 1.3.0.0, bytestring >= 0.9.2.1, test-framework,+                 test-framework-hunit+  extensions: DeriveDataTypeable++test-suite ParserTests+  hs-source-dirs: tests+  main-is: ParserTests.hs+  type: exitcode-stdio-1.0+  build-depends: base ==4.5.*, hquery >= 0.1.0.0, HUnit, test-framework,+                 test-framework-hunit, parsec >= 3.1++test-suite UtilsTests+  hs-source-dirs: tests+  main-is: UtilsTests.hs+  type: exitcode-stdio-1.0+  build-depends: base ==4.5.*, hquery >= 0.1.0.0, HUnit, test-framework,+                 test-framework-hunit, xmlhtml >= 0.2.0.3, text >= 0.11.2.3
+ src/Text/Hquery.hs view
@@ -0,0 +1,128 @@+{- | This module exports the top level constructors+used for building node transformations.+For example, if your template is++> <div class="person">+>   <div class="name"></div>+>   <div class="occupation"></div>+> </div>++and you invoke hquery like this:++> import Text.Hquery+> template = ... -- parse your template here+> people = [ ("Justin Bieber", "Celebrity")+>          , ("Jens Kidman", "Musician")+>          ]+> bindPerson (n, o) = hq ".name *" n . hq ".occupation *" o+> f = hq ".person *" $ map bindPerson people+> f template++you'll get markup like this:++> <div class="person">+>   <div class="name">Justin Bieber</div>+>   <div class="occupation">Celebrity</div>+> </div>+> <div class="person">+>   <div class="name">Jens Kidman</div>+>   <div class="occupation">Musician</div>+> </div>++You can also add, remove, and append to element attributes. For example if we+have: @ \<div class=\"foo\"\>\</div\> @, below are some example+transformations:++  * @ hq \"div [class+]\" \"hidden\" @ gives @ \<div class=\"foo hidden\"\>\</div\> @++  * @ hq \".foo [id]\" \"bar\" @ gives @ \<div id=\"bar\" class=\"foo\"\>\</div\> @++  * @ hq \"* [class!]\" \"foo\" @ gives @ \<div\>\</div\> @++This module exports several constructors for common types of node+transformations. These constructors simply give you back a @ 'Node' -> 'Node'+@, which you can then apply however you choose.+-}++module Text.Hquery (+  -- * Constructors+  MakeTransformer(..)+  ) where++import Data.List+import Data.Maybe++import qualified Data.Text as T+import Text.Parsec+import Text.XmlHtml+import Text.XmlHtml.Cursor+import Text.Hquery.Internal.Error+import Text.Hquery.Internal.Selector+import Text.Hquery.Internal.Transform++parseSel :: String ->+            (Maybe AttrSel -> Cursor -> Cursor) ->+            [Node] ->+            [Node]+parseSel sel builder = case parse commandParser "" sel of+  Left _ -> id -- TODO: error handling? invalid sel+  Right (css, attr) -> transform css (builder attr)++class MakeTransformer a where+  hq :: String -> a -> [Node] -> [Node]++instance MakeTransformer String where+  hq sel target = parseSel sel nodeXform+    where+      nodeXform attr c = case (attr, current c) of+        (Just CData, e @ Element {}) -> setNode (e { elementChildren = [TextNode (T.pack target)] }) c+        -- the non-Element case isn't relevant here, since we can't match non-Elements+        (Just s, _) -> buildAttrMod s (T.pack target) c+        (Nothing, _) -> (setNode (TextNode (T.pack target))) c++instance MakeTransformer [String] where+  hq sel xs = hq sel (map (TextNode . T.pack) xs)++instance MakeTransformer Node where+  hq sel target = hq sel [target]++instance MakeTransformer ([Node] -> [Node]) where+  hq sel f = hq sel [f]++instance MakeTransformer [[Node] -> [Node]] where+  hq sel fs = parseSel sel (\_ -> replicateAndApply)+    where+      replicateAndApply c = let n = (current c)+                                ns = concat $ fmap ($[n]) fs+                            in replaceCurrent ns c++instance MakeTransformer [Node] where+  hq sel ns = parseSel sel buildNodesXform+    where+      buildNodesXform (Just CData) = replicateNode+      buildNodesXform (Just _) = id -- TODO: error handling? can't insert nodes in an attr+      buildNodesXform Nothing = replaceCurrent(ns)+      replicateNode :: Cursor -> Cursor+      replicateNode c = let n = (current c) in+        case n of+          e @ Element {} ->+            let replicated = map (\x -> e { elementChildren = [x] }) ns+            in replaceCurrent replicated c+          _ -> raise "bug: shouldn't be replicating on a non-Element node"++replaceCurrent :: [Node] -> Cursor -> Cursor+replaceCurrent ns c = fromMaybe dflt $ do+  p <- parent c+  case current p of+    pn@Element { elementChildren = kids } -> do+      ix <- elemIndex curN kids+      let next = setNode (pn { elementChildren = concatMap replaceN kids }) p+      getChild (ix - 1 + (length ns)) next+    _ -> raise "should be no non-Element parents!"+  where+    curN = current c+    replaceN n2 = if n2 == curN then ns else [n2]+    dflt = fromMaybe c $ do+      newCur <- (fromNodes ns)+      endCur <- findRight isLast newCur+      return endCur
+ src/Text/Hquery/Internal/Error.hs view
@@ -0,0 +1,16 @@+-- | NOTE: This exception should only be used to indicate an Hquery bug.+{-# LANGUAGE DeriveDataTypeable #-}+module Text.Hquery.Internal.Error where++import Control.Exception+import Data.Typeable++data HqueryInternalException = HqueryInternalException String+  deriving (Show, Typeable)+instance Exception HqueryInternalException++-- | Unconditionally throw an HqueryInternalException with the specified error+-- message. This should not be used for user errors, just internal hquery+-- errors.+raise :: String -> a+raise = throw . HqueryInternalException
+ src/Text/Hquery/Internal/Selector.hs view
@@ -0,0 +1,71 @@+-- | ADTs for representing what node operations to perform, and their parsers.+module Text.Hquery.Internal.Selector (+  -- * Types+  AttrMod(..),+  AttrSel(..),+  CssSel(..),++  -- * Parsers+  attrModParser,+  attrSelParser,+  cssSelParser,+  commandParser+  ) where++import Data.Text+import Text.Parsec hiding (many, optional, (<|>))+import Text.Parsec.String+import Text.Parsec.Token+import Text.Parsec.Language++import Control.Applicative++data AttrMod = Remove | Append | Set deriving (Show, Eq)++data AttrSel =+  AttrSel Text AttrMod |+  CData+  deriving (Show, Eq)++data CssSel =+  Id Text |+  Name Text |+  Class Text |+  Attr Text Text |  -- [first=second], special cases for name, id?+  Elem Text |+  Star+  deriving (Show, Eq)++m_identifier :: Parser String+rop :: String -> Parser ()+TokenParser{ identifier = m_identifier+           , reservedOp = rop+           } = makeTokenParser emptyDef{ identStart = letter+                                       , identLetter = alphaNum+                                       }++idp :: Parser Text+idp = pack <$> m_identifier++attrModParser :: Parser AttrMod+attrModParser = option Set $+      (Append <$ rop "+")+  <|> (Remove <$ rop "!")++attrSelParser :: Parser (Maybe AttrSel)+attrSelParser = optionMaybe selParser+  where+    selParser :: Parser AttrSel+    selParser =+          AttrSel <$> (rop "[" *> idp) <*> attrModParser <* rop "]"+      <|> CData <$ rop "*"++cssSelParser :: Parser CssSel+cssSelParser = Class <$> (rop "." *> idp)+           <|> Id <$> (rop "#" *> idp)+           <|> Attr <$> (rop "[" *> idp) <*> (rop "=" *> idp <* rop "]")+           <|> Star <$ rop "*"+           <|> Elem <$> idp++commandParser :: Parser (CssSel, Maybe AttrSel)+commandParser = (,) <$> (cssSelParser <* spaces) <*> attrSelParser
+ src/Text/Hquery/Internal/Transform.hs view
@@ -0,0 +1,67 @@+-- | This module contains all of the actual tree traversal/matching code.+{-# LANGUAGE OverloadedStrings #-}+module Text.Hquery.Internal.Transform where++import qualified Data.Text as T+import Data.List+import Data.Maybe+import Text.XmlHtml+import Text.XmlHtml.Cursor++import Control.Monad++import Text.Hquery.Internal.Error+import Text.Hquery.Internal.Selector++buildAttrMod :: AttrSel -> T.Text -> Cursor -> Cursor+buildAttrMod (AttrSel name attrMod) value cur = do+  let att = maybe "" id (getAttribute name (current cur))+  let remove n = case n of+                 Element { elementTag = tag+                         , elementAttrs = attrs+                         , elementChildren = kids+                         }+                   -> Element { elementTag = tag+                              , elementAttrs = filter ((name /=) . fst) attrs+                              , elementChildren = kids+                              }+                 _ -> n+  let f = case attrMod of+            Set -> setAttribute name (value)+            Remove | name == "class" -> do+              let classes = T.words value+              let without = filter ((flip notElem) classes) (T.words att)+              let result = T.intercalate "" without+              if T.null result+                then remove+                else setAttribute name result+            Remove -> remove+            Append | name == "class" -> do+              let classes = value : (T.words att)+              setAttribute name (T.unwords classes)+            Append -> setAttribute name (T.append att value)+  modifyNode f cur+buildAttrMod CData _ _ = (raise "shouldn't be attr-modding a CData")++transform :: CssSel -> (Cursor -> Cursor) -> [Node] -> [Node]+transform sel f roots =+  fromMaybe [] $ liftM (\c -> topNodes (transformR c)) (fromNodes roots)+  where+    transformR cur = do+      let result = process cur+      maybe result transformR (nextDF result)+    process cur = do+      let node = current cur+      let matchAttr attr pred_ = case getAttribute attr node of+                                   Just value | pred_ value -> f cur+                                   _ -> cur+      case sel of+        Id name -> matchAttr "id" ((==) name)+        Name name -> matchAttr "name" ((==) name)+        Class name -> matchAttr "class" (\x -> isInfixOf [name] (T.words x))+        Attr key value -> matchAttr key ((==) value)+        Elem name ->+          case tagName node of+            Just id_ | id_ == name -> f cur+            _ -> cur+        Star -> f cur
+ src/Text/Hquery/Utils.hs view
@@ -0,0 +1,78 @@+-- | This module exports various useful utility functions for working with+-- XmlHtml Nodes. For example, the equality operator on Node does a structural+-- comparison of the nodes. However, this is not entirely useful, since+-- transformed nodes may be equal but e.g. have their attributes in a different+-- order in the list. Among other things, this module defines an EqNode type+-- which has an Eq instance that does semantic equality instead of structural+-- equality.+{-# LANGUAGE OverloadedStrings #-}+module Text.Hquery.Utils (+  -- * Types+  EqNode(..),++  -- * Functions+  -- ** Equality+  attrsEq,+  nodeEq,++  -- ** Utility+  stripWhitespaceNodes+  ) where++import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text as T+import Text.XmlHtml+import Data.Maybe++newtype EqNode = EqNode Node deriving Show+instance Eq (EqNode) where+  (EqNode n1) == (EqNode n2) = nodeEq n1 n2++-- | Test a list of attributes for equality. This has special handling for the+-- "class" attribute, so that the order in which the classes are applied to the+-- node doesn't matter. Additionally, the oder of the attributes in either list+-- is also ignored.+attrsEq :: [(T.Text, T.Text)] -> [(T.Text, T.Text)] -> Bool+attrsEq attrs1 attrs2 = do+  let (m1, class1) = mapNoClass attrs1+  let (m2, class2) = mapNoClass attrs2+  m1 == m2 && classEq class1 class2+  where+    mapNoClass xs = do+      let m = Map.fromList xs+      (Map.delete "class" m, Map.lookup "class" m)+    classEq Nothing Nothing = True+    classEq (Just class1) (Just class2) = do+      let s1 = Set.fromList (T.words class1)+      let s2 = Set.fromList (T.words class2)+      s1 == s2+    classEq _ _ = False++-- | A top level semantic node equality funciton.+nodeEq :: Node -> Node -> Bool+nodeEq (TextNode t1) (TextNode t2) = t1 == t2+nodeEq (Comment t1) (Comment t2) = t1 == t2+nodeEq Element { elementTag = tag1+               , elementAttrs = attrs1+               , elementChildren = kids1+               }+       Element { elementTag = tag2+               , elementAttrs = attrs2+               , elementChildren = kids2+               }+       = tag1 == tag2+       && attrsEq attrs1 attrs2+       && length kids1 == length kids2+       && all (uncurry nodeEq) (zip kids1 kids2)+nodeEq _ _ = False++-- | Strip nodes that contain only whitespace. This can be useful when doing+-- equality comparisons of trees (e.g. in testing). XmlHtml keeps all+-- whitespace, which can cause structural equality differences in trees which+-- were produced programattically vs. hand written and nicely formatted trees.+stripWhitespaceNodes :: Node -> Maybe Node+stripWhitespaceNodes (TextNode t1) | T.null (T.strip (t1)) = Nothing+stripWhitespaceNodes e @ Element { elementChildren = kids } =+  Just (e { elementChildren = mapMaybe stripWhitespaceNodes kids })+stripWhitespaceNodes x = Just x
+ tests/ParserTests.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import Test.Framework ( defaultMain, Test )+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test)++import Text.Parsec+import Text.Parsec.Error++import Text.Hquery+import Text.Hquery.Utils+import Text.Hquery.Internal.Selector++tests :: [(String, (CssSel, Maybe AttrSel))]+tests = [ ("div", (Elem "div", Nothing))+        , (".elt", (Class "elt", Nothing))+        , (".elt *", (Class "elt", Just CData))+        , (".elt [class+]", (Class "elt", Just $ AttrSel "class" Append))+        , (".elt [class]", (Class "elt", Just $ AttrSel "class" Set))+        ]++makeTest :: (String, (CssSel, Maybe AttrSel)) -> Test+makeTest (sel, expected) = do+  let errorToString e = Left (unwords (map messageString (errorMessages e)))+      result = either errorToString Right (parse commandParser "" sel)+  testCase sel (assertEqual sel (Right expected) result)++main :: IO ()+main = defaultMain (map makeTest tests)
+ tests/TransformTests.hs view
@@ -0,0 +1,79 @@+module Main (main) where++import Control.Exception+import Data.Typeable+import Data.Maybe+import qualified Data.ByteString.Char8 as BS+import Test.HUnit hiding (Node, Test)+import Text.XmlHtml++import Test.Framework ( defaultMain, Test )+import Test.Framework.Providers.HUnit++import System.FilePath++import Text.Hquery+import Text.Hquery.Utils++data TestException = TestException String deriving (Show, Typeable)+instance Exception TestException++peopleTest :: [Node] -> [Node]+peopleTest =+  let people = [ ("Bob", "Engineer")+               , ("Sally", "CEO")+               , ("Rutherford", "Hacker")+               , ("Vikki", "Hybrid")+               ]+      bind (name, occupation) =+        hq ".name *" name . hq ".occupation *" occupation++  in hq ".person" (map bind people)++tests :: [([Node] -> [Node], String)]+tests = [ (hq "#foo [class+]" "bar", "AddClass")+        , (hq "div [class+]" "bar", "AddClass")+        , (hq "div [class!]" "baz", "RemoveClass")+        , (hq ".bar [class!]" "baz", "RemoveClass")+        , (hq "#foo [id!]" "baz", "RemoveId")+        , (hq ".foo *" "bar", "PopulateString")+        , (hq ".elt *" ["one", "two", "three"], "PopulateList")+        , (hq "thisshouldnotmatch" "", "Noop")+        , (hq "div [class+]" "bar", "AppendClass")+        , ( (hq ".name *" "Aaron Swartz") . (hq ".address *" "aaronsw@example.com")+          , "BasicComposition"+          )+        , (peopleTest, "PeopleOccupations")+        , (hq ".foo *" "bar", "NestXform")+        , (hq ".foo" "bar", "NestReplace")+        ]++makeTests :: [([Node] -> [Node], String)] -> IO [Test]+makeTests xs = mapM makeTest xs+  where+    readInputAndExpected :: String -> IO (String, String)+    readInputAndExpected name = do+      let path = ("tests/markup/" ++ name ++ ".html")+      inp <- readFile path+      exp <- readFile (path <.> "expected")+      return (inp, exp)+    makeTest (f, testName) = do+      (inp, exp) <- readInputAndExpected testName+      let parsedInp = toHTML (testName ++ " input") inp+      let parsedExp = toHTML (testName ++ " expected") exp+      let result = comparable (f parsedInp)+      let expected = comparable parsedExp+      return (testCase testName (assertEqual testName expected result))+      where+        comparable ns = map EqNode $ catMaybes (map stripWhitespaceNodes ns)+        docToNode doc = case doc of+                          HtmlDocument { docContent = content } -> content+                          _ -> throw (TestException (testName ++ "'s inp/exp is not a single node" ++ show doc))+        toHTML name inp = do+          let result = parseHTML name (BS.pack inp)+          either (throw . TestException) docToNode result++main :: IO ()+main = do+  toRun <- makeTests (tests)+  defaultMain toRun
+ tests/UtilsTests.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import qualified Data.Text as T++import Test.Framework ( defaultMain, Test )+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Node, Test)++import Text.Hquery+import Text.Hquery.Utils++import Text.XmlHtml++elt :: T.Text -> [(T.Text, T.Text)] -> [Node] -> Node+elt tag attrs kids = Element { elementTag = tag+                             , elementAttrs = attrs+                             , elementChildren = kids+                             }++mkDiv :: [Node] -> Node+mkDiv = elt "div" []++nodeEqTests :: [(Node, Node, Bool)]+nodeEqTests = [ (TextNode "foo", TextNode "foo", True)+              , (Comment "foo", Comment "foo", True)+              , (TextNode "foo", TextNode "bar", False)+              , (Comment "foo", Comment "bar", False)+              , (TextNode "foo", Comment "foo", False)+              , (mkDiv [TextNode "foo"], mkDiv [TextNode "foo"], True)+              , (mkDiv [TextNode "bar"], mkDiv [TextNode "foo"], False)+              , (mkDiv [mkDiv []], mkDiv [mkDiv []], True)+              , (mkDiv [mkDiv [TextNode "foo"]], mkDiv [mkDiv [TextNode "bar"]], False)+              , (mkDiv [mkDiv [TextNode "foo"]], mkDiv [], False)+              ]++main :: IO ()+main =+  let makeEqNodeTest (n1, n2, t) =+        let eq1 = EqNode n1+            eq2 = EqNode n2+            str = (show n1) ++ " == " ++ (show n2)+        in testCase "nodeEqTestcase" (assertEqual str t (eq1 == eq2))+      nodeTests = map makeEqNodeTest nodeEqTests+  in defaultMain nodeTests