module Text.URI.Lens
( uriScheme
, uriAuthority
, uriPath
, isPathAbsolute
, uriQuery
, uriFragment
, authUserInfo
, authHost
, authPort
, uiUsername
, uiPassword
, _QueryFlag
, _QueryParam
, queryFlag
, queryParam
, unRText )
where
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 Text.URI.Types as URI
uriScheme :: Lens' URI (Maybe (RText 'Scheme))
uriScheme f s = (\x -> s { URI.uriScheme = x }) <$> f (URI.uriScheme s)
uriAuthority :: Lens' URI (Either Bool URI.Authority)
uriAuthority f s = (\x -> s { URI.uriAuthority = x }) <$> f (URI.uriAuthority s)
uriPath :: Lens' URI [RText 'PathPiece]
uriPath f s = (\x -> s { URI.uriPath = x }) <$> f (URI.uriPath s)
isPathAbsolute :: Getter URI Bool
isPathAbsolute = to URI.isPathAbsolute
uriQuery :: Lens' URI [URI.QueryParam]
uriQuery f s = (\x -> s { URI.uriQuery = x }) <$> f (URI.uriQuery s)
uriFragment :: Lens' URI (Maybe (RText 'Fragment))
uriFragment f s = (\x -> s { URI.uriFragment = x }) <$> f (URI.uriFragment s)
authUserInfo :: Lens' Authority (Maybe URI.UserInfo)
authUserInfo f s = (\x -> s { URI.authUserInfo = x }) <$> f (URI.authUserInfo s)
authHost :: Lens' Authority (RText 'Host)
authHost f s = (\x -> s { URI.authHost = x }) <$> f (URI.authHost s)
authPort :: Lens' Authority (Maybe Word)
authPort f s = (\x -> s { URI.authPort = x }) <$> f (URI.authPort s)
uiUsername :: Lens' UserInfo (RText 'Username)
uiUsername f s = (\x -> s { URI.uiUsername = x }) <$> f (URI.uiUsername s)
uiPassword :: Lens' UserInfo (Maybe (RText 'Password))
uiPassword f s = (\x -> s { URI.uiPassword = x }) <$> f (URI.uiPassword s)
_QueryFlag :: Prism' URI.QueryParam (RText 'QueryKey)
_QueryFlag = prism' QueryFlag $ \case
QueryFlag x -> Just x
_ -> Nothing
_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
queryFlag :: RText 'QueryKey -> Getter [URI.QueryParam] Bool
queryFlag k = to (isJust . find g)
where
g (QueryFlag k') = k' == k
g _ = False
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
unRText :: Getter (RText l) Text
unRText = to 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 bt seta = dimap seta (either pure (fmap bt)) . right'
prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s))
to :: (Profunctor p, Contravariant f) => (s -> a) -> (p a (f a) -> p s (f s))
to f = dimap f (contramap f)