{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}

-- |
-- Module      :  Text.URI.Lens
-- Copyright   :  © 2017–present Mark Karpov
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- Lenses for working with the 'URI' data type and its internals.
module Text.URI.Lens
  ( uriScheme,
    uriAuthority,
    uriPath,
    isPathAbsolute,
    uriTrailingSlash,
    uriQuery,
    uriFragment,
    authUserInfo,
    authHost,
    authPort,
    uiUsername,
    uiPassword,
    _QueryFlag,
    _QueryParam,
    queryFlag,
    queryParam,
    unRText,
  )
where

import Data.Foldable (find)
import Data.Functor.Contravariant
import qualified Data.List.NonEmpty as NE
import Data.Maybe (isJust)
import Data.Profunctor
import Data.Text (Text)
import Text.URI.Types
  ( Authority,
    QueryParam (..),
    RText,
    RTextLabel (..),
    URI,
    UserInfo,
  )
import qualified Text.URI.Types as URI

#if !MIN_VERSION_base(4,18,0)
import Control.Applicative (liftA2)
#endif

-- | 'URI' scheme lens.
uriScheme :: Lens' URI (Maybe (RText 'Scheme))
uriScheme :: Lens' URI (Maybe (RText 'Scheme))
uriScheme Maybe (RText 'Scheme) -> f (Maybe (RText 'Scheme))
f URI
s = (\Maybe (RText 'Scheme)
x -> URI
s {uriScheme :: Maybe (RText 'Scheme)
URI.uriScheme = Maybe (RText 'Scheme)
x}) 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)

-- | 'URI' authority lens.
--
-- __Note__: before version /0.1.0.0/ this lens allowed to focus on @'Maybe'
-- 'URI.Authority'@.
uriAuthority :: Lens' URI (Either Bool URI.Authority)
uriAuthority :: Lens' URI (Either Bool Authority)
uriAuthority Either Bool Authority -> f (Either Bool Authority)
f URI
s = (\Either Bool Authority
x -> URI
s {uriAuthority :: Either Bool Authority
URI.uriAuthority = Either Bool Authority
x}) 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)

-- | 'URI' path lens.
uriPath :: Lens' URI [RText 'PathPiece]
uriPath :: Lens' URI [RText 'PathPiece]
uriPath [RText 'PathPiece] -> f [RText 'PathPiece]
f URI
s = (\[RText 'PathPiece]
x -> URI
s {uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece))
URI.uriPath = (Bool
ts,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [RText 'PathPiece]
x}) 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False forall a b. (a, b) -> a
fst Maybe (Bool, NonEmpty (RText 'PathPiece))
path
    ps :: [RText 'PathPiece]
ps = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a. NonEmpty a -> [a]
NE.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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

-- | A getter that can tell if path component of a 'URI' is absolute.
--
-- @since 0.1.0.0
isPathAbsolute :: Getter URI Bool
isPathAbsolute :: Getter URI Bool
isPathAbsolute = forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> p a (f a) -> p s (f s)
to URI -> Bool
URI.isPathAbsolute

-- | A 0-1 traversal allowing to view and manipulate trailing slash.
--
-- @since 0.2.0.0
uriTrailingSlash :: Traversal' URI Bool
uriTrailingSlash :: Traversal' URI Bool
uriTrailingSlash Bool -> f Bool
f URI
s =
  (\Maybe Bool
x -> URI
s {uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece))
URI.uriPath = 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}) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Bool, NonEmpty (RText 'PathPiece))
path
    ps :: Maybe (NonEmpty (RText 'PathPiece))
ps = forall a b. (a, b) -> b
snd 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

-- | 'URI' query params lens.
uriQuery :: Lens' URI [URI.QueryParam]
uriQuery :: Lens' URI [QueryParam]
uriQuery [QueryParam] -> f [QueryParam]
f URI
s = (\[QueryParam]
x -> URI
s {uriQuery :: [QueryParam]
URI.uriQuery = [QueryParam]
x}) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [QueryParam] -> f [QueryParam]
f (URI -> [QueryParam]
URI.uriQuery URI
s)

-- | 'URI' fragment lens.
uriFragment :: Lens' URI (Maybe (RText 'Fragment))
uriFragment :: Lens' URI (Maybe (RText 'Fragment))
uriFragment Maybe (RText 'Fragment) -> f (Maybe (RText 'Fragment))
f URI
s = (\Maybe (RText 'Fragment)
x -> URI
s {uriFragment :: Maybe (RText 'Fragment)
URI.uriFragment = Maybe (RText 'Fragment)
x}) 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)

-- | 'Authority' user info lens.
authUserInfo :: Lens' Authority (Maybe URI.UserInfo)
authUserInfo :: Lens' Authority (Maybe UserInfo)
authUserInfo Maybe UserInfo -> f (Maybe UserInfo)
f Authority
s = (\Maybe UserInfo
x -> Authority
s {authUserInfo :: Maybe UserInfo
URI.authUserInfo = Maybe UserInfo
x}) 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)

-- | 'Authority' host lens.
authHost :: Lens' Authority (RText 'Host)
authHost :: Lens' Authority (RText 'Host)
authHost RText 'Host -> f (RText 'Host)
f Authority
s = (\RText 'Host
x -> Authority
s {authHost :: RText 'Host
URI.authHost = RText 'Host
x}) 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)

