Permalink
Browse files

lens updates

  • Loading branch information...
1 parent 9e776a3 commit e3b949455396a05aed57edde6ab0b483d38edd62 @Philonous Philonous committed Jul 4, 2014
View
@@ -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
@@ -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 .
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"
@@ -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.
View
@@ -5,30 +5,60 @@
{-# 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
, modify
, 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
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
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)
<$> 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
@@ -22,6 +22,7 @@ module Network.Xmpp.Types
, IQResponse(..)
, IQResult(..)
, LangTag (..)
+ , langTagQ
, langTagFromText
, langTagToText
, parseLangTag
@@ -38,13 +39,16 @@ module Network.Xmpp.Types
, SaslFailure(..)
, StreamFeatures(..)
, Stanza(..)
+ , messageS
+ , presenceS
, StanzaError(..)
, StanzaErrorCondition(..)
, StanzaErrorType(..)
, XmppFailure(..)
, XmppTlsError(..)
, StreamErrorCondition(..)
, Version(..)
+ , versionFromText
, StreamHandle(..)
, Stream(..)
, StreamState(..)
@@ -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
-- | 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

0 comments on commit e3b9494

Please sign in to comment.