{-|
    /NOTE/: This module is preliminary and may change at a future date.

    This module is intended to help converting a list of tags into a
    tree of tags.
-}

module Text.HTML.TagSoup.Tree
    (
    TagTree(..), tagTree, parseTree, parseTreeOptions, ParseOptions(..),
    flattenTree, renderTree, renderTreeOptions, RenderOptions(..), transformTree, universeTree
    ) where

import Text.HTML.TagSoup (parseTags, parseTagsOptions, renderTags, renderTagsOptions, ParseOptions(..), RenderOptions(..))
import Text.HTML.TagSoup.Type
import Control.Arrow
import GHC.Exts (build)


-- | A tree of 'Tag' values.
data TagTree str
    = -- | A 'TagOpen'/'TagClose' pair with the 'Tag' values in between.
      TagBranch str [Attribute str] [TagTree str]
    | -- | Any leaf node
      TagLeaf (Tag str)
                   deriving (TagTree str -> TagTree str -> Bool
(TagTree str -> TagTree str -> Bool)
-> (TagTree str -> TagTree str -> Bool) -> Eq (TagTree str)
forall str. Eq str => TagTree str -> TagTree str -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall str. Eq str => TagTree str -> TagTree str -> Bool
== :: TagTree str -> TagTree str -> Bool
$c/= :: forall str. Eq str => TagTree str -> TagTree str -> Bool
/= :: TagTree str -> TagTree str -> Bool
Eq,Eq (TagTree str)
Eq (TagTree str) =>
(TagTree str -> TagTree str -> Ordering)
-> (TagTree str -> TagTree str -> Bool)
-> (TagTree str -> TagTree str -> Bool)
-> (TagTree str -> TagTree str -> Bool)
-> (TagTree str -> TagTree str -> Bool)
-> (TagTree str -> TagTree str -> TagTree str)
-> (TagTree str -> TagTree str -> TagTree str)
-> Ord (TagTree str)
TagTree str -> TagTree str -> Bool
TagTree str -> TagTree str -> Ordering
TagTree str -> TagTree str -> TagTree str
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall str. Ord str => Eq (TagTree str)
forall str. Ord str => TagTree str -> TagTree str -> Bool
forall str. Ord str => TagTree str -> TagTree str -> Ordering
forall str. Ord str => TagTree str -> TagTree str -> TagTree str
$ccompare :: forall str. Ord str => TagTree str -> TagTree str -> Ordering
compare :: TagTree str -> TagTree str -> Ordering
$c< :: forall str. Ord str => TagTree str -> TagTree str -> Bool
< :: TagTree str -> TagTree str -> Bool
$c<= :: forall str. Ord str => TagTree str -> TagTree str -> Bool
<= :: TagTree str -> TagTree str -> Bool
$c> :: forall str. Ord str => TagTree str -> TagTree str -> Bool
> :: TagTree str -> TagTree str -> Bool
$c>= :: forall str. Ord str => TagTree str -> TagTree str -> Bool
>= :: TagTree str -> TagTree str -> Bool
$cmax :: forall str. Ord str => TagTree str -> TagTree str -> TagTree str
max :: TagTree str -> TagTree str -> TagTree str
$cmin :: forall str. Ord str => TagTree str -> TagTree str -> TagTree str
min :: TagTree str -> TagTree str -> TagTree str
Ord,Int -> TagTree str -> ShowS
[TagTree str] -> ShowS
TagTree str -> String
(Int -> TagTree str -> ShowS)
-> (TagTree str -> String)
-> ([TagTree str] -> ShowS)
-> Show (TagTree str)
forall str. Show str => Int -> TagTree str -> ShowS
forall str. Show str => [TagTree str] -> ShowS
forall str. Show str => TagTree str -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall str. Show str => Int -> TagTree str -> ShowS
showsPrec :: Int -> TagTree str -> ShowS
$cshow :: forall str. Show str => TagTree str -> String
show :: TagTree str -> String
$cshowList :: forall str. Show str => [TagTree str] -> ShowS
showList :: [TagTree str] -> ShowS
Show)

instance Functor TagTree where
    fmap :: forall a b. (a -> b) -> TagTree a -> TagTree b
