lens updates

12 years ago · e3b9494553
5 changed files with 126 additions and 20 deletions
--- a/pontarius-xmpp.cabal
+++ b/pontarius-xmpp.cabal
@ -68,6 +68,8 @@ Library
				@@ -68,6 +68,8 @@ Library
               , xml-conduit          >=1.1.0.7
               , xml-picklers         >=0.3.3
               , x509-system          >=1.4
+               , profunctors          >= 4
+               , lens-family

  If impl(ghc ==7.0.1) {
    Build-Depends: bytestring         >=0.9.1.9 && <=0.9.2.1
--- a/source/Network/Xmpp/IM/Presence.hs
+++ b/source/Network/Xmpp/IM/Presence.hs
@ -4,11 +4,11 @@
				@@ -4,11 +4,11 @@

 module Network.Xmpp.IM.Presence where

-import Data.Default
-import Data.Text (Text)
-import Data.XML.Pickle
-import Data.XML.Types
-import Network.Xmpp.Types
+import           Data.Default
+import           Data.Text (Text)
+import           Data.XML.Pickle
+import           Data.XML.Types
+import           Network.Xmpp.Types

 data ShowStatus = StatusAway
                | StatusChat
@ -53,6 +53,7 @@ xpIMPresence = xpUnliftElems .
				@@ -53,6 +53,7 @@ xpIMPresence = xpUnliftElems .
               xp3Tuple
                  (xpOption $ xpElemNodes "{jabber:client}show"
                     (xpContent xpShow))
+                  -- TODO: Multiple status elements with different lang tags
                  (xpOption $ xpElemNodes "{jabber:client}status"
                     (xpContent xpText))
                  (xpOption $ xpElemNodes "{jabber:client}priority"
--- a/source/Network/Xmpp/IM/Roster.hs
+++ b/source/Network/Xmpp/IM/Roster.hs
@ -78,9 +78,13 @@ rosterRemove j sess = do
				@@ -78,9 +78,13 @@ rosterRemove j sess = do
        let el = pickleElem xpQuery (Query Nothing [fromItem item])
        sendIQA' timeout Nothing Set Nothing el [] session

+-- | Retrieve the current Roster state (STM version)
+getRoster' :: Session -> STM Roster
+getRoster' session = readTVar (rosterRef session)
+
 -- | Retrieve the current Roster state
 getRoster :: Session -> IO Roster
-getRoster session = atomically $ readTVar (rosterRef session)
+getRoster session = atomically $ getRoster' session

 -- | Get the initial roster or refresh the roster. You don't need to call this
 -- on your own.
--- a/source/Network/Xmpp/Lens.hs
+++ b/source/Network/Xmpp/Lens.hs
@ -5,20 +5,32 @@
				@@ -5,20 +5,32 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FunctionalDependencies #-}

-- | Van Laarhoven lenses for XMPP types. The lenses are designed to work with
-- the lens library. This module also provides a few simple accessors ('view',
-- 'modify', 'set' and 'getAll') so you don't need to pull in the
-- lens library to get some use out of them.
+-- | (More than just) Van Laarhoven lenses for XMPP types. The accessors in here
+-- are designed to work with an optics library like lens or lens-family. This
+-- module also provides a few simple functions ('view', 'modify', 'set' and
+-- 'getAll') so you don't need to pull in another library to get some use out
+-- of them.
 --
-- The name of the lenses corresponds to the field name of the data types with
+-- * The name of the lenses corresponds to the field name of the data types with
 -- an upper-case L appended. For documentation of the fields refer to the documentation of the data types (linked in the section header)
+--
+-- * Same goes for Traversals, except they are suffixed with a \'T\'
+--
+-- * Prism generally start with an underscore
+--
+-- /NB/ you do not need to import this module to get access to the optics
+-- defined herein. They are also exported from Network.Xmpp. You only need to
+-- import this module if you want to use the complementary accessor functions
+-- without using an optics library like lens or lens-family

 module Network.Xmpp.Lens
       ( Lens
       , Traversal
+       , Prism
+       , Iso
         -- * Accessors
         -- | Reimplementation of the basic lens functions so you don't have to
-         -- bring in all of lens library in to use the lenses
+         -- bring in a lens library to use the optics

         -- ** Lenses
       , view
@ -26,9 +38,27 @@ module Network.Xmpp.Lens
				@@ -26,9 +38,27 @@ module Network.Xmpp.Lens
       , set
         -- * Traversals
       , getAll
+         -- * Prisms
+
+         -- ** Construction
+       , prism'
+       , mkLens
+
         -- * Lenses

+         -- ** JID
+       , _JidText
+       , _isFull
+       , _isBare
+
         -- ** Stanzas
+       , _IQRequest
+       , _IQResult
+       , _IQError
+       , _Message
+       , _MessageError
+       , _Presence
+       , _PresenceError
       , IsStanza(..)
       , HasStanzaPayload(..)
       , IsErrorStanza(..)
@ -109,25 +139,39 @@ module Network.Xmpp.Lens
				@@ -109,25 +139,39 @@ module Network.Xmpp.Lens
       where

 import           Control.Applicative
-import           Data.Functor.Identity(Identity(..))
+import qualified Data.ByteString as BS
+import           Data.Functor.Identity (Identity(..))
 import qualified Data.Map as Map
+import           Data.Profunctor
+import           Data.Text (Text)
 import qualified Data.Text as Text
-import           Data.Text(Text)
-import           Data.XML.Types(Element)
-import           Network.DNS(ResolvConf)
+import           Data.XML.Types (Element)
+import           Network.DNS (ResolvConf)
 import           Network.TLS as TLS
 import           Network.Xmpp.Concurrent.Types
 import           Network.Xmpp.IM.Message
 import           Network.Xmpp.IM.Presence
 import           Network.Xmpp.IM.Roster.Types
 import           Network.Xmpp.Types
-import qualified Data.ByteString as BS

 -- | Van-Laarhoven lenses.
 type Lens a b = Functor f => (b -> f b) -> a -> f a

 type Traversal a b = Applicative f => (b -> f b) -> a -> f a

+type Prism a b = forall p f. (Choice p, Applicative f) => p b (f b) -> p a (f a)
+
+type Iso a b = forall p f. (Profunctor p, Functor f) => p a (f a) -> p b (f b)
+
+prism' :: (b -> s) -> (s -> Maybe b) -> Prism s b
+prism' bs sma = dimap (\s -> maybe (Left s) Right (sma s))
+                      (either pure (fmap bs)) . right'
+
+mkLens :: (a -> b) -> (b -> a ->  a) -> Lens a b
+mkLens get set = \inj x -> fmap (flip set x) (inj $ get x)
+
+mkIso :: (a -> b) -> (b -> a) -> Iso a b
+mkIso to from = dimap from (fmap to)

 -- Accessors
 ---------------
@ -154,10 +198,18 @@ instance Applicative (Collect a) where
				@@ -154,10 +198,18 @@ instance Applicative (Collect a) where
 getAll :: Traversal a b -> a -> [b]
 getAll t = getCollection . t (Collect . pure)

-
 -- Xmpp Lenses
 --------------------

+_JidText :: Prism Text Jid
+_JidText = prism' jidToText jidFromText
+
+_isFull :: Prism Jid Jid
+_isFull = prism' id (\j -> if isFull j then Just j else Nothing)
+
+_isBare :: Prism Jid Jid
+_isBare = prism' toBare (\j -> if isBare j then Just j else Nothing)
+
 class IsStanza s where
    -- | From-attribute of the stanza
    from :: Lens s (Maybe Jid)
@ -288,6 +340,48 @@ maybeNonempty inj x = (maybe Text.empty id)
				@@ -288,6 +340,48 @@ maybeNonempty inj x = (maybe Text.empty id)
                      <$> inj (if Text.null x then Nothing else Just x)


+_IQRequest :: Prism Stanza IQRequest
+_IQRequest = prism' IQRequestS fromIQRequestS
+  where
+    fromIQRequestS (IQRequestS s) = Just s
+    fromIQRequestS _ = Nothing
+
+_IQResult :: Prism Stanza IQResult
+_IQResult = prism' IQResultS fromIQResultS
+  where
+    fromIQResultS (IQResultS s) = Just s
+    fromIQResultS _ = Nothing
+
+_IQError :: Prism Stanza IQError
+_IQError = prism' IQErrorS fromIQErrorS
+  where
+    fromIQErrorS (IQErrorS s) = Just s
+    fromIQErrorS _ = Nothing
+
+_Message :: Prism Stanza Message
+_Message = prism' MessageS fromMessageS
+  where
+    fromMessageS (MessageS s) = Just s
+    fromMessageS _ = Nothing
+
+_MessageError :: Prism Stanza MessageError
+_MessageError = prism' MessageErrorS fromMessageErrorS
+  where
+    fromMessageErrorS (MessageErrorS s) = Just s
+    fromMessageErrorS _ = Nothing
+
+_Presence :: Prism Stanza Presence
+_Presence = prism' PresenceS fromPresenceS
+  where
+    fromPresenceS (PresenceS s) = Just s
+    fromPresenceS _ = Nothing
+
+_PresenceError :: Prism Stanza PresenceError
+_PresenceError = prism' PresenceErrorS fromPresenceErrorS
+  where
+    fromPresenceErrorS (PresenceErrorS s) = Just s
+    fromPresenceErrorS _ = Nothing
+
 class IsErrorStanza s where
    -- | Error element of the stanza
    stanzaError :: Lens s StanzaError
--- a/source/Network/Xmpp/Types.hs
+++ b/source/Network/Xmpp/Types.hs
@ -22,6 +22,7 @@ module Network.Xmpp.Types
				@@ -22,6 +22,7 @@ module Network.Xmpp.Types
    , IQResponse(..)
    , IQResult(..)
    , LangTag (..)
+    , langTagQ
    , langTagFromText
    , langTagToText
    , parseLangTag
@ -38,6 +39,8 @@ module Network.Xmpp.Types
				@@ -38,6 +39,8 @@ module Network.Xmpp.Types
    , SaslFailure(..)
    , StreamFeatures(..)
    , Stanza(..)
+    , messageS
+    , presenceS
    , StanzaError(..)
    , StanzaErrorCondition(..)
    , StanzaErrorType(..)
@ -45,6 +48,7 @@ module Network.Xmpp.Types
				@@ -45,6 +48,7 @@ module Network.Xmpp.Types
    , XmppTlsError(..)
    , StreamErrorCondition(..)
    , Version(..)
+    , versionFromText
    , StreamHandle(..)
    , Stream(..)
    , StreamState(..)
@ -53,6 +57,7 @@ module Network.Xmpp.Types
				@@ -53,6 +57,7 @@ module Network.Xmpp.Types
    , ConnectionDetails(..)
    , StreamConfiguration(..)
    , xmppDefaultParams
+    , xmppDefaultParamsStrong
    , Jid(..)
 #if WITH_TEMPLATE_HASKELL
    , jidQ
@ -704,10 +709,10 @@ data StreamFeatures = StreamFeatures
				@@ -704,10 +709,10 @@ data StreamFeatures = StreamFeatures

 -- | Signals the state of the stream connection.
 data ConnectionState
-    = Closed  -- ^ No stream has been established
+    = Closed  -- ^ Stream has not been established yet
    | Plain   -- ^ Stream established, but not secured via TLS
    | Secured -- ^ Stream established and secured via TLS
-    | Finished -- ^ Stream is closed
+    | Finished -- ^ Stream was closed
      deriving (Show, Eq, Typeable)

 -- | Defines operations for sending, receiving, flushing, and closing on a