urlpath 0.1.0.1 → 0.2
raw patch · 3 files changed
+90/−183 lines, 3 files
Files
- src/UrlPath.hs +48/−64
- src/UrlPath/Types.hs +41/−117
- urlpath.cabal +1/−2
src/UrlPath.hs view
@@ -24,79 +24,63 @@ -- | @Url@ is a relationship between an underlying (monomorphic) string type--- @string@, and a deployment context @m@. We try to make the deployment and --- implementation type coercible at the top level - coercing your final --- expression to @String@ or @T.Text@ will have /all/ use-cases coerce to that --- type, similarly with the deployment scheme.------ We chose to not force @MonadReader@ as a superclass for @m@ due to the --- monomorphic demand on functional dependencies.-class ( IsString string, Monoid string, MonadReader string m ) =>- Url string (m :: * -> *) where- url :: UrlString string -- ^ Url type- -> m string -- ^ Rendered Url in some context.- stringUrl :: string -- ^ raw string- -> m string -- ^ Rendered string in some context.+-- @plain@, and a deployment context @m@. We try to make the deployment style+-- coercible at the top level - if the+-- expression has a type @Url String (AbsoluteUrlT String Identity)@+-- or @Monad m => Url T.Text (GroundedUrlT LT.Text m)@ will force /all use-cases+-- within the expression/ to coerce to that type.+class ( IsString plain+ , Monoid plain+ , MonadReader plain m+ ) => Url plain (m :: * -> *) where+ url :: UrlString plain -- ^ Url type, parameterized over a string type @plain@+ -> m plain -- ^ Rendered Url in some context.+ plainUrl :: plain -- ^ raw small string+ -> m plain -- ^ Rendered string in some context. + -- | Overload deployment schemes with this - then, all that's needed is a type --- coercion to change deployment. This only works with flat (co)monads, so monad --- transformers are out.-class Url string m => UrlReader string m where- runUrlReader :: Url string m =>- m string -- ^ Monad with result @string@- -> string -- ^ Reader index- -> string -- ^ Final result+-- coercion to change deployment.+class Url plain m => UrlReader plain m where+ type Result m :: * -> *+ runUrlReader :: Url plain m =>+ m b -- ^ MonadReader with index @string@ and result @b@+ -> plain -- ^ Reader index+ -> Result m b -- ^ Final result --- * Monads -instance ( Monoid a- , IsString a ) => Url a (RelativeUrl a) where- url = RelativeUrl . const . expandRelative- stringUrl x = RelativeUrl $ const $ expandRelative $ UrlString x []--instance ( Monoid a- , IsString a ) => UrlReader a (RelativeUrl a) where- runUrlReader = runRelativeUrl-------instance ( Monoid a- , IsString a ) => Url a (GroundedUrl a) where- url = GroundedUrl . const . expandGrounded- stringUrl x = GroundedUrl $ const $ expandGrounded $ UrlString x []--instance ( Monoid a- , IsString a ) => UrlReader a (GroundedUrl a) where- runUrlReader = runGroundedUrl-------instance ( Monoid a- , IsString a ) => Url a (AbsoluteUrl a) where- url = expandAbsolute- stringUrl x = expandAbsolute $ UrlString x []---- | Hand-off host prepending to the MonadReader instance-instance ( Monoid a- , IsString a ) => UrlReader a (AbsoluteUrl a) where- runUrlReader = runAbsoluteUrl---- * Transformers- instance ( Monad m- , Monoid a- , IsString a ) => Url a (RelativeUrlT a m) where+ , Monoid plain+ , IsString plain ) => Url plain (RelativeUrlT plain m) where url = RelativeUrlT . const . return . expandRelative- stringUrl x = RelativeUrlT $ const $ return $ expandRelative $ UrlString x []+ plainUrl x = RelativeUrlT $ const $ return $ expandRelative $ UrlString x [] instance ( Monad m- , Monoid a- , IsString a ) => Url a (GroundedUrlT a m) where+ , Monoid plain+ , IsString plain ) => UrlReader plain (RelativeUrlT plain m) where+ type Result (RelativeUrlT plain m) = m+ runUrlReader = runRelativeUrlT++instance ( Monad m+ , Monoid plain+ , IsString plain ) => Url plain (GroundedUrlT plain m) where url = GroundedUrlT . const . return . expandGrounded- stringUrl x = GroundedUrlT $ const $ return $ expandGrounded $ UrlString x []+ plainUrl x = GroundedUrlT $ const $ return $ expandGrounded $ UrlString x [] instance ( Monad m- , Monoid a- , IsString a ) => Url a (AbsoluteUrlT a m) where+ , Monoid plain+ , IsString plain ) => UrlReader plain (GroundedUrlT plain m) where+ type Result (GroundedUrlT plain m) = m+ runUrlReader = runGroundedUrlT++instance ( Monad m+ , Monoid plain+ , IsString plain ) => Url plain (AbsoluteUrlT plain m) where url = expandAbsolute- stringUrl x = expandAbsolute $ UrlString x []+ plainUrl x = expandAbsolute $ UrlString x []++instance ( Monad m+ , Monoid plain+ , IsString plain ) => UrlReader plain (AbsoluteUrlT plain m) where+ type Result (AbsoluteUrlT plain m) = m+ runUrlReader = runAbsoluteUrlT
src/UrlPath/Types.hs view
@@ -10,13 +10,14 @@ import Data.String import Data.Monoid+import Data.Functor.Identity import Control.Applicative import Control.Monad import Control.Monad.Trans import Control.Monad.Reader.Class --- | A Url string - a target page and GET parameters. We only require a --- constraint of @IsString@ so that construction can be convenient, but +-- | A Url string - a "target" and GET parameters. We require @IsString@+-- and @Monoid@ so that construction can be convenient and generic, but -- rendering will require a monomorphic type. data UrlString a where UrlString :: ( IsString a@@ -26,7 +27,7 @@ -> UrlString a -- | We choose to not provide a @Show@ instance for @UrlString@ to evade the --- @String@ demand.+-- @String@ restriction. showUrlString :: UrlString a -> a showUrlString (UrlString !t []) = t@@ -38,7 +39,7 @@ -- | Lifts a raw target path and a GET parameter pair into a @UrlString@. (<?>) :: ( IsString a , Monoid a ) =>- a -- ^ Target string+ a -- ^ Target string -> (a, a) -- ^ GET Parameter -> UrlString a (<?>) !t !kv = UrlString t [kv]@@ -49,7 +50,7 @@ (<&>) :: ( IsString a , Monoid a ) => UrlString a -- ^ Old Url- -> (a, a) -- ^ Additional GET Parameter+ -> (a, a) -- ^ Additional GET Parameter -> UrlString a (<&>) (UrlString !t !p) !kv = UrlString t $ p ++ [kv] @@ -57,27 +58,27 @@ -- | Render the Url String as relative-expandRelative :: ( IsString a- , Monoid a ) =>- UrlString a- -> a+expandRelative :: ( IsString plain+ , Monoid plain ) =>+ UrlString plain+ -> plain expandRelative = showUrlString -- | Render the Url String as grounded-expandGrounded :: ( IsString a- , Monoid a ) =>- UrlString a- -> a+expandGrounded :: ( IsString plain+ , Monoid plain ) =>+ UrlString plain+ -> plain expandGrounded !x = "/" <> showUrlString x -- | Render the Url String as absolute - getting the root from a @MonadReader@ -- context. The @Monoid@ instance will be decided monomorphically, therefore a -- type signature will be needed when ran.-expandAbsolute :: ( MonadReader a m- , IsString a- , Monoid a ) =>- UrlString a- -> m a+expandAbsolute :: ( MonadReader plain m+ , IsString plain+ , Monoid plain ) =>+ UrlString plain+ -> m plain expandAbsolute !x = do host <- ask return $ host <> "/" <> showUrlString x@@ -98,29 +99,16 @@ -- > bar = (runReader (runTextT foo)) $ -- > SiteConfig "example.com" "cdn.example.com" expandAbsoluteWith :: ( MonadReader a m- , IsString a- , Monoid a ) =>- UrlString a- -> (a -> a)- -> m a+ , IsString plain+ , Monoid plain ) =>+ UrlString plain+ -> (a -> plain)+ -> m plain expandAbsoluteWith !x f = do root <- liftM f ask return $ root <> "/" <> showUrlString x --- | Rendering mode transformer. This isn't an instance of @UrlReader@ - to use, --- simple @lift@ as many levels as you need:--- --- > foo :: Monad m => HtmlT (RelativeUrlT m) ()--- > foo = do--- > path <- lift $ url $ "foo.php" <?> ("bar","baz")--- > script_ [src_ path] ""------ When rendering @foo@, simply use the Transformer's @run@ function to convert --- it to a reader:------ > bar :: ( Monad m, IsString a, Monoid a ) => m a--- > bar = (runRelativeUrlT (renderTextT foo)) "example.com"-newtype RelativeUrlT h m a = RelativeUrlT { runRelativeUrlT :: h -> m a }+newtype RelativeUrlT h m b = RelativeUrlT { runRelativeUrlT :: h -> m b } deriving Functor instance Applicative f => Applicative (RelativeUrlT h f) where@@ -133,50 +121,19 @@ runRelativeUrlT m a >>= (\x -> runRelativeUrlT (f x) a) instance MonadTrans (RelativeUrlT h) where- lift m = RelativeUrlT (const m)+ lift = RelativeUrlT . const instance ( Monad m- , IsString a ) => MonadReader a (RelativeUrlT a m) where+ , IsString h ) => MonadReader h (RelativeUrlT h m) where ask = return "" -instance MonadIO m => MonadIO (RelativeUrlT a m) where+instance MonadIO m => MonadIO (RelativeUrlT h m) where liftIO = lift . liftIO --- | Concrete Monad for automatically coercing HtmlT's to use a mode of Url --- rendering (relative, grounded, or absolute).------ > foo :: HtmlT RelativeUrl ()--- > foo = do--- > path <- lift $ url $ "foo.php" <?> ("bar","baz")--- > script_ [src_ path] ""------ when running the monad reader, use the @runUrlReader@ member function of the--- @UrlReader@ typeclass:------ > bar :: ( IsString a, Monoid a ) => a--- > bar = (runUrlReader (renderTextT foo)) "example.com"------ To change the deployment sheme, simply coerce the environment monad in @foo@.-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 h m a = GroundedUrlT { runGroundedUrlT :: h -> m a }+type RelativeUrl h b = RelativeUrlT h Identity b -instance Functor f => Functor (GroundedUrlT h f) where- fmap f x = GroundedUrlT $ \a ->- fmap f (runGroundedUrlT x a)+newtype GroundedUrlT h m b = GroundedUrlT { runGroundedUrlT :: h -> m b }+ deriving Functor instance Applicative f => Applicative (GroundedUrlT h f) where (<*>) f x = GroundedUrlT $ \a ->@@ -188,37 +145,19 @@ runGroundedUrlT m a >>= (\x -> runGroundedUrlT (f x) a) instance MonadTrans (GroundedUrlT h) where- lift m = GroundedUrlT (const m)+ lift = GroundedUrlT . const instance ( Monad m- , IsString a ) => MonadReader a (GroundedUrlT a m) where+ , IsString h ) => MonadReader h (GroundedUrlT h m) where ask = return "/" -instance MonadIO m => MonadIO (GroundedUrlT a m) where+instance MonadIO m => MonadIO (GroundedUrlT h m) where liftIO = lift . liftIO -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 h m a = AbsoluteUrlT { runAbsoluteUrlT :: h -> m a }+type GroundedUrl h b = GroundedUrlT h Identity b -instance Functor f => Functor (AbsoluteUrlT h f) where- fmap f x = AbsoluteUrlT $ \a ->- fmap f (runAbsoluteUrlT x a)+newtype AbsoluteUrlT h m b = AbsoluteUrlT { runAbsoluteUrlT :: h -> m b }+ deriving Functor instance Applicative f => Applicative (AbsoluteUrlT h f) where (<*>) f x = AbsoluteUrlT $ \a ->@@ -230,28 +169,13 @@ runAbsoluteUrlT m a >>= (\x -> runAbsoluteUrlT (f x) a) instance MonadTrans (AbsoluteUrlT h) where- lift m = AbsoluteUrlT (const m)+ lift = AbsoluteUrlT . const instance ( Monad m- , IsString a ) => MonadReader a (AbsoluteUrlT a m) where+ , IsString h ) => MonadReader h (AbsoluteUrlT h m) where ask = AbsoluteUrlT return -instance MonadIO m => MonadIO (AbsoluteUrlT a m) where+instance MonadIO m => MonadIO (AbsoluteUrlT h m) where liftIO = lift . liftIO -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+type AbsoluteUrl h b = AbsoluteUrlT h Identity b
urlpath.cabal view
@@ -1,5 +1,5 @@ Name: urlpath-Version: 0.1.0.1+Version: 0.2 Author: Athan Clark <athan.clark@gmail.com> Maintainer: Athan Clark <athan.clark@gmail.com> License: MIT@@ -80,7 +80,6 @@ GHC-Options: -Wall Exposed-Modules: UrlPath UrlPath.Types- -- UrlPath.Foo Build-Depends: base >= 4 && < 5 , mtl , transformers