{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
module Text.URI.Lens
( uriScheme
, uriAuthority
, uriPath
, isPathAbsolute
, uriTrailingSlash
, uriQuery
, uriFragment
, authUserInfo
, authHost
, authPort
, uiUsername
, uiPassword
, _QueryFlag
, _QueryParam
, queryFlag
, queryParam
, unRText )
where
import Control.Applicative (liftA2)
import Data.Foldable (find)
import Data.Functor.Contravariant
import Data.Maybe (isJust)
import Data.Profunctor
import Data.Text (Text)
import Text.URI.Types (URI, Authority, UserInfo, QueryParam (..), RText, RTextLabel (..))
import qualified Data.List.NonEmpty as NE
import qualified Text.URI.Types as URI
uriScheme :: Lens' URI (Maybe (RText 'Scheme))
uriScheme :: (Maybe (RText 'Scheme) -> f (Maybe (RText 'Scheme)))
-> URI -> f URI
uriScheme f :: Maybe (RText 'Scheme) -> f (Maybe (RText 'Scheme))
f s :: URI
s = (\x :: Maybe (RText 'Scheme)
x -> URI
s { uriScheme :: Maybe (RText 'Scheme)
URI.uriScheme = Maybe (RText 'Scheme)
x }) (Maybe (RText 'Scheme) -> URI)
-> f (Maybe (RText 'Scheme)) -> f URI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (RText 'Scheme) -> f (Maybe (RText 'Scheme))
f (URI -> Maybe (RText 'Scheme)
URI.uriScheme URI
s)
uriAuthority :: Lens' URI (Either Bool URI.Authority)
uriAuthority :: (Either Bool Authority -> f (Either Bool Authority))
-> URI -> f URI
uriAuthority f :: Either Bool Authority -> f (Either Bool Authority)
f s :: URI
s = (\x :: Either Bool Authority
x -> URI
s { uriAuthority :: Either Bool Authority
URI.uriAuthority = Either Bool Authority
x }) (Either Bool Authority -> URI)
-> f (Either Bool Authority) -> f URI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Bool Authority -> f (Either Bool Authority)
f (URI -> Either Bool Authority
URI.uriAuthority URI
s)
uriPath :: Lens' URI [RText 'PathPiece]
uriPath :: ([RText 'PathPiece] -> f [RText 'PathPiece]) -> URI -> f URI
uriPath f :: [RText 'PathPiece] -> f [RText 'PathPiece]
f s :: URI
s = (\x :: [RText 'PathPiece]
x -> URI
s { uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece))
URI.uriPath = (Bool
ts,) (NonEmpty (RText 'PathPiece)
-> (Bool, NonEmpty (RText 'PathPiece)))
-> Maybe (NonEmpty (RText 'PathPiece))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RText 'PathPiece] -> Maybe (NonEmpty (RText 'PathPiece))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [RText 'PathPiece]
x }) ([RText 'PathPiece] -> URI) -> f [RText 'PathPiece] -> f URI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RText 'PathPiece] -> f [RText 'PathPiece]
f [RText 'PathPiece]
ps
where
ts :: Bool
ts = Bool
-> ((Bool, NonEmpty (RText 'PathPiece)) -> Bool)
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool, NonEmpty (RText 'PathPiece)) -> Bool
forall a b. (a, b) -> a
fst Maybe (Bool, NonEmpty (RText 'PathPiece))
path
ps :: [RText 'PathPiece]
ps = [RText 'PathPiece]
-> ((Bool, NonEmpty (RText 'PathPiece)) -> [RText 'PathPiece])
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
-> [RText 'PathPiece]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (NonEmpty (RText 'PathPiece) -> [RText 'PathPiece]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (RText 'PathPiece) -> [RText 'PathPiece])
-> ((Bool, NonEmpty (RText 'PathPiece))
-> NonEmpty (RText 'PathPiece))
-> (Bool, NonEmpty (RText 'PathPiece))
-> [RText 'PathPiece]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, NonEmpty (RText 'PathPiece)) -> NonEmpty (RText 'PathPiece)
forall a b. (a, b) -> b
snd) Maybe (Bool, NonEmpty (RText 'PathPiece))
path
path :: Maybe (Bool, NonEmpty (RText 'PathPiece))
path = URI -> Maybe (Bool, NonEmpty (RText 'PathPiece))
URI.uriPath URI
s
isPathAbsolute :: Getter URI Bool
isPathAbsolute :: (Bool -> f Bool) -> URI -> f URI
isPathAbsolute = (URI -> Bool) -> (Bool -> f Bool) -> URI -> f URI
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> p a (f a) -> p s (f s)
to URI -> Bool
URI.isPathAbsolute
uriTrailingSlash :: Traversal' URI Bool
uriTrailingSlash :: (Bool -> f Bool) -> URI -> f URI
uriTrailingSlash f :: Bool -> f Bool
f s :: URI
s =
(\x :: Maybe Bool
x -> URI
s { uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece))
URI.uriPath = (Bool
-> NonEmpty (RText 'PathPiece)
-> (Bool, NonEmpty (RText 'PathPiece)))
-> Maybe Bool
-> Maybe (NonEmpty (RText 'PathPiece))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) Maybe Bool
x Maybe (NonEmpty (RText 'PathPiece))
ps }) (Maybe Bool -> URI) -> f (Maybe Bool) -> f URI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> f Bool) -> Maybe Bool -> f (Maybe Bool)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Bool -> f Bool
f Maybe Bool
ts
where
ts :: Maybe Bool
ts = (Bool, NonEmpty (RText 'PathPiece)) -> Bool
forall a b. (a, b) -> a
fst ((Bool, NonEmpty (RText 'PathPiece)) -> Bool)
-> Maybe (Bool, NonEmpty (RText 'PathPiece)) -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Bool, NonEmpty (RText 'PathPiece))
path
ps :: Maybe (NonEmpty (RText 'PathPiece))
ps = (Bool, NonEmpty (RText 'PathPiece)) -> NonEmpty (RText 'PathPiece)
forall a b. (a, b) -> b
snd ((Bool, NonEmpty (RText 'PathPiece))
-> NonEmpty (RText 'PathPiece))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
-> Maybe (NonEmpty (RText 'PathPiece))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Bool, NonEmpty (RText 'PathPiece))
path
path :: Maybe (Bool, NonEmpty (RText 'PathPiece))
path = URI -> Maybe (Bool, NonEmpty (RText 'PathPiece))
URI.uriPath URI
s
uriQuery :: Lens' URI [URI.QueryParam]
uriQuery :: ([QueryParam] -> f [QueryParam]) -> URI -> f URI
uriQuery f :: [QueryParam] -> f [QueryParam]
f s :: URI
s = (\x :: [QueryParam]
x -> URI
s { uriQuery :: [QueryParam]
URI.uriQuery = [QueryParam]
x }) ([QueryParam] -> URI) -> f [QueryParam] -> f URI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [QueryParam] -> f [QueryParam]
f (URI -> [QueryParam]
URI.uriQuery URI
s)
uriFragment :: Lens' URI (Maybe (RText 'Fragment))
uriFragment :: (Maybe (RText 'Fragment) -> f (Maybe (RText 'Fragment)))
-> URI -> f URI
uriFragment f :: Maybe (RText 'Fragment) -> f (Maybe (RText 'Fragment))
f s :: URI
s = (\x :: Maybe (RText 'Fragment)
x -> URI
s { uriFragment :: Maybe (RText 'Fragment)
URI.uriFragment = Maybe (RText 'Fragment)
x }) (Maybe (RText 'Fragment) -> URI)
-> f (Maybe (RText 'Fragment)) -> f URI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (RText 'Fragment) -> f (Maybe (RText 'Fragment))
f (URI -> Maybe (RText 'Fragment)
URI.uriFragment URI
s)
authUserInfo :: Lens' Authority (Maybe URI.UserInfo)
authUserInfo :: (Maybe UserInfo -> f (Maybe UserInfo)) -> Authority -> f Authority
authUserInfo f :: Maybe UserInfo -> f (Maybe UserInfo)
f s :: Authority
s = (\x :: Maybe UserInfo
x -> Authority
s { authUserInfo :: Maybe UserInfo
URI.authUserInfo = Maybe UserInfo
x }) (Maybe UserInfo -> Authority) -> f (Maybe UserInfo) -> f Authority
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UserInfo -> f (Maybe UserInfo)
f (Authority -> Maybe UserInfo
URI.authUserInfo Authority
s)
authHost :: Lens' Authority (RText 'Host)
authHost :: (RText 'Host -> f (RText 'Host)) -> Authority -> f Authority
authHost f :: RText 'Host -> f (RText 'Host)
f s :: Authority
s = (\x :: RText 'Host
x -> Authority
s { authHost :: RText 'Host
URI.authHost = RText 'Host
x }) (RText 'Host -> Authority) -> f (RText 'Host) -> f Authority
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RText 'Host -> f (RText 'Host)
f (Authority -> RText 'Host
URI.authHost Authority
s)
authPort :: Lens' Authority (Maybe Word)
authPort :: (Maybe Word -> f (Maybe Word)) -> Authority -> f Authority
authPort f :: Maybe Word -> f (Maybe Word)
f s :: Authority
s = (\x :: Maybe Word
x -> Authority
s { authPort :: Maybe Word
URI.authPort = Maybe Word
x }) (Maybe Word -> Authority) -> f (Maybe Word) -> f Authority
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Word -> f (Maybe Word)
f (Authority -> Maybe Word
URI.authPort Authority
s)
uiUsername :: Lens' UserInfo (RText 'Username)
uiUsername :: (RText 'Username -> f (RText 'Username)) -> UserInfo -> f UserInfo
uiUsername f :: RText 'Username -> f (RText 'Username)
f s :: UserInfo
s = (\x :: RText 'Username
x -> UserInfo
s { uiUsername :: RText 'Username
URI.uiUsername = RText 'Username
x }) (RText 'Username -> UserInfo) -> f (RText 'Username) -> f UserInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RText 'Username -> f (RText 'Username)
f (UserInfo -> RText 'Username
URI.uiUsername UserInfo
s)
uiPassword :: Lens' UserInfo (Maybe (RText 'Password))
uiPassword :: (Maybe (RText 'Password) -> f (Maybe (RText 'Password)))
-> UserInfo -> f UserInfo
uiPassword f :: Maybe (RText 'Password) -> f (Maybe (RText 'Password))
f s :: UserInfo
s = (\x :: Maybe (RText 'Password)
x -> UserInfo
s { uiPassword :: Maybe (RText 'Password)
URI.uiPassword = Maybe (RText 'Password)
x }) (Maybe (RText 'Password) -> UserInfo)
-> f (Maybe (RText 'Password)) -> f UserInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (RText 'Password) -> f (Maybe (RText 'Password))
f (UserInfo -> Maybe (RText 'Password)
URI.uiPassword UserInfo
s)
_QueryFlag :: Prism' URI.QueryParam (RText 'QueryKey)
_QueryFlag :: p (RText 'QueryKey) (f (RText 'QueryKey))
-> p QueryParam (f QueryParam)
_QueryFlag = (RText 'QueryKey -> QueryParam)
-> (QueryParam -> Maybe (RText 'QueryKey))
-> Prism QueryParam QueryParam (RText 'QueryKey) (RText 'QueryKey)
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' RText 'QueryKey -> QueryParam
QueryFlag ((QueryParam -> Maybe (RText 'QueryKey))
-> p (RText 'QueryKey) (f (RText 'QueryKey))
-> p QueryParam (f QueryParam))
-> (QueryParam -> Maybe (RText 'QueryKey))
-> p (RText 'QueryKey) (f (RText 'QueryKey))
-> p QueryParam (f QueryParam)
forall a b. (a -> b) -> a -> b
$ \case
QueryFlag x :: RText 'QueryKey
x -> RText 'QueryKey -> Maybe (RText 'QueryKey)
forall a. a -> Maybe a
Just RText 'QueryKey
x
_ -> Maybe (RText 'QueryKey)
forall a. Maybe a
Nothing
_QueryParam :: Prism' QueryParam (RText 'QueryKey, RText 'QueryValue)
_QueryParam :: p (RText 'QueryKey, RText 'QueryValue)
(f (RText 'QueryKey, RText 'QueryValue))
-> p QueryParam (f QueryParam)
_QueryParam = ((RText 'QueryKey, RText 'QueryValue) -> QueryParam)
-> (QueryParam -> Maybe (RText 'QueryKey, RText 'QueryValue))
-> Prism
QueryParam
QueryParam
(RText 'QueryKey, RText 'QueryValue)
(RText 'QueryKey, RText 'QueryValue)
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (RText 'QueryKey, RText 'QueryValue) -> QueryParam
construct QueryParam -> Maybe (RText 'QueryKey, RText 'QueryValue)
pick
where
construct :: (RText 'QueryKey, RText 'QueryValue) -> QueryParam
construct (x :: RText 'QueryKey
x, y :: RText 'QueryValue
y) = RText 'QueryKey -> RText 'QueryValue -> QueryParam
QueryParam RText 'QueryKey
x RText 'QueryValue
y
pick :: QueryParam -> Maybe (RText 'QueryKey, RText 'QueryValue)
pick = \case
QueryParam x :: RText 'QueryKey
x y :: RText 'QueryValue
y -> (RText 'QueryKey, RText 'QueryValue)
-> Maybe (RText 'QueryKey, RText 'QueryValue)
forall a. a -> Maybe a
Just (RText 'QueryKey
x, RText 'QueryValue
y)
_ -> Maybe (RText 'QueryKey, RText 'QueryValue)
forall a. Maybe a
Nothing
queryFlag :: RText 'QueryKey -> Getter [URI.QueryParam] Bool
queryFlag :: RText 'QueryKey -> Getter [QueryParam] Bool
queryFlag k :: RText 'QueryKey
k = ([QueryParam] -> Bool)
-> (Bool -> f Bool) -> [QueryParam] -> f [QueryParam]
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> p a (f a) -> p s (f s)
to (Maybe QueryParam -> Bool
forall a. Maybe a -> Bool
isJust (Maybe QueryParam -> Bool)
-> ([QueryParam] -> Maybe QueryParam) -> [QueryParam] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QueryParam -> Bool) -> [QueryParam] -> Maybe QueryParam
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find QueryParam -> Bool
g)
where
g :: QueryParam -> Bool
g (QueryFlag k' :: RText 'QueryKey
k') = RText 'QueryKey
k' RText 'QueryKey -> RText 'QueryKey -> Bool
forall a. Eq a => a -> a -> Bool
== RText 'QueryKey
k
g _ = Bool
False
queryParam :: RText 'QueryKey -> Traversal' [URI.QueryParam] (RText 'QueryValue)
queryParam :: RText 'QueryKey -> Traversal' [QueryParam] (RText 'QueryValue)
queryParam k :: RText 'QueryKey
k f :: RText 'QueryValue -> f (RText 'QueryValue)
f = (QueryParam -> f QueryParam) -> [QueryParam] -> f [QueryParam]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse QueryParam -> f QueryParam
g
where
g :: QueryParam -> f QueryParam
g p :: QueryParam
p@(QueryParam k' :: RText 'QueryKey
k' v :: RText 'QueryValue
v) =
if RText 'QueryKey
k RText 'QueryKey -> RText 'QueryKey -> Bool
forall a. Eq a => a -> a -> Bool
== RText 'QueryKey
k'
then RText 'QueryKey -> RText 'QueryValue -> QueryParam
QueryParam RText 'QueryKey
k' (RText 'QueryValue -> QueryParam)
-> f (RText 'QueryValue) -> f QueryParam
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RText 'QueryValue -> f (RText 'QueryValue)
f RText 'QueryValue
v
else QueryParam -> f QueryParam
forall (f :: * -> *) a. Applicative f => a -> f a
pure QueryParam
p
g p :: QueryParam
p = QueryParam -> f QueryParam
forall (f :: * -> *) a. Applicative f => a -> f a
pure QueryParam
p
unRText :: Getter (RText l) Text
unRText :: (Text -> f Text) -> RText l -> f (RText l)
unRText = (RText l -> Text) -> (Text -> f Text) -> RText l -> f (RText l)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> p a (f a) -> p s (f s)
to RText l -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText
type Lens' s a =
forall f. Functor f => (a -> f a) -> s -> f s
type Traversal' s a =
forall f. Applicative f => (a -> f a) -> s -> f s
type Getter s a =
forall f. (Contravariant f, Functor f) => (a -> f a) -> s -> f s
type Prism s t a b =
forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
type Prism' s a = Prism s s a a
prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
prism bt :: b -> t
bt seta :: s -> Either t a
seta = (s -> Either t a)
-> (Either t (f b) -> f t)
-> p (Either t a) (Either t (f b))
-> p s (f t)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> Either t a
seta ((t -> f t) -> (f b -> f t) -> Either t (f b) -> f t
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either t -> f t
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((b -> t) -> f b -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> t
bt)) (p (Either t a) (Either t (f b)) -> p s (f t))
-> (p a (f b) -> p (Either t a) (Either t (f b)))
-> p a (f b)
-> p s (f t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a (f b) -> p (Either t a) (Either t (f b))
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right'
prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' bs :: b -> s
bs sma :: s -> Maybe a
sma = (b -> s) -> (s -> Either s a) -> Prism s s a b
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism b -> s
bs (\s :: s
s -> Either s a -> (a -> Either s a) -> Maybe a -> Either s a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (s -> Either s a
forall a b. a -> Either a b
Left s
s) a -> Either s a
forall a b. b -> Either a b
Right (s -> Maybe a
sma s
s))
to :: (Profunctor p, Contravariant f) => (s -> a) -> (p a (f a) -> p s (f s))
to :: (s -> a) -> p a (f a) -> p s (f s)
to f :: s -> a
f = (s -> a) -> (f a -> f s) -> p a (f a) -> p s (f s)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> a
f ((s -> a) -> f a -> f s
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap s -> a
f)