summaryrefslogtreecommitdiff
path: root/Presence/NestingXML.hs
blob: c26e3d5ccc6d1c056966c7933d91f1f58b37426b (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
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
{-# LANGUAGE OverloadedStrings #-}
module NestingXML where

import Data.Conduit
import Data.XML.Types
import Control.Monad.State
import qualified Data.Text as S
import Data.List (find)
-- import qualified Text.XML.Stream.Parse as Parse (content)

type Lang = S.Text

data StrictList a = a :! !(StrictList a) | StrictNil

top ( a :! as ) = Just a
top _           = Nothing

data XMLState = XMLState { 
        nestingLevel :: Int,
        langStack :: StrictList (Int,Lang)
}

type NestingXML o m a = StateT XMLState (ConduitM Event o m) a


runNestingXML :: NestingXML o m a -> Int -> ConduitM Event o m (a,XMLState)
runNestingXML m lvl = runStateT m (XMLState lvl StrictNil)

doNestingXML :: Monad m => NestingXML o m a -> ConduitM Event o m a
doNestingXML = fmap fst . flip runNestingXML 0

nesting :: Monad m => NestingXML o m Int
nesting = fmap nestingLevel get

xmlLang :: Monad m => NestingXML o m (Maybe Lang)
xmlLang = fmap (fmap snd . top . langStack) get

lookupLang attrs =
    case find ( (=="xml:lang") . fst) attrs of
        Just (_,[ContentText x])   -> Just x
        Just (_,[ContentEntity x]) -> Just x
        _                          -> Nothing

awaitXML :: Monad m => NestingXML o m (Maybe Event)
awaitXML = do
    XMLState lvl langs <- get
    xml <- lift await
    put $ case xml of
              Just (EventBeginElement _ attrs) -> 
                case lookupLang attrs of
                  Nothing   -> XMLState (lvl+1) langs
                  Just lang -> XMLState (lvl+1) ( (lvl+1,lang) :! langs)
              Just (EventEndElement _)     -> 
                case langs of 
                  (llvl,_) :! ls | llvl==lvl -> XMLState (lvl-1) ls
                  _              | otherwise -> XMLState (lvl-1) langs
              _  -> XMLState lvl langs
    return xml

withXML
  :: Monad m => (Event -> NestingXML o m ()) -> NestingXML o m ()
withXML f = do
    xml <- awaitXML
    maybe (return ()) f xml


maybeXML
  :: Monad m => NestingXML o m a -> (Event -> NestingXML o m a) -> NestingXML o m a
maybeXML whenNothing withJust = do
    xml <- awaitXML
    maybe whenNothing withJust xml


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

doUntilCloser :: Monad m 
               => Int -> (Event -> NestingXML o m ()) -> NestingXML o m ()
doUntilCloser lvl thunk = do
    fix $ \loop -> do
        lvl' <- nesting
        when (lvl' >= lvl) $ do
        withXML $ \xml -> do
            thunk xml
            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 _ _) -> do
                return xml
            Just _ -> do
                lvl' <- nesting
                if (lvl'>=lvl) then loop 
                               else return Nothing