Browse Source

lens and type cleanup

master
Philipp Balzarek 12 years ago
parent
commit
d17a918510
  1. 10
      pontarius-xmpp.cabal
  2. 33
      source/Network/Xmpp/Lens.hs
  3. 3
      source/Network/Xmpp/Stream.hs
  4. 1
      source/Network/Xmpp/Types.hs

10
pontarius-xmpp.cabal

@ -50,12 +50,14 @@ Library
, dns >=0.3.0 , dns >=0.3.0
, hslogger >=1.1.0 , hslogger >=1.1.0
, iproute >=1.2.4 , iproute >=1.2.4
, lens-family
, lifted-base >=0.1.0.1 , lifted-base >=0.1.0.1
, mtl >=2.0.0.0 , mtl >=2.0.0.0
, network >=2.3.1.0 , network >=2.3.1.0
, profunctors >= 4
, pureMD5 >=2.1.2.1 , pureMD5 >=2.1.2.1
, resourcet >=0.3.0
, random >=1.0.0.0 , random >=1.0.0.0
, resourcet >=0.3.0
, split >=0.1.2.3 , split >=0.1.2.3
, stm >=2.4 , stm >=2.4
, stringprep >=1.0.0 , stringprep >=1.0.0
@ -64,12 +66,10 @@ Library
, transformers >=0.2.2.0 , transformers >=0.2.2.0
, unbounded-delays >=0.1 , unbounded-delays >=0.1
, void >=0.5.5 , void >=0.5.5
, xml-types >=0.3.1 , x509-system >=1.4
, xml-conduit >=1.1.0.7 , xml-conduit >=1.1.0.7
, xml-picklers >=0.3.3 , xml-picklers >=0.3.3
, x509-system >=1.4 , xml-types >=0.3.1
, profunctors >= 4
, lens-family
If impl(ghc ==7.0.1) { If impl(ghc ==7.0.1) {
Build-Depends: bytestring >=0.9.1.9 && <=0.9.2.1 Build-Depends: bytestring >=0.9.1.9 && <=0.9.2.1

33
source/Network/Xmpp/Lens.hs

@ -33,9 +33,9 @@ module Network.Xmpp.Lens
-- bring in a lens library to use the optics -- bring in a lens library to use the optics
-- ** Lenses -- ** Lenses
, view , LF.view
, modify , modify
, set , LF.set
-- * Traversals -- * Traversals
, getAll , getAll
-- * Prisms -- * Prisms
@ -43,7 +43,7 @@ module Network.Xmpp.Lens
-- ** Construction -- ** Construction
, prism' , prism'
, mkLens , mkLens
, mkIso
-- * Lenses -- * Lenses
-- ** JID -- ** JID
@ -146,6 +146,7 @@ import Data.Profunctor
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.XML.Types (Element) import Data.XML.Types (Element)
import qualified Lens.Family2 as LF
import Network.DNS (ResolvConf) import Network.DNS (ResolvConf)
import Network.TLS as TLS import Network.TLS as TLS
import Network.Xmpp.Concurrent.Types import Network.Xmpp.Concurrent.Types
@ -155,13 +156,15 @@ import Network.Xmpp.IM.Roster.Types
import Network.Xmpp.Types import Network.Xmpp.Types
-- | Van-Laarhoven lenses. -- | Van-Laarhoven lenses.
{-# DEPRECATED Lens "Use Lens' from lens-family or lens" #-}
type Lens a b = Functor f => (b -> f b) -> a -> f a type Lens a b = Functor f => (b -> f b) -> a -> f a
{-# DEPRECATED Traversal "Use Traversal' from lens-family or lens" #-}
type Traversal a b = Applicative 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 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) type Iso a b = forall p f. (Profunctor p, Functor f) => p b (f b) -> p a (f a)
prism' :: (b -> s) -> (s -> Maybe b) -> Prism s b prism' :: (b -> s) -> (s -> Maybe b) -> Prism s b
prism' bs sma = dimap (\s -> maybe (Left s) Right (sma s)) prism' bs sma = dimap (\s -> maybe (Left s) Right (sma s))
@ -171,22 +174,7 @@ mkLens :: (a -> b) -> (b -> a -> a) -> Lens a b
mkLens get set = \inj x -> fmap (flip set x) (inj $ get x) mkLens get set = \inj x -> fmap (flip set x) (inj $ get x)
mkIso :: (a -> b) -> (b -> a) -> Iso a b mkIso :: (a -> b) -> (b -> a) -> Iso a b
mkIso to from = dimap from (fmap to) mkIso t f = dimap t (fmap f)
-- Accessors
---------------
-- | Read the value the lens is pointing to
view :: Lens a b -> a -> b
view l x = getConst $ l Const x
-- | Replace the value the lens is pointing to
set :: Lens a b -> b -> a -> a
set l b x = modify l (const b) x
-- | modify the Value(s) a Lens or Traversal is pointing to
modify :: Traversal a b -> (b -> b) -> a -> a
modify t f = runIdentity . t (Identity . f)
newtype Collect a b = Collect {getCollection :: [a]} deriving Functor newtype Collect a b = Collect {getCollection :: [a]} deriving Functor
@ -194,10 +182,15 @@ instance Applicative (Collect a) where
pure _ = Collect [] pure _ = Collect []
Collect xs <*> Collect ys = Collect $ xs ++ ys Collect xs <*> Collect ys = Collect $ xs ++ ys
{-# DEPRECATED getAll "use toListOf (lens-family), partsOf (lens) or similar" #-}
-- | Return all the values a Traversal is pointing to in a list -- | Return all the values a Traversal is pointing to in a list
getAll :: Traversal a b -> a -> [b] getAll :: Traversal a b -> a -> [b]
getAll t = getCollection . t (Collect . pure) getAll t = getCollection . t (Collect . pure)
{-# DEPRECATED modify "use over (lens-family, lens)" #-}
modify :: Traversal a b -> (b -> b) -> a -> a
modify t f = runIdentity . t (Identity . f)
-- Xmpp Lenses -- Xmpp Lenses
-------------------- --------------------

3
source/Network/Xmpp/Stream.hs

@ -44,6 +44,7 @@ import System.IO
import System.Log.Logger import System.Log.Logger
import System.Random (randomRIO) import System.Random (randomRIO)
import Text.XML.Stream.Parse as XP import Text.XML.Stream.Parse as XP
import Lens.Family2 (over)
import Network.Xmpp.Utilities import Network.Xmpp.Utilities
import qualified Network.Xmpp.Lens as L import qualified Network.Xmpp.Lens as L
@ -553,7 +554,7 @@ createStream realm config = do
tlsIdentL = L.tlsParamsL . L.clientServerIdentificationL tlsIdentL = L.tlsParamsL . L.clientServerIdentificationL
updateHost host ("", _) = (host, "") updateHost host ("", _) = (host, "")
updateHost _ hst = hst updateHost _ hst = hst
maybeSetTlsHost host = L.modify tlsIdentL (updateHost host) maybeSetTlsHost host = over tlsIdentL (updateHost host)
-- Connects using the specified method. Returns the Handle acquired, if any. -- Connects using the specified method. Returns the Handle acquired, if any.
connect :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO connect :: HostName -> StreamConfiguration -> ErrorT XmppFailure IO

1
source/Network/Xmpp/Types.hs

@ -79,7 +79,6 @@ module Network.Xmpp.Types
, parseJid , parseJid
, TlsBehaviour(..) , TlsBehaviour(..)
, AuthFailure(..) , AuthFailure(..)
, versionFromText
) where ) where
import Control.Applicative ((<$>), (<|>), many) import Control.Applicative ((<$>), (<|>), many)

Loading…
Cancel
Save