fmap a -> b
f (TagBranch a
x [Attribute a]
y [TagTree a]
z) = b -> [Attribute b] -> [TagTree b] -> TagTree b
forall str. str -> [Attribute str] -> [TagTree str] -> TagTree str
TagBranch (a -> b
f a
x) ((Attribute a -> Attribute b) -> [Attribute a] -> [Attribute b]
forall a b. (a -> b) -> [a] -> [b]
map (a -> b
f(a -> b) -> (a -> b) -> Attribute a -> Attribute 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) [Attribute a]
y) ((TagTree a -> TagTree b) -> [TagTree a] -> [TagTree b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> TagTree a -> TagTree b
forall a b. (a -> b) -> TagTree a -> TagTree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) [TagTree a]
z)
    fmap a -> b
f (TagLeaf Tag a
x) = Tag b -> TagTree b
forall str. Tag str -> TagTree str
TagLeaf ((a -> b) -> Tag a -> Tag b
forall a b. (a -> b) -> Tag a -> Tag b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Tag a
x)


-- | Convert a list of tags into a tree. This version is not lazy at
--   all, that is saved for version 2.
tagTree :: Eq str => [Tag str] -> [TagTree str]
tagTree :: forall str. Eq str => [Tag str] -> [TagTree str]
tagTree = [Tag str] -> [TagTree str]
forall str. Eq str => [Tag str] -> [TagTree str]
g
    where
        g :: Eq str => [Tag str] -> [TagTree str]
        g :: forall str. Eq str => [Tag str] -> [TagTree str]
g [] = []
        g [Tag str]
xs = [TagTree str]
a [TagTree str] -> [TagTree str] -> [TagTree str]
forall a. [a] -> [a] -> [a]
++ (Tag str -> TagTree str) -> [Tag str] -> [TagTree str]
forall a b. (a -> b) -> [a] -> [b]
map Tag str -> TagTree str
forall str. Tag str -> TagTree str
TagLeaf (Int -> [Tag str] -> [Tag str]
forall a. Int -> [a] -> [a]
take Int
1 [Tag str]
b) [TagTree str] -> [TagTree str] -> [TagTree str]
forall a. [a] -> [a] -> [a]
++ [Tag str] -> [TagTree str]
forall str. Eq str => [Tag str] -> [TagTree str]
g (Int -> [Tag str] -> [Tag str]
forall a. Int -> [a] -> [a]
drop Int
1 [Tag str]
b)
            where ([TagTree str]
a,[Tag str]
b) = [Tag str] -> ([TagTree str], [Tag str])
forall str. Eq str => [Tag str] -> ([TagTree str], [Tag str])
f [Tag str]
xs

        -- the second tuple is either null or starts with a close
        f :: Eq str => [Tag str] -> ([TagTree str],[Tag str])
        f :: forall str. Eq str => [Tag str] -> ([TagTree str], [Tag str])
f (TagOpen str
name [Attribute str]
atts:[Tag str]
rest) =
            case [Tag str] -> ([TagTree str], [Tag str])
forall str. Eq str => [Tag str] -> ([TagTree str], [Tag str])
f [Tag str]
rest of
                ([TagTree str]
inner,[]) -> (Tag str -> TagTree str
forall str. Tag str -> TagTree str
TagLeaf (str -> [Attribute str] -> Tag str
forall str. str -> [Attribute str] -> Tag str
TagOpen str
name [Attribute str]
atts)TagTree str -> [TagTree str] -> [TagTree str]
forall a. a -> [a] -> [a]
:[TagTree str]
inner, [])
                ([TagTree str]
inner,TagClose str
x:[Tag str]
xs)
                    | str
x str -> str -> Bool
forall a. Eq a => a -> a -> Bool
== str
name -> let ([TagTree str]
a,[Tag str]
b) = [Tag str] -> ([TagTree str], [Tag str])
forall str. Eq str => [Tag str] -> ([TagTree str], [Tag str])
f [Tag str]
xs in (str -> [Attribute str] -> [TagTree str] -> TagTree str
forall str. str -> [Attribute str] -> [TagTree str] -> TagTree str
TagBranch str
name [Attribute str]
atts [TagTree str]
innerTagTree str -> [TagTree str] -> [TagTree str]
forall a. a -> [a] -> [a]
:[TagTree str]
a, [Tag str]
b)
                    | Bool
otherwise -> (Tag str -> TagTree str
forall str. Tag str -> TagTree str
TagLeaf (str -> [Attribute str] -> Tag str
forall str. str -> [Attribute str] -> Tag str
TagOpen str
name [Attribute str]
atts)TagTree str -> [TagTree str] -> [TagTree str]
forall a. a -> [a] -> [a]
:[TagTree str]
inner, str -> Tag str
forall str. str -> Tag str
TagClose str
xTag str -> [Tag str] -> [Tag str]
forall a. a -> [a] -> [a]
:[Tag str]
xs)
                ([TagTree str], [Tag str])
