Foldable and Tranversable instance for Token'

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
+