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

module Text.HTML.TagSoup.Navigate.Types.TagTreePos(
  TagTreePos(..)
, HasTagTreePos(..)
, AsTagTreePos(..)
, tagsoupTagTreePos
, fromTagTree
, toTagTree
) where

import Control.Applicative((<*>))
import Control.Category((.), id)
import Control.Lens(Each(each), Lens', Prism', Iso, iso, view, from)
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.Monoid(mappend)
import Data.Traversable(Traversable(traverse))
import Prelude(Show)
import Text.HTML.TagSoup.Navigate.Types.Attribute(tagsoupAttribute)
import Text.HTML.TagSoup.Navigate.Types.TagTree(TagTree, tagsoupTagTree)
import Text.HTML.TagSoup.Navigate.Types.TagTreePosParent(TagTreePosParent(TagTreePosParent))
import qualified Text.HTML.TagSoup.Tree.Zipper as TagSoup(TagTreePos(TagTreePos), fromTagTree, root)
import Text.Show.Deriving(deriveShow1)

data TagTreePos str =
  TagTreePos
    (TagTree str)
    [TagTree str]
    [TagTree str]
    [TagTreePosParent str]
  deriving (Eq, Ord, Show)

instance Functor TagTreePos where
  fmap f (TagTreePos c b a p) =
    TagTreePos (fmap f c) (fmap (fmap f) b) (fmap (fmap f) a) (fmap (fmap f) p)

instance Foldable TagTreePos where
  foldMap f (TagTreePos c b a p) =
    foldMap f c `mappend` foldMap (foldMap f) b `mappend` foldMap (foldMap f) a `mappend` foldMap (foldMap f) p

instance Traversable TagTreePos where
  traverse f (TagTreePos c b a p) =
    TagTreePos <$> traverse f c <*> traverse (traverse f) b <*> traverse (traverse f) a <*> traverse (traverse f) p

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

class HasTagTreePos a str | a -> str where
  tagTreePos ::
    Lens' a (TagTreePos str)
  tagTreePosContent ::
    Lens' a (TagTree str)
  tagTreePosContent =
    tagTreePos . tagTreePosContent
  tagTreePosBefore ::
    Lens' a [TagTree str]
  tagTreePosBefore =
    tagTreePos . tagTreePosBefore
  tagTreePosAfter ::
    Lens' a [TagTree str]
  tagTreePosAfter =
    tagTreePos . tagTreePosAfter
  tagTreePosParents ::
    Lens' a [TagTreePosParent str]
  tagTreePosParents =
    tagTreePos . tagTreePosParents

instance HasTagTreePos (TagTreePos str) str where
  tagTreePos =
    id
  tagTreePosContent f (TagTreePos c b a p) =
    fmap (\c' -> TagTreePos c' b a p) (f c)
  tagTreePosBefore f (TagTreePos c b a p) =
    fmap (\b' -> TagTreePos c b' a p) (f b)
  tagTreePosAfter f (TagTreePos c b a p) =
    fmap (\a' -> TagTreePos c b a' p) (f a)
  tagTreePosParents f (TagTreePos c b a p) =
    fmap (\p' -> TagTreePos c b a p') (f p)

class AsTagTreePos a str | a -> str where
  _TagTreePos ::
    Prism' a (TagTreePos str)

instance AsTagTreePos (TagTreePos str) str where
  _TagTreePos =
    id

deriveEq1 ''TagTreePos
deriveOrd1 ''TagTreePos
deriveShow1 ''TagTreePos

tagsoupTagTreePos ::
  Iso (TagTreePos str) (TagTreePos str') (TagSoup.TagTreePos str) (TagSoup.TagTreePos str')
tagsoupTagTreePos =
  iso
    (\(TagTreePos c b a p) ->
      TagSoup.TagTreePos
        (view tagsoupTagTree c)
        (fmap (view tagsoupTagTree) b)
        (fmap (view tagsoupTagTree) a)
        (fmap (\(TagTreePosParent l' x' a' r') -> (fmap (view tagsoupTagTree) l', x', fmap (view tagsoupAttribute) a', fmap (view tagsoupTagTree) r')) p)
    )
    (\(TagSoup.TagTreePos c b a p) ->
      let tagsoupTagTree' = 
            from tagsoupTagTree
          tagsoupAttribute' =
            from tagsoupAttribute
      in  TagTreePos
            (view tagsoupTagTree' c)
            (fmap (view tagsoupTagTree') b)
            (fmap (view tagsoupTagTree') a)
            (fmap (\(l', x', a', r') -> TagTreePosParent (fmap (view tagsoupTagTree') l') x' (fmap (view tagsoupAttribute') a') (fmap (view tagsoupTagTree') r')) p)
    )

instance AsTagTreePos (TagSoup.TagTreePos str) str where
  _TagTreePos =
    from tagsoupTagTreePos . _TagTreePos

instance HasTagTreePos (TagSoup.TagTreePos str) str where
  tagTreePos =
    from tagsoupTagTreePos . tagTreePos

fromTagTree ::
  TagTree str
  -> TagTreePos str
fromTagTree =
  view (from tagsoupTagTreePos) . TagSoup.fromTagTree . view tagsoupTagTree

toTagTree ::
  TagTreePos str
  -> TagTree str
toTagTree t =
  let TagSoup.TagTreePos x _ _ _ = TagSoup.root (view tagsoupTagTreePos t)
  in  view (from tagsoupTagTree) x