blob: dd0e41132b568d5c704a92aee6a7c314b2e01711 (
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
|
{-# 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
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 => ConduitM Event Event (StateT XMLState m) ()
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 = do
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 _ _) -> do
return xml
Just _ -> do
lvl' <- nesting
if (lvl'>=lvl) then loop
else return Nothing
|
