diff options
author | James Crayne <jim.crayne@gmail.com> | 2019-09-28 13:43:29 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2020-01-01 19:27:53 -0500 |
commit | 11987749fc6e6d3e53ea737d46d5ab13a16faeb8 (patch) | |
tree | 5716463275c2d3e902889db619908ded2a73971c /Presence/Nesting.hs | |
parent | add2c76bced51fde5e9917e7449ef52be70faf87 (diff) |
Factor out some new libraries
word64-map:
Data.Word64Map
network-addr:
Network.Address
tox-crypto:
Crypto.Tox
lifted-concurrent:
Control.Concurrent.Lifted.Instrument
Control.Concurrent.Async.Lifted.Instrument
psq-wrap:
Data.Wrapper.PSQInt
Data.Wrapper.PSQ
minmax-psq:
Data.MinMaxPSQ
tasks:
Control.Concurrent.Tasks
kad:
Network.Kademlia
Network.Kademlia.Bootstrap
Network.Kademlia.Routing
Network.Kademlia.CommonAPI
Network.Kademlia.Persistence
Network.Kademlia.Search
Diffstat (limited to 'Presence/Nesting.hs')
-rw-r--r-- | Presence/Nesting.hs | 86 |
1 files changed, 0 insertions, 86 deletions
diff --git a/Presence/Nesting.hs b/Presence/Nesting.hs deleted file mode 100644 index cf47c9fc..00000000 --- a/Presence/Nesting.hs +++ /dev/null | |||
@@ -1,86 +0,0 @@ | |||
1 | {-# LANGUAGE FlexibleContexts #-} | ||
2 | {-# LANGUAGE OverloadedStrings #-} | ||
3 | module Nesting where | ||
4 | |||
5 | import Control.Monad.State.Strict | ||
6 | import Data.Conduit | ||
7 | import Data.Conduit.Lift | ||
8 | import qualified Data.List as List | ||
9 | import qualified Data.Text as S | ||
10 | import Data.XML.Types | ||
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 | xmlLang :: Monad m => NestingXML o m (Maybe Lang) | ||
31 | xmlLang = fmap (fmap snd . top . langStack) (lift get) | ||
32 | where | ||
33 | top ( a :! _as ) = Just a | ||
34 | top _ = Nothing | ||
35 | |||
36 | trackNesting :: Monad m => ConduitM Event Event (StateT XMLState m) () | ||
37 | trackNesting = awaitForever doit | ||
38 | where | ||
39 | doit xml = do | ||
40 | XMLState lvl langs <- lift get | ||
41 | lift . put $ case xml of | ||
42 | EventBeginElement _ attrs -> | ||
43 | case lookupLang attrs of | ||
44 | Nothing -> XMLState (lvl+1) langs | ||
45 | Just lang -> XMLState (lvl+1) ( (lvl+1,lang) :! langs) | ||
46 | EventEndElement _ -> | ||
47 | case langs of | ||
48 | (llvl,_) :! ls | llvl==lvl -> XMLState (lvl-1) ls | ||
49 | _ | otherwise -> XMLState (lvl-1) langs | ||
50 | _ -> XMLState lvl langs | ||
51 | yield xml | ||
52 | |||
53 | |||
54 | lookupLang :: [(Name, [Content])] -> Maybe S.Text | ||
55 | lookupLang attrs = | ||
56 | case List.find ( (=="xml:lang") . fst) attrs of | ||
57 | Just (_,[ContentText x]) -> Just x | ||
58 | Just (_,[ContentEntity x]) -> Just x | ||
59 | _ -> Nothing | ||
60 | |||
61 | |||
62 | awaitCloser :: Monad m => Int -> NestingXML o m () | ||
63 | awaitCloser lvl = | ||
64 | fix $ \loop -> do | ||
65 | lvl' <- nesting | ||
66 | when (lvl' >= lvl) $ do | ||
67 | xml <- await | ||
68 | maybe (return ()) (const loop) xml | ||
69 | |||
70 | withXML :: | ||
71 | Monad m => | ||
72 | (i -> ConduitM i o m ()) -> ConduitM i o m () | ||
73 | withXML f = await >>= maybe (return ()) f | ||
74 | |||
75 | nextElement :: Monad m => NestingXML o m (Maybe Event) | ||
76 | nextElement = do | ||
77 | lvl <- nesting | ||
78 | fix $ \loop -> do | ||
79 | xml <- await | ||
80 | case xml of | ||
81 | Nothing -> return Nothing | ||
82 | Just (EventBeginElement _ _) -> return xml | ||
83 | Just _ -> do | ||
84 | lvl' <- nesting | ||
85 | if (lvl'>=lvl) then loop | ||
86 | else return Nothing | ||