urlpath 3.2.0 → 3.2.1
raw patch · 2 files changed
+303/−4 lines, 2 filesdep +exceptionsdep +mmorphdep +monad-control
Dependencies added: exceptions, mmorph, monad-control, monad-logger, resourcet, transformers, transformers-base
Files
- src/Data/Url.hs +295/−3
- urlpath.cabal +8/−1
src/Data/Url.hs view
@@ -14,12 +14,25 @@ import Path.Extended import Data.Functor.Identity-import Control.Monad.Trans+import Control.Monad.Base+import Control.Monad.Catch+import Control.Monad.Cont+import Control.Monad.Error+import Control.Monad.Except+import Control.Monad.Trans.Control+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import Control.Monad.List import Control.Monad.Reader import Control.Monad.Writer import Control.Monad.State+import Control.Monad.RWS+import Control.Monad.Logger+import Control.Monad.Trans.Resource+import Control.Monad.Morph + -- * Classes class MonadUrl b (m :: * -> *) where@@ -32,14 +45,101 @@ -> m String instance ( MonadUrl b m- , MonadTrans t , Monad m- ) => MonadUrl b (t m) where+ ) => MonadUrl b (MaybeT m) where pathUrl = lift . pathUrl locUrl = lift . locUrl symbolUrl = lift . symbolUrl +instance ( MonadUrl b m+ , Monad m+ ) => MonadUrl b (ListT m) where+ pathUrl = lift . pathUrl+ locUrl = lift . locUrl+ symbolUrl = lift . symbolUrl +instance ( MonadUrl b m+ , Monad m+ ) => MonadUrl b (ResourceT m) where+ pathUrl = lift . pathUrl+ locUrl = lift . locUrl+ symbolUrl = lift . symbolUrl++instance ( MonadUrl b m+ , Monad m+ ) => MonadUrl b (IdentityT m) where+ pathUrl = lift . pathUrl+ locUrl = lift . locUrl+ symbolUrl = lift . symbolUrl++instance ( MonadUrl b m+ , Monad m+ ) => MonadUrl b (LoggingT m) where+ pathUrl = lift . pathUrl+ locUrl = lift . locUrl+ symbolUrl = lift . symbolUrl++instance ( MonadUrl b m+ , Monad m+ ) => MonadUrl b (NoLoggingT m) where+ pathUrl = lift . pathUrl+ locUrl = lift . locUrl+ symbolUrl = lift . symbolUrl+++instance ( MonadUrl b m+ , Monad m+ ) => MonadUrl b (ReaderT r m) where+ pathUrl = lift . pathUrl+ locUrl = lift . locUrl+ symbolUrl = lift . symbolUrl++instance ( MonadUrl b m+ , Monad m+ , Monoid w+ ) => MonadUrl b (WriterT w m) where+ pathUrl = lift . pathUrl+ locUrl = lift . locUrl+ symbolUrl = lift . symbolUrl++instance ( MonadUrl b m+ , Monad m+ ) => MonadUrl b (StateT s m) where+ pathUrl = lift . pathUrl+ locUrl = lift . locUrl+ symbolUrl = lift . symbolUrl++instance ( MonadUrl b m+ , Monad m+ , Error e+ ) => MonadUrl b (ErrorT e m) where+ pathUrl = lift . pathUrl+ locUrl = lift . locUrl+ symbolUrl = lift . symbolUrl++instance ( MonadUrl b m+ , Monad m+ ) => MonadUrl b (ContT r m) where+ pathUrl = lift . pathUrl+ locUrl = lift . locUrl+ symbolUrl = lift . symbolUrl++instance ( MonadUrl b m+ , Monad m+ ) => MonadUrl b (ExceptT e m) where+ pathUrl = lift . pathUrl+ locUrl = lift . locUrl+ symbolUrl = lift . symbolUrl++instance ( MonadUrl b m+ , Monad m+ , Monoid w+ ) => MonadUrl b (RWST r w s m) where+ pathUrl = lift . pathUrl+ locUrl = lift . locUrl+ symbolUrl = lift . symbolUrl++ -- | Make an instance for your own stringless route type to use your symbols -- instead of strings or @Path@. class ToLocation a b t | a -> b t where@@ -134,7 +234,71 @@ get = lift get put x = lift (put x) +instance ( MonadRWS r w s m+ ) => MonadRWS r w s (RelativeUrlT m) where +instance ( MonadCont m+ ) => MonadCont (RelativeUrlT m) where+ callCC f = RelativeUrlT $ \r ->+ callCC $ \c -> runRelativeUrlT (f (RelativeUrlT . const . c)) r++instance ( MonadError e m+ ) => MonadError e (RelativeUrlT m) where+ throwError = lift . throwError+ catchError (RelativeUrlT x) f = RelativeUrlT $ \r ->+ catchError (x r) (flip runRelativeUrlT r . f)++instance ( MonadBase b m+ ) => MonadBase b (RelativeUrlT m) where+ liftBase = liftBaseDefault++instance MonadTransControl RelativeUrlT where+ type StT RelativeUrlT a = a+ liftWith f = RelativeUrlT $ \r ->+ f $ \t -> runRelativeUrlT t r+ restoreT = RelativeUrlT . const++instance ( MonadBaseControl b m+ ) => MonadBaseControl b (RelativeUrlT m) where+ type StM (RelativeUrlT m) a = ComposeSt RelativeUrlT m a+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM++instance ( MonadThrow m+ ) => MonadThrow (RelativeUrlT m) where+ throwM = lift . throwM++instance ( MonadCatch m+ ) => MonadCatch (RelativeUrlT m) where+ catch (RelativeUrlT x) f = RelativeUrlT $ \r ->+ catch (x r) (flip runRelativeUrlT r . f)++instance ( MonadMask m+ ) => MonadMask (RelativeUrlT m) where+ mask a = RelativeUrlT $ \r ->+ mask $ \u -> runRelativeUrlT (a $ q u) r+ where q u (RelativeUrlT x) = RelativeUrlT (u . x)+ uninterruptibleMask a = RelativeUrlT $ \r ->+ uninterruptibleMask $ \u -> runRelativeUrlT (a $ q u) r+ where q u (RelativeUrlT x) = RelativeUrlT (u . x)++instance ( MonadLogger m+ ) => MonadLogger (RelativeUrlT m) where+ monadLoggerLog a b c d = lift (monadLoggerLog a b c d)++instance ( MonadResource m+ ) => MonadResource (RelativeUrlT m) where+ liftResourceT = lift . liftResourceT++instance MFunctor RelativeUrlT where+ hoist f (RelativeUrlT x) = RelativeUrlT $ \r ->+ f (x r)++instance MMonad RelativeUrlT where+ embed f x = RelativeUrlT $ \r ->+ runRelativeUrlT (f (runRelativeUrlT x r)) r++ -- ** Grounded Urls newtype GroundedUrlT m a = GroundedUrlT@@ -188,7 +352,71 @@ get = lift get put x = lift (put x) +instance ( MonadRWS r w s m+ ) => MonadRWS r w s (GroundedUrlT m) where +instance ( MonadCont m+ ) => MonadCont (GroundedUrlT m) where+ callCC f = GroundedUrlT $ \r ->+ callCC $ \c -> runGroundedUrlT (f (GroundedUrlT . const . c)) r++instance ( MonadError e m+ ) => MonadError e (GroundedUrlT m) where+ throwError = lift . throwError+ catchError (GroundedUrlT x) f = GroundedUrlT $ \r ->+ catchError (x r) (flip runGroundedUrlT r . f)++instance ( MonadBase b m+ ) => MonadBase b (GroundedUrlT m) where+ liftBase = liftBaseDefault++instance MonadTransControl GroundedUrlT where+ type StT GroundedUrlT a = a+ liftWith f = GroundedUrlT $ \r ->+ f $ \t -> runGroundedUrlT t r+ restoreT = GroundedUrlT . const++instance ( MonadBaseControl b m+ ) => MonadBaseControl b (GroundedUrlT m) where+ type StM (GroundedUrlT m) a = ComposeSt GroundedUrlT m a+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM++instance ( MonadThrow m+ ) => MonadThrow (GroundedUrlT m) where+ throwM = lift . throwM++instance ( MonadCatch m+ ) => MonadCatch (GroundedUrlT m) where+ catch (GroundedUrlT x) f = GroundedUrlT $ \r ->+ catch (x r) (flip runGroundedUrlT r . f)++instance ( MonadMask m+ ) => MonadMask (GroundedUrlT m) where+ mask a = GroundedUrlT $ \r ->+ mask $ \u -> runGroundedUrlT (a $ q u) r+ where q u (GroundedUrlT x) = GroundedUrlT (u . x)+ uninterruptibleMask a = GroundedUrlT $ \r ->+ uninterruptibleMask $ \u -> runGroundedUrlT (a $ q u) r+ where q u (GroundedUrlT x) = GroundedUrlT (u . x)++instance ( MonadLogger m+ ) => MonadLogger (GroundedUrlT m) where+ monadLoggerLog a b c d = lift (monadLoggerLog a b c d)++instance ( MonadResource m+ ) => MonadResource (GroundedUrlT m) where+ liftResourceT = lift . liftResourceT++instance MFunctor GroundedUrlT where+ hoist f (GroundedUrlT x) = GroundedUrlT $ \r ->+ f (x r)++instance MMonad GroundedUrlT where+ embed f x = GroundedUrlT $ \r ->+ runGroundedUrlT (f (runGroundedUrlT x r)) r++ -- ** Absolute Urls newtype AbsoluteUrlT m a = AbsoluteUrlT@@ -241,3 +469,67 @@ ) => MonadState s (AbsoluteUrlT m) where get = lift get put x = lift (put x)++instance ( MonadRWS r w s m+ ) => MonadRWS r w s (AbsoluteUrlT m) where++instance ( MonadCont m+ ) => MonadCont (AbsoluteUrlT m) where+ callCC f = AbsoluteUrlT $ \r ->+ callCC $ \c -> runAbsoluteUrlT (f (AbsoluteUrlT . const . c)) r++instance ( MonadError e m+ ) => MonadError e (AbsoluteUrlT m) where+ throwError = lift . throwError+ catchError (AbsoluteUrlT x) f = AbsoluteUrlT $ \r ->+ catchError (x r) (flip runAbsoluteUrlT r . f)++instance ( MonadBase b m+ ) => MonadBase b (AbsoluteUrlT m) where+ liftBase = liftBaseDefault++instance MonadTransControl AbsoluteUrlT where+ type StT AbsoluteUrlT a = a+ liftWith f = AbsoluteUrlT $ \r ->+ f $ \t -> runAbsoluteUrlT t r+ restoreT = AbsoluteUrlT . const++instance ( MonadBaseControl b m+ ) => MonadBaseControl b (AbsoluteUrlT m) where+ type StM (AbsoluteUrlT m) a = ComposeSt AbsoluteUrlT m a+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM++instance ( MonadThrow m+ ) => MonadThrow (AbsoluteUrlT m) where+ throwM = lift . throwM++instance ( MonadCatch m+ ) => MonadCatch (AbsoluteUrlT m) where+ catch (AbsoluteUrlT x) f = AbsoluteUrlT $ \r ->+ catch (x r) (flip runAbsoluteUrlT r . f)++instance ( MonadMask m+ ) => MonadMask (AbsoluteUrlT m) where+ mask a = AbsoluteUrlT $ \r ->+ mask $ \u -> runAbsoluteUrlT (a $ q u) r+ where q u (AbsoluteUrlT x) = AbsoluteUrlT (u . x)+ uninterruptibleMask a = AbsoluteUrlT $ \r ->+ uninterruptibleMask $ \u -> runAbsoluteUrlT (a $ q u) r+ where q u (AbsoluteUrlT x) = AbsoluteUrlT (u . x)++instance ( MonadLogger m+ ) => MonadLogger (AbsoluteUrlT m) where+ monadLoggerLog a b c d = lift (monadLoggerLog a b c d)++instance ( MonadResource m+ ) => MonadResource (AbsoluteUrlT m) where+ liftResourceT = lift . liftResourceT++instance MFunctor AbsoluteUrlT where+ hoist f (AbsoluteUrlT x) = AbsoluteUrlT $ \r ->+ f (x r)++instance MMonad AbsoluteUrlT where+ embed f x = AbsoluteUrlT $ \r ->+ runAbsoluteUrlT (f (runAbsoluteUrlT x r)) r
urlpath.cabal view
@@ -1,5 +1,5 @@ Name: urlpath-Version: 3.2.0+Version: 3.2.1 Author: Athan Clark <athan.clark@gmail.com> Maintainer: Athan Clark <athan.clark@gmail.com> License: MIT@@ -17,8 +17,15 @@ GHC-Options: -Wall Exposed-Modules: Data.Url Build-Depends: base >= 4.8 && < 5+ , exceptions+ , mmorph+ , monad-control+ , monad-logger , mtl , path-extra+ , resourcet+ , transformers+ , transformers-base Source-Repository head Type: git