summaryrefslogtreecommitdiff
path: root/Presence/Nesting.hs
blob: 720237fd481b54f39c349f4cade041d3d44227d8 (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
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module Nesting where

import Data.Conduit
import Data.Conduit.Lift
import Data.XML.Types
import qualified Data.Text as S
import Control.Monad.State.Strict
import qualified Data.List as List

type Lang = S.Text

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

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

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

doNestingXML :: Monad m => NestingXML o m r -> ConduitM Event o m r
doNestingXML m = 
    evalStateC (XMLState 0 StrictNil) (trackNesting =$= m)

nesting :: Monad m => NestingXML o m Int
nesting = lift $ (return . nestingLevel) =<< get

xmlLang :: Monad m => NestingXML o m (Maybe Lang)
xmlLang = fmap (fmap snd . top . langStack) (lift get)
  where
    top ( a :! _as ) = Just a
    top _           = Nothing

trackNesting :: Monad m => Conduit Event (StateT XMLState m) Event
trackNesting = awaitForever doit
 where
  doit xml = do
    XMLState lvl langs <- lift get
    lift . put $ case xml of
              EventBeginElement _ attrs -> 
                case lookupLang attrs of
                  Nothing   -> XMLState (lvl+1) langs
                  Just lang -> XMLState (lvl+1) ( (lvl+1,lang) :! langs)
              EventEndElement _     -> 
                case langs of 
                  (llvl,_) :! ls | llvl==lvl -> XMLState (lvl-1) ls
                  _              | otherwise -> XMLState (lvl-1) langs
              _  -> XMLState lvl langs
    yield xml


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


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

withXML ::
    Monad m =>
    (i -> ConduitM i o m ()) -> ConduitM i o m ()
withXML f = await >>= maybe (return ()) f

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