add lenses for stanza types

source/Network/Xmpp/Lens.hs

@@ -0,0 +1,106 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Network.Xmpp.Lens where
+
+import Control.Applicative((<$>), Const(..))
+import Network.Xmpp.Types
+
+type Lens a b = Functor f => (b -> f b) -> a -> f a
+
+class StanzaC s where
+    from :: Lens s (Maybe Jid)
+    to   :: Lens s (Maybe Jid)
+    lang :: Lens s (Maybe LangTag)
+
+
+instance StanzaC Message where
+    from inj m@(Message{messageFrom=f}) = (\f' -> m{messageFrom = f'}) <$> inj f
+    to inj m@(Message{messageTo=t}) = (\t' -> m{messageTo = t'}) <$> inj t
+    lang inj m@(Message{messageLangTag=t}) =
+        (\t' -> m{messageLangTag = t'}) <$> inj t
+
+
+instance StanzaC MessageError where
+    from inj m@(MessageError{messageErrorFrom=f}) =
+        (\f' -> m{messageErrorFrom = f'}) <$> inj f
+    to inj m@(MessageError{messageErrorTo=t}) =
+        (\t' -> m{messageErrorTo = t'}) <$> inj t
+    lang inj m@(MessageError{messageErrorLangTag=t}) =
+        (\t' -> m{messageErrorLangTag = t'}) <$> inj t
+
+instance StanzaC Presence where
+    from inj m@(Presence{presenceFrom=f}) = (\f' -> m{presenceFrom = f'}) <$> inj f
+    to inj m@(Presence{presenceTo=t}) = (\t' -> m{presenceTo = t'}) <$> inj t
+    lang inj m@(Presence{presenceLangTag=t}) =
+        (\t' -> m{presenceLangTag = t'}) <$> inj t
+
+instance StanzaC PresenceError where
+    from inj m@(PresenceError{presenceErrorFrom=f}) =
+        (\f' -> m{presenceErrorFrom = f'}) <$> inj f
+    to inj m@(PresenceError{presenceErrorTo=t}) =
+        (\t' -> m{presenceErrorTo = t'}) <$> inj t
+    lang inj m@(PresenceError{presenceErrorLangTag=t}) =
+        (\t' -> m{presenceErrorLangTag = t'}) <$> inj t
+
+instance StanzaC IQRequest where
+    from inj m@(IQRequest{iqRequestFrom=f}) =
+        (\f' -> m{iqRequestFrom = f'}) <$> inj f
+    to inj m@(IQRequest{iqRequestTo=t}) =
+        (\t' -> m{iqRequestTo = t'}) <$> inj t
+    lang inj m@(IQRequest{iqRequestLangTag=t}) =
+        (\t' -> m{iqRequestLangTag = t'}) <$> inj t
+
+instance StanzaC IQResult where
+    from inj m@(IQResult{iqResultFrom=f}) =
+        (\f' -> m{iqResultFrom = f'}) <$> inj f
+    to inj m@(IQResult{iqResultTo=t}) =
+        (\t' -> m{iqResultTo = t'}) <$> inj t
+    lang inj m@(IQResult{iqResultLangTag=t}) =
+        (\t' -> m{iqResultLangTag = t'}) <$> inj t
+
+instance StanzaC IQError where
+    from inj m@(IQError{iqErrorFrom=f}) =
+        (\f' -> m{iqErrorFrom = f'}) <$> inj f
+    to inj m@(IQError{iqErrorTo=t}) =
+        (\t' -> m{iqErrorTo = t'}) <$> inj t
+    lang inj m@(IQError{iqErrorLangTag=t}) =
+        (\t' -> m{iqErrorLangTag = t'}) <$> inj t
+
+lift :: (forall s. StanzaC s => Lens s a) -> Lens Stanza a
+lift f inj (IQRequestS     s) = IQRequestS     <$> f inj s
+lift f inj (IQResultS      s) = IQResultS      <$> f inj s
+lift f inj (IQErrorS       s) = IQErrorS       <$> f inj s
+lift f inj (MessageS       s) = MessageS       <$> f inj s
+lift f inj (MessageErrorS  s) = MessageErrorS  <$> f inj s
+lift f inj (PresenceS      s) = PresenceS      <$> f inj s
+lift f inj (PresenceErrorS s) = PresenceErrorS <$> f inj s
+
+instance StanzaC Stanza where
+    from = lift from
+    to   = lift to
+    lang = lift lang
+
+class HasStanzaID s where
+    sid :: Lens s StanzaID
+
+instance HasStanzaID IQRequest where
+    sid inj m@(IQRequest {iqRequestID = i}) = (\i' -> m{iqRequestID = i'}) <$>
+                                                  inj i
+
+instance HasStanzaID IQResult where
+    sid inj m@(IQResult {iqResultID = i}) = (\i' -> m{iqResultID = i'}) <$>
+                                                  inj i
+
+instance HasStanzaID IQError where
+    sid inj m@(IQError {iqErrorID = i}) = (\i' -> m{iqErrorID = i'}) <$>
+                                                  inj i
+class MaybeHasStanzaID s where
+    msid :: Lens s (Maybe StanzaID)
+
+instance MaybeHasStanzaID Message where
+    msid inj m@(Message {messageID = i}) = (\i' -> m{messageID = i'}) <$>
+                                                  inj i
+
+($.) :: Lens a b -> a -> b
+f $. x = getConst $ f Const x