{-|
    /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
forall str. Eq str => TagTree str -> TagTree str -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TagTree str -> TagTree str -> Bool
$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
Eq,TagTree str -> TagTree str -> Bool
TagTree str -> TagTree str -> Ordering
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
min :: TagTree str -> TagTree str -> TagTree str
$cmin :: forall str. Ord str => TagTree str -> TagTree str -> TagTree str
max :: TagTree str -> TagTree str -> TagTree str
$cmax :: forall str. Ord str => TagTree str -> TagTree str -> TagTree str
>= :: 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
$c< :: forall str. Ord str => TagTree str -> TagTree str -> Bool
compare :: TagTree str -> TagTree str -> Ordering
$ccompare :: forall str. Ord str => TagTree str -> TagTree str -> Ordering
Ord,Int -> TagTree str -> ShowS
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
showList :: [TagTree str] -> ShowS
$cshowList :: forall str. Show str => [TagTree str] -> ShowS
show :: TagTree str -> String
$cshow :: forall str. Show str => TagTree str -> String
showsPrec :: Int -> TagTree str -> ShowS
$cshowsPrec :: forall str. Show str => Int -> 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) = forall str. str -> [Attribute str] -> [TagTree str] -> TagTree str
TagBranch (a -> b
f a
x) (forall a b. (a -> b) -> [a] -> [b]
map (a -> b
fforall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
***a -> b
f) [Attribute a]
y) (forall a b. (a -> b) -> [a] -> [b]
map (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) = forall str. Tag str -> TagTree str
TagLeaf (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 = 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 forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall str. Tag str -> TagTree str
TagLeaf (forall a. Int -> [a] -> [a]
take Int
1 [Tag str]
b) forall a. [a] -> [a] -> [a]
++ forall str. Eq str => [Tag str] -> [TagTree str]
g (forall a. Int -> [a] -> [a]
drop Int
1 [Tag str]
b)
            where ([TagTree str]
a,[Tag str]
b) = 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 forall str. Eq str => [Tag str] -> ([TagTree str], [Tag str])
f [Tag str]
rest of
                ([TagTree str]
inner,[]) -> (forall str. Tag str -> TagTree str
TagLeaf (forall str. str -> [Attribute str] -> Tag str
TagOpen str
name [Attribute str]
atts)forall a. a -> [a] -> [a]
:[TagTree str]
inner, [])
                ([TagTree str]
inner,TagClose str
x:[Tag str]
xs)
                    | str
x forall a. Eq a => a -> a -> Bool
== str
name -> let ([TagTree str]
a,[Tag str]
b) = forall str. Eq str => [Tag str] -> ([TagTree str], [Tag str])
f [Tag str]
xs in (forall str. str -> [Attribute str] -> [TagTree str] -> TagTree str
TagBranch str
name [Attribute str]
atts [TagTree str]
innerforall a. a -> [a] -> [a]
:[TagTree str]
a, [Tag str]
b)
                    | Bool
otherwise -> (forall str. Tag str -> TagTree str
TagLeaf (forall str. str -> [Attribute str] -> Tag str
TagOpen str
name [Attribute str]
atts)forall a. a -> [a] -> [a]
:[TagTree str]
inner, forall str. str -> Tag str
TagClose str
xforall a. a -> [a] -> [a]
:[Tag str]
xs)
                ([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) = ([], forall str. str -> Tag str
TagClose str
xforall a. a -> [a] -> [a]
:[Tag str]
xs)
        f (Tag str
x:[Tag str]
xs) = (forall str. Tag str -> TagTree str
TagLeaf Tag str
xforall a. a -> [a] -> [a]
:[TagTree str]
a,[Tag str]
b)
            where ([TagTree str]
a,[Tag str]
b) = 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 = forall str. Eq str => [Tag str] -> [TagTree str]
tagTree forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall str. Eq str => [Tag str] -> [TagTree str]
tagTree forall a b. (a -> b) -> a -> b
$ 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 a. (forall b. (a -> b -> b) -> b -> b) -> [a]
build forall a b. (a -> b) -> a -> 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 =
            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 (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 = forall str. StringLike str => [Tag str] -> str
renderTags forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall str. StringLike str => RenderOptions str -> [Tag str] -> str
renderTagsOptions RenderOptions str
opts forall a b. (a -> b) -> a -> b
$ 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 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap 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 forall a. a -> [a] -> [a]
: 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 = 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 forall a b. (a -> b) -> a -> b
$ forall str. str -> [Attribute str] -> [TagTree str] -> TagTree str
TagBranch str
a [Attribute str]
b (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