urlpath 4.1.0 → 4.2.0
raw patch · 2 files changed
+61/−188 lines, 2 files
Files
- src/Data/Url.hs +60/−187
- urlpath.cabal +1/−1
src/Data/Url.hs view
@@ -3,17 +3,38 @@ , DeriveFunctor , KindSignatures , FlexibleInstances+ , StandaloneDeriving , TypeSynonymInstances , UndecidableInstances , MultiParamTypeClasses , FunctionalDependencies+ , GeneralizedNewtypeDeriving #-} +-- |+-- Module : Data.Url+-- Copyright : (c) Athan L. Clark+-- License : MIT+--+-- Maintainer : Athan L. Clark <athan.clark@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-- This library helps us distinguish how we present URLs - we might show them+-- relatively, absolutely (with the URI authority - scheme, port, hostname, etc.),+-- or /grounded/ - where the path begins with @/@.+--+-- We leverage Chris Done's <https://hackage.haskell.org/package/path path>+-- library to distinguish relative vs. grounded paths at compile time, and provide+-- some additional features like a file extension and query parameters in+-- <https://hackage.haskell.org/package/path-extra path-extra>.+ module Data.Url where import Path.Extended import Data.Functor.Identity+import Control.Applicative import Control.Monad.Base import Control.Monad.Catch import Control.Monad.Cont@@ -84,7 +105,6 @@ pathUrl = lift . pathUrl locUrl = lift . locUrl - instance ( MonadUrl b t m , Monad m ) => MonadUrl b t (ReaderT r m) where@@ -169,79 +189,23 @@ -- ** Relative Urls newtype RelativeUrlT m a = RelativeUrlT- { runRelativeUrlT :: UrlAuthority -> m a- } deriving Functor--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)+ { runRelativeUrlT :: m a+ } deriving ( Show, Eq, Ord, Functor, Applicative, Alternative, Monad, MonadFix+ , MonadPlus, MonadIO, MonadReader r, MonadWriter w, MonadState s+ , MonadRWS r w s, MonadCont, MonadError e, MonadBase b, MonadThrow+ , MonadCatch, MonadMask, MonadLogger) -instance Applicative m => Applicative (RelativeUrlT m) where- pure x = RelativeUrlT $ const (pure x)- f <*> x = RelativeUrlT $ \r ->- runRelativeUrlT f r <*> runRelativeUrlT x r+deriving instance (MonadResource m, MonadBase IO m) => MonadResource (RelativeUrlT m) -instance Monad m => Monad (RelativeUrlT m) where- return x = RelativeUrlT $ const (return x)- m >>= f = RelativeUrlT $ \r ->- runRelativeUrlT m r >>= (\x -> runRelativeUrlT (f x) r)+type RelativeUrl = RelativeUrlT Identity instance MonadTrans RelativeUrlT where- lift = RelativeUrlT . const--instance MonadIO m => MonadIO (RelativeUrlT m) where- liftIO = lift . liftIO--instance ( MonadReader r m- ) => MonadReader r (RelativeUrlT m) where- ask = lift ask- local f (RelativeUrlT x) = RelativeUrlT $ \r ->- local f (x r)--instance ( MonadWriter w m- ) => MonadWriter w (RelativeUrlT m) where- tell w = lift (tell w)- listen (RelativeUrlT x) = RelativeUrlT $ \r ->- listen (x r)- pass (RelativeUrlT x) = RelativeUrlT $ \r ->- pass (x r)--instance ( MonadState s m- ) => MonadState s (RelativeUrlT m) where- 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+ lift = RelativeUrlT instance MonadTransControl RelativeUrlT where type StT RelativeUrlT a = a- liftWith f = RelativeUrlT $ \r ->- f $ \t -> runRelativeUrlT t r- restoreT = RelativeUrlT . const+ liftWith f = RelativeUrlT (f (\t -> runRelativeUrlT t))+ restoreT = RelativeUrlT instance ( MonadBaseControl b m ) => MonadBaseControl b (RelativeUrlT m) where@@ -249,117 +213,44 @@ 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)+ hoist f (RelativeUrlT x) = RelativeUrlT (f x) instance MMonad RelativeUrlT where- embed f x = RelativeUrlT $ \r ->- runRelativeUrlT (f (runRelativeUrlT x r)) r+ embed f x = f (runRelativeUrlT x) --- ** Grounded Urls--newtype GroundedUrlT m a = GroundedUrlT- { runGroundedUrlT :: UrlAuthority -> m a- } deriving Functor--type GroundedUrl = GroundedUrlT Identity- instance ( Applicative m- ) => MonadUrl Abs File (GroundedUrlT m) where+ ) => MonadUrl Rel File (RelativeUrlT m) where pathUrl x = pure (toFilePath x) locUrl x = pure (show x) instance ( Applicative m- ) => MonadUrl Abs Dir (GroundedUrlT m) where+ ) => MonadUrl Rel Dir (RelativeUrlT 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 -instance Monad m => Monad (GroundedUrlT m) where- return x = GroundedUrlT $ const (return x)- m >>= f = GroundedUrlT $ \r ->- runGroundedUrlT m r >>= (\x -> runGroundedUrlT (f x) r)--instance MonadTrans GroundedUrlT where- lift = GroundedUrlT . const--instance MonadIO m => MonadIO (GroundedUrlT m) where- liftIO = lift . liftIO--instance ( MonadReader r m- ) => MonadReader r (GroundedUrlT m) where- ask = lift ask- local f (GroundedUrlT x) = GroundedUrlT $ \r ->- local f (x r)--instance ( MonadWriter w m- ) => MonadWriter w (GroundedUrlT m) where- tell w = lift (tell w)- listen (GroundedUrlT x) = GroundedUrlT $ \r ->- listen (x r)- pass (GroundedUrlT x) = GroundedUrlT $ \r ->- pass (x r)--instance ( MonadState s m- ) => MonadState s (GroundedUrlT m) where- get = lift get- put x = lift (put x)+-- ** Grounded Urls -instance ( MonadRWS r w s m- ) => MonadRWS r w s (GroundedUrlT m) where+newtype GroundedUrlT m a = GroundedUrlT+ { runGroundedUrlT :: m a+ } deriving ( Show, Eq, Ord, Functor, Applicative, Alternative, Monad, MonadFix+ , MonadPlus, MonadIO, MonadReader r, MonadWriter w, MonadState s+ , MonadRWS r w s, MonadCont, MonadError e, MonadBase b, MonadThrow+ , MonadCatch, MonadMask, MonadLogger) -instance ( MonadCont m- ) => MonadCont (GroundedUrlT m) where- callCC f = GroundedUrlT $ \r ->- callCC $ \c -> runGroundedUrlT (f (GroundedUrlT . const . c)) r+deriving instance (MonadResource m, MonadBase IO m) => MonadResource (GroundedUrlT m) -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)+type GroundedUrl = GroundedUrlT Identity -instance ( MonadBase b m- ) => MonadBase b (GroundedUrlT m) where- liftBase = liftBaseDefault+instance MonadTrans GroundedUrlT where+ lift = GroundedUrlT instance MonadTransControl GroundedUrlT where type StT GroundedUrlT a = a- liftWith f = GroundedUrlT $ \r ->- f $ \t -> runGroundedUrlT t r- restoreT = GroundedUrlT . const+ liftWith f = GroundedUrlT (f (\t -> runGroundedUrlT t))+ restoreT = GroundedUrlT instance ( MonadBaseControl b m ) => MonadBaseControl b (GroundedUrlT m) where@@ -367,39 +258,21 @@ 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)+ hoist f (GroundedUrlT x) = GroundedUrlT (f x) instance MMonad GroundedUrlT where- embed f x = GroundedUrlT $ \r ->- runGroundedUrlT (f (runGroundedUrlT x r)) r+ embed f x = f (runGroundedUrlT x)++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) -- ** Absolute Urls
urlpath.cabal view
@@ -1,5 +1,5 @@ Name: urlpath-Version: 4.1.0+Version: 4.2.0 Author: Athan Clark <athan.clark@gmail.com> Maintainer: Athan Clark <athan.clark@gmail.com> License: MIT