Lens.hs

{-# 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 f s = (\x -> s {URI.uriScheme = x}) <$> f (URI.uriScheme 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 f s = (\x -> s {URI.uriAuthority = x}) <$> f (URI.uriAuthority s)

-- | 'URI' path lens.
uriPath :: Lens' URI [RText 'PathPiece]
uriPath f s = (\x -> s {URI.uriPath = (ts,) <$> NE.nonEmpty x}) <$> f ps
  where
    ts = maybe False fst path
    ps = maybe [] (NE.toList . snd) path
    path = URI.uriPath s

-- | A getter that can tell if path component of a 'URI' is absolute.
--
-- @since 0.1.0.0
isPathAbsolute :: Getter URI Bool
isPathAbsolute = to URI.isPathAbsolute

-- | A 0-1 traversal allowing to view and manipulate trailing slash.
--
-- @since 0.2.0.0
uriTrailingSlash :: Traversal' URI Bool
uriTrailingSlash f s =
  (\x -> s {URI.uriPath = liftA2 (,) x ps}) <$> traverse f ts
  where
    ts = fst <$> path
    ps = snd <$> path
    path = URI.uriPath s

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

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

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

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

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

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

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

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

-- | 'QueryParam' prism for query parameters.
_QueryParam :: Prism' QueryParam (RText 'QueryKey, RText 'QueryValue)
_QueryParam = prism' construct pick
  where
    construct (x, y) = QueryParam x y
    pick = \case
      QueryParam x y -> Just (x, y)
      _ -> Nothing

-- | Check if the given query key is present in the collection of query
-- parameters.
queryFlag :: RText 'QueryKey -> Getter [URI.QueryParam] Bool
queryFlag k = to (isJust . find g)
  where
    g (QueryFlag k') = k' == k
    g _ = 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 k f = traverse g
  where
    g p@(QueryParam k' v) =
      if k == k'
        then QueryParam k' <$> f v
        else pure p
    g p = pure p

-- | A getter that can project 'Text' from refined text values.
unRText :: Getter (RText l) Text
unRText = to 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 bt seta = dimap seta (either pure (fmap bt)) . right'

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

-- | Lift a function into optic.
to :: (Profunctor p, Contravariant f) => (s -> a) -> (p a (f a) -> p s (f s))
to f = dimap f (contramap f)