packages feed

html-rules (empty) → 0.1.0.0

raw patch · 10 files changed

+788/−0 lines, 10 filesdep +basedep +lensdep +mtlsetup-changed

Dependencies added: base, lens, mtl, tagsoup, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, ???++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of ??? nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ html-rules.cabal view
@@ -0,0 +1,38 @@++name:                html-rules+version:             0.1.0.0+synopsis:            Perform traversals of HTML structures using sets of rules.+description:         +license:             BSD3+license-file:        LICENSE+author:              Kyle Carter+maintainer:          Kyle Carter <kcarter@galois.com>+copyright:           (c) Kyle Carter 2014, All rights reserved+category:            HTML, Web, Text, Transformation+build-type:          Simple+-- extra-source-files:  +cabal-version:       >=1.10++library+  exposed-modules:     Text.HTML.Rules+                       ----+                       Text.HTML.Rules.Types+                       Text.HTML.Rules.Apply+                       ----+                       Text.HTML.Rules.Query+                       ----+                       Text.HTML.Rules.Transform+                       Text.HTML.Rules.Attributes+                       ----+                       Text.HTML.Rules.Util+  -- other-modules:       +  -- other-extensions:    +  build-depends:       base >=2 && < 5,+                       lens >=4 && < 5,+                       tagsoup >= 0.13,+                       transformers >=0.2 && <0.4,+                       mtl >=2 && <3+  hs-source-dirs:      src+  default-language:    Haskell2010+  ghc-options:         -Wall -fno-warn-unused-do-bind+
+ src/Text/HTML/Rules.hs view
@@ -0,0 +1,96 @@+{-# OPTIONS_HADDOCK show-extensions #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Rank2Types #-}++{-|+Module      : Text.HTML.Rules+Description : Transform an HTML structure by sets of rules.+Copyright   : (c) Kyle Carter, 2014+License     : BSD3+Maintainer  : kylcarte@gmail.com+Stability   : experimental+-}++module Text.HTML.Rules+  ( module Text.HTML.Rules+  , module Text.HTML.Rules.Types+  , module Text.HTML.Rules.Apply+  , module Text.HTML.Rules.Query+  , module Text.HTML.Rules.Transform+  , module Text.HTML.Rules.Attributes+  ) where++import Text.HTML.Rules.Types+import Text.HTML.Rules.Apply+import Text.HTML.Rules.Query+import Text.HTML.Rules.Transform+import Text.HTML.Rules.Attributes++import Control.Applicative hiding (optional)+import Control.Monad (forM_)+import Data.Maybe (fromMaybe)++-- * Example++-- | an example set of rules.+testRules :: (Applicative m, Monad m) => [FragmentRule m]+testRules =+  [ ( tag "row"                           -- <- match tags with the 'row' name.+    , one $ do                            -- <- return a single fragment of HTML.+      _Tag   *-> "div"                    -- <- replace the tag name with 'div'.+      _Attrs $-> addClass "row"           -- <- add 'row' to the list of classes,+                                          --    keeping all existing attributes.+    )+  ------------------------------------------------------------------------------+  , ( tag "col"                           -- <- match 'col' tags.+    , one $ do                            --+      _Tag   *-> "div"                    --+      _Attrs $-> do                       --+        w  <- required $ _Attr "width"    -- <- pull out the 'width' attribute,+                                          --    failing if it isn't present.+        ms <- optional $ _Attr "size"     -- <- pull out the 'size' attribute,+                                          --    if it is present.+        addClass $ concat                 -- <- add a Bootstrap-friendly+                                          --    class, e.g. 'col-md-3'.+          [ "col-"+          , fromMaybe "xs" ms+          , "-"+          , w+          ]+    )+  ------------------------------------------------------------------------------+  , ( tags ["ol","ul"]                    -- <- match tags with either the 'ol'+    , one $ do                            --    or 'ul' name.+      _Attrs $-> addClass "list-unstyled" -- <- add 'list-unstyled' to its list+    )                                     --    of classes.+  ------------------------------------------------------------------------------+  , ( tag "expand"                        -- <- match 'expand' tags.+    , onEach (_Attrs $-> addClass "bar")  -- <- add 'bar' to the list of classes+      $ return                            --    of each of the following:+      [ Leaf "expanded" [("class","foo")] --  * a leaf tag, with no descendents,+      , Branch "expanded-also" []         --  * a branch tag, with one descendent,+        [ Leaf "yet-another" []           --+        ]                                 --+      , Text "some text"                  --  * a text node.+      ]+    )+  ]++runTestExamples :: IO ()+runTestExamples = do+  putStrLn "Examples:\n"+  forM_ examples $ \s -> do+    s' <- applyHTMLRules testRules s+    putStrLn $ unlines [ s , "===>" , s' ]++examples :: [String]+examples =+  [ "<row>some text</row>"+  , "just some text"+  , "<row><col width=\"3\">nested</col>a bit more text</row>"+  , "<expand class=\"these get lost in expansion\">"+  ]+
+ src/Text/HTML/Rules/Apply.hs view
@@ -0,0 +1,106 @@+{-# OPTIONS_HADDOCK show-extensions #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Rank2Types #-}++{-|+Module      : Text.HTML.Rules.Apply+Description : Functions for applying sets of rules.+Copyright   : (c) Kyle Carter, 2014+License     : BSD3+Maintainer  : kylcarte@gmail.com+Stability   : experimental+-}++module Text.HTML.Rules.Apply+  ( _HTML+  , onHTML+  , applyHTMLRules+  , applyHTMLRules'+  , htmlRules+  , htmlRules'+  , joinRules+  , rule+  ) where++import Text.HTML.Rules.Transform+import Text.HTML.Rules.Types+import Text.HTML.Rules.Util++import Control.Lens+import Control.Applicative hiding (optional)+import Control.Monad.State++import Text.HTML.TagSoup hiding (Tag)+import Text.HTML.TagSoup.Tree+++-- | a parsing/rendering Isomorphism.+_HTML :: Iso' String HTML+_HTML = iso (tagTree . parseTags) (renderTags . flattenTree)++-- | a traversal over HTML under parsing+onHTML :: Functor m => (HTML -> m HTML) -> String -> m String+onHTML = traverseOf _HTML++-- | apply all rules, left to right, bottom up.+applyHTMLRules :: (Applicative m, Monad m) => [FragmentRule m] -> String -> m String+applyHTMLRules = traverseOf _HTML . htmlRules++-- | appy all rules, left to right, top down.+applyHTMLRules' :: (Applicative m, Monad m) => [FragmentRule m] -> String -> m String+applyHTMLRules' = traverseOf _HTML . htmlRules'++{-+-- | apply all rules, left to right, bottom up.+applyRules :: (Functor m, Monad m) => Iso s t a b -> [Rule m a b] -> s -> m t+applyRules l = traverseOf l . rules_XXX++-- | appy all rules, left to right, top down.+applyRules' :: (Applicative m, Monad m) => Iso s t a b -> [Rule m a b] -> s -> m t+applyRules' l = traverseOf l . rules_XXX++rules_XXX :: Monad m => [Rule m a b] -> a -> m b+rules_XXX = undefined+-}++-- | form a bottom-up traversal from a list of 'Rule's+htmlRules :: (Applicative m, Monad m) => [FragmentRule m] -> HTML -> m HTML+htmlRules (joinRules -> go) = (concat <$<) $ mapM $ \t ->+  case t of+    TagBranch _ _ ds -> do+      ds' <- go ds+      go1 $ t & _Desc .~ ds'+    TagLeaf _ -> go1 t+  where+  go1 = go . one_++-- | form a top-down traversal from a list of 'Rule's+htmlRules' :: (Applicative m, Monad m) => [FragmentRule m] -> HTML -> m HTML+htmlRules' (joinRules -> go) = (concat <$<) $ mapM $ \t ->+  case t of+    TagBranch {} -> mapM (traverseOf _Desc go) =<< go1 t+    TagLeaf   {} -> go1 t+  where+  go1 = go . one_++-- | join a list of 'Rule's into a traversal, left to right.+joinRules :: (Applicative m, Monad m) => [FragmentRule m] -> HTML -> m HTML+joinRules = concatEndo . map rule++-- | make a traversal out of a single 'Rule'.+-- the 'Trans'formation is applied iff the query predicate holds.+rule :: (Applicative m, Monad m) => FragmentRule m -> HTML -> m HTML+rule (q,m) = mapM go >$> concat+  where+  go x = do+    b <- q x+    if b then evalStateT m x+         else return [x]++{-+  | q x  = evalStateT m x+       | True = return [x]+-}+
+ src/Text/HTML/Rules/Attributes.hs view
@@ -0,0 +1,58 @@+{-# OPTIONS_HADDOCK show-extensions #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Rank2Types #-}++{-|+Module      : Text.HTML.Rules.Attributes+Description : Transform an HTML structure by sets of rules.+Copyright   : (c) Kyle Carter, 2014+License     : BSD3+Maintainer  : kylcarte@gmail.com+Stability   : experimental+-}++module Text.HTML.Rules.Attributes where++import Text.HTML.Rules.Types+import Text.HTML.Rules.Transform++-- | add a single attribute key-value pair to a tag's attributes.+addAttr :: Monad m => (AttrKey,AttrVal) -> Trans' m Attrs+addAttr = with (:)++-- | add multiple attributes at once.+addAttrs :: Monad m => Attrs -> Trans' m Attrs+addAttrs = with (++)++-- | add an additional class value if the 'class' attribute is already+-- present, or just the given value if it is absent.+addClass :: Monad m => AttrVal -> Trans' m Attrs+addClass c' = insertAttr "class" $ maybe c' (++ " " ++ c')++-- | operate on an attribute's presence or absence.+alterAttr :: Monad m => AttrKey -> (Maybe AttrVal -> Maybe AttrVal) -> Trans' m Attrs+alterAttr k = alterOf (_Attr k) . mkAttr k++-- | add an attribute that may or may not already be present.+insertAttr :: Monad m => AttrKey -> (Maybe AttrVal -> AttrVal) -> Trans' m Attrs+insertAttr k = insertOf (_Attr k) . mkAttr' k++-- | update the value of an attribute, if it is present.+-- does nothing if the attribute is absent.+updateAttr :: Monad m => AttrKey -> (AttrVal -> AttrVal) -> Trans' m Attrs+updateAttr k = updateOf (_Attr k) . mkAttr' k++-- | either modify or remove an attribute, if it is present.+-- does nothing if otherwise.+adjustAttr :: Monad m => AttrKey -> (AttrVal -> Maybe AttrVal) -> Trans' m Attrs+adjustAttr k = adjustOf (_Attr k) . mkAttr k++mkAttr :: Functor f => AttrKey -> (a -> f AttrVal) -> a -> f (AttrKey, AttrVal)+mkAttr k = (.) $ fmap ((,) k)++mkAttr' :: AttrKey -> (a -> AttrVal) -> a -> (AttrKey, AttrVal)+mkAttr' k = ((,) k .)+
+ src/Text/HTML/Rules/Query.hs view
@@ -0,0 +1,88 @@+{-# OPTIONS_HADDOCK show-extensions #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Rank2Types #-}++{-|+Module      : Text.HTML.Rules.Query+Description : Transform an HTML structure by sets of rules.+Copyright   : (c) Kyle Carter, 2014+License     : BSD3+Maintainer  : kylcarte@gmail.com+Stability   : experimental+-}++module Text.HTML.Rules.Query where++import Text.HTML.Rules.Types+import Text.HTML.Rules.Util++import Control.Applicative hiding (optional)+import Data.List+import Data.Maybe++-- * Attribute-Specific Queries++-- | match any of the given 'Name's.+tags :: Applicative m => [Name] -> FragmentQuery m+tags = or_ . map tag+{-# INLINE tags #-}++-- | match a 'Name'.+tag :: Applicative m => Name -> FragmentQuery m+tag t = pure . \case+  Branch tg _ _ -> t == tg+  Leaf   tg _   -> t == tg+  _             -> False++-- | match a 'Text' node.+isText :: Applicative m => FragmentQuery m+isText = pure . \case+  Text _ -> True+  _      -> False++-- | match all nodes with a particular Attribute.+hasAttr :: Applicative m => AttrKey -> FragmentQuery m+hasAttr a = pure . \case+  Branch _ (yes -> r) _ -> isJust r+  Leaf   _ (yes -> r)   -> isJust r+  _                     -> False+  where+  yes = find ((== a) . fst)++-- * General Combinators++true, false :: Applicative m => Query m a+-- | always matches.+true  = pure2 True+-- | always fails.+false = pure2 False++-- ** Lifted Operations++-- | logical disjunction of 'Query's.+(.||.) :: Applicative m => Query m a -> Query m a -> Query m a+(.||.) = liftAA2 (||)+infixr 2 .||.++-- | logical disjunction of a list of 'Query's.+or_ :: Applicative m => [Query m a] -> Query m a+or_ = foldr (.||.) false+{-# INLINE or_ #-}++-- | logical conjunction of 'Query's.+(.&&.) :: Applicative m => Query m a -> Query m a -> Query m a+(.&&.) = liftAA2 (&&)+infixr 3 .&&.++-- | logical conjunction of a list of 'Query's.+and_ :: Applicative m => [Query m a] -> Query m a+and_ = foldr (.&&.) true+{-# INLINE and_ #-}++-- | negate the result of a 'Query'.+not_ :: Applicative m => Query m a -> Query m a+not_ = liftAA not+
+ src/Text/HTML/Rules/Transform.hs view
@@ -0,0 +1,224 @@+{-# OPTIONS_HADDOCK show-extensions #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Rank2Types #-}++{-|+Module      : Text.HTML.Rules.Transform+Description : Transform an HTML structure by sets of rules.+Copyright   : (c) Kyle Carter, 2014+License     : BSD3+Maintainer  : kylcarte@gmail.com+Stability   : experimental+-}++module Text.HTML.Rules.Transform where++import Text.HTML.Rules.Types+import Text.HTML.Rules.Util++import Control.Lens+import Control.Lens.Internal.Context+import Control.Arrow (first)+import Control.Monad.Trans.Class+import Control.Monad.State+import Data.List+import Data.Maybe+++-- * Transformations+-- {{{++-- ** Prisms and Traversals+-- {{{++-- | A pattern match onto an opening @Tag@.+_Open :: Prism' Fragment (Name,Attrs,Maybe Desc)+_Open = prism'+  (\(tg,as,mds) -> maybe (Leaf tg as) (Branch tg as) mds)+  (\case+    Branch tg as ds -> Just (tg,as,Just ds)+    Leaf   tg as    -> Just (tg,as,Nothing)+    _               -> Nothing)++-- | A pattern match onto a text @Tag@.+_Text :: Prism' Fragment String+_Text = prism' Text $+  \case+    Text s -> Just s+    _      -> Nothing++-- | A traversal to a @Tag@'s name.+_Tag :: Traversal' Fragment Name+_Tag = _Open . _1++-- | A traversal to a @Tag@'s Attributes.+_Attrs :: Traversal' Fragment Attrs+_Attrs = _Open . _2++-- | A traversal to a @Tag@'s descendents.+_Desc :: Traversal' Fragment Desc+_Desc = _Open . _3 . _Just++-- | A refining traversal to a particular attribute+-- in a list of attributes.+--+-- A refining traversal is one that additionally gives the+-- unmatched values. Used with 'on', this gives a stateful+-- filtering, so that matched Attributes are removed by default+-- from the attribute list.+_Attr :: AttrKey -> Lens Attrs Attrs (Maybe AttrVal,Attrs) Attrs+_Attr k = lens to_ from_+  where+  from_  = (++)+  to_ as = case ys of+    [(_,v)] -> (Just v  , ns)+    _       -> (Nothing , as)+    where+    (ys,ns) = partition ((== k) . fst) as++-- | give the first attribute satisfying some predicate. All other matching attributes+-- are dropped from the list.+_AttrWhere :: ((AttrKey,AttrVal) -> Bool) -> Traversal Attrs Attrs (Maybe (AttrKey,AttrVal),Attrs) Attrs+_AttrWhere pr = _Partition pr . travPre (first listToMaybe)++-- | give all attributes satisfying some predicate. The attribute list is refined+-- to only the non-matching attributes.+_AttrsWhere :: ((AttrKey,AttrVal) -> Bool) -> Traversal Attrs Attrs (Attrs,Attrs) Attrs+_AttrsWhere = _Partition++-- | give the first item from a list that satisfies a predicate. All other matches are+-- kept in the list, along with the non-matching items.+_First :: (a -> Bool) -> Traversal [a] b (Maybe a,[a]) b+_First pr = travPre $ \as ->+  let (ys,ns) = partition pr as+  in case ys of+    y : ys' -> (Just y  , ys' ++ ns)+    _       -> (Nothing , as)++-- | partition a list by a predicate. The satisfying items are given, and the others+-- are kept in the list.+_Partition :: (a -> Bool) -> Traversal [a] b ([a],[a]) b+_Partition = travPre . partition++-- }}}++-- ** Traversal Construction+-- {{{++-- | build a traversal from an 'in' and an 'out' function. Analogous to "Data.Profunctor"'s @dimap@+trav :: (s -> a) -> (b -> t) -> Traversal s t a b+trav in_ out_ = (. in_) . (fmap out_ .)+{-# INLINE trav #-}++-- | build a traversal that only operates going in. Analogous to "Data.Profunctor"'s @lmap@.+travPre  :: (s -> a) -> Traversal s t a t+travPre = flip trav id+{-# INLINE travPre #-}++-- | build a traversal that only operates going out. Analogous to "Data.Profunctor"'s @rmap@.+travPost :: (b -> t) -> Traversal s t s b+travPost = trav id+{-# INLINE travPost #-}++-- | alter a 'Trans'formation to forget the refined state that it was+-- carrying around.+forget :: ATraversal s t (a,u) b -> Traversal s t a b+forget f = cloneTraversal $ \g s -> runBazaar (f sell s) $ g . fst++-- | pass the initial @s@ as the refined state.+remember :: ATraversal s t a b -> Traversal s t (a,s) b+remember = modifyBy id++-- | refine the state by a given function.+modifyBy :: (s -> u) -> ATraversal s t a b -> Traversal s t (a,u) b+modifyBy f l = cloneTraversal $ \g s -> runBazaar (l sell s) $ g . flip (,) (f s)++-- }}}++-- ** Combinators+-- {{{++-- | lift an operation on one thing to an operation resulting in a list containing+-- only the one thing.+one :: Monad m => Trans m a b -> Trans m a [b]+one = (>>$ one_)++-- | perform a sub-'Trans'formation over each item resulting from+-- a higher 'Trans'formation. Essentially composition, with a resulting+-- list.+onEach :: Monad m => Trans m b c -> Trans m a [b] -> Trans m a [c]+onEach bc = (>>= mapM (lift . evalStateT bc))++-- | embed a sub-'Trans'formation into a larger context using a traversal.+-- viewing the state @s@ with the traversal provides the initial state+-- of the sub-'Trans'formation, and the resulting value is used to alter the+-- higher state, using 'set'.+on :: Monad m => Traversal s s a b -> Trans m a b -> Trans' m s+on l m = do+  s <- get+  case s ^? coerced l of+    Just a -> do+      b <- lift $ evalStateT m a+      with (set l) b+    _ -> return s++-- | fold a value into the state using some given function.+with :: Monad m => (a -> s -> s) -> a -> Trans' m s+with f a = state $ \s -> let s' = f a s in (s',s')+{-# INLINE with #-}++-- | shorthand for 'on'.+($->) :: Monad m => Traversal s s a b -> Trans m a b -> Trans' m s+($->) = on+infixr 0 $->++-- | return a pure value to 'on'.+(*->) :: Monad m => Traversal s s a b -> b -> Trans' m s+l *-> b = l $-> return b+infixr 0 *->++-- | pull out an item from a traversal of the 'Trans'formation's state.+-- fails if the traversal has no target.+required :: Monad m => Traversal s t (Maybe a,s) b -> Trans m s a+required l = optional l >>= \case+  Just a -> return a+  _      -> fail "required: No content in traversal"++-- | pull out an item from a traversal of the 'Trans'formation's state.+-- returns 'Just' the item if the traversal has a target, or+-- 'Nothing' if not.+optional :: Monad m => Traversal s t (Maybe a,s) b -> Trans m s (Maybe a)+optional l = do+  s <- get+  case s ^? coerced l of+    Just (a,s') -> put s' >> return a+    _           -> return Nothing++-- }}}++-- }}}++-- * Combinators+-- {{{++alterOf :: (Cons s s c c, Monad m) => Traversal s t (Maybe a,s) b -> (Maybe a -> Maybe c) -> Trans' m s+alterOf l f = do+  mv <- optional l+  case f mv of+    Just v -> with (<|) v+    _      -> get++insertOf :: (Cons s s r r, Monad m) => Traversal s t (Maybe a,s) b -> (Maybe a -> r) -> Trans' m s+insertOf l = alterOf l . (return .)++updateOf :: (Cons s s r r, Monad m) => Traversal s t (Maybe a,s) b -> (a -> r) -> Trans' m s+updateOf l = alterOf l . fmap++adjustOf :: (Cons s s r r, Monad m) => Traversal s t (Maybe a,s) b -> (a -> Maybe r) -> Trans' m s+adjustOf l = alterOf l . (=<<)++-- }}}+
+ src/Text/HTML/Rules/Types.hs view
@@ -0,0 +1,69 @@+{-# OPTIONS_HADDOCK show-extensions #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Rank2Types #-}++{-|+Module      : Text.HTML.Rules.Types+Description : Ubiquitous types for html-rules.+Copyright   : (c) Kyle Carter, 2014+License     : BSD3+Maintainer  : kylcarte@gmail.com+Stability   : experimental+-}++module Text.HTML.Rules.Types where++import Control.Monad.State++import Text.HTML.TagSoup hiding (Tag)+import Text.HTML.TagSoup.Tree+++-- | a single HTML Tree+type Fragment = TagTree String+-- | an HTML Forest+type HTML     = [Fragment]+-- | Tag name+type Name     = String+-- | Attribute name+type AttrKey  = String+-- | Attribute value+type AttrVal  = String+type Attrs    = [Attribute String]+-- | an HTML branch's descendents+type Desc     = HTML++-- | a 'Query' to decide when to apply a transformation,+--   paired with the 'Trans'formation.+--+--   NB: a Transformation makes+--   a single 'Fragment' into zero or more 'Fragment's.+type Rule  m a b = (Query m a, Trans m a b)++-- | a Rule over a 'Fragment' of HTML.+type FragmentRule m     = Rule m Fragment HTML++-- | a predicate on some type+type Query m a = a -> m Bool+-- | a predicate on an HTML Fragment+type FragmentQuery m = Query m Fragment++-- | a Transformation with a State of @a@+type Trans  m a b = StateT a m b+-- | a reflexive Transformation, analogous to @(a -> a)@+type Trans' m a   = Trans m a a++-- * Pattern Synonyms++-- | @Branch tg as ds = TagBranch tg as ds@+pattern Branch tg as ds = TagBranch tg as ds++-- | @Leaf tg as = TagLeaf (TagOpen tg as)@+pattern Leaf tg as = TagLeaf (TagOpen tg as)++-- | @Text t = TagLeaf (TagText t)@+pattern Text t = TagLeaf (TagText t)+
+ src/Text/HTML/Rules/Util.hs view
@@ -0,0 +1,77 @@+{-# OPTIONS_HADDOCK show-extensions #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Rank2Types #-}++{-|+Module      : Text.HTML.Rules.Util+Description : Transform an HTML structure by sets of rules.+Copyright   : (c) Kyle Carter, 2014+License     : BSD3+Maintainer  : kylcarte@gmail.com+Stability   : experimental+-}++module Text.HTML.Rules.Util where++import Control.Applicative+import Control.Monad ((>=>))++{-+-- ** Traversal Functions++alterOf :: (Cons s s c c, Monad m) => Traversal s t (Maybe a,s) b -> (Maybe a -> Maybe c) -> Trans' m s+alterOf l f = do+  mv <- optional l+  case f mv of+    Just v -> with (<|) v+    _      -> get++insertOf :: (Cons s s r r, Monad m) => Traversal s t (Maybe a,s) b -> (Maybe a -> r) -> Trans' m s+insertOf l = alterOf l . (return .)++updateOf :: (Cons s s r r, Monad m) => Traversal s t (Maybe a,s) b -> (a -> r) -> Trans' m s+updateOf l = alterOf l . fmap++adjustOf :: (Cons s s r r, Monad m) => Traversal s t (Maybe a,s) b -> (a -> Maybe r) -> Trans' m s+adjustOf l = alterOf l . (=<<)+-}+++-- | bind into a pure function.+(>>$) :: Monad m => m a -> (a -> b) -> m b+m >>$ f = m >>= return . f+infixl 1 >>$++-- | compose monadic sequent function with a pure function, left to right.+(>$>) :: Monad m => (a -> m b) -> (b -> c) -> a -> m c+f >$> g = f >=> return . g+infixr 1 >$>++-- | compose monadic sequent function with a pure function, right to left.+(<$<) :: Monad m => (b -> c) -> (a -> m b) -> a -> m c+(<$<) = flip (>$>)+infixr 1 <$<++-- | construct a singleton list.+one_ :: a -> [a]+one_ = (:[])++-- | compse a list of sequent endo-functions into a single sequent.+concatEndo :: Monad m => [a -> m a] -> a -> m a+concatEndo = foldr (>=>) return++liftAA :: (Applicative f, Applicative g) => (a -> b) -> f (g a) -> f (g b)+liftAA = fmap . fmap++pure2 :: (Applicative f, Applicative g) => a -> f (g a)+pure2 = pure . pure++ap2   :: (Applicative f, Applicative g) => f (g (a -> b)) -> f (g a) -> f (g b)+ap2 f x = (<*>) <$> f <*> x++liftAA2 :: (Applicative f, Applicative g) => (a -> b -> c) -> f (g a) -> f (g b) -> f (g c)+liftAA2 f x y = pure2 f `ap2` x `ap2` y+