tagchup 0.4.0.6 → 0.4.1
raw patch · 3 files changed
+101/−17 lines, 3 filesdep +non-emptydep ~utility-htdep ~xml-basic
Dependencies added: non-empty
Dependency ranges changed: utility-ht, xml-basic
Files
- src/Text/HTML/Tagchup/Process.hs +92/−10
- src/Text/HTML/Tagchup/Tag/Match.hs +4/−3
- tagchup.cabal +5/−4
src/Text/HTML/Tagchup/Process.hs view
@@ -1,17 +1,21 @@ module Text.HTML.Tagchup.Process ( Encoding, Encoded, evalDecodeAdaptive, decodeAdaptive, decodeTagAdaptive,+ getEmbeddedEncoding, getXMLEncoding, findMetaEncoding, getMetaHTTPHeaders, getHeadTags, partAttrs, parts,+ takeBeforeMatchingClose,+ takeUntilMatchingClose, ) where import qualified Text.HTML.Tagchup.Tag as Tag import qualified Text.HTML.Tagchup.Tag.Match as Match +import qualified Text.XML.Basic.ProcessingInstruction as PI import qualified Text.XML.Basic.Attribute as Attr import qualified Text.XML.Basic.Name as Name import qualified Text.XML.Basic.Tag as TagX@@ -23,10 +27,15 @@ import Control.Monad.Trans.State (State, put, get, evalState, ) import Control.Monad.HT ((<=<), )-import Control.Monad (msum, mplus, )+import Control.Monad (msum, guard, )+import Control.Applicative ((<|>)) +import qualified Data.NonEmpty as NonEmpty+import qualified Data.List.Match as ListMatch+import qualified Data.Foldable as Fold import Data.Traversable (traverse, )-import Data.List.HT (viewL, )+import Data.List.HT (viewL, takeUntil, switchR, )+import Data.Maybe.HT (toMaybe, ) import Data.Maybe (fromMaybe, mapMaybe, ) @@ -87,16 +96,34 @@ then decoder s else s) (Tag.maybeSpecial tag0)- maybe- (return ())- (put . getDecoder) $- mplus- (uncurry TagH.maybeMetaEncoding =<<- Tag.maybeOpen tag1)- (uncurry TagX.maybeXMLEncoding =<<- Tag.maybeProcessing tag1)+ Fold.mapM_ (put . getDecoder) $+ (do openTag <- Tag.maybeOpen tag1+ uncurry TagH.maybeMetaEncoding openTag <|>+ uncurry TagH.maybeMetaCharset openTag)+ <|>+ (uncurry TagX.maybeXMLEncoding =<< Tag.maybeProcessing tag1) return tag1 ++getEmbeddedEncoding ::+ (Name.Attribute name, Name.Tag name) =>+ [Tag.T name String] -> Maybe Encoding+getEmbeddedEncoding leadingTags =+ let xmlEncoding = do+ (t,_) <- viewL leadingTags+ (name, PI.Known attrs) <- Tag.maybeProcessing t+ guard (TagX.xmlName == name)+ Attr.lookup Attr.encodingName attrs++ in msum $+ xmlEncoding :+ map+ (\tag ->+ uncurry TagH.maybeMetaCharset tag <|>+ uncurry TagH.maybeMetaEncoding tag)+ (mapMaybe Tag.maybeOpen $ getHeadTags leadingTags)++ {- | Check whether the first tag is an @xml@ processing instruction tag and return the value of its @encoding@ attribute.@@ -189,3 +216,58 @@ let (part,suffix2) = break (Match.close (name==)) suffix1 return $ Left ((name, attrs), part) : recourse (drop 1 suffix2)) in recourse++++nestDiff :: (Eq name) => TagH.Name name -> Tag.T name string -> Int+nestDiff name tag =+ fromEnum (Match.open (name==) (const True) tag)+ -+ fromEnum (Match.close (name==) tag)++countNesting :: (a -> Int) -> [a] -> [Int]+countNesting p = NonEmpty.tail . NonEmpty.scanl (+) 0 . map p+++{-+Could be moved to utility-ht, but there seem to be several useful variants+with respect to whether opening and closing element should be included.+-}+{- |+> Process> let parenDiff c = case c of '(' -> 1; ')' -> -1; _ -> 0+> Process> takeBeforeMatch parenDiff "((abc)de)f"+> "((abc)de"+-}+takeBeforeMatch :: (a -> Int) -> [a] -> [a]+takeBeforeMatch p xs =+ flip ListMatch.take xs $ takeWhile (>0) $ countNesting p xs++{- |+Take all tags until the one that matches the opening tag.+The matching closing tag is not included in the list.+The list must begin with the according opening tag.+Nesting of the considered tag is respected,+but the nesting of other tags is ignored.+-}+takeBeforeMatchingClose ::+ (Eq name) => TagH.Name name -> [Tag.T name string] -> [Tag.T name string]+takeBeforeMatchingClose name = takeBeforeMatch $ nestDiff name+++{- |+> Process> takeUntilMatch parenDiff "((abc)de)f"+> Just "((abc)de)"+-}+takeUntilMatch :: (a -> Int) -> [a] -> Maybe [a]+takeUntilMatch p xs =+ (\ys -> switchR (Just []) (\_ y -> toMaybe (y==0) $ ListMatch.take ys xs) ys) $+ takeUntil (==0) $ countNesting p xs++{- |+This is like 'takeBeforeMatchingClose'+but the matching close tag is included in the result.+-}+takeUntilMatchingClose ::+ (Eq name) =>+ TagH.Name name -> [Tag.T name string] -> Maybe [Tag.T name string]+takeUntilMatchingClose name = takeUntilMatch $ nestDiff name
src/Text/HTML/Tagchup/Tag/Match.hs view
@@ -10,9 +10,10 @@ -- | match an opening tag-open :: (Tag.Name name -> Bool) -> ([Attr.T name string] -> Bool) -> Tag.T name string -> Bool-open pName pAttrs (Tag.Open name attrs) =- pName name && pAttrs attrs+open ::+ (Tag.Name name -> Bool) -> ([Attr.T name string] -> Bool) ->+ Tag.T name string -> Bool+open pName pAttrs (Tag.Open name attrs) = pName name && pAttrs attrs open _ _ _ = False -- | match a closing tag
tagchup.cabal view
@@ -1,5 +1,5 @@ Name: tagchup-Version: 0.4.0.6+Version: 0.4.1 License: GPL License-File: LICENSE Author: Henning Thielemann <tagchup@henning-thielemann.de>@@ -38,7 +38,7 @@ Source-Repository this Type: darcs Location: http://code.haskell.org/~thielema/tagchup/- Tag: 0.4.0.6+ Tag: 0.4.1 Flag buildExamples description: Build example executables@@ -47,13 +47,14 @@ Library Build-Depends:- xml-basic >=0.1.1 && <0.2,+ xml-basic >=0.1.2 && <0.2, transformers >=0.2 && <0.6, explicit-exception >=0.1 && <0.2, bytestring >=0.9.0.1 && <0.11, containers >=0.1 && <0.6,+ non-empty >=0.2.1 && <0.4, data-accessor >=0.2 && <0.3,- utility-ht >=0.0.1 && <0.1,+ utility-ht >=0.0.13 && <0.1, base >=3 && <5 Default-Language: Haskell98 GHC-Options: -Wall