{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}

module Text.HTML.TagSoup.Navigate.Types.TagTreePosState(
  TagTreePosStateT(..)
, TagTreePosState
, tagTreePosState
, runTagTreePosStateT
, evalTagTreePosStateT
, execTagTreePosStateT
, runTagTreePosState
, evalTagTreePosState
, execTagTreePosState
, modifyTagTreePosStateT
, modifyTagTreePosState
, getsTagTreePosStateT
, getsTagTreePosState
, maybeTagTreePosStateT
, maybeTagTreePosState
, putTagTreePosStateT
, putTagTreePosState
, getTagTreePos
, root
, parent
, firstChild
, lastChild
, prevSibling
, nextSibling
, content
, before
, befores
, after
, afters
, parents
, liftTagTreePosState
, putTagTree
, opticContent
, findTreeT
, findTree
, depthFirstFindTreeT
, depthFirstFindTree
, breadthFirstFindTreeT
, breadthFirstFindTree
, findContentUntil
, findUntil
, tagBranchLeafText
) where

import Control.Applicative(Applicative((<*>), pure), Alternative((<|>), empty), liftA2, (*>))
import Control.Category((.))
import Control.Lens(Rewrapped, Wrapped, Unwrapped, _Wrapped', _Wrapped, iso, view, preview, over, from, _head, _1, _2, _3)
import Control.Monad(Monad(return, (>>=)))
import Control.Monad.Morph(MFunctor(hoist))
import Control.Monad.Reader.Class(MonadReader(ask, local, reader))
import Control.Monad.State.Class(MonadState(state, get, put), gets, modify)
import Control.Monad.Trans.Class(MonadTrans(lift))
import Control.Monad.IO.Class(MonadIO(liftIO))
import Data.Bool(Bool, bool)
import Data.Functor(Functor(fmap))
import Data.Functor.Apply(Apply((<.>)))
import Data.Functor.Alt(Alt((<!>)))
import Data.Functor.Bind(Bind((>>-)))
import Data.Functor.Const(Const)
import Data.Functor.Identity(Identity(Identity, runIdentity))
import Data.List.NonEmpty
import Data.Maybe(Maybe(Nothing, Just))
import Data.Semigroup(Semigroup((<>)))
import Data.Monoid(Monoid(mempty, mappend), First)
import Text.HTML.TagSoup.Navigate.Types.Tag(_TagText)
import Text.HTML.TagSoup.Navigate.Types.TagTree(TagTree, _TagLeaf, _TagBranch, _TagBranch_)
import Text.HTML.TagSoup.Navigate.Types.TagTreePos(TagTreePos, tagsoupTagTreePos, tagTreePosContent, tagTreePosBefore, tagTreePosAfter, tagTreePosParents, fromTagTree)
import Text.HTML.TagSoup.Navigate.Types.TagTreePosParent(TagTreePosParent)
import qualified Text.HTML.TagSoup.Tree.Zipper as TagSoup(prevSibling, nextSibling, parent, firstChild, lastChild, root)

newtype TagTreePosStateT str f a =
  TagTreePosStateT
    (TagTreePos str -> f (Maybe (TagTreePos str, a)))

type TagTreePosState str a =
  TagTreePosStateT str Identity a

tagTreePosState ::
  (TagTreePos str -> Maybe (TagTreePos str, a))
  -> TagTreePosState str a
tagTreePosState k =
  TagTreePosStateT (Identity . k)

instance TagTreePosStateT str f a ~ t =>
  Rewrapped (TagTreePosStateT str f' a') t

instance Wrapped (TagTreePosStateT str f a) where
  type Unwrapped (TagTreePosStateT str f a) =
    TagTreePos str -> f (Maybe (TagTreePos str, a))
  _Wrapped' =
    iso (\(TagTreePosStateT x) -> x) TagTreePosStateT

instance Functor f => Functor (TagTreePosStateT str f) where
  fmap f (TagTreePosStateT x) =
    TagTreePosStateT (fmap (fmap (fmap (fmap f))) x)

instance Monad f => Apply (TagTreePosStateT str f) where
  TagTreePosStateT f <.> TagTreePosStateT a =
    TagTreePosStateT (\p -> 
     f p >>= \case
      Nothing ->
        pure Nothing
      Just (s, f') ->
        fmap (fmap (fmap f')) (a s)
    )

instance Monad f => Applicative (TagTreePosStateT str f) where
  pure a =
    TagTreePosStateT (\p -> pure (pure (p, a)))
  (<*>) =
    (<.>)

instance Monad f => Alt (TagTreePosStateT str f) where
  TagTreePosStateT x <!> TagTreePosStateT y =
    TagTreePosStateT (\p -> 
      x p >>= \case
        Nothing ->
          y p
        Just (s, a) ->
          pure (Just (s, a))
    )

instance Monad f => Alternative (TagTreePosStateT str f) where
  (<|>) =
    (<!>)
  empty =
    TagTreePosStateT (pure (pure Nothing))

instance Monad f => Bind (TagTreePosStateT str f) where
  TagTreePosStateT x >>- f =
    TagTreePosStateT (\p -> 
      x p >>= \case
        Nothing ->
          pure Nothing
        Just (s, a) ->
          view _Wrapped (f a) s
    )

instance Monad f => Monad (TagTreePosStateT str f) where
  return =
    pure
  (>>=) =
    (>>-)

instance MonadTrans (TagTreePosStateT str) where
  lift x =
    TagTreePosStateT (\p -> fmap (\a -> pure (p, a)) x)

instance MonadIO f => MonadIO (TagTreePosStateT str f) where
  liftIO x =
    TagTreePosStateT (\p -> liftIO (fmap (\a -> pure (p, a)) x))

instance Monad f => MonadState (TagTreePos str) (TagTreePosStateT str f) where
  state k =
    TagTreePosStateT (\p -> let (a, q) = k p in pure (pure (q, a)))
  get =
    TagTreePosStateT (\p -> pure (pure (p, p)))
  put p =
    TagTreePosStateT (pure (pure (pure (p, ()))))

instance Monad f => MonadReader (TagTreePos str) (TagTreePosStateT str f) where
  ask =
    get
  local k (TagTreePosStateT x) =
    TagTreePosStateT (fmap (fmap (over _1 k)) . x)
  reader k =
    TagTreePosStateT (\p -> pure (pure (p, k p)))

instance MFunctor (TagTreePosStateT str) where
  hoist k (TagTreePosStateT x) =
    TagTreePosStateT (k . x)

instance (Monad f, Semigroup a) => Semigroup (TagTreePosStateT str f a) where
  (<>) =
    liftA2 (<>)

instance (Monad f, Monoid a) => Monoid (TagTreePosStateT str f a) where
  mappend =
    liftA2 mappend
  mempty =
    pure mempty

runTagTreePosStateT ::
  TagTreePosStateT str f a
  -> TagTreePos str
  -> f (Maybe (TagTreePos str, a))
runTagTreePosStateT =
  view _Wrapped

evalTagTreePosStateT ::
  Functor f =>
  TagTreePosStateT str f a
  -> TagTreePos str
  -> f (Maybe a)
evalTagTreePosStateT s p =
  fmap (fmap (view _2)) (runTagTreePosStateT s p)

execTagTreePosStateT ::
  Functor f =>
  TagTreePosStateT str f a
  -> TagTreePos str
  -> f (Maybe (TagTreePos str))
execTagTreePosStateT s p =
  fmap (fmap (view _1)) (runTagTreePosStateT s p)

runTagTreePosState ::
  TagTreePosState str a
  -> TagTreePos str
  -> Maybe (TagTreePos str, a)
runTagTreePosState s p =
  runIdentity (runTagTreePosStateT s p)

evalTagTreePosState ::
  TagTreePosState str a
  -> TagTreePos str
  -> Maybe a
evalTagTreePosState s p =
  fmap (view _2) (runTagTreePosState s p)

execTagTreePosState ::
  TagTreePosState str a
  -> TagTreePos str
  -> Maybe (TagTreePos str)
execTagTreePosState s p =
  fmap (view _1) (runTagTreePosState s p)

modifyTagTreePosStateT ::
  Functor f =>
  (TagTreePos x -> f (Maybe (TagTreePos x)))
  -> TagTreePosStateT x f ()
modifyTagTreePosStateT k =
  TagTreePosStateT (fmap (fmap (\q -> (q, ()))) . k)

modifyTagTreePosState ::
  (TagTreePos x -> Maybe (TagTreePos x))
  -> TagTreePosState x ()
modifyTagTreePosState k =
  modifyTagTreePosStateT (pure . k)

getsTagTreePosStateT ::
  Functor f =>
  (TagTreePos x -> f (Maybe a))
  -> TagTreePosStateT x f a
getsTagTreePosStateT k =
  TagTreePosStateT (\p -> fmap (fmap (\a -> (p, a))) (k p))

getsTagTreePosState ::
  (TagTreePos x -> Maybe a)
  -> TagTreePosState x a
getsTagTreePosState k =
  getsTagTreePosStateT (pure . k)

maybeTagTreePosStateT ::
  Functor f =>
  f (Maybe a)
  -> TagTreePosStateT x f a
maybeTagTreePosStateT =
  getsTagTreePosStateT . pure

maybeTagTreePosState ::
  Maybe a
  -> TagTreePosState x a
maybeTagTreePosState =
  getsTagTreePosState . pure

putTagTreePosStateT ::
  Functor f =>
  f (Maybe (TagTreePos x))
  -> TagTreePosStateT x f ()
putTagTreePosStateT x =
  TagTreePosStateT (pure (fmap (fmap (\p -> (p, ()))) x))

putTagTreePosState ::
  Maybe (TagTreePos x)
  -> TagTreePosState x ()
putTagTreePosState =
  putTagTreePosStateT . pure

getTagTreePos ::
  TagTreePosState x (TagTree x)
getTagTreePos =
  liftTagTreePosState getTagTreePos

root ::
  TagTreePosState str ()
root =
  modify (view (from tagsoupTagTreePos) . TagSoup.root . view tagsoupTagTreePos)
  
parent ::
  TagTreePosState str ()
parent =
  modifyTagTreePosState (fmap (view (from tagsoupTagTreePos)) . TagSoup.parent . view tagsoupTagTreePos)
  
firstChild ::
  TagTreePosState str ()
firstChild =
  modifyTagTreePosState (fmap (view (from tagsoupTagTreePos)) . TagSoup.firstChild . view tagsoupTagTreePos)
  
lastChild ::
  TagTreePosState str ()
lastChild =
  modifyTagTreePosState (fmap (view (from tagsoupTagTreePos)) . TagSoup.lastChild . view tagsoupTagTreePos)
  
prevSibling ::
  TagTreePosState str ()
prevSibling =
  modifyTagTreePosState (fmap (view (from tagsoupTagTreePos)) . TagSoup.prevSibling . view tagsoupTagTreePos)
  
nextSibling ::
  TagTreePosState str ()
nextSibling =
  modifyTagTreePosState (fmap (view (from tagsoupTagTreePos)) . TagSoup.nextSibling . view tagsoupTagTreePos)
  
content ::
  TagTreePosState x (TagTree x)
content =
  gets (view tagTreePosContent)

before ::
  TagTreePosState x [TagTree x]
before =
  gets (view tagTreePosBefore)

befores ::
  TagTreePosState x (NonEmpty (TagTree x))
befores =
  liftA2 (:|) content before

after ::
  TagTreePosState x [TagTree x]
after =
  gets (view tagTreePosAfter)

afters ::
  TagTreePosState x (NonEmpty (TagTree x))
afters =
  liftA2 (:|) content after

parents ::
  TagTreePosState x [TagTreePosParent x]
parents =
  gets (view tagTreePosParents)

liftTagTreePosState ::
  Applicative f =>
  TagTreePosState str a
  -> TagTreePosStateT str f a
liftTagTreePosState (TagTreePosStateT x) =
  TagTreePosStateT (pure . runIdentity . x)

putTagTree ::
  Monad f =>
  TagTree str
  -> TagTreePosStateT str f ()
putTagTree =
  put . fromTagTree

opticContent ::
  ((a -> Const (First a) a) -> TagTree str -> Const (First a) (TagTree str))
  -> TagTreePosState str a
opticContent k =
  getsTagTreePosState
    (preview (tagTreePosContent . k))

findTreeT ::
  Monad f =>
  TagTreePosStateT str f a
  -> TagTreePosStateT str f a
  -> (TagTree str -> f (Maybe a))
  -> TagTreePosStateT str f a
findTreeT s1 s2 pr =
  do  c <- liftTagTreePosState content
      z <- lift (pr c)
      case z of
        Nothing ->
          s1 <|> s2
        Just x ->
          pure x
  
findTree ::
  TagTreePosState str a
  -> TagTreePosState str a
  -> (TagTree str -> Maybe a)
  -> TagTreePosState str a
findTree s1 s2 pr =
  findTreeT s1 s2 (Identity . pr)

depthFirstFindTreeT ::
  Monad f =>
  (TagTree str -> f (Maybe x))
  -> TagTreePosStateT str f x
depthFirstFindTreeT pr =
  findTreeT (liftTagTreePosState firstChild *> depthFirstFindTreeT pr) (liftTagTreePosState nextSibling *> depthFirstFindTreeT pr) pr

depthFirstFindTree ::
  (TagTree str -> Maybe x)
  -> TagTreePosState str x
depthFirstFindTree pr =
  depthFirstFindTreeT (Identity . pr)

breadthFirstFindTreeT ::
  Monad f =>
  (TagTree str -> f (Maybe x))
  -> TagTreePosStateT str f x
breadthFirstFindTreeT pr =
  findTreeT (liftTagTreePosState nextSibling *> breadthFirstFindTreeT pr) (liftTagTreePosState firstChild *> breadthFirstFindTreeT pr) pr

breadthFirstFindTree ::
  (TagTree str -> Maybe x)
  -> TagTreePosState str x
breadthFirstFindTree pr =
  breadthFirstFindTreeT (Identity . pr)

findContentUntil ::
  Monad f =>
  TagTreePosStateT str f a
  -> (TagTree str -> Bool)
  -> TagTreePosStateT str f ()
findContentUntil oper pr =
  findUntil oper (reader (pr . view tagTreePosContent) >>= bool empty (pure ()))

findUntil ::
  Monad f =>
  TagTreePosStateT str f a
  -> TagTreePosStateT str f b
  -> TagTreePosStateT str f b
findUntil oper pr =
  do  _ <- oper
      pr <|> findUntil oper pr

-- |
--
-- produces `(x, t)` in `TagBranch x _ [TagLeaf (TagText t)]`
tagBranchLeafText ::
  TagTreePosState a (a, a)
tagBranchLeafText =
  do  x <- opticContent _TagBranch_
      t <- opticContent (_TagBranch . _3 . _head . _TagLeaf . _TagText)
      pure (x, t)