module UrlPath.Types where
import Data.String
import Data.Monoid
import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Reader.Class
data UrlString a where
UrlString :: ( IsString a
, Monoid a ) =>
a
-> [(a, a)]
-> UrlString a
showUrlString :: UrlString a
-> a
showUrlString (UrlString !t []) = t
showUrlString (UrlString !t ((!k,!v):xs)) =
t <> "?" <> k <> "=" <> v <>
foldl (\acc (x,y) -> acc <> "&" <> x <> "=" <> y) "" xs
(<?>) :: ( IsString a
, Monoid a ) =>
a
-> (a, a)
-> UrlString a
(<?>) !t !kv = UrlString t [kv]
infixl 9 <?>
(<&>) :: ( IsString a
, Monoid a ) =>
UrlString a
-> (a, a)
-> UrlString a
(<&>) (UrlString !t !p) !kv = UrlString t $ p ++ [kv]
infixl 8 <&>
expandRelative :: ( IsString plain
, Monoid plain ) =>
UrlString plain
-> plain
expandRelative = showUrlString
expandGrounded :: ( IsString plain
, Monoid plain ) =>
UrlString plain
-> plain
expandGrounded !x = "/" <> showUrlString x
expandAbsolute :: ( MonadReader plain m
, IsString plain
, Monoid plain ) =>
UrlString plain
-> m plain
expandAbsolute !x = do
host <- ask
return $ host <> "/" <> showUrlString x
expandAbsoluteWith :: ( MonadReader a m
, IsString plain
, Monoid plain ) =>
UrlString plain
-> (a -> plain)
-> m plain
expandAbsoluteWith !x f = do
root <- liftM f ask
return $ root <> "/" <> showUrlString x
newtype RelativeUrlT m h b = RelativeUrlT { runRelativeUrlT :: h -> m b }
deriving Functor
instance Applicative f => Applicative (RelativeUrlT f h) where
(<*>) f x = RelativeUrlT $ \a ->
(<*>) (runRelativeUrlT f a) (runRelativeUrlT x a)
instance Monad m => Monad (RelativeUrlT m h) where
return x = RelativeUrlT $ \_ -> return x
m >>= f = RelativeUrlT $ \a ->
runRelativeUrlT m a >>= (\x -> runRelativeUrlT (f x) a)
instance ( Monad m
, IsString h ) => MonadReader h (RelativeUrlT m h) where
ask = return ""
newtype RelativeUrl h a = RelativeUrl { runRelativeUrl :: h -> a }
deriving Functor
instance Applicative (RelativeUrl h) where
(<*>) f x = RelativeUrl $ \a ->
runRelativeUrl f a (runRelativeUrl x a)
instance Monad (RelativeUrl h) where
return x = RelativeUrl $ const x
m >>= f = RelativeUrl $ \a ->
(\y -> runRelativeUrl (f y) a) (runRelativeUrl m a)
instance IsString a => MonadReader a (RelativeUrl a) where
ask = return ""
newtype GroundedUrlT m h b = GroundedUrlT { runGroundedUrlT :: h -> m b }
instance Functor f => Functor (GroundedUrlT f h) where
fmap f x = GroundedUrlT $ \a ->
fmap f (runGroundedUrlT x a)
instance Applicative f => Applicative (GroundedUrlT f h) where
(<*>) f x = GroundedUrlT $ \a ->
(<*>) (runGroundedUrlT f a) (runGroundedUrlT x a)
instance Monad m => Monad (GroundedUrlT m h) where
return x = GroundedUrlT $ \_ -> return x
m >>= f = GroundedUrlT $ \a ->
runGroundedUrlT m a >>= (\x -> runGroundedUrlT (f x) a)
instance ( Monad m
, IsString h ) => MonadReader h (GroundedUrlT m h) where
ask = return "/"
newtype GroundedUrl h a = GroundedUrl { runGroundedUrl :: h -> a }
instance Functor (GroundedUrl h) where
fmap f x = GroundedUrl $ \a -> f $ runGroundedUrl x a
instance Applicative (GroundedUrl h) where
(<*>) f x = GroundedUrl $ \a ->
runGroundedUrl f a (runGroundedUrl x a)
instance Monad (GroundedUrl h) where
return x = GroundedUrl $ const x
m >>= f = GroundedUrl $ \a ->
(\y -> runGroundedUrl (f y) a) (runGroundedUrl m a)
instance IsString a => MonadReader a (GroundedUrl a) where
ask = return "/"
newtype AbsoluteUrlT m h b = AbsoluteUrlT { runAbsoluteUrlT :: h -> m b }
instance Functor f => Functor (AbsoluteUrlT f h) where
fmap f x = AbsoluteUrlT $ \a ->
fmap f (runAbsoluteUrlT x a)
instance Applicative f => Applicative (AbsoluteUrlT f h) where
(<*>) f x = AbsoluteUrlT $ \a ->
(<*>) (runAbsoluteUrlT f a) (runAbsoluteUrlT x a)
instance Monad m => Monad (AbsoluteUrlT m h) where
return x = AbsoluteUrlT $ const $ return x
m >>= f = AbsoluteUrlT $ \a ->
runAbsoluteUrlT m a >>= (\x -> runAbsoluteUrlT (f x) a)
instance ( Monad m
, IsString h ) => MonadReader h (AbsoluteUrlT m h) where
ask = AbsoluteUrlT return
newtype AbsoluteUrl h a = AbsoluteUrl { runAbsoluteUrl :: h -> a }
instance Functor (AbsoluteUrl h) where
fmap f x = AbsoluteUrl $ \a -> f $ runAbsoluteUrl x a
instance Applicative (AbsoluteUrl h) where
(<*>) f x = AbsoluteUrl $ \a ->
runAbsoluteUrl f a (runAbsoluteUrl x a)
instance Monad (AbsoluteUrl h) where
return x = AbsoluteUrl $ const x
m >>= f = AbsoluteUrl $ \a ->
(\y -> runAbsoluteUrl (f y) a) (runAbsoluteUrl m a)
instance IsString a => MonadReader a (AbsoluteUrl a) where
ask = AbsoluteUrl id