TryParse monad, for cleaner xmppParse function

1 files changed, 35 insertions, 10 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 5008213c..ba542909 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -2,7 +2,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE ViewPatterns        #-}
 {-# LANGUAGE TupleSections       #-}
-module XMPPServer ( listenForXmppClients ) where
+module XMPPServer where -- ( listenForXmppClients ) where
 
 import Data.HList.TypeEqGeneric1()
 import Data.HList.TypeCastGeneric1()
@@ -23,7 +23,10 @@ import Data.HList
 import AdaptServer
 import Text.XML.HaXml.Lex (xmlLex)
 import Text.XML.HaXml.Parse  (xmlParseWith,element,{-doctypedecl,-}processinginstruction,elemOpenTag,elemCloseTag)
-import Text.XML.HaXml.Types as Hax (ElemTag,QName(..),Namespace(..),Element(..),Content(..),AttValue(..))
+import Text.XML.HaXml.Types as Hax hiding (Element) -- (ElemTag,QName(..),Namespace(..),Element(..),Content(..),AttValue(..))
+import qualified Text.XML.HaXml.Types as Hax (Element(..))
+import Text.XML.HaXml.Posn (Posn)
+import Text.XML.HaXml.Lex  (TokenT)
 import qualified Text.XML.HaXml.Pretty as PP
 import Text.PrettyPrint
 import Data.Maybe
@@ -199,11 +202,11 @@ doCon st elem cont = do
 instance Show Hax.ElemTag where
     show _ = "elemtag"
 
-data XmppObject e i t c
-    = Element e
-    | ProcessingInstruction i
-    | OpenTag t
-    | CloseTag c
+data XmppObject
+    = Element (Hax.Element Posn)
+    | ProcessingInstruction Hax.ProcessingInstruction
+    | OpenTag ElemTag
+    | CloseTag ()
  deriving Show
 
 pp (Element e) = PP.element e
@@ -211,7 +214,28 @@ pp o = fromString (show o)
 
 streamName = QN (Namespace {nsPrefix= "stream" , nsURI="http://etherx.jabber.org/streams" }) "stream" 
 
-xmppParse ls =
+newtype TryParse p x e = Try (Either e p,[x])
+
+instance Monad (TryParse p x) where
+        return v = Try (Left v,[])
+        Try (Left m,xs)  >>= k = k m
+        Try (Right e,xs) >>= _ = Try (Right e,xs)
+
+runTryParse (Try p) = p
+mapRight f (Right x,ls) = (Right (f x),ls)
+mapRight f (Left  y,ls) = (Left  y    ,ls)
+
+xmppParse :: [(Posn, TokenT)] -> (Either String XmppObject, [(Posn, TokenT)])
+xmppParse ls = runTryParse $ do
+    let xml tag = mapRight tag . flip xmlParseWith ls
+    Try . xml Element               $ element
+    Try . xml OpenTag               $ elemOpenTag
+    Try . xml CloseTag              $ elemCloseTag streamName
+    Try . xml ProcessingInstruction $ processinginstruction
+
+{-
+xmppParseOld :: [(Posn, TokenT)] -> (Either String XmppObject, [(Posn, TokenT)])
+xmppParseOld ls =
     case xmlParseWith element ls of
         (Right e,rs) -> (Right (Element e), rs)
         (Left _,_) -> 
@@ -219,11 +243,12 @@ xmppParse ls =
             (Right e,rs) -> (Right (OpenTag e),rs)
             (Left _,_) -> 
               case xmlParseWith (elemCloseTag streamName) ls of
-                (Right e,rs) -> (Right (CloseTag e),rs)
-                (Left _,_) -> 
+                (Right (),rs) -> (Right (CloseTag ()),rs)
+                (Left _,_) ->
                   case xmlParseWith processinginstruction ls of
                     (Right e,rs) -> (Right (ProcessingInstruction e),rs)
                     (Left err,rs) -> (Left err,rs)
+-}