summaryrefslogtreecommitdiff
path: root/Presence/NestingXML.hs
blob: 220e82a02361699877cd47fa2464c6a3e503be23 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
module NestingXML where

import Data.Conduit
import Data.XML.Types
import Control.Monad.Reader

type NestingXML o m a = ReaderT Int (ConduitM Event o m) a

runNestingXML :: NestingXML o m a -> Int -> ConduitM Event o m a
runNestingXML = runReaderT

nesting :: Monad m => NestingXML o m Int
nesting = ask

awaitXML :: Monad m => NestingXML o m (Maybe Event)
awaitXML = do
    xml <- lift await
    let f = case xml of
              Just (EventBeginElement _ _) -> (+1)
              Just (EventEndElement _)     -> (subtract 1)
              _                            -> id 
    local f (return xml)


awaitCloser :: Monad m => Int -> NestingXML o m ()
awaitCloser lvl = do
    fix $ \loop -> do
        awaitXML
        lvl' <- nesting
        when (lvl' >= lvl) loop

nextElement :: Monad m => NestingXML o m (Maybe Event)
nextElement = do
    lvl <- nesting
    fix $ \loop  -> do
        xml <- awaitXML
        case xml of
            Nothing                      -> return Nothing
            Just (EventBeginElement _ _) -> return xml
            Just _ -> do
                lvl' <- nesting
                if (lvl'>=lvl) then loop 
                               else return Nothing