_ -> String -> ([TagTree str], [Tag str])
forall a. HasCallStack => String -> a
error String
"TagSoup.Tree.tagTree: safe as - forall x . isTagClose (snd (f x))"

        f (TagClose str
x:[Tag str]
xs) = ([], str -> Tag str
forall str. str -> Tag str
TagClose str
xTag str -> [Tag str] -> [Tag str]
forall a. a -> [a] -> [a]
:[Tag str]
xs)
        f (Tag str
x:[Tag str]
xs) = (Tag str -> TagTree str
forall str. Tag str -> TagTree str
TagLeaf Tag str
xTagTree str -> [TagTree str] -> [TagTree str]
forall a. a -> [a] -> [a]
:[TagTree str]
a,[Tag str]
b)
            where ([TagTree str]
a,[Tag str]
b) = [Tag str] -> ([TagTree str], [Tag str])
forall str. Eq str => [Tag str] -> ([TagTree str], [Tag str])
f [Tag str]
xs
        f [] = ([], [])

-- | Build a 'TagTree' from a string.
parseTree :: StringLike str => str -> [TagTree str]
parseTree :: forall str. StringLike str => str -> [TagTree str]
parseTree = [Tag str] -> [TagTree str]
forall str. Eq str => [Tag str] -> [TagTree str]
tagTree ([Tag str] -> [TagTree str])
-> (str -> [Tag str]) -> str -> [TagTree str]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. str -> [Tag str]
forall str. StringLike str => str -> [Tag str]
parseTags

-- | Build a 'TagTree' from a string, specifying the 'ParseOptions'.
parseTreeOptions :: StringLike str => ParseOptions str -> str -> [TagTree str]
parseTreeOptions :: forall str.
StringLike str =>
ParseOptions str -> str -> [TagTree str]
parseTreeOptions ParseOptions str
opts str
str = [Tag str] -> [TagTree str]
forall str. Eq str => [Tag str] -> [TagTree str]
tagTree ([Tag str] -> [TagTree str]) -> [Tag str] -> [TagTree str]
forall a b. (a -> b) -> a -> b
$ ParseOptions str -> str -> [Tag str]
forall str. StringLike str => ParseOptions str -> str -> [Tag str]
parseTagsOptions ParseOptions str
opts str
str

-- | Flatten a 'TagTree' back to a list of 'Tag'.
flattenTree :: [TagTree str] -> [Tag str]
flattenTree :: forall str. [TagTree str] -> [Tag str]
flattenTree [TagTree str]
xs = (forall b. (Tag str -> b -> b) -> b -> b) -> [Tag str]
forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
build ((forall b. (Tag str -> b -> b) -> b -> b) -> [Tag str])
-> (forall b. (Tag str -> b -> b) -> b -> b) -> [Tag str]
forall a b. (a -> b) -> a -> b
$ [TagTree str] -> (Tag str -> b -> b) -> b -> b
forall str lst.
[TagTree str] -> (Tag str -> lst -> lst) -> lst -> lst
flattenTreeFB [TagTree str]
xs

flattenTreeFB :: [TagTree str] -> (Tag str -> lst -> lst) -> lst -> lst
flattenTreeFB :: forall str lst.
[TagTree str] -> (Tag str -> lst -> lst) -> lst -> lst
flattenTreeFB [TagTree str]
xs Tag str -> lst -> lst
cons lst
nil = [TagTree str] -> lst -> lst
flattenTreeOnto [TagTree str]
xs lst
nil
    where
        flattenTreeOnto :: [TagTree str] -> lst -> lst
flattenTreeOnto [] lst
tags = lst
tags
        flattenTreeOnto (TagBranch str
name [Attribute str]
atts [TagTree str]
inner:[TagTree str]
trs) lst
tags =
            str -> [Attribute str] -> Tag str
forall str. str -> [Attribute str] -> Tag str
TagOpen str
name [Attribute str]
atts Tag str -> lst -> lst
`cons` [TagTree str] -> lst -> lst
flattenTreeOnto [TagTree str]
inner (str -> Tag str
forall str. str -> Tag str
TagClose str
name Tag str -> lst -> lst
`cons` [TagTree str] -> lst -> lst
flattenTreeOnto [TagTree str]
trs lst
tags)
        flattenTreeOnto (TagLeaf Tag str
x:[TagTree str]
trs) lst
tags = Tag str
x Tag str -> lst -> lst
`cons` [TagTree str] -> lst -> lst
flattenTreeOnto [TagTree str]
trs lst
tags

