Permalink
Browse files

Foldable and Tranversable instance for Token'

  • Loading branch information...
1 parent bd609ca commit 4c0680e673377feab08be3f4cf6a8c91b052f322 @yihuang committed Oct 13, 2012
Showing with 32 additions and 6 deletions.
  1. +32 −6 Text/HTML/TagStream/Types.hs
@@ -1,6 +1,10 @@
module Text.HTML.TagStream.Types where
+import Control.Applicative (pure, (<$>), (<*>))
import Control.Arrow ((***))
+import Data.Monoid (mappend, mconcat)
+import Data.Foldable (Foldable(foldMap))
+import Data.Traversable (Traversable(traverse), sequenceA)
type Attr' s = (s, s)
@@ -17,9 +21,31 @@ data TagType = TagTypeClose
| TagTypeNormal
instance Functor Token' where
- fmap f (TagOpen x pairs b) = TagOpen (f x) (map (f *** f) pairs) b
- fmap f (TagClose x) = TagClose (f x)
- fmap f (Text x) = Text (f x)
- fmap f (Comment x) = Comment (f x)
- fmap f (Special x y) = Special (f x) (f y)
- fmap f (Incomplete x) = Incomplete (f x)
+ fmap f t = case t of
+ (TagOpen x pairs b) -> TagOpen (f x) (map (f *** f) pairs) b
+ (TagClose x) -> TagClose (f x)
+ (Text x) -> Text (f x)
+ (Comment x) -> Comment (f x)
+ (Special x y) -> Special (f x) (f y)
+ (Incomplete x) -> Incomplete (f x)
+
+instance Foldable Token' where
+ foldMap f t = case t of
+ (TagOpen x pairs _) -> f x `mappend` mconcat (map (\(a1, a2) -> f a1 `mappend` f a2) pairs)
+ (TagClose x) -> f x
+ (Text x) -> f x
+ (Comment x) -> f x
+ (Special x y) -> f x `mappend` f y
+ (Incomplete x) -> f x
+
+instance Traversable Token' where
+ traverse f t = case t of
+ (TagOpen x pairs b) -> TagOpen <$> f x
+ <*> sequenceA (map (\(a1, a2) -> (,) <$> f a1 <*> f a2) pairs)
+ <*> pure b
+ (TagClose x) -> TagClose <$> f x
+ (Text x) -> Text <$> f x
+ (Comment x) -> Comment <$> f x
+ (Special x y) -> Special <$> f x <*> f y
+ (Incomplete x) -> Incomplete <$> f x
+

0 comments on commit 4c0680e

Please sign in to comment.