-- | 'Authority' port lens.
authPort :: Lens' Authority (Maybe Word)
authPort :: Lens' Authority (Maybe Word)
authPort Maybe Word -> f (Maybe Word)
f Authority
s = (\Maybe Word
x -> Authority
s {authPort :: Maybe Word
URI.authPort = Maybe Word
x}) 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)

-- | 'UserInfo' username lens.
uiUsername :: Lens' UserInfo (RText 'Username)
uiUsername :: Lens' UserInfo (RText 'Username)
uiUsername RText 'Username -> f (RText 'Username)
f UserInfo
s = (\RText 'Username
x -> UserInfo
s {uiUsername :: RText 'Username
URI.uiUsername = RText 'Username
x}) 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)

-- | 'UserInfo' password lens.
uiPassword :: Lens' UserInfo (Maybe (RText 'Password))
uiPassword :: Lens' UserInfo (Maybe (RText 'Password))
uiPassword Maybe (RText 'Password) -> f (Maybe (RText 'Password))
f UserInfo
s = (\Maybe (RText 'Password)
x -> UserInfo
s {uiPassword :: Maybe (RText 'Password)
URI.uiPassword = Maybe (RText 'Password)
x}) 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)

-- | 'QueryParam' prism for query flags.
_QueryFlag :: Prism' URI.QueryParam (RText 'QueryKey)
_QueryFlag :: Prism' QueryParam (RText 'QueryKey)
_QueryFlag = forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' RText 'QueryKey -> QueryParam
QueryFlag forall a b. (a -> b) -> a -> b
$ \case
  QueryFlag RText 'QueryKey
x -> forall a. a -> Maybe a
Just RText 'QueryKey
x
  QueryParam
_ -> forall a. Maybe a
Nothing

-- | 'QueryParam' prism for query parameters.
_QueryParam :: Prism' QueryParam (RText 'QueryKey, RText 'QueryValue)
_QueryParam :: Prism' QueryParam (RText 'QueryKey, RText 'QueryValue)
_QueryParam = 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 (RText 'QueryKey
x, 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 RText 'QueryKey
x RText 'QueryValue
y -> forall a. a -> Maybe a
Just (RText 'QueryKey
x, RText 'QueryValue
y)
      QueryParam
_ -> forall a. Maybe a
Nothing

-- | Check if the given query key is present in the collection of query
-- parameters.
queryFlag :: RText 'QueryKey -> Getter [URI.QueryParam] Bool
queryFlag :: RText 'QueryKey -> Getter [QueryParam] Bool
queryFlag RText 'QueryKey
k = forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> p a (f a) -> p s (f s)
to (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find QueryParam -> Bool
g)
  where
    g :: QueryParam -> Bool
g (QueryFlag RText 'QueryKey
k') = RText 'QueryKey
k' forall a. Eq a => a -> a -> Bool
== RText 'QueryKey
k
    g QueryParam
_ = Bool
False

-- | Manipulate a query parameter by its key. Note that since there may be
-- several query parameters with the same key this is a traversal that can
-- return\/modify several items at once.
queryParam :: RText 'QueryKey -> Traversal' [URI.QueryParam] (RText 'QueryValue)
queryParam :: RText 'QueryKey -> Traversal' [QueryParam] (RText 'QueryValue)
queryParam RText 'QueryKey
k RText 'QueryValue -> f (RText 'QueryValue)
f = 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 RText 'QueryKey
k' RText 'QueryValue
v) =
      if RText 'QueryKey
k forall a. Eq a => a -> a -> Bool
== RText 'QueryKey
k'
        then RText 'QueryKey -> RText 'QueryValue -> QueryParam
QueryParam RText 'QueryKey
k' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RText 'QueryValue -> f (RText 'QueryValue)
f RText 'QueryValue
v
        else forall (f :: * -> *) a. Applicative f => a -> f a
pure QueryParam
p
    g QueryParam
p = forall (f :: * -> *) a. Applicative f => a -> f a
pure QueryParam
p

-- | A getter that can project 'Text' from refined text values.
unRText :: Getter (RText l) Text
unRText :: forall (l :: RTextLabel). Getter (RText l) Text
unRText = forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> p a (f a) -> p s (f s)
to forall (l :: RTextLabel). RText l -> Text
URI.unRText

----------------------------------------------------------------------------
-- Helpers

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

-- | Build a 'Prism'.
prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
prism :: forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism b -> t
bt s -> Either t a
seta = forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> Either t a
seta (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> t
bt)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right'

-- | Another way to build a 'Prism'.
prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' :: forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' b -> s
bs s -> Maybe a
sma = forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism b -> s
bs (\s
s -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left s
s) forall a b. b -> Either a b
Right (s -> Maybe a
sma s
s))

-- | Lift a function into optic.
to :: (Profunctor p, Contravariant f) => (s -> a) -> (p a (f a) -> p s (f s))
to :: forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> p a (f a) -> p s (f s)
to s -> a
f = forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> a
f (forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap s -> a
f)