module URLT.Base where
import Control.Applicative
import Control.Monad (MonadPlus)
import Control.Monad.Trans (MonadTrans, MonadIO)
import Control.Monad.Fix (MonadFix)
import Control.Monad.Reader (MonadReader(ask), ReaderT(ReaderT), mapReaderT, withReaderT)
import HSX.XMLGenerator (XMLGenT(..))
type Link = String
newtype URLT url m a = URLT { unURLT :: ReaderT (url -> Link) m a }
deriving (Functor, Monad, MonadFix, MonadPlus, MonadIO, MonadTrans, MonadReader (url -> Link))
instance (Applicative m, Monad m) => Applicative (URLT url m) where
pure = return
(URLT (ReaderT f)) <*> (URLT (ReaderT a))
= URLT $ ReaderT $ \env -> (f env) <*> (a env)
class ShowURL m where
type URL m
showURL :: (URL m) -> m Link
instance (Monad m) => ShowURL (URLT url m) where
type URL (URLT url m) = url
showURL url =
do showF <- ask
return (showF url)
withURLT :: ((url' -> Link) -> (url -> Link)) -> URLT url m a -> URLT url' m a
withURLT f (URLT r) = URLT $ withReaderT f r
mapURLT :: (m a -> n b) -> URLT url m a -> URLT url n b
mapURLT f (URLT r) = URLT $ mapReaderT f r
nestURL :: (Monad m) => (url2 -> url1) -> URLT url2 m a -> URLT url1 m a
nestURL b = withURLT (. b)
crossURL :: (Monad m) => (url2 -> url1) -> URLT url1 m (url2 -> Link)
crossURL f =
do showF <- ask
return $ \url2 -> showF (f url2)