-- | Render a 'TagTree'.
renderTree :: StringLike str => [TagTree str] -> str
renderTree :: forall str. StringLike str => [TagTree str] -> str
renderTree = [Tag str] -> str
forall str. StringLike str => [Tag str] -> str
renderTags ([Tag str] -> str)
-> ([TagTree str] -> [Tag str]) -> [TagTree str] -> str
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TagTree str] -> [Tag str]
forall str. [TagTree str] -> [Tag str]
flattenTree

-- | Render a 'TagTree' with some 'RenderOptions'.
renderTreeOptions :: StringLike str => RenderOptions str -> [TagTree str] -> str
renderTreeOptions :: forall str.
StringLike str =>
RenderOptions str -> [TagTree str] -> str
renderTreeOptions RenderOptions str
opts [TagTree str]
trees = RenderOptions str -> [Tag str] -> str
forall str. StringLike str => RenderOptions str -> [Tag str] -> str
renderTagsOptions RenderOptions str
opts ([Tag str] -> str) -> [Tag str] -> str
forall a b. (a -> b) -> a -> b
$ [TagTree str] -> [Tag str]
forall str. [TagTree str] -> [Tag str]
flattenTree [TagTree str]
trees

-- | This operation is based on the Uniplate @universe@ function. Given a
--   list of trees, it returns those trees, and all the children trees at
--   any level. For example:
--
-- > universeTree
-- >    [TagBranch "a" [("href","url")] [TagBranch "b" [] [TagLeaf (TagText "text")]]]
-- > == [TagBranch "a" [("href","url")] [TagBranch "b" [] [TagLeaf (TagText "text")]]]
-- >    ,TagBranch "b" [] [TagLeaf (TagText "text")]]
--
--   This operation is particularly useful for queries. To collect all @\"a\"@
--   tags in a tree, simply do:
--
-- > [x | x@(TagBranch "a" _ _) <- universeTree tree]
universeTree :: [TagTree str] -> [TagTree str]
universeTree :: forall str. [TagTree str] -> [TagTree str]
universeTree = (TagTree str -> [TagTree str]) -> [TagTree str] -> [TagTree str]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TagTree str -> [TagTree str]
forall {str}. TagTree str -> [TagTree str]
f
    where
        f :: TagTree str -> [TagTree str]
f t :: TagTree str
t@(TagBranch str
_ [Attribute str]
_ [TagTree str]
inner) = TagTree str
t TagTree str -> [TagTree str] -> [TagTree str]
forall a. a -> [a] -> [a]
: [TagTree str] -> [TagTree str]
forall str. [TagTree str] -> [TagTree str]
universeTree [TagTree str]
inner
        f TagTree str
x = [TagTree str
x]


-- | This operation is based on the Uniplate @transform@ function. Given a
--   list of trees, it applies the function to every tree in a bottom-up
--   manner. This operation is useful for manipulating a tree - for example
--   to make all tag names upper case:
--
-- > upperCase = transformTree f
-- >   where f (TagBranch name atts inner) = [TagBranch (map toUpper name) atts inner]
-- >         f x = [x]
transformTree :: (TagTree str -> [TagTree str]) -> [TagTree str] -> [TagTree str]
transformTree :: forall str.
(TagTree str -> [TagTree str]) -> [TagTree str] -> [TagTree str]
transformTree TagTree str -> [TagTree str]
act = (TagTree str -> [TagTree str]) -> [TagTree str] -> [TagTree str]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TagTree str -> [TagTree str]
f
    where
        f :: TagTree str -> [TagTree str]
f (TagBranch str
a [Attribute str]
b [TagTree str]
inner) = TagTree str -> [TagTree str]
act (TagTree str -> [TagTree str]) -> TagTree str -> [TagTree str]
forall a b. (a -> b) -> a -> b
$ str -> [Attribute str] -> [TagTree str] -> TagTree str
forall str. str -> [Attribute str] -> [TagTree str] -> TagTree str
TagBranch str
a [Attribute str]
b ((TagTree str -> [TagTree str]) -> [TagTree str] -> [TagTree str]
forall str.
(TagTree str -> [TagTree str]) -> [TagTree str] -> [TagTree str]
transformTree TagTree str -> [TagTree str]
act [TagTree str]
inner)
        f TagTree str
x = TagTree str -> [TagTree str]
act TagTree str
x