urlpath 3.3.0 → 4.0.0
raw patch · 2 files changed
+76/−119 lines, 2 filesdep ~path-extra
Dependency ranges changed: path-extra
Files
- src/Data/Url.hs +74/−117
- urlpath.cabal +2/−2
src/Data/Url.hs view
@@ -6,7 +6,6 @@ , TypeSynonymInstances , UndecidableInstances , MultiParamTypeClasses- , FunctionalDependencies #-} module Data.Url where@@ -35,140 +34,106 @@ -- * Classes -class MonadUrl b (m :: * -> *) where- pathUrl :: Path b t+-- | Turns a @Path@ or @Location@ into a @String@, where the rendering behavior+-- (relative, grounded and absolute) is encoded in the monad you use, much like+-- @LoggingT@ and @NoLoggingT@ from <https://hackage.haskell.org/package/monad-logger monad-logger>.+class MonadUrl base type' (m :: * -> *) where+ pathUrl :: Path base type' -> m String- locUrl :: Location b t+ locUrl :: Location base type' -> m String- symbolUrl :: ( ToLocation s b t- , MonadThrow m- ) => s -> m String -instance MonadUrl b IO where+instance MonadUrl b t IO where pathUrl = pure . toFilePath locUrl = pure . show- symbolUrl x = show <$> toLocation x -instance ( MonadUrl b m+instance ( MonadUrl b t m , Monad m- , MonadThrow m- ) => MonadUrl b (MaybeT m) where+ ) => MonadUrl b t (MaybeT m) where pathUrl = lift . pathUrl locUrl = lift . locUrl- symbolUrl = symbolUrl -instance ( MonadUrl b m+instance ( MonadUrl b t m , Monad m- , MonadThrow m- ) => MonadUrl b (ListT m) where+ ) => MonadUrl b t (ListT m) where pathUrl = lift . pathUrl locUrl = lift . locUrl- symbolUrl = symbolUrl -instance ( MonadUrl b m+instance ( MonadUrl b t m , Monad m- , MonadThrow m- ) => MonadUrl b (ResourceT m) where+ ) => MonadUrl b t (ResourceT m) where pathUrl = lift . pathUrl locUrl = lift . locUrl- symbolUrl = symbolUrl -instance ( MonadUrl b m+instance ( MonadUrl b t m , Monad m- , MonadThrow m- ) => MonadUrl b (IdentityT m) where+ ) => MonadUrl b t (IdentityT m) where pathUrl = lift . pathUrl locUrl = lift . locUrl- symbolUrl = symbolUrl -instance ( MonadUrl b m+instance ( MonadUrl b t m , Monad m- , MonadThrow m- ) => MonadUrl b (LoggingT m) where+ ) => MonadUrl b t (LoggingT m) where pathUrl = lift . pathUrl locUrl = lift . locUrl- symbolUrl = symbolUrl -instance ( MonadUrl b m+instance ( MonadUrl b t m , Monad m- , MonadThrow m- ) => MonadUrl b (NoLoggingT m) where+ ) => MonadUrl b t (NoLoggingT m) where pathUrl = lift . pathUrl locUrl = lift . locUrl- symbolUrl = symbolUrl -instance ( MonadUrl b m+instance ( MonadUrl b t m , Monad m- , MonadThrow m- ) => MonadUrl b (ReaderT r m) where+ ) => MonadUrl b t (ReaderT r m) where pathUrl = lift . pathUrl locUrl = lift . locUrl- symbolUrl = symbolUrl -instance ( MonadUrl b m+instance ( MonadUrl b t m , Monad m- , MonadThrow m , Monoid w- ) => MonadUrl b (WriterT w m) where+ ) => MonadUrl b t (WriterT w m) where pathUrl = lift . pathUrl locUrl = lift . locUrl- symbolUrl = symbolUrl -instance ( MonadUrl b m+instance ( MonadUrl b t m , Monad m- , MonadThrow m- ) => MonadUrl b (StateT s m) where+ ) => MonadUrl b t (StateT s m) where pathUrl = lift . pathUrl locUrl = lift . locUrl- symbolUrl = symbolUrl -instance ( MonadUrl b m+instance ( MonadUrl b t m , Monad m- , MonadThrow m , Error e- ) => MonadUrl b (ErrorT e m) where+ ) => MonadUrl b t (ErrorT e m) where pathUrl = lift . pathUrl locUrl = lift . locUrl- symbolUrl = symbolUrl -instance ( MonadUrl b m+instance ( MonadUrl b t m , Monad m- , MonadThrow m- ) => MonadUrl b (ContT r m) where+ ) => MonadUrl b t (ContT r m) where pathUrl = lift . pathUrl locUrl = lift . locUrl- symbolUrl = symbolUrl -instance ( MonadUrl b m+instance ( MonadUrl b t m , Monad m- , MonadThrow m- ) => MonadUrl b (ExceptT e m) where+ ) => MonadUrl b t (ExceptT e m) where pathUrl = lift . pathUrl locUrl = lift . locUrl- symbolUrl = symbolUrl -instance ( MonadUrl b m+instance ( MonadUrl b t m , Monad m- , MonadThrow m , Monoid w- ) => MonadUrl b (RWST r w s m) where+ ) => MonadUrl b t (RWST r w s m) where pathUrl = lift . pathUrl locUrl = lift . locUrl- symbolUrl = 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- toLocation :: MonadThrow m => a -> m (Location b t)---- | Overload extraction for deployment transformers.-class UrlReader m where- type RunUrlReader m :: * -> *- runUrlReader :: m a -- ^ MonadReader with index @string@ and result @b@- -> UrlAuthority -- ^ URI Scheme, hostname, and other details- -> RunUrlReader m a -- ^ Final result+-- | Convenience typeclass for symbolic, stringless routes - make an instance+-- for your own data type to use your constructors as route-referencing symbols.+class ToLocation sym base type' where+ toLocation :: MonadThrow m => sym -> m (Location base type') -- * Types@@ -180,23 +145,24 @@ , urlAuth :: Maybe UrlAuthent , urlHost :: String , urlPort :: Maybe Int- } deriving (Eq, Ord)+ } deriving (Show, Eq, Ord) -instance Show UrlAuthority where- show (UrlAuthority sh sl ma h mp) =+showUrlAuthority :: UrlAuthority -> String+showUrlAuthority (UrlAuthority sh sl ma h mp) = sh ++ ":"- ++ if sl then "//" else ""- ++ maybe "" (\a -> show a ++ "@") ma+ ++ (if sl then "//" else "")+ ++ maybe "" (\a -> showUrlAuthent a ++ "@") ma ++ h ++ maybe "" (\p -> ":" ++ show p) mp data UrlAuthent = UrlAuthent { urlAuthUser :: String , urlAuthPass :: Maybe String- } deriving (Eq, Ord)+ } deriving (Show, Eq, Ord) -instance Show UrlAuthent where- show (UrlAuthent u mp) = u ++ maybe "" (\p -> ":" ++ p) mp+showUrlAuthent :: UrlAuthent -> String+showUrlAuthent (UrlAuthent u mp) =+ u ++ maybe "" (\p -> ":" ++ p) mp -- ** Relative Urls@@ -207,10 +173,20 @@ type RelativeUrl = RelativeUrlT Identity +instance ( Applicative m+ ) => MonadUrl Rel File (RelativeUrlT m) where+ pathUrl x = pure (toFilePath x)+ locUrl x = pure (show x)++instance ( Applicative m+ ) => MonadUrl Rel Dir (RelativeUrlT m) where+ pathUrl x = pure (toFilePath x)+ locUrl x = pure (show x)+ instance Applicative m => Applicative (RelativeUrlT m) where pure x = RelativeUrlT $ const (pure x) f <*> x = RelativeUrlT $ \r ->- (runRelativeUrlT f r) <*> (runRelativeUrlT x r)+ runRelativeUrlT f r <*> runRelativeUrlT x r instance Monad m => Monad (RelativeUrlT m) where return x = RelativeUrlT $ const (return x)@@ -223,16 +199,6 @@ instance MonadIO m => MonadIO (RelativeUrlT m) where liftIO = lift . liftIO -instance ( Applicative m- ) => MonadUrl Rel (RelativeUrlT m) where- pathUrl x = pure (toFilePath x)- locUrl x = pure (show x)- symbolUrl x = show <$> toLocation x--instance UrlReader (RelativeUrlT m) where- type RunUrlReader (RelativeUrlT m) = m- runUrlReader = runRelativeUrlT- instance ( MonadReader r m ) => MonadReader r (RelativeUrlT m) where ask = lift ask@@ -325,10 +291,20 @@ type GroundedUrl = GroundedUrlT Identity +instance ( Applicative m+ ) => MonadUrl Abs File (GroundedUrlT m) where+ pathUrl x = pure (toFilePath x)+ locUrl x = pure (show x)++instance ( Applicative m+ ) => MonadUrl Abs Dir (GroundedUrlT m) where+ pathUrl x = pure (toFilePath x)+ locUrl x = pure (show x)+ instance Applicative m => Applicative (GroundedUrlT m) where pure x = GroundedUrlT $ const (pure x) f <*> x = GroundedUrlT $ \r ->- (runGroundedUrlT f r) <*> (runGroundedUrlT x r)+ runGroundedUrlT f r <*> runGroundedUrlT x r instance Monad m => Monad (GroundedUrlT m) where return x = GroundedUrlT $ const (return x)@@ -341,17 +317,6 @@ instance MonadIO m => MonadIO (GroundedUrlT m) where liftIO = lift . liftIO -instance ( Applicative m- , MonadThrow m- ) => MonadUrl Abs (GroundedUrlT m) where- pathUrl x = pure (toFilePath x)- locUrl x = pure (show x)- symbolUrl x = show <$> toLocation x--instance UrlReader (GroundedUrlT m) where- type RunUrlReader (GroundedUrlT m) = m- runUrlReader = runGroundedUrlT- instance ( MonadReader r m ) => MonadReader r (GroundedUrlT m) where ask = lift ask@@ -444,10 +409,15 @@ type AbsoluteUrl = AbsoluteUrlT Identity +instance ( Applicative m+ ) => MonadUrl Abs File (AbsoluteUrlT m) where+ pathUrl x = AbsoluteUrlT (\h -> pure $ showUrlAuthority h ++ toFilePath x)+ locUrl x = AbsoluteUrlT (\h -> pure $ showUrlAuthority h ++ show x)+ instance Applicative m => Applicative (AbsoluteUrlT m) where pure x = AbsoluteUrlT $ const (pure x) f <*> x = AbsoluteUrlT $ \r ->- (runAbsoluteUrlT f r) <*> (runAbsoluteUrlT x r)+ runAbsoluteUrlT f r <*> runAbsoluteUrlT x r instance Monad m => Monad (AbsoluteUrlT m) where return x = AbsoluteUrlT $ const (return x)@@ -459,19 +429,6 @@ instance MonadIO m => MonadIO (AbsoluteUrlT m) where liftIO = lift . liftIO--instance ( Applicative m- , MonadThrow m- ) => MonadUrl Abs (AbsoluteUrlT m) where- pathUrl x = AbsoluteUrlT (\h -> pure $ show h ++ toFilePath x)- locUrl x = AbsoluteUrlT (\h -> pure $ show h ++ show x)- symbolUrl x = AbsoluteUrlT $ \h -> do- x' <- toLocation x- return $ show h ++ show x'--instance UrlReader (AbsoluteUrlT m) where- type RunUrlReader (AbsoluteUrlT m) = m- runUrlReader = runAbsoluteUrlT instance ( MonadReader r m ) => MonadReader r (AbsoluteUrlT m) where
urlpath.cabal view
@@ -1,5 +1,5 @@ Name: urlpath-Version: 3.3.0+Version: 4.0.0 Author: Athan Clark <athan.clark@gmail.com> Maintainer: Athan Clark <athan.clark@gmail.com> License: MIT@@ -22,7 +22,7 @@ , monad-control , monad-logger , mtl- , path-extra+ , path-extra >= 0.0.2 , resourcet , transformers , transformers-base