Added tracking of xml:lang attribute.

1 files changed, 40 insertions, 9 deletions

diff --git a/Presence/NestingXML.hs b/Presence/NestingXML.hs
index 5956b34d..bf12c9ae 100644
--- a/Presence/NestingXML.hs
+++ b/Presence/NestingXML.hs
@@ -1,29 +1,60 @@
+{-# 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 NestingXML o m a = StateT Int (ConduitM Event o m) a
+type Lang = S.Text
 
-runNestingXML :: NestingXML o m a -> Int -> ConduitM Event o m (a,Int)
-runNestingXML = runStateT
+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 = get
+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
-    lvl <- get
+    XMLState lvl langs <- get
     xml <- lift await
-    put $case xml of
-              Just (EventBeginElement _ _) -> lvl+1
-              Just (EventEndElement _)     -> lvl-1
-              _                            -> lvl
+    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