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)

data Token' s = TagOpen s [Attr' s] Bool
              | TagClose s
              | Text s
              | Comment s
              | Special s s
              | Incomplete s
    deriving (Token' s -> Token' s -> Bool
(Token' s -> Token' s -> Bool)
-> (Token' s -> Token' s -> Bool) -> Eq (Token' s)
forall s. Eq s => Token' s -> Token' s -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall s. Eq s => Token' s -> Token' s -> Bool
== :: Token' s -> Token' s -> Bool
$c/= :: forall s. Eq s => Token' s -> Token' s -> Bool
/= :: Token' s -> Token' s -> Bool
Eq, Int -> Token' s -> ShowS
[Token' s] -> ShowS
Token' s -> String
(Int -> Token' s -> ShowS)
-> (Token' s -> String) -> ([Token' s] -> ShowS) -> Show (Token' s)
forall s. Show s => Int -> Token' s -> ShowS
forall s. Show s => [Token' s] -> ShowS
forall s. Show s => Token' s -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall s. Show s => Int -> Token' s -> ShowS
showsPrec :: Int -> Token' s -> ShowS
$cshow :: forall s. Show s => Token' s -> String
show :: Token' s -> String
$cshowList :: forall s. Show s => [Token' s] -> ShowS
showList :: [Token' s] -> ShowS
Show)

data TagType = TagTypeClose
             | TagTypeSpecial
             | TagTypeNormal

instance Functor Token' where
    fmap :: forall a b. (a -> b) -> Token' a -> Token' b
fmap a -> b
f Token' a
t = case Token' a
t of
        (TagOpen a
x [Attr' a]
pairs Bool
b) -> b -> [Attr' b] -> Bool -> Token' b
forall s. s -> [Attr' s] -> Bool -> Token' s
TagOpen (a -> b
f a
x) ((Attr' a -> Attr' b) -> [Attr' a] -> [Attr' b]
forall a b. (a -> b) -> [a] -> [b]
map (a -> b
f (a -> b) -> (a -> b) -> Attr' a -> Attr' b
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** a -> b
f) [Attr' a]
pairs) Bool
b
        (TagClose a
x)        -> b -> Token' b
forall s. s -> Token' s
TagClose (a -> b
f a
x)
        (Text a
x)            -> b -> Token' b
forall s. s -> Token' s
Text (a -> b
f a
x)
        (Comment a
x)         -> b -> Token' b
forall s. s -> Token' s
Comment (a -> b
f a
x)
        (Special a
x a
y)       -> b -> b -> Token' b
forall s. s -> s -> Token' s
Special (a -> b
f a
x) (a -> b
f a
y)
        (Incomplete a
x)      -> b -> Token' b
forall s. s -> Token' s
Incomplete (a -> b
f a
x)

instance Foldable Token' where
    foldMap :: forall m a. Monoid m => (a -> m) -> Token' a -> m
foldMap a -> m
f Token' a
t = case Token' a
t of
        (TagOpen a
x [Attr' a]
pairs Bool
_) -> a -> m
f a
x m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` [m] -> m
forall a. Monoid a => [a] -> a
mconcat ((Attr' a -> m) -> [Attr' a] -> [m]
forall a b. (a -> b) -> [a] -> [b]
map (\(a
a1, a
a2) -> a -> m
f a
a1 m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` a -> m
f a
a2) [Attr' a]
pairs)
        (TagClose a
x)        -> a -> m
f a
x
        (Text a
x)            -> a -> m
f a
x
        (Comment a
x)         -> a -> m
f a
x
        (Special a
x a
y)       -> a -> m
f a
x m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` a -> m
f a
y
        (Incomplete a
x)      -> a -> m
f a
x

instance Traversable Token' where
    traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Token' a -> f (Token' b)
traverse a -> f b
f Token' a
t = case Token' a
t of
        (TagOpen a
x [Attr' a]
pairs Bool
b) -> b -> [Attr' b] -> Bool -> Token' b
forall s. s -> [Attr' s] -> Bool -> Token' s
TagOpen (b -> [Attr' b] -> Bool -> Token' b)
-> f b -> f ([Attr' b] -> Bool -> Token' b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x
                                       f ([Attr' b] -> Bool -> Token' b)
-> f [Attr' b] -> f (Bool -> Token' b)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [f (Attr' b)] -> f [Attr' b]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA ((Attr' a -> f (Attr' b)) -> [Attr' a] -> [f (Attr' b)]
forall a b. (a -> b) -> [a] -> [b]
map (\(a
a1, a
a2) -> (,) (b -> b -> Attr' b) -> f b -> f (b -> Attr' b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a1 f (b -> Attr' b) -> f b -> f (Attr' b)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> f b
f a
a2) [Attr' a]
pairs)
                                       f (Bool -> Token' b) -> f Bool -> f (Token' b)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> f Bool
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
b
        (TagClose a
x)        -> b -> Token' b
forall s. s -> Token' s
TagClose (b -> Token' b) -> f b -> f (Token' b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x
        (Text a
x)            -> b -> Token' b
forall s. s -> Token' s
Text (b -> Token' b) -> f b -> f (Token' b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x
        (Comment a
x)         -> b -> Token' b
forall s. s -> Token' s
Comment (b -> Token' b) -> f b -> f (Token' b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x
        (Special a
x a
y)       -> b -> b -> Token' b
forall s. s -> s -> Token' s
Special (b -> b -> Token' b) -> f b -> f (b -> Token' b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x f (b -> Token' b) -> f b -> f (Token' b)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> f b
f a
y
        (Incomplete a
x)      -> b -> Token' b
forall s. s -> Token' s
Incomplete (b -> Token' b) -> f b -> f (Token' b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x