{-# 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
, after
, 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.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)
after ::
TagTreePosState x [TagTree x]
after =
gets (view tagTreePosAfter)
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
tagBranchLeafText ::
TagTreePosState a (a, a)
tagBranchLeafText =
do x <- opticContent _TagBranch_
t <- opticContent (_TagBranch . _3 . _head . _TagLeaf . _TagText)
pure (x, t)