{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}

module Text.HTML.TagSoup.Navigate.Types.TagTree(
  TagTree(..)
, HasTagTree(..)
, AsTagTree(..)
, tagsoupTagTree
, _TagBranch_
, _TagBranchAttributeList_
, _TagBranchAttributes_
, _TagBranchChildrenList_
, _TagBranchChildren_
, _TagBranchAttributeNames_
, _TagBranchAttributeValues_
, tagTree'
, flattenTree
) where

import Control.Applicative((<*>))
import Control.Category((.), id)
import Control.Lens(Plated(plate), Each(each), Lens', Prism', Iso, Traversal', prism', iso, from, (^.), ( # ), _1, _2, _3)
import Data.Eq(Eq)
import Data.Eq.Deriving(deriveEq1)
import Data.Foldable(Foldable(foldMap))
import Data.Functor(Functor(fmap), (<$>))
import Data.Ord(Ord)
import Data.Ord.Deriving(deriveOrd1)
import Data.Maybe(Maybe(Just, Nothing))
import Data.Monoid(mappend)
import Data.Traversable(Traversable(traverse))
import Prelude(Show)
import Text.HTML.TagSoup.Navigate.Types.Attribute(Attribute, tagsoupAttribute, attributeName, attributeValue)
import Text.HTML.TagSoup.Navigate.Types.Tag(Tag, AsTag(_Tag), tagsoupTag)
import qualified Text.HTML.TagSoup.Tree as TagSoup(TagTree(TagBranch, TagLeaf), tagTree, flattenTree)
import Text.Show.Deriving(deriveShow1)

data TagTree str =
  TagBranch
    str
    [Attribute str]
    [TagTree str]
  | TagLeaf (Tag str)
  deriving (Eq, Ord, Show)

instance Functor TagTree where
  fmap f (TagBranch s as ts) =
    TagBranch (f s) (fmap (fmap f) as) (fmap (fmap f) ts)
  fmap f (TagLeaf t) =
    TagLeaf (fmap f t)

instance Foldable TagTree where
  foldMap f (TagBranch s as ts) =
    f s `mappend` foldMap (foldMap f) as `mappend` foldMap (foldMap f) ts
  foldMap f (TagLeaf t) =
    foldMap f t

instance Traversable TagTree where
  traverse f (TagBranch s as ts) =
    TagBranch <$> f s <*> traverse (traverse f) as <*> traverse (traverse f) ts
  traverse f (TagLeaf t) =
    TagLeaf <$> traverse f t

instance Plated (TagTree str) where
  plate =
    _TagBranchChildren_

instance Each (TagTree str) (TagTree str') str str' where
  each =
    traverse

class HasTagTree a str | a -> str where
  tagTree ::
    Lens' a (TagTree str)

instance HasTagTree (TagTree str) str where
  tagTree =
    id

instance HasTagTree (TagSoup.TagTree str) str where
  tagTree =
    from tagsoupTagTree . tagTree

class AsTagTree a str | a -> str where
  _TagTree ::
    Prism' a (TagTree str)
  _TagBranch ::
    Prism' a (str, [Attribute str], [TagTree str])
  _TagBranch =
    _TagTree . _TagBranch
  _TagLeaf ::
    Prism' a (Tag str)
  _TagLeaf =
    _TagTree . _TagLeaf

instance AsTagTree (TagTree str) str where
  _TagTree =
    id
  _TagBranch =
    prism'
      (\(s, as, t) -> TagBranch s as t)
      (\tr ->  case tr of
                TagBranch s as t ->
                  Just (s, as, t)
                TagLeaf _ ->
                  Nothing)
  _TagLeaf =
    prism'
      TagLeaf
      (\tr ->  case tr of
                TagBranch _ _ _ ->
                  Nothing
                TagLeaf x ->
                  Just x)

instance AsTagTree (TagSoup.TagTree str) str where
  _TagTree =
    from tagsoupTagTree . _TagTree

instance AsTag (TagTree str) str where
  _Tag =
    _TagLeaf . _Tag

tagsoupTagTree ::
  Iso (TagTree str) (TagTree str') (TagSoup.TagTree str) (TagSoup.TagTree str')
tagsoupTagTree =
  iso
    (\tr ->
      case tr of
        TagBranch s as t ->
          TagSoup.TagBranch s (fmap (^. tagsoupAttribute) as) (fmap (^. tagsoupTagTree) t)
        TagLeaf x ->
          TagSoup.TagLeaf (x ^. tagsoupTag))
    (\tr ->
      case tr of
        TagSoup.TagBranch s as t ->
          TagBranch s (fmap (tagsoupAttribute #) as) (fmap (tagsoupTagTree #) t)
        TagSoup.TagLeaf x ->
          TagLeaf (tagsoupTag # x))

_TagBranch_ ::
  AsTagTree a str =>
  Traversal' a str
_TagBranch_ =
  _TagBranch . _1

_TagBranchAttributeList_ ::
  AsTagTree a str =>
  Traversal' a [Attribute str]
_TagBranchAttributeList_ =
  _TagBranch . _2

_TagBranchAttributes_ ::
  AsTagTree a str =>
  Traversal' a (Attribute str)
_TagBranchAttributes_ =
  _TagBranchAttributeList_ . traverse

_TagBranchChildrenList_ ::
  AsTagTree a str =>
  Traversal' a [TagTree str]
_TagBranchChildrenList_ =
  _TagBranch . _3

_TagBranchChildren_ ::
  AsTagTree a str =>
  Traversal' a (TagTree str)
_TagBranchChildren_ =
  _TagBranchChildrenList_ . traverse

_TagBranchAttributeNames_ ::
  AsTagTree a str =>
  Traversal' a str
_TagBranchAttributeNames_ =
  _TagBranchAttributes_ . attributeName

_TagBranchAttributeValues_ ::
  AsTagTree a str =>
  Traversal' a str
_TagBranchAttributeValues_ =
  _TagBranchAttributes_ . attributeValue

deriveEq1 ''TagTree
deriveOrd1 ''TagTree
deriveShow1 ''TagTree

tagTree' ::
  Eq str =>
  [Tag str]
  -> [TagTree str] 
tagTree' =
  fmap (tagsoupTagTree #) . TagSoup.tagTree . fmap (^. tagsoupTag)

flattenTree ::
  [TagTree str]
  -> [Tag str]
flattenTree =
  fmap (tagsoupTag #) . TagSoup.flattenTree . fmap (^. tagsoupTagTree)