diff options
author | joe <joe@jerkface.net> | 2014-02-12 20:35:52 -0500 |
---|---|---|
committer | joe <joe@jerkface.net> | 2014-02-12 20:35:52 -0500 |
commit | 7ccaa169bc2309df7df2db118dd646177867f2b0 (patch) | |
tree | 82b5e8f7e744f7d919b49ebcb0b0654def7d7d32 /Presence/Nesting.hs | |
parent | 5ad7794bcd86a0049d1e62cae2f04f6088a0ef34 (diff) |
Reply to pings with pongs.
Diffstat (limited to 'Presence/Nesting.hs')
-rw-r--r-- | Presence/Nesting.hs | 79 |
1 files changed, 79 insertions, 0 deletions
diff --git a/Presence/Nesting.hs b/Presence/Nesting.hs new file mode 100644 index 00000000..24f9baad --- /dev/null +++ b/Presence/Nesting.hs | |||
@@ -0,0 +1,79 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | ||
2 | {-# LANGUAGE FlexibleContexts #-} | ||
3 | module Nesting where | ||
4 | |||
5 | import Data.Conduit | ||
6 | import Data.Conduit.Lift | ||
7 | import Data.XML.Types | ||
8 | import qualified Data.Text as S | ||
9 | import Control.Monad.State | ||
10 | import qualified Data.List as List | ||
11 | |||
12 | type Lang = S.Text | ||
13 | |||
14 | data StrictList a = a :! !(StrictList a) | StrictNil | ||
15 | |||
16 | data XMLState = XMLState { | ||
17 | nestingLevel :: Int, | ||
18 | langStack :: StrictList (Int,Lang) | ||
19 | } | ||
20 | |||
21 | type NestingXML o m a = ConduitM Event o (StateT XMLState m) a | ||
22 | |||
23 | doNestingXML :: Monad m => NestingXML o m r -> ConduitM Event o m r | ||
24 | doNestingXML m = | ||
25 | evalStateC (XMLState 0 StrictNil) (trackNesting =$= m) | ||
26 | |||
27 | nesting :: Monad m => NestingXML o m Int | ||
28 | nesting = lift $ (return . nestingLevel) =<< get | ||
29 | |||
30 | |||
31 | trackNesting :: Monad m => ConduitM Event Event (StateT XMLState m) () | ||
32 | trackNesting = awaitForever doit | ||
33 | where | ||
34 | doit xml = do | ||
35 | XMLState lvl langs <- lift get | ||
36 | lift . put $ case xml of | ||
37 | EventBeginElement _ attrs -> | ||
38 | case lookupLang attrs of | ||
39 | Nothing -> XMLState (lvl+1) langs | ||
40 | Just lang -> XMLState (lvl+1) ( (lvl+1,lang) :! langs) | ||
41 | EventEndElement _ -> | ||
42 | case langs of | ||
43 | (llvl,_) :! ls | llvl==lvl -> XMLState (lvl-1) ls | ||
44 | _ | otherwise -> XMLState (lvl-1) langs | ||
45 | _ -> XMLState lvl langs | ||
46 | yield xml | ||
47 | |||
48 | |||
49 | lookupLang attrs = | ||
50 | case List.find ( (=="xml:lang") . fst) attrs of | ||
51 | Just (_,[ContentText x]) -> Just x | ||
52 | Just (_,[ContentEntity x]) -> Just x | ||
53 | _ -> Nothing | ||
54 | |||
55 | |||
56 | awaitCloser :: Monad m => Int -> NestingXML o m () | ||
57 | awaitCloser lvl = do | ||
58 | fix $ \loop -> do | ||
59 | lvl' <- nesting | ||
60 | when (lvl' >= lvl) $ do | ||
61 | xml <- await | ||
62 | maybe (return ()) (const loop) xml | ||
63 | |||
64 | withXML f = await >>= maybe (return ()) f | ||
65 | |||
66 | nextElement :: Monad m => NestingXML o m (Maybe Event) | ||
67 | nextElement = do | ||
68 | lvl <- nesting | ||
69 | fix $ \loop -> do | ||
70 | xml <- await | ||
71 | case xml of | ||
72 | Nothing -> return Nothing | ||
73 | Just (EventBeginElement _ _) -> do | ||
74 | return xml | ||
75 | Just _ -> do | ||
76 | lvl' <- nesting | ||
77 | if (lvl'>=lvl) then loop | ||
78 | else return Nothing | ||
79 | |||