diff --git a/Network/IRC/Conduit.hs b/Network/IRC/Conduit.hs --- a/Network/IRC/Conduit.hs +++ b/Network/IRC/Conduit.hs @@ -53,6 +53,9 @@ -- *Utilities , rawMessage , toByteString + + -- *Lenses + , module Network.IRC.Conduit.Lens ) where import Control.Applicative ((*>)) @@ -71,6 +74,7 @@ import Data.X509.Validation (FailedReason(..)) import Network.Connection (TLSSettings(..)) import Network.IRC.Conduit.Internal +import Network.IRC.Conduit.Lens import Network.TLS (ClientParams(..), ClientHooks(..), Supported(..), Version(..), defaultParamsClient) import Network.TLS.Extra (ciphersuite_all) diff --git a/Network/IRC/Conduit/Internal.hs b/Network/IRC/Conduit/Internal.hs --- a/Network/IRC/Conduit/Internal.hs +++ b/Network/IRC/Conduit/Internal.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} -- | @@ -9,7 +10,7 @@ -- License : MIT -- Maintainer : Michael Walker -- Stability : experimental --- Portability : BangPatterns, DeriveFunctor, OverloadedStrings, TupleSections +-- Portability : BangPatterns, DeriveFunctor, OverloadedStrings, RankNTypes, TupleSections -- -- Internal IRC conduit types and utilities. This module is NOT -- considered to form part of the public interface of this library. @@ -22,6 +23,7 @@ import Data.Conduit (Conduit, await, yield) import Data.Maybe (listToMaybe, isJust) import Data.Monoid ((<>)) +import Data.Profunctor (Choice) import Data.String (fromString) import Network.IRC.CTCP (CTCPByteString, getUnderlyingByteString, orCTCP) import Text.Read (readMaybe) @@ -29,6 +31,21 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import qualified Network.IRC as I + +-- * Internal Lens synonyms + +-- | See @@. +type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t + +-- | A @@ 'Lens'. +type Lens' s a = Lens s s a a + +-- | See @@. +type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) + +-- | A @@ 'Prism'. +type Prism' s a = Prism s s a a + -- *Conduits diff --git a/Network/IRC/Conduit/Lens.hs b/Network/IRC/Conduit/Lens.hs new file mode 100644 --- /dev/null +++ b/Network/IRC/Conduit/Lens.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Module : Network.IRC.Conduit +-- Copyright : (c) 2017 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : CPP +-- +-- 'Lens'es and 'Prism's. +module Network.IRC.Conduit.Lens where + +import Data.ByteString (ByteString) +import Data.Profunctor (Choice (right'), Profunctor (dimap)) + +import Network.IRC.CTCP (CTCPByteString) +import Network.IRC.Conduit.Internal + +-- CPP seem to dislike the first ' on the RHS… +#define PRIME() ' + +#define LENS(S,F,A) \ + {-# INLINE F #-}; \ + {-| PRIME()Lens' for '_/**/F'. -}; \ + F :: Lens' S A; \ + F = \ afb s -> (\ b -> s {_/**/F = b}) <$> afb (_/**/F s) + +#define PRISM(S,C,ARG,TUP,A) \ + {-| PRIME()Prism' for 'C'. -}; \ + {-# INLINE _/**/C #-}; \ + _/**/C :: Prism' S A; \ + _/**/C = dimap (\ s -> case s of C ARG -> Right TUP; _ -> Left s) \ + (either pure $ fmap (\ TUP -> C ARG)) . right' + +-- * Lenses for 'Event' +LENS((Event a),raw,ByteString) +LENS((Event a),source,(Source a)) +LENS((Event a),message,(Message a)) + +-- * Prisms for 'Source' +PRISM((Source a),User,name,name,(NickName a)) +PRISM((Source a),Channel,chan name,(chan,name),(ChannelName a, NickName a)) +PRISM((Source a),Server,name,name,(ServerName a)) + +-- * #Message# Prisms for 'Message' +PRISM((Message a),Privmsg,tar msg,(tar, msg),(Target a, Either CTCPByteString a)) +PRISM((Message a),Notice,tar msg,(tar, msg),(Target a, Either CTCPByteString a)) +PRISM((Message a),Nick,name,name,(NickName a)) +PRISM((Message a),Join,chan,chan,(ChannelName a)) +PRISM((Message a),Part,chan reason,(chan, reason),(ChannelName a, Reason a)) +PRISM((Message a),Quit,reason,reason,(Reason a)) +PRISM((Message a),Mode,tar is flags args,(tar, is, flags, args),(Target a, IsModeSet, [ModeFlag a], [ModeArg a])) +PRISM((Message a),Topic,name topic,(name, topic),(ChannelName a, a)) +PRISM((Message a),Invite,chan name,(chan, name),(ChannelName a, NickName a)) +PRISM((Message a),Kick,chan name reason,(chan, name, reason),(ChannelName a, NickName a, Reason a)) +PRISM((Message a),Ping,ser ver,(ser, ver),(ServerName a, Maybe (ServerName a))) +PRISM((Message a),Pong,ser,ser,(ServerName a)) +PRISM((Message a),Numeric,num args,(num, args),(Int, [NumericArg a])) +PRISM((Message a),RawMsg,msg,msg,a) diff --git a/irc-conduit.cabal b/irc-conduit.cabal --- a/irc-conduit.cabal +++ b/irc-conduit.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.2.1.1 +version: 0.2.2.0 -- A short (one-line) description of the package. synopsis: Streaming IRC message library using conduits. @@ -68,6 +68,7 @@ -- Modules exported by the library. exposed-modules: Network.IRC.Conduit , Network.IRC.Conduit.Internal + , Network.IRC.Conduit.Lens -- Modules included in this library but not exported. -- other-modules: @@ -87,6 +88,7 @@ , irc >=0.6 && <0.7 , irc-ctcp >=0.1.1 && <0.2 , network-conduit-tls >=1.1 && <1.3 + , profunctors >=5 && <6 , text >=1.0 && <1.3 , time >=1.4 && <1.7 , tls >=1.3 && <1.4 @@ -106,4 +108,4 @@ source-repository this type: git location: https://github.com/barrucadu/irc-conduit.git - tag: 0.2.1.1 + tag: 0.2